1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveAnyClass #-} 3{-# LANGUAGE DeriveGeneric #-} 4{-# LANGUAGE DerivingStrategies #-} 5{-# LANGUAGE OverloadedStrings #-} 6{-# LANGUAGE Rank2Types #-} 7 8-- | 9-- Module : Data.Versions 10-- Copyright : (c) Colin Woodbury, 2015 - 2020 11-- License : BSD3 12-- Maintainer: Colin Woodbury <colin@fosskers.ca> 13-- 14-- A library for parsing and comparing software version numbers. 15-- 16-- We like to give version numbers to our software in a myriad of different 17-- ways. Some ways follow strict guidelines for incrementing and comparison. 18-- Some follow conventional wisdom and are generally self-consistent. Some are 19-- just plain asinine. This library provides a means of parsing and comparing 20-- /any/ style of versioning, be it a nice Semantic Version like this: 21-- 22-- > 1.2.3-r1+git123 23-- 24-- ...or a monstrosity like this: 25-- 26-- > 2:10.2+0.0093r3+1-1 27-- 28-- Please switch to <http://semver.org Semantic Versioning> if you aren't 29-- currently using it. It provides consistency in version incrementing and has 30-- the best constraints on comparisons. 31-- 32-- == Using the Parsers 33-- In general, `versioning` is the function you want. It attempts to parse a 34-- given `Text` using the three individual parsers, `semver`, `version` and 35-- `mess`. If one fails, it tries the next. If you know you only want to parse 36-- one specific version type, use that parser directly (e.g. `semver`). 37 38module Data.Versions 39 ( -- * Types 40 Versioning(..), isIdeal, isGeneral, isComplex 41 , SemVer(..) 42 , PVP(..) 43 , Version(..) 44 , Mess(..), messMajor, messMinor, messPatch, messPatchChunk 45 , MChunk(..) 46 , VUnit(..), digits, str 47 , VChunk 48 , VSep(..) 49 -- * Parsing Versions 50 , ParsingError 51 , versioning, semver, pvp, version, mess 52 -- ** Megaparsec Parsers 53 -- | For when you'd like to mix version parsing into some larger parser. 54 , versioning', semver', pvp', version', mess' 55 -- * Pretty Printing 56 , prettyV, prettySemVer, prettyPVP, prettyVer, prettyMess, errorBundlePretty 57 -- * Lenses 58 , Lens' 59 , Traversal' 60 , Semantic(..) 61 -- ** Traversing Text 62 -- | When traversing `Text`, leveraging its `Semantic` instance will 63 -- likely benefit you more than using these Traversals directly. 64 , _Versioning, _SemVer, _Version, _Mess 65 -- ** Versioning Traversals 66 , _Ideal, _General, _Complex 67 -- ** (General) Version Lenses 68 , epoch 69 -- ** Misc. Lenses / Traversals 70 , _Digits, _Str 71 ) where 72 73import qualified Control.Applicative.Combinators.NonEmpty as PC 74import Control.DeepSeq 75import Control.Monad (void) 76import Data.Bool (bool) 77import Data.Char (isAlpha) 78import Data.Foldable (fold) 79import Data.Hashable (Hashable) 80import Data.List (intersperse) 81import Data.List.NonEmpty (NonEmpty(..)) 82import qualified Data.List.NonEmpty as NEL 83import Data.Maybe (fromMaybe) 84import Data.Text (Text) 85import qualified Data.Text as T 86import Data.Void (Void) 87import GHC.Generics (Generic) 88import Text.Megaparsec hiding (chunk) 89import Text.Megaparsec.Char 90import qualified Text.Megaparsec.Char.Lexer as L 91 92#if !MIN_VERSION_base(4,11,0) 93import Data.Semigroup 94#endif 95 96--- 97 98-- | A top-level Versioning type. Acts as a wrapper for the more specific types. 99-- This allows each subtype to have its own parser, and for said parsers to be 100-- composed. This is useful for specifying custom behaviour for when a certain 101-- parser fails. 102data Versioning = Ideal SemVer | General Version | Complex Mess 103 deriving (Eq, Show, Generic, NFData, Hashable) 104 105-- | Short-hand for detecting a `SemVer`. 106isIdeal :: Versioning -> Bool 107isIdeal (Ideal _) = True 108isIdeal _ = False 109 110-- | Short-hand for detecting a `Version`. 111isGeneral :: Versioning -> Bool 112isGeneral (General _) = True 113isGeneral _ = False 114 115-- | Short-hand for detecting a `Mess`. 116isComplex :: Versioning -> Bool 117isComplex (Complex _) = True 118isComplex _ = False 119 120-- | Comparison of @Ideal@s is always well defined. 121-- 122-- If comparison of @General@s is well-defined, then comparison of @Ideal@ and 123-- @General@ is well-defined, as there exists a perfect mapping from @Ideal@ to 124-- @General@. 125-- 126-- If comparison of @Complex@es is well-defined, then comparison of @General@ 127-- and @Complex@ is well defined for the same reason. This implies comparison of 128-- @Ideal@ and @Complex@ is also well-defined. 129instance Ord Versioning where 130 compare (Ideal s) (Ideal s') = compare s s' 131 compare (General v) (General v') = compare v v' 132 compare (Complex m) (Complex m') = compare m m' 133 compare (Ideal s) (General v) = compare (vFromS s) v 134 compare (General v) (Ideal s) = opposite $ compare (vFromS s) v 135 compare (General v) (Complex m) = compare (mFromV v) m 136 compare (Complex m) (General v) = opposite $ compare (mFromV v) m 137 compare (Ideal s) (Complex m) = semverAndMess s m 138 compare (Complex m) (Ideal s) = opposite $ semverAndMess s m 139 140-- | Convert a `SemVer` to a `Version`. 141vFromS :: SemVer -> Version 142vFromS (SemVer ma mi pa re me) = 143 Version Nothing ((Digits ma :| []) :| [(Digits mi :| []), Digits pa :| []]) re me 144 145-- | Convert a `Version` to a `Mess`. 146mFromV :: Version -> Mess 147mFromV (Version e v m r) = maybe affix (\a -> Mess (MDigit a (showt a) :| []) $ Just (VColon, affix)) e 148 where 149 affix :: Mess 150 affix = Mess (chunksAsM v) m' 151 152 m' :: Maybe (VSep, Mess) 153 m' = case NEL.nonEmpty m of 154 Nothing -> r' 155 Just m'' -> Just (VPlus, Mess (chunksAsM m'') r') 156 157 r' :: Maybe (VSep, Mess) 158 r' = case NEL.nonEmpty r of 159 Nothing -> Nothing 160 Just r'' -> Just (VHyphen, Mess (chunksAsM r'') Nothing) 161 162 163-- | Special logic for when semver-like values can be extracted from a `Mess`. 164-- This avoids having to "downcast" the `SemVer` into a `Mess` before comparing, 165-- and in some cases can offer better comparison results. 166semverAndMess :: SemVer -> Mess -> Ordering 167semverAndMess s@(SemVer ma mi pa _ _) m = case compare ma <$> messMajor m of 168 Nothing -> fallback 169 Just LT -> LT 170 Just GT -> GT 171 Just EQ -> case compare mi <$> messMinor m of 172 Nothing -> fallback 173 Just LT -> LT 174 Just GT -> GT 175 Just EQ -> case compare pa <$> messPatch m of 176 Just LT -> LT 177 Just GT -> GT 178 -- If they've been equal up to this point, the `Mess` 179 -- will by definition have more to it, meaning that 180 -- it's more likely to be newer, despite its poor shape. 181 Just EQ -> fallback 182 Nothing -> case messPatchChunk m of 183 Nothing -> fallback 184 Just (Digits pa':|_) -> case compare pa pa' of 185 LT -> LT 186 GT -> GT 187 EQ -> GT -- This follows semver's rule! 188 Just _ -> fallback 189 where 190 fallback :: Ordering 191 fallback = compare (General $ vFromS s) (Complex m) 192 193instance Semantic Versioning where 194 major f (Ideal v) = Ideal <$> major f v 195 major f (General v) = General <$> major f v 196 major f (Complex v) = Complex <$> major f v 197 {-# INLINE major #-} 198 199 minor f (Ideal v) = Ideal <$> minor f v 200 minor f (General v) = General <$> minor f v 201 minor f (Complex v) = Complex <$> minor f v 202 {-# INLINE minor #-} 203 204 patch f (Ideal v) = Ideal <$> patch f v 205 patch f (General v) = General <$> patch f v 206 patch f (Complex v) = Complex <$> patch f v 207 {-# INLINE patch #-} 208 209 release f (Ideal v) = Ideal <$> release f v 210 release f (General v) = General <$> release f v 211 release f (Complex v) = Complex <$> release f v 212 {-# INLINE release #-} 213 214 meta f (Ideal v) = Ideal <$> meta f v 215 meta f (General v) = General <$> meta f v 216 meta f (Complex v) = Complex <$> meta f v 217 {-# INLINE meta #-} 218 219 semantic f (Ideal v) = Ideal <$> semantic f v 220 semantic f (General v) = General <$> semantic f v 221 semantic f (Complex v) = Complex <$> semantic f v 222 {-# INLINE semantic #-} 223 224-- | Traverse some Text for its inner versioning. 225-- 226-- @ 227-- λ "1.2.3" & _Versioning . _Ideal . patch %~ (+ 1) -- or just: "1.2.3" & patch %~ (+ 1) 228-- "1.2.4" 229-- @ 230_Versioning :: Traversal' Text Versioning 231_Versioning f t = either (const (pure t)) (fmap prettyV . f) $ versioning t 232{-# INLINE _Versioning #-} 233 234-- | Traverse some Text for its inner SemVer. 235_SemVer :: Traversal' Text SemVer 236_SemVer f t = either (const (pure t)) (fmap prettySemVer . f) $ semver t 237{-# INLINE _SemVer #-} 238 239-- | Traverse some Text for its inner Version. 240_Version :: Traversal' Text Version 241_Version f t = either (const (pure t)) (fmap prettyVer . f) $ version t 242{-# INLINE _Version #-} 243 244-- | Traverse some Text for its inner Mess. 245_Mess :: Traversal' Text Mess 246_Mess f t = either (const (pure t)) (fmap prettyMess . f) $ mess t 247{-# INLINE _Mess #-} 248 249_Ideal :: Traversal' Versioning SemVer 250_Ideal f (Ideal s) = Ideal <$> f s 251_Ideal _ v = pure v 252{-# INLINE _Ideal #-} 253 254_General :: Traversal' Versioning Version 255_General f (General v) = General <$> f v 256_General _ v = pure v 257{-# INLINE _General #-} 258 259_Complex :: Traversal' Versioning Mess 260_Complex f (Complex m) = Complex <$> f m 261_Complex _ v = pure v 262{-# INLINE _Complex #-} 263 264-- | Simple Lenses compatible with both lens and microlens. 265type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s 266 267-- | Simple Traversals compatible with both lens and microlens. 268type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s 269 270-- | Version types which sanely and safely yield `SemVer`-like information about 271-- themselves. For instances other than `SemVer` itself however, these optics 272-- may /not/ yield anything, depending on the actual value being traversed. 273-- Hence, the optics here are all `Traversal'`s. 274-- 275-- Consider the `Version` @1.2.3.4.5@. We can imagine wanting to increment the 276-- minor number: 277-- 278-- @ 279-- λ "1.2.3.4.5" & minor %~ (+ 1) 280-- "1.3.3.4.5" 281-- @ 282-- 283-- But of course something like this would fail: 284-- 285-- @ 286-- λ "1.e.3.4.5" & minor %~ (+ 1) 287-- "1.e.3.4.5" 288-- @ 289-- 290-- However! 291-- 292-- @ 293-- λ "1.e.3.4.5" & major %~ (+ 1) 294-- "2.e.3.4.5" 295-- @ 296class Semantic v where 297 -- | @MAJOR.minor.patch-prerel+meta@ 298 major :: Traversal' v Word 299 -- | @major.MINOR.patch-prerel+meta@ 300 minor :: Traversal' v Word 301 -- | @major.minor.PATCH-prerel+meta@ 302 patch :: Traversal' v Word 303 -- | @major.minor.patch-PREREL+meta@ 304 release :: Traversal' v [VChunk] 305 -- | @major.minor.patch-prerel+META@ 306 meta :: Traversal' v [VChunk] 307 -- | A Natural Transformation into an proper `SemVer`. 308 semantic :: Traversal' v SemVer 309 310instance Semantic Text where 311 major = _Versioning . major 312 minor = _Versioning . minor 313 patch = _Versioning . patch 314 release = _Versioning . release 315 meta = _Versioning . meta 316 semantic = _SemVer 317 318-------------------------------------------------------------------------------- 319-- (Ideal) SemVer 320 321-- | An (Ideal) version number that conforms to Semantic Versioning. 322-- This is a /prescriptive/ parser, meaning it follows the SemVer standard. 323-- 324-- Legal semvers are of the form: MAJOR.MINOR.PATCH-PREREL+META 325-- 326-- Example: @1.2.3-r1+commithash@ 327-- 328-- Extra Rules: 329-- 330-- 1. Pre-release versions have /lower/ precedence than normal versions. 331-- 332-- 2. Build metadata does not affect version precedence. 333-- 334-- 3. PREREL and META strings may only contain ASCII alphanumerics. 335-- 336-- For more information, see http://semver.org 337data SemVer = SemVer 338 { _svMajor :: !Word 339 , _svMinor :: !Word 340 , _svPatch :: !Word 341 , _svPreRel :: ![VChunk] 342 , _svMeta :: ![VChunk] } 343 deriving stock (Show, Generic) 344 deriving anyclass (NFData, Hashable) 345 346-- | Two SemVers are equal if all fields except metadata are equal. 347instance Eq SemVer where 348 (SemVer ma mi pa pr _) == (SemVer ma' mi' pa' pr' _) = 349 (ma,mi,pa,pr) == (ma',mi',pa',pr') 350 351-- | Build metadata does not affect version precedence. 352instance Ord SemVer where 353 compare (SemVer ma mi pa pr _) (SemVer ma' mi' pa' pr' _) = 354 case compare (ma,mi,pa) (ma',mi',pa') of 355 LT -> LT 356 GT -> GT 357 EQ -> case (pr,pr') of 358 ([],[]) -> EQ 359 ([],_) -> GT 360 (_,[]) -> LT 361 _ -> compare pr pr' 362 363instance Semigroup SemVer where 364 SemVer mj mn pa p m <> SemVer mj' mn' pa' p' m' = 365 SemVer (mj + mj') (mn + mn') (pa + pa') (p ++ p') (m ++ m') 366 367instance Monoid SemVer where 368 mempty = SemVer 0 0 0 [] [] 369 370#if !MIN_VERSION_base(4,11,0) 371 mappend = (<>) 372#endif 373 374instance Semantic SemVer where 375 major f sv = fmap (\ma -> sv { _svMajor = ma }) (f $ _svMajor sv) 376 {-# INLINE major #-} 377 378 minor f sv = fmap (\mi -> sv { _svMinor = mi }) (f $ _svMinor sv) 379 {-# INLINE minor #-} 380 381 patch f sv = fmap (\pa -> sv { _svPatch = pa }) (f $ _svPatch sv) 382 {-# INLINE patch #-} 383 384 release f sv = fmap (\pa -> sv { _svPreRel = pa }) (f $ _svPreRel sv) 385 {-# INLINE release #-} 386 387 meta f sv = fmap (\pa -> sv { _svMeta = pa }) (f $ _svMeta sv) 388 {-# INLINE meta #-} 389 390 semantic = ($) 391 {-# INLINE semantic #-} 392 393-- | A single unit of a Version. May be digits or a string of characters. Groups 394-- of these are called `VChunk`s, and are the identifiers separated by periods 395-- in the source. 396data VUnit = Digits Word | Str Text 397 deriving stock (Eq, Show, Read, Ord, Generic) 398 deriving anyclass (NFData, Hashable) 399 400instance Semigroup VUnit where 401 Digits n <> Digits m = Digits $ n + m 402 Str t <> Str s = Str $ t <> s 403 Digits n <> _ = Digits n 404 _ <> Digits n = Digits n 405 406instance Monoid VUnit where 407 mempty = Str "" 408 409#if !MIN_VERSION_base(4,11,0) 410 mappend = (<>) 411#endif 412 413-- | Smart constructor for a `VUnit` made of digits. 414digits :: Word -> VUnit 415digits = Digits 416 417-- | Smart constructor for a `VUnit` made of letters. 418str :: Text -> Maybe VUnit 419str t = bool Nothing (Just $ Str t) $ T.all isAlpha t 420 421_Digits :: Traversal' VUnit Word 422_Digits f (Digits i) = Digits <$> f i 423_Digits _ v = pure v 424{-# INLINE _Digits #-} 425 426_Str :: Traversal' VUnit Text 427_Str f (Str t) = Str . (\t' -> bool t t' (T.all isAlpha t')) <$> f t 428_Str _ v = pure v 429{-# INLINE _Str #-} 430 431-- | A logical unit of a version number. Can consist of multiple letters 432-- and numbers. 433type VChunk = NonEmpty VUnit 434 435-------------------------------------------------------------------------------- 436-- (Haskell) PVP 437 438-- | A PVP version number specific to the Haskell ecosystem. Like SemVer this is 439-- a prescriptive scheme, and follows <https://pvp.haskell.org/ the PVP spec>. 440-- 441-- Legal PVP values are of the form: MAJOR(.MAJOR.MINOR) 442-- 443-- Example: @1.2.3@ 444-- 445-- Extra Rules: 446-- 447-- 1. Each component must be a number. 448-- 449-- 2. Only the first MAJOR component is actually necessary. Otherwise, there can 450-- be any number of components. @1.2.3.4.5.6.7@ is legal. 451-- 452-- 3. Unlike SemVer there are two MAJOR components, and both indicate a breaking 453-- change. The spec otherwise designates no special meaning to components 454-- past the MINOR position. 455newtype PVP = PVP { _pComponents :: NonEmpty Word } 456 deriving stock (Eq, Ord, Show, Generic) 457 deriving anyclass (NFData, Hashable) 458 459instance Semigroup PVP where 460 PVP (m :| r) <> PVP (m' :| r') = PVP $ (m + m') :| f r r' 461 where 462 f a [] = a 463 f [] b = b 464 f (a:as) (b:bs) = (a + b) : f as bs 465 466instance Monoid PVP where 467 mempty = PVP (0 :| []) 468 469#if !MIN_VERSION_base(4,11,0) 470 mappend = (<>) 471#endif 472 473instance Semantic PVP where 474 major f (PVP (m :| rs)) = (\ma -> PVP $ ma :| rs) <$> f m 475 {-# INLINE major #-} 476 477 minor f (PVP (m :| mi : rs)) = (\mi' -> PVP $ m :| mi' : rs) <$> f mi 478 minor f (PVP (m :| [])) = (\mi' -> PVP $ m :| [mi']) <$> f 0 479 {-# INLINE minor #-} 480 481 patch f (PVP (m :| mi : pa : rs)) = (\pa' -> PVP $ m :| mi : pa' : rs) <$> f pa 482 patch f (PVP (m :| mi : [])) = (\pa' -> PVP $ m :| mi : [pa']) <$> f 0 483 patch f (PVP (m :| [])) = (\pa' -> PVP $ m :| 0 : [pa']) <$> f 0 484 {-# INLINE patch #-} 485 486 release f p = const p <$> f [] 487 {-# INLINE release #-} 488 489 meta f p = const p <$> f [] 490 {-# INLINE meta #-} 491 492 semantic f (PVP (m :| rs)) = (\(SemVer ma mi pa _ _) -> PVP $ ma :| [mi, pa]) <$> f s 493 where 494 s = case rs of 495 mi : pa : _ -> SemVer m mi pa [] [] 496 mi : _ -> SemVer m mi 0 [] [] 497 [] -> SemVer m 0 0 [] [] 498 {-# INLINE semantic #-} 499 500-------------------------------------------------------------------------------- 501-- (General) Version 502 503-- | A (General) Version. 504-- Not quite as ideal as a `SemVer`, but has some internal consistancy 505-- from version to version. 506-- 507-- Generally conforms to the @a.b.c-p@ pattern, and may optionally have an 508-- /epoch/ and /metadata/. Epochs are prefixes marked by a colon, like in 509-- @1:2.3.4@. Metadata is prefixed by @+@, and unlike SemVer can appear before 510-- the "prerelease" (the @-p@). 511-- 512-- Examples of @Version@ that are not @SemVer@: 0.25-2, 8.u51-1, 20150826-1, 513-- 1:2.3.4, 1.11.0+20200830-1 514data Version = Version 515 { _vEpoch :: !(Maybe Word) 516 , _vChunks :: !(NonEmpty VChunk) 517 , _vMeta :: ![VChunk] 518 , _vRel :: ![VChunk] } 519 deriving stock (Eq, Show, Generic) 520 deriving anyclass (NFData, Hashable) 521 522instance Semigroup Version where 523 Version e c m r <> Version e' c' m' r' = Version ((+) <$> e <*> e') (c <> c') (m <> m') (r <> r') 524 525-- | Customized. 526instance Ord Version where 527 -- | For the purposes of Versions with epochs, `Nothing` is the same as `Just 0`, 528 -- so we need to compare their actual version numbers. 529 compare (Version ae as _ rs) (Version be bs _ rs') = case compare (fromMaybe 0 ae) (fromMaybe 0 be) of 530 EQ -> case g (NEL.toList as) (NEL.toList bs) of 531 -- If the two Versions were otherwise equal and recursed down this far, 532 -- we need to compare them by their "release" values. 533 EQ -> g rs rs' 534 ord -> ord 535 ord -> ord 536 where 537 g :: [VChunk] -> [VChunk] -> Ordering 538 g [] [] = EQ 539 540 -- | If all chunks up until this point were equal, but one side continues 541 -- on with "lettered" sections, these are considered to be indicating a 542 -- beta\/prerelease, and thus are /less/ than the side who already ran out 543 -- of chunks. 544 g [] ((Str _ :| _):_) = GT 545 g ((Str _ :| _):_) [] = LT 546 547 -- | If one side has run out of chunks to compare but the other hasn't, 548 -- the other must be newer. 549 g _ [] = GT 550 g [] _ = LT 551 552 -- | The usual case. 553 g (x:xs) (y:ys) = case f (NEL.toList x) (NEL.toList y) of 554 EQ -> g xs ys 555 res -> res 556 557 f :: [VUnit] -> [VUnit] -> Ordering 558 f [] [] = EQ 559 560 -- | Opposite of the above. If we've recursed this far and one side 561 -- has fewer chunks, it must be the "greater" version. A Chunk break 562 -- only occurs in a switch from digits to letters and vice versa, so 563 -- anything "extra" must be an @rc@ marking or similar. Consider @1.1@ 564 -- compared to @1.1rc1@. 565 f [] _ = GT 566 f _ [] = LT 567 568 -- | The usual case. 569 f (Digits n:ns) (Digits m:ms) | n > m = GT 570 | n < m = LT 571 | otherwise = f ns ms 572 f (Str n:ns) (Str m:ms) | n > m = GT 573 | n < m = LT 574 | otherwise = f ns ms 575 576 -- | An arbitrary decision to prioritize digits over letters. 577 f (Digits _ :_) (Str _ :_) = GT 578 f (Str _ :_ ) (Digits _ :_) = LT 579 580instance Semantic Version where 581 major f (Version e ((Digits n :| []) :| cs) me rs) = 582 (\n' -> Version e ((Digits n' :| []) :| cs) me rs) <$> f n 583 major _ v = pure v 584 {-# INLINE major #-} 585 586 minor f (Version e (c :| (Digits n :| []) : cs) me rs) = 587 (\n' -> Version e (c :| (Digits n' :| []) : cs) me rs) <$> f n 588 minor _ v = pure v 589 {-# INLINE minor #-} 590 591 patch f (Version e (c :| d : (Digits n :| []) : cs) me rs) = 592 (\n' -> Version e (c :| d : (Digits n' :| []) : cs) me rs) <$> f n 593 patch _ v = pure v 594 {-# INLINE patch #-} 595 596 -- | This will always succeed. 597 release f v = fmap (\vr -> v { _vRel = vr }) (f $ _vRel v) 598 {-# INLINE release #-} 599 600 -- | This will always fail. 601 meta _ v = pure v 602 {-# INLINE meta #-} 603 604 semantic f (Version _ ((Digits a:|[]) :| (Digits b:|[]) : (Digits c:|[]) : _) me rs) = 605 vFromS <$> f (SemVer a b c me rs) 606 semantic _ v = pure v 607 {-# INLINE semantic #-} 608 609epoch :: Lens' Version (Maybe Word) 610epoch f v = fmap (\ve -> v { _vEpoch = ve }) (f $ _vEpoch v) 611{-# INLINE epoch #-} 612 613-------------------------------------------------------------------------------- 614-- (Complex) Mess 615 616-- | Possible values of a section of a `Mess`. A numeric value is extracted if 617-- it could be, alongside the original text it came from. This preserves both 618-- `Ord` and pretty-print behaviour for versions like @1.003.0@. 619data MChunk 620 = MDigit Word Text 621 -- ^ A nice numeric value. 622 | MRev Word Text 623 -- ^ A numeric value preceeded by an @r@, indicating a revision. 624 | MPlain Text 625 -- ^ Anything else. 626 deriving stock (Eq, Show, Generic) 627 deriving anyclass (NFData, Hashable) 628 629instance Ord MChunk where 630 compare (MDigit a _) (MDigit b _) = compare a b 631 compare (MRev a _) (MRev b _) = compare a b 632 compare (MPlain a) (MPlain b) = compare a b 633 compare a b = compare (mchunkText a) (mchunkText b) 634 635-- | A total extraction of the `Text` from an `MChunk`. 636mchunkText :: MChunk -> Text 637mchunkText (MDigit _ t) = t 638mchunkText (MRev _ t) = t 639mchunkText (MPlain t) = t 640 641-- | A (Complex) Mess. This is a /descriptive/ parser, based on examples of 642-- stupidly crafted version numbers used in the wild. 643-- 644-- Groups of letters/numbers, separated by a period, can be further separated by 645-- the symbols @_-+:@ 646-- 647-- Some `Mess` values have a shape that is tantalizingly close to a `SemVer`. 648-- Example: @1.6.0a+2014+m872b87e73dfb-1@. For values like these, we can extract 649-- the semver-compatible values out with `messMajor`, etc. 650-- 651-- Not guaranteed to have well-defined ordering (@Ord@) behaviour, but so far 652-- internal tests show consistency. `messMajor`, etc., are used internally where 653-- appropriate to enhance accuracy. 654data Mess = Mess !(NonEmpty MChunk) !(Maybe (VSep, Mess)) 655 deriving stock (Eq, Show, Generic) 656 deriving anyclass (NFData, Hashable) 657 658-- | Try to extract the "major" version number from `Mess`, as if it were a 659-- `SemVer`. 660messMajor :: Mess -> Maybe Word 661messMajor (Mess (MDigit i _ :| _) _) = Just i 662messMajor _ = Nothing 663 664-- | Try to extract the "minor" version number from `Mess`, as if it were a 665-- `SemVer`. 666messMinor :: Mess -> Maybe Word 667messMinor (Mess (_ :| MDigit i _ : _) _) = Just i 668messMinor _ = Nothing 669 670-- | Try to extract the "patch" version number from `Mess`, as if it were a 671-- `SemVer`. 672messPatch :: Mess -> Maybe Word 673messPatch (Mess (_ :| _ : MDigit i _ : _) _) = Just i 674messPatch _ = Nothing 675 676-- | Okay, fine, say `messPatch` couldn't find a nice value. But some `Mess`es 677-- have a "proper" patch-plus-release-candidate value in their patch position, 678-- which is parsable as a `VChunk`. 679-- 680-- Example: @1.6.0a+2014+m872b87e73dfb-1@ We should be able to extract @0a@ safely. 681messPatchChunk :: Mess -> Maybe VChunk 682messPatchChunk (Mess (_ :| _ : MPlain p : _) _) = hush $ parse chunk "Chunk" p 683messPatchChunk _ = Nothing 684 685instance Ord Mess where 686 compare (Mess t1 Nothing) (Mess t2 Nothing) = compare t1 t2 687 compare (Mess t1 m1) (Mess t2 m2) = case compare t1 t2 of 688 EQ -> case (m1, m2) of 689 (Just (_, v1), Just (_, v2)) -> compare v1 v2 690 (Just (_, _), Nothing) -> GT 691 (Nothing, Just (_, _)) -> LT 692 (Nothing, Nothing) -> EQ 693 res -> res 694 695instance Semantic Mess where 696 major f (Mess (MDigit n _ :| ts) m) = (\n' -> Mess (MDigit n' (showt n') :| ts) m) <$> f n 697 major _ v = pure v 698 {-# INLINE major #-} 699 700 minor f (Mess (t0 :| MDigit n _ : ts) m) = (\n' -> Mess (t0 :| MDigit n' (showt n') : ts) m) <$> f n 701 minor _ v = pure v 702 {-# INLINE minor #-} 703 704 patch f (Mess (t0 :| t1 : MDigit n _ : ts) m) = (\n' -> Mess (t0 :| t1 : MDigit n' (showt n') : ts) m) <$> f n 705 patch _ v = pure v 706 {-# INLINE patch #-} 707 708 -- | This will always fail. 709 release _ v = pure v 710 {-# INLINE release #-} 711 712 -- | This will always fail. 713 meta _ v = pure v 714 {-# INLINE meta #-} 715 716 -- | Good luck. 717 semantic f (Mess (MDigit t0 _ :| MDigit t1 _ : MDigit t2 _ : _) _) = 718 mFromV . vFromS <$> (f $ SemVer t0 t1 t2 [] []) 719 semantic _ v = pure v 720 {-# INLINE semantic #-} 721 722-- | Developers use a number of symbols to seperate groups of digits/letters in 723-- their version numbers. These are: 724-- 725-- * A colon (:). Often denotes an "epoch". 726-- * A hyphen (-). 727-- * A plus (+). Stop using this outside of metadata if you are. Example: @10.2+0.93+1-1@ 728-- * An underscore (_). Stop using this if you are. 729data VSep = VColon | VHyphen | VPlus | VUnder 730 deriving stock (Eq, Show, Generic) 731 deriving anyclass (NFData, Hashable) 732 733-------------------------------------------------------------------------------- 734-- Parsing 735 736-- | A synonym for the more verbose `megaparsec` error type. 737type ParsingError = ParseErrorBundle Text Void 738 739-- | Parse a piece of `Text` into either an (Ideal) `SemVer`, a (General) 740-- `Version`, or a (Complex) `Mess`. 741versioning :: Text -> Either ParsingError Versioning 742versioning = parse versioning' "versioning" 743 744-- | Parse a `Versioning`. Assumes the version number is the last token in 745-- the string. 746versioning' :: Parsec Void Text Versioning 747versioning' = choice [ try (fmap Ideal semver'' <* eof) 748 , try (fmap General version'' <* eof) 749 , fmap Complex mess'' <* eof ] 750 751-- | Parse a (Ideal) Semantic Version. 752semver :: Text -> Either ParsingError SemVer 753semver = parse (semver'' <* eof) "Semantic Version" 754 755-- | Internal megaparsec parser of `semver`. 756semver' :: Parsec Void Text SemVer 757semver' = L.lexeme space semver'' 758 759semver'' :: Parsec Void Text SemVer 760semver'' = SemVer <$> majorP <*> minorP <*> patchP <*> preRel <*> metaData 761 762-- | Parse a group of digits, which can't be lead by a 0, unless it is 0. 763digitsP :: Parsec Void Text Word 764digitsP = read <$> ((T.unpack <$> string "0") <|> some digitChar) 765 766majorP :: Parsec Void Text Word 767majorP = digitsP <* char '.' 768 769minorP :: Parsec Void Text Word 770minorP = majorP 771 772patchP :: Parsec Void Text Word 773patchP = digitsP 774 775preRel :: Parsec Void Text [VChunk] 776preRel = (char '-' *> chunks) <|> pure [] 777 778metaData :: Parsec Void Text [VChunk] 779metaData = (char '+' *> chunks) <|> pure [] 780 781chunksNE :: Parsec Void Text (NonEmpty VChunk) 782chunksNE = chunk `PC.sepBy1` char '.' 783 784chunks :: Parsec Void Text [VChunk] 785chunks = chunk `sepBy` char '.' 786 787-- | Handling @0@ is a bit tricky. We can't allow runs of zeros in a chunk, 788-- since a version like @1.000.1@ would parse as @1.0.1@. 789chunk :: Parsec Void Text VChunk 790chunk = try zeroWithLetters <|> oneZero <|> PC.some (iunit <|> sunit) 791 where 792 oneZero :: Parsec Void Text (NonEmpty VUnit) 793 oneZero = (Digits 0 :| []) <$ single '0' 794 795 zeroWithLetters :: Parsec Void Text (NonEmpty VUnit) 796 zeroWithLetters = do 797 z <- Digits 0 <$ single '0' 798 s <- PC.some sunit 799 c <- optional chunk 800 case c of 801 Nothing -> pure $ NEL.cons z s 802 Just c' -> pure $ NEL.cons z s <> c' 803 804iunit :: Parsec Void Text VUnit 805iunit = Digits <$> ((0 <$ single '0') <|> (read <$> some digitChar)) 806 807sunit :: Parsec Void Text VUnit 808sunit = Str . T.pack <$> some letterChar 809 810-- | Parse a (Haskell) `PVP`, as defined above. 811pvp :: Text -> Either ParsingError PVP 812pvp = parse (pvp' <* eof) "PVP" 813 814-- | Internal megaparsec parser of `pvp`. 815pvp' :: Parsec Void Text PVP 816pvp' = L.lexeme space (PVP . NEL.fromList <$> L.decimal `sepBy` char '.') 817 818-- | Parse a (General) `Version`, as defined above. 819version :: Text -> Either ParsingError Version 820version = parse (version'' <* eof) "Version" 821 822-- | Internal megaparsec parser of `version`. 823version' :: Parsec Void Text Version 824version' = L.lexeme space version'' 825 826version'' :: Parsec Void Text Version 827version'' = Version <$> optional (try epochP) <*> chunksNE <*> metaData <*> preRel 828 829epochP :: Parsec Void Text Word 830epochP = read <$> (some digitChar <* char ':') 831 832-- | Parse a (Complex) `Mess`, as defined above. 833mess :: Text -> Either ParsingError Mess 834mess = parse (mess'' <* eof) "Mess" 835 836-- | Internal megaparsec parser of `mess`. 837mess' :: Parsec Void Text Mess 838mess' = L.lexeme space mess'' 839 840mess'' :: Parsec Void Text Mess 841mess'' = Mess <$> mchunks <*> optional ((,) <$> sep <*> mess') 842 843mchunks :: Parsec Void Text (NonEmpty MChunk) 844mchunks = mchunk `PC.sepBy1` char '.' 845 846mchunk :: Parsec Void Text MChunk 847mchunk = choice [ try $ (\(t, i) -> MDigit i t) <$> match (L.decimal <* next) 848 , try $ (\(t, i) -> MRev i t) <$> (match (single 'r' *> L.decimal <* next)) 849 , MPlain . T.pack <$> some (letterChar <|> digitChar) ] 850 where 851 next :: Parsec Void Text () 852 next = lookAhead (void (single '.') <|> void sep <|> eof) 853 854sep :: Parsec Void Text VSep 855sep = choice [ VColon <$ char ':' 856 , VHyphen <$ char '-' 857 , VPlus <$ char '+' 858 , VUnder <$ char '_' ] 859 860sepCh :: VSep -> Char 861sepCh VColon = ':' 862sepCh VHyphen = '-' 863sepCh VPlus = '+' 864sepCh VUnder = '_' 865 866-- | Convert any parsed Versioning type to its textual representation. 867prettyV :: Versioning -> Text 868prettyV (Ideal sv) = prettySemVer sv 869prettyV (General v) = prettyVer v 870prettyV (Complex m) = prettyMess m 871 872-- | Convert a `SemVer` back to its textual representation. 873prettySemVer :: SemVer -> Text 874prettySemVer (SemVer ma mi pa pr me) = mconcat $ ver <> pr' <> me' 875 where 876 ver = intersperse "." [ showt ma, showt mi, showt pa ] 877 pr' = foldable [] ("-" :) $ intersperse "." (chunksAsT pr) 878 me' = foldable [] ("+" :) $ intersperse "." (chunksAsT me) 879 880-- | Convert a `PVP` back to its textual representation. 881prettyPVP :: PVP -> Text 882prettyPVP (PVP (m :| rs)) = T.intercalate "." . map showt $ m : rs 883 884-- | Convert a `Version` back to its textual representation. 885prettyVer :: Version -> Text 886prettyVer (Version ep cs me pr) = ep' <> mconcat (ver <> me' <> pr') 887 where 888 ver = intersperse "." . chunksAsT $ NEL.toList cs 889 me' = foldable [] ("+" :) $ intersperse "." (chunksAsT me) 890 pr' = foldable [] ("-" :) $ intersperse "." (chunksAsT pr) 891 ep' = maybe "" (\e -> showt e <> ":") ep 892 893-- | Convert a `Mess` back to its textual representation. 894prettyMess :: Mess -> Text 895prettyMess (Mess t m) = case m of 896 Nothing -> t' 897 Just (s, v) -> T.snoc t' (sepCh s) <> prettyMess v 898 where 899 t' :: Text 900 t' = fold . NEL.intersperse "." $ NEL.map mchunkText t 901 902chunksAsT :: Functor t => t VChunk -> t Text 903chunksAsT = fmap (foldMap f) 904 where 905 f :: VUnit -> Text 906 f (Digits i) = showt i 907 f (Str s) = s 908 909chunksAsM :: Functor t => t VChunk -> t MChunk 910chunksAsM = fmap f 911 where 912 f :: VChunk -> MChunk 913 f (Digits i :| []) = MDigit i $ showt i 914 f (Str "r" :| [Digits i]) = MRev i . T.cons 'r' $ showt i 915 f vc = MPlain . T.concat $ chunksAsT [vc] 916 917-- | Analogous to `maybe` and `either`. If a given Foldable is empty, 918-- a default value is returned. Else, a function is applied to that Foldable. 919foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b 920foldable d g f | null f = d 921 | otherwise = g f 922 923-- | Flip an Ordering. 924opposite :: Ordering -> Ordering 925opposite EQ = EQ 926opposite LT = GT 927opposite GT = LT 928 929-- Yes, `text-show` exists, but this reduces external dependencies. 930showt :: Show a => a -> Text 931showt = T.pack . show 932 933hush :: Either a b -> Maybe b 934hush (Left _) = Nothing 935hush (Right b) = Just b 936