diff --git a/semver-range.cabal b/semver-range.cabal --- a/semver-range.cabal +++ b/semver-range.cabal @@ -1,5 +1,5 @@ name: semver-range -version: 0.1.1 +version: 0.2.2 synopsis: An implementation of semver and semantic version ranges. license: MIT license-file: LICENSE @@ -14,9 +14,9 @@ location: git://github.com/adnelson/semver-range.git library - Exposed-modules: - Data.SemVer - Data.SemVer.Parser + Exposed-modules: Data.SemVer + other-modules: Data.SemVer.Parser + , Data.SemVer.Types other-extensions: FlexibleContexts , FlexibleInstances , LambdaCase @@ -28,10 +28,24 @@ , ScopedTypeVariables , TypeFamilies , TypeSynonymInstances - build-depends: base >=4.8 && <4.9 + build-depends: base >=4.8 && <5 , classy-prelude , text , unordered-containers , parsec hs-source-dirs: src + default-language: Haskell2010 + +test-suite unit-tests + type: exitcode-stdio-1.0 + hs-source-dirs: src, tests + main-is: Unit.hs + build-depends: base + , classy-prelude + , text + , unordered-containers + , parsec + , hspec + , QuickCheck + ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/Data/SemVer.hs b/src/Data/SemVer.hs --- a/src/Data/SemVer.hs +++ b/src/Data/SemVer.hs @@ -1,197 +1,7 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -module Data.SemVer where - -import ClassyPrelude -import qualified Prelude as P -import Data.Text (Text) -import qualified Data.Text as T - -type ReleaseTag = Text - --- | A SemVer has major, minor and patch versions, and zero or more --- pre-release version tags. -type SemVer = (Int, Int, Int, [ReleaseTag]) - --- | A partially specified semantic version. Implicitly defines --- a range of acceptable versions, as seen in @wildcardToRange@. -data Wildcard = Any - | One Int - | Two Int Int - | Three Int Int Int [Text] - deriving (Show, Eq) - --- | A range specifies bounds on a semver. -data SemVerRange - = Eq SemVer -- ^ Exact equality - | Gt SemVer -- ^ Greater than - | Lt SemVer -- ^ Less than - | Geq SemVer -- ^ Greater than or equal to - | Leq SemVer -- ^ Less than or equal to - | And SemVerRange SemVerRange -- ^ Conjunction - | Or SemVerRange SemVerRange -- ^ Disjunction - deriving (Eq, Ord) - --- | Pull all of the concrete versions out of a range. -versionsOf :: SemVerRange -> [SemVer] -versionsOf = \case - Eq sv -> [sv] - Geq sv -> [sv] - Leq sv -> [sv] - Lt sv -> [sv] - Gt sv -> [sv] - And svr1 svr2 -> versionsOf svr1 <> versionsOf svr2 - Or svr1 svr2 -> versionsOf svr1 <> versionsOf svr2 - --- | Create a SemVer with no version tags. -semver :: Int -> Int -> Int -> SemVer -semver a b c = (a, b, c, []) - --- | Get the release tags from a semver. -releaseTags :: SemVer -> [ReleaseTag] -releaseTags (_, _, _, tags) = tags - --- | Get only the version tuple from a semver. -toTuple :: SemVer -> (Int, Int, Int) -toTuple (a, b, c, _) = (a, b, c) - --- | Get a list of tuples from a version range. -tuplesOf :: SemVerRange -> [(Int, Int, Int)] -tuplesOf = map toTuple . versionsOf - --- | Get all of the release tags from a version range. -rangeReleaseTags :: SemVerRange -> [ReleaseTag] -rangeReleaseTags = concatMap releaseTags . versionsOf - --- | Get the range release tags if they're all the same; otherwise --- Nothing. -sharedReleaseTags :: SemVerRange -> Maybe [ReleaseTag] -sharedReleaseTags range = case map releaseTags $ versionsOf range of - [] -> Nothing -- shouldn't happen but in case - []:_ -> Nothing -- no release tags, so that seals it - tagList:otherLists - | all (== tagList) otherLists -> Just tagList - | otherwise -> Nothing - --- | Satisfies any version. -anyVersion :: SemVerRange -anyVersion = Gt $ semver 0 0 0 - --- | Render a semver as Text. -renderSV :: SemVer -> Text -renderSV = pack . renderSV' - --- | Render a semver as a String. -renderSV' :: SemVer -> String -renderSV' (x, y, z, []) = show x <> "." <> show y <> "." <> show z -renderSV' (x, y, z, tags) = renderSV' (x, y, z, []) <> "-" <> - (intercalate "." $ map unpack tags) - -instance Show SemVerRange where - show = \case - Eq sv -> "=" <> renderSV' sv - Gt sv -> ">" <> renderSV' sv - Lt sv -> "<" <> renderSV' sv - Geq sv -> ">=" <> renderSV' sv - Leq sv -> "<=" <> renderSV' sv - And svr1 svr2 -> show svr1 <> " " <> show svr2 - Or svr1 svr2 -> show svr1 <> " || " <> show svr2 - --- | Returns whether a given semantic version matches a range. --- Note that there are special cases when there are release tags. For detauls --- see https://github.com/npm/node-semver#prerelease-tags. -matches :: SemVerRange -> SemVer -> Bool -matches range version = case (sharedReleaseTags range, releaseTags version) of - -- This is the simple case, where neither the range nor the version has given - -- any release tags. Then we can just do regular predicate calculus. - (Nothing, []) -> matchesSimple range version - (Just rTags, vTags) - | rTags == vTags -> matchesSimple range version - | tuplesOf range /= [toTuple version] -> False - | otherwise -> matchesTags range rTags vTags - (_, _) -> False - --- | Simple predicate calculus matching, doing AND and OR combination with --- numerical comparison. -matchesSimple :: SemVerRange -> SemVer -> Bool -matchesSimple range ver = case range of - Eq sv -> ver == sv - Gt sv -> ver > sv - Lt sv -> ver < sv - Geq sv -> ver >= sv - Leq sv -> ver <= sv - And sv1 sv2 -> matchesSimple sv1 ver && matchesSimple sv2 ver - Or sv1 sv2 -> matchesSimple sv1 ver || matchesSimple sv2 ver - --- | Given a range and two sets of tags, the first being a bound on the second, --- uses the range to compare the tags and see if they match. -matchesTags :: SemVerRange -> [ReleaseTag] -> [ReleaseTag] -> Bool -matchesTags range rangeTags verTags = case range of - Eq _ -> verTags == rangeTags - Gt _ -> verTags > rangeTags - Lt _ -> verTags < rangeTags - Geq _ -> verTags >= rangeTags - Leq _ -> verTags <= rangeTags - -- Note that as we're currently doing things, these cases won't get hit. - And svr1 svr2 -> matchesTags svr1 verTags rangeTags && - matchesTags svr2 verTags rangeTags - Or svr1 svr2 -> matchesTags svr1 verTags rangeTags || - matchesTags svr2 verTags rangeTags - --- | Gets the highest-matching semver in a range. -bestMatch :: SemVerRange -> [SemVer] -> Either String SemVer -bestMatch range vs = case filter (matches range) vs of - [] -> Left "No matching versions" - vs -> Right $ P.maximum vs - --- | Fills in zeros in a wildcard. -wildcardToSemver :: Wildcard -> SemVer -wildcardToSemver Any = (0, 0, 0, []) -wildcardToSemver (One n) = (n, 0, 0, []) -wildcardToSemver (Two n m) = (n, m, 0, []) -wildcardToSemver (Three n m o tags) = (n, m, o, tags) - --- | Translates a wildcard (partially specified version) to a range. --- Ex: 2 := >=2.0.0 <3.0.0 --- Ex: 1.2.x := 1.2 := >=1.2.0 <1.3.0 -wildcardToRange :: Wildcard -> SemVerRange -wildcardToRange = \case - Any -> Geq (0, 0, 0, []) - One n -> Geq (n, 0, 0, []) `And` Lt (n+1, 0, 0, []) - Two n m -> Geq (n, m, 0, []) `And` Lt (n, m + 1, 0, []) - Three n m o tags -> Eq (n, m, o, tags) - --- | Translates a ~wildcard to a range. --- Ex: ~1.2.3 := >=1.2.3 <1.(2+1).0 := >=1.2.3 <1.3.0 -tildeToRange :: Wildcard -> SemVerRange -tildeToRange = \case - Any -> tildeToRange (Three 0 0 0 []) - One n -> tildeToRange (Three n 0 0 []) - Two n m -> tildeToRange (Three n m 0 []) - Three n m o tags -> And (Geq (n, m, o, tags)) (Lt (n, m + 1, 0, tags)) - --- | Translates a ^wildcard to a range. --- Ex: ^1.2.x := >=1.2.0 <2.0.0 -caratToRange :: Wildcard -> SemVerRange -caratToRange = \case - One n -> And (Geq (n, 0, 0, [])) (Lt (n+1, 0, 0, [])) - Two n m -> And (Geq (n, m, 0, [])) (Lt (n+1, 0, 0, [])) - Three 0 0 n tags -> Eq (0, 0, n, tags) - Three 0 n m tags -> And (Geq (0, n, m, tags)) (Lt (0, n + 1, 0, tags)) - Three n m o tags -> And (Geq (n, m, o, tags)) (Lt (n+1, 0, 0, tags)) +module Data.SemVer ( + module Data.SemVer.Types, + module Data.SemVer.Parser + ) where --- | Translates two hyphenated wildcards to an actual range. --- Ex: 1.2.3 - 2.3.4 := >=1.2.3 <=2.3.4 --- Ex: 1.2 - 2.3.4 := >=1.2.0 <=2.3.4 --- Ex: 1.2.3 - 2 := >=1.2.3 <3.0.0 -hyphenatedRange :: Wildcard -> Wildcard -> SemVerRange -hyphenatedRange wc1 wc2 = And sv1 sv2 where - sv1 = case wc1 of Any -> Geq (0, 0, 0, []) - One n -> Geq (n, 0, 0, []) - Two n m -> Geq (n, m, 0, []) - Three n m o tags -> Geq (n, m, o, tags) - sv2 = case wc2 of Any -> Geq (0, 0, 0, []) -- Refers to "any version" - One n -> Lt (n+1, 0, 0, []) - Two n m -> Lt (n, m + 1, 0, []) - Three n m o tags -> Leq (n, m, o, tags) +import Data.SemVer.Types +import Data.SemVer.Parser diff --git a/src/Data/SemVer/Parser.hs b/src/Data/SemVer/Parser.hs --- a/src/Data/SemVer/Parser.hs +++ b/src/Data/SemVer/Parser.hs @@ -1,21 +1,92 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} -module Data.SemVer.Parser ( - parseSemVer, parseSemVerRange, pSemVerRange, pSemVer, - fromHaskellVersion, matchText - ) where +{-# LANGUAGE OverloadedLists #-} +module Data.SemVer.Parser where -- ( + -- parseSemVer, parseSemVerRange, pSemVerRange, pSemVer, p + -- fromHaskellVersion, matchText + -- ) where + import qualified Prelude as P -import ClassyPrelude hiding (try) -import Text.Parsec hiding ((<|>), spaces, parse, State, uncons) +import ClassyPrelude hiding (try, many) +import Text.Parsec hiding ((<|>), spaces, parse, State, uncons, optional) import qualified Text.Parsec as Parsec +import qualified Data.Text as T +import Text.Read (readMaybe) import Data.Version (Version(..)) -import Data.SemVer +import Data.SemVer.Types type Parser = ParsecT String () Identity +------------------------------------------------------------------------------- +-- Wildcards: intermediate representations of semvers +-- +-- | A partially specified semantic version. Implicitly defines +-- a range of acceptable versions, as seen in @wildcardToRange@. +data Wildcard = Any + | One Int + | Two Int Int + | Full SemVer + deriving (Show, Eq) + +-- | Fills in zeros in a wildcard. +wildcardToSemver :: Wildcard -> SemVer +wildcardToSemver Any = semver 0 0 0 +wildcardToSemver (One n) = semver n 0 0 +wildcardToSemver (Two n m) = semver n m 0 +wildcardToSemver (Full sv) = sv + +-- | Translates a wildcard (partially specified version) to a range. +-- Ex: 2 := >=2.0.0 <3.0.0 +-- Ex: 1.2.x := 1.2 := >=1.2.0 <1.3.0 +wildcardToRange :: Wildcard -> SemVerRange +wildcardToRange = \case + Any -> Geq $ semver 0 0 0 + One n -> Geq (semver n 0 0) `And` Lt (semver (n+1) 0 0) + Two n m -> Geq (semver n m 0) `And` Lt (semver n (m+1) 0) + Full sv -> Eq sv + +-- | Translates a ~wildcard to a range. +-- Ex: ~1.2.3 := >=1.2.3 <1.(2+1).0 := >=1.2.3 <1.3.0 +tildeToRange :: Wildcard -> SemVerRange +tildeToRange = \case + -- I'm not sure this is officially supported, but just in case... + Any -> tildeToRange (Full $ semver 0 0 0) + -- ~1 := >=1.0.0 <(1+1).0.0 := >=1.0.0 <2.0.0 (Same as 1.x) + One n -> Geq (semver n 0 0) `And` Lt (semver (n+1) 0 0) + -- ~1.2 := >=1.2.0 <1.(2+1).0 := >=1.2.0 <1.3.0 (Same as 1.2.x) + Two n m -> Geq (semver n m 0) `And` Lt (semver n (m+1) 0) + -- ~1.2.3 := >=1.2.3 <1.(2+1).0 := >=1.2.3 <1.3.0 + Full (SemVer n m o [] _) -> Geq (semver n m o) `And` Lt (semver n (m+1) 0) + -- ~1.2.3-beta.2 := >=1.2.3-beta.2 <1.3.0 + Full (SemVer n m o tags _) -> Geq (semver' n m o tags) `And` Lt (semver n (m+1) 0) + +-- | Translates a ^wildcard to a range. +-- Ex: ^1.2.x := >=1.2.0 <2.0.0 +caratToRange :: Wildcard -> SemVerRange +caratToRange = \case + One n -> Geq (semver n 0 0) `And` Lt (semver (n+1) 0 0) + Two n m -> Geq (semver n m 0) `And` Lt (semver (n+1) 0 0) + Full (SemVer 0 n m tags _) -> Geq (semver' 0 n m tags) `And` Lt (semver' 0 (n+1) 0 tags) + Full (SemVer n m o tags _) -> Geq (semver' n m o tags) `And` Lt (semver' (n+1) 0 0 tags) + +-- | Translates two hyphenated wildcards to an actual range. +-- Ex: 1.2.3 - 2.3.4 := >=1.2.3 <=2.3.4 +-- Ex: 1.2 - 2.3.4 := >=1.2.0 <=2.3.4 +-- Ex: 1.2.3 - 2 := >=1.2.3 <3.0.0 +hyphenatedRange :: Wildcard -> Wildcard -> SemVerRange +hyphenatedRange wc1 wc2 = And sv1 sv2 where + sv1 = case wc1 of Any -> anyVersion + One n -> Geq (semver n 0 0) + Two n m -> Geq (semver n m 0) + Full sv -> Geq sv + sv2 = case wc2 of Any -> anyVersion + One n -> Lt (semver (n+1) 0 0) + Two n m -> Lt (semver n (m+1) 0) + Full sv -> Lt sv + -- | Given a parser and a string, attempts to parse the string. parse :: Parser a -> Text -> Either ParseError a parse p = Parsec.parse p "" . unpack @@ -25,11 +96,11 @@ -- | Consumes any spaces (not other whitespace). spaces :: Parser String -spaces = many $ char ' ' +spaces = many $ oneOf [' ', '\t'] -- | Consumes at least one space (not other whitespace). spaces1 :: Parser String -spaces1 = many1 $ char ' ' +spaces1 = many1 $ oneOf [' ', '\t'] -- | Parses the given string and any trailing spaces. sstring :: String -> Parser String @@ -53,7 +124,11 @@ -- | Parse a string as a version range, or return an error. parseSemVerRange :: Text -> Either ParseError SemVerRange -parseSemVerRange = parse pSemVerRange +parseSemVerRange text = case T.strip text of + -- Handle a few special cases + "" -> return anyVersion + "||" -> return anyVersion + t -> parse pSemVerRange t -- | Parse a string as an explicit version, or return an error. parseSemVer :: Text -> Either ParseError SemVer @@ -64,23 +139,35 @@ pSemVer = wildcardToSemver <$> pWildCard pVersionComp :: Parser SemVerRange -pVersionComp = do - comparator <- cmp - ver <- pSemVer - let func = case comparator of {"=" -> Eq; ">" -> Gt; "<" -> Lt; - ">=" -> Geq; "<=" -> Leq; "==" -> Eq} - return $ func ver +pVersionComp = cmp >>= \case + "=" -> wildcardToRange <$> pWildCard + "==" -> wildcardToRange <$> pWildCard + -- This is a special case to deal with a test case in the npm semver + -- test suite. The case states that "0.7.2" should satisfy + -- "<=0.7.x". I'm interpreting this to mean that "<= X", where X is + -- a range, means "less than or equal to the maximum supported in + -- this range." + "<=" -> Leq . topOf <$> pWildCard + ">=" -> Geq <$> pSemVer + ">" -> Gt <$> pSemVer + "<" -> Lt <$> pSemVer + where + topOf = \case + Any -> semver 0 0 0 + One n -> semver (n+1) 0 0 + Two n m -> semver n (m+1) 0 + Full sv -> sv -- | Parses a comparison operator. cmp :: Parser String -cmp = choice $ fmap (try . sstring) [">=", "<=", ">", "<", "==", "="] +cmp = choice (try . sstring <$> [">=", "<=", ">", "<", "==", "="]) -- | Parses versions with an explicit range qualifier (gt, lt, etc). pSemVerRangeSingle :: Parser SemVerRange pSemVerRangeSingle = choice [ wildcardToRange <$> pWildCard, - tildeToRange <$> pTildeRange, - caratToRange <$> pCaratRange, + pTildeRange, + pCaratRange, pVersionComp ] @@ -102,45 +189,50 @@ pWildCard = try $ do let seps = choice $ map string ["x", "X", "*"] let bound = choice [seps *> pure Nothing, Just <$> pInt'] - let stripNothings [Nothing] = [] - stripNothings (Just x:xs) = x : stripNothings xs - tag = fmap pack $ many1 $ letter <|> digit <|> char '-' - -- Versions can optionally start with the character 'v' + let getTag t = case readMaybe t of + Just i -> IntTag i + _ -> TextTag $ pack t + let tag = getTag <$> many1 (letter <|> digit <|> char '-') + -- Versions can optionally start with the character 'v'; ignore this. optional (char 'v') res <- takeWhile isJust <$> sepBy1 bound (sstring ".") >>= \case [] -> return Any [Just n] -> return $ One n [Just n, Just m] -> return $ Two n m - [Just n, Just m, Just o] -> option (Three n m o []) $ do - char '-' - tags <- tag `sepBy1` char '.' - return $ Three n m o tags + [Just n, Just m, Just o] -> option (Full $ semver n m o) $ do + -- Release tags might be separated by a hyphen, or not. + optional (char '-') + tags <- PrereleaseTags <$> (tag `sepBy1` char '.') + -- Grab metadata if there is any + option (Full $ semver'' n m o tags []) $ do + char '+' + metadata <- many1 (letter <|> digit <|> char '-') `sepBy1` char '.' + return $ Full $ semver'' n m o tags (map pack metadata) w -> unexpected ("Invalid version " ++ show w) spaces *> return res -- | Parses a tilde range (~1.2.3). -pTildeRange :: Parser Wildcard +pTildeRange :: Parser SemVerRange pTildeRange = do sstring "~" -- For some reason, including the following operators after -- a tilde is valid, but seems to have no effect. optional $ choice [try $ sstring ">=", sstring ">", sstring "="] - pWildCard + tildeToRange <$> pWildCard -- | Parses a carat range (^1.2.3). -pCaratRange :: Parser Wildcard -pCaratRange = sstring "^" *> pWildCard +pCaratRange :: Parser SemVerRange +pCaratRange = sstring "^" *> map caratToRange pWildCard -- | Top-level parser. Parses a semantic version range. pSemVerRange :: Parser SemVerRange pSemVerRange = try pHyphen <|> pJoinedSemVerRange - -- | Parse a semver from a haskell version. There must be exactly -- three numbers in the versionBranch field. fromHaskellVersion :: Version -> Either Text SemVer fromHaskellVersion v = case versionBranch v of - [x, y, z] -> return (x, y, z, []) -- ignoring version tags since deprecated + [x, y, z] -> return (semver x y z) -- ignoring version tags since deprecated bad -> do let badVer = intercalate "." (map show bad) Left $ pack ("Not a SemVer version: " <> badVer) diff --git a/src/Data/SemVer/Types.hs b/src/Data/SemVer/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/SemVer/Types.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.SemVer.Types where + +import ClassyPrelude +import qualified Prelude as P +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Exts (IsList(..), Item) + +------------------------------------------------------------------------------- +-- Prerelease tags + +-- | Prerelease tags can either be numbers or text. +data PrereleaseTag + = IntTag Int + | TextTag Text + deriving (Eq, Ord, Generic) + +instance Show PrereleaseTag where + show (IntTag i) = show i + show (TextTag t) = T.unpack t + +instance IsString PrereleaseTag where + fromString = TextTag . fromString + +instance Hashable PrereleaseTag + +newtype PrereleaseTags = PrereleaseTags [PrereleaseTag] + deriving (Show, Eq, Monoid, Generic) + +instance IsList PrereleaseTags where + type Item PrereleaseTags = PrereleaseTag + fromList = PrereleaseTags + toList (PrereleaseTags tags) = tags + +instance Hashable PrereleaseTags +instance Ord PrereleaseTags where + -- | Compare two lists of prerelease tags. See for reference: + -- + -- https://github.com/npm/node-semver/blob/ + -- d21444a0658224b152ce54965d02dbe0856afb84/semver.js#L356 + -- + -- Note that having no prerelease tags is considered "greater" than having + -- them, the idea being that prerelease tags indicate a version which + -- is not yet complete. Conversely, if neither is empty, then greater length + -- is considered to be "greater" overall, if two versions have the same + -- prefix. + -- + -- Examples: + -- [A, B] < [] + -- [1, 2, 3] < [2] + -- [1, 2] < [1, 2, 3] + compare (PrereleaseTags prt1) (PrereleaseTags prt2) = case (prt1, prt2) of + ([], _:_) -> GT + (_:_, []) -> GT + _ -> go $ zipMaybe prt1 prt2 where + zipMaybe (x:xs) (y:ys) = (Just x, Just y) : zipMaybe xs ys + zipMaybe xs [] = [(Just x, Nothing) | x <- xs] + zipMaybe [] ys = [(Nothing, Just y) | y <- ys] + + go [] = EQ -- They were the same + go ((Nothing, Nothing):_) = EQ -- Same as above (shouldn't happen but) + go ((Just _, Nothing):_) = GT -- First list was longer than the second. + go ((Nothing, Just _):_) = LT -- Second list was longer than the first. + go ((Just tag1, Just tag2):rest) = case compare tag1 tag2 of + EQ -> go rest + result -> result + +------------------------------------------------------------------------------- +-- Build Metadata +-- +-- Extra data that can be attached to a version, but which doesn't affect its +-- version comparison. +type BuildMetaData = [Text] + +------------------------------------------------------------------------------- +-- Semantic versions (SemVers) +-- +-- | A SemVer has major, minor and patch versions, and zero or more +-- pre-release version tags. +data SemVer = SemVer { + svMajor :: !Int, + svMinor :: !Int, + svPatch :: !Int, + svTags :: !PrereleaseTags, + svBuildMetadata :: !BuildMetaData + } deriving (Eq, Generic) + +-- | Define an Ord instance which ignores the buildMetaData. +instance Ord SemVer where + compare (SemVer maj1 min1 pat1 tags1 _) (SemVer maj2 min2 pat2 tags2 _) = + compare (maj1, min1, pat1, tags1) (maj2, min2, pat2, tags2) + +instance Show SemVer where + show (SemVer x y z tags mdata) = base <> tags' <> mdata' where + base = show x <> "." <> show y <> "." <> show z + tags' = case tags of + PrereleaseTags [] -> mempty + PrereleaseTags tags -> "-" <> intercalate "." (map show tags) + mdata' = case mdata of + [] -> mempty + stuff -> "+" <> intercalate "." (map T.unpack stuff) + +instance Hashable SemVer + +-- | A range specifies bounds on a semver. +data SemVerRange + = Eq SemVer -- ^ Exact equality + | Gt SemVer -- ^ Greater than + | Lt SemVer -- ^ Less than + | Geq SemVer -- ^ Greater than or equal to + | Leq SemVer -- ^ Less than or equal to + | And SemVerRange SemVerRange -- ^ Conjunction + | Or SemVerRange SemVerRange -- ^ Disjunction + deriving (Eq, Ord) + +infixl 3 `And` +infixl 3 `Or` +infixl 4 `Eq` +infixl 4 `Gt` +infixl 4 `Geq` +infixl 4 `Lt` +infixl 4 `Leq` + +instance Show SemVerRange where + show = \case + Eq sv -> "=" <> show sv + Gt sv -> ">" <> show sv + Lt sv -> "<" <> show sv + Geq sv -> ">=" <> show sv + Leq sv -> "<=" <> show sv + And svr1 svr2 -> show svr1 <> " " <> show svr2 + Or svr1 svr2 -> show svr1 <> " || " <> show svr2 + +-- | Pull all of the concrete versions out of a range. +versionsOf :: SemVerRange -> [SemVer] +versionsOf = \case + Eq sv -> [sv] + Geq sv -> [sv] + Leq sv -> [sv] + Lt sv -> [sv] + Gt sv -> [sv] + And svr1 svr2 -> versionsOf svr1 <> versionsOf svr2 + Or svr1 svr2 -> versionsOf svr1 <> versionsOf svr2 + +-- | Create a SemVer with no version tags. +semver :: Int -> Int -> Int -> SemVer +semver major minor patch = semver' major minor patch [] + +-- | Create a SemVer with tags +semver' :: Int -> Int -> Int -> PrereleaseTags -> SemVer +semver' major minor patch tags = semver'' major minor patch tags [] + +-- | Create a SemVer with tags and metadata. +semver'' :: Int -> Int -> Int -> PrereleaseTags -> BuildMetaData -> SemVer +semver'' = SemVer + +-- | Get only the version tuple from a semver. +toTuple :: SemVer -> (Int, Int, Int) +toTuple (SemVer a b c _ _) = (a, b, c) + +-- | Get a list of tuples from a version range. +tuplesOf :: SemVerRange -> [(Int, Int, Int)] +tuplesOf = map toTuple . versionsOf + +-- | Get all of the prerelease tags from a version range. +rangePrereleaseTags :: SemVerRange -> PrereleaseTags +rangePrereleaseTags = concatMap svTags . versionsOf + +-- | Get the range prerelease tags if they're all the same; otherwise +-- Nothing. +sharedTags :: SemVerRange -> Maybe PrereleaseTags +sharedTags range = case map svTags $ versionsOf range of + [] -> Nothing -- shouldn't happen but in case + []:_ -> Nothing -- no prerelease tags, so that seals it + tagList:otherLists + | all (== tagList) otherLists -> Just tagList + | otherwise -> Nothing + +-- | Satisfies any version. +anyVersion :: SemVerRange +anyVersion = Geq $ semver 0 0 0 + +-- | Render a semver as Text. +renderSV :: SemVer -> Text +renderSV = pack . show + +-- | Returns whether a given semantic version matches a range. +-- Note that there are special cases when there are prerelease tags. For +-- details see https://github.com/npm/node-semver#prerelease-tags. +-- matches :: SemVerRange -> SemVer -> Bool +-- matches range version = case (sharedTags range, svTags version) of +-- -- This is the simple case, where neither the range nor the version has given +-- -- prerelease tags. Then we can just do regular predicate calculus. +-- (Nothing, PrereleaseTags []) -> matchesSimple range version +-- _ -> undefined +-- -- (Just rTags, PrereleaseTags vTags) +-- -- | rTags == vTags -> matchesSimple range version +-- -- | tuplesOf range /= [toTuple version] -> False +-- -- | otherwise -> matchesTags range rTags vTags +-- -- (_, _) -> False + +-- | Simple predicate calculus matching, doing AND and OR combination with +-- numerical comparison. +matches :: SemVerRange -> SemVer -> Bool +matches range ver = case range of + Eq sv -> ver == sv + Gt sv -> ver > sv + Lt sv -> ver < sv + Geq sv -> ver >= sv + Leq sv -> ver <= sv + And range1 range2 -> matches range1 ver && matches range2 ver + Or range1 range2 -> matches range1 ver || matches range2 ver + +infixl 2 `matches` + +-- | Given a range and two sets of tags, the first being a bound on the second, +-- uses the range to compare the tags and see if they match. +matchesTags :: SemVerRange -> [PrereleaseTag] -> [PrereleaseTag] -> Bool +matchesTags range rangeTags verTags = case range of + Eq _ -> verTags == rangeTags + Gt _ -> verTags > rangeTags + Lt _ -> verTags < rangeTags + Geq _ -> verTags >= rangeTags + Leq _ -> verTags <= rangeTags + -- Note that as we're currently doing things, these cases won't get hit. + And svr1 svr2 -> matchesTags svr1 verTags rangeTags && + matchesTags svr2 verTags rangeTags + Or svr1 svr2 -> matchesTags svr1 verTags rangeTags || + matchesTags svr2 verTags rangeTags + +-- | Gets the highest-matching semver in a range. +bestMatch :: SemVerRange -> [SemVer] -> Either String SemVer +bestMatch range vs = case filter (matches range) vs of + [] -> Left "No matching versions" + vs -> Right $ P.maximum vs diff --git a/tests/Unit.hs b/tests/Unit.hs new file mode 100644 --- /dev/null +++ b/tests/Unit.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} + + +module Main (main) where + +import ClassyPrelude +import Data.Either +import Test.Hspec +import Test.QuickCheck (property, Arbitrary(..), oneof) +import qualified Data.Text as T + +import Data.SemVer + +-- | This instance seems to be missing :( +instance (Arbitrary a, Arbitrary b, Arbitrary c, + Arbitrary d, Arbitrary e, Arbitrary f) + => Arbitrary (a, b, c, d, e, f) where + arbitrary = (,,,,,) <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary +-- | Arbitrary semver +instance Arbitrary SemVer where + arbitrary = semver' <$> arb <*> arb <*> arb <*> arbitrary where + arb = abs <$> arbitrary + +instance Arbitrary SemVerRange where + arbitrary = oneof [Eq <$> arbitrary, + Lt <$> arbitrary, + Gt <$> arbitrary, + Leq <$> arbitrary, + Geq <$> arbitrary + ] + +-- | Unsafe instance! +instance IsString SemVer where + fromString s = case parseSemVer (T.pack s) of + Right sv -> sv + Left err -> error $ show err + +-- | Unsafe instance! +instance IsString SemVerRange where + fromString s = case parseSemVerRange (T.pack s) of + Right svr -> svr + Left err -> error $ show err + +instance Arbitrary Text where + arbitrary = pack <$> arbitrary + +instance Arbitrary PrereleaseTag where + arbitrary = oneof [IntTag . abs <$> arbitrary] + +instance Arbitrary PrereleaseTags where + arbitrary = PrereleaseTags <$> arbitrary + +-- | Asserts that the first argument is a `Right` value equal to the second +-- argument. +shouldBeR :: (Show a, Show b, Eq b) => Either a b -> b -> IO () +shouldBeR x y = do + shouldSatisfy x isRight + let Right x' = x + x' `shouldBe` y + +infixl 1 `shouldBeR` + +main :: IO () +main = hspec $ do + describe "semver parsing" $ do + it "should parse basic semvers" $ property $ + -- Pre-apply absolute value so we know they're positive integers + \((abs -> maj, abs -> min, abs -> patch) :: (Int, Int, Int)) -> do + let s = intercalate "." $ map tshow ([maj, min, patch] :: [Int]) + parseSemVer s `shouldBeR` semver maj min patch + + it "should parse a semver with only major version" $ property $ + \(abs -> maj :: Int) -> do + parseSemVer (tshow maj) `shouldBeR` semver maj 0 0 + + it "should parse a semver with only major and minor versions" $ property $ + \((abs -> maj, abs -> min) :: (Int, Int)) -> do + let s = intercalate "." $ map tshow ([maj, min] :: [Int]) + parseSemVer s `shouldBeR` semver maj min 0 + + it "pretty-printing is an injection" $ property $ \sv -> do + parseSemVer (tshow sv) `shouldBeR` sv + + it "should parse a semver with metadata" $ do + parseSemVer "1.2.3-pre+asdf" `shouldBeR` semver'' 1 2 3 ["pre"] ["asdf"] + + describe "with release tags" $ do + it "should parse a semver with release tags" $ do + parseSemVer "1.2.3-alpha" `shouldBeR` semver' 1 2 3 ["alpha"] + parseSemVer "1.2.3alpha" `shouldBeR` semver' 1 2 3 ["alpha"] + + it "should parse a semver with multiple release tags" $ do + parseSemVer "1.2.3-alpha.3" `shouldBeR` semver' 1 2 3 ["alpha", IntTag 3] + parseSemVer "1.2.3alpha.3" `shouldBeR` semver' 1 2 3 ["alpha", IntTag 3] + + describe "prerelease tag comparison" $ do + it "should treat empty lists as greater" $ property $ + \(tags::PrereleaseTags) -> case tags of + PrereleaseTags [] -> return () + tags -> [] > tags `shouldBe` True + + describe "semver range parsing" $ do + it "should parse a semver into an exact range" $ property $ \sv -> do + -- This says that if we pretty-print a semver V and parse it as a + -- semver range, we get the range "= V" back. + parseSemVerRange (tshow sv) `shouldBeR` Eq sv + + it "pretty printing should be an injection" $ property $ \svr -> do + -- This says that if we pretty-print a semver V and parse it as a + -- semver range, we get the range "= V" back. + parseSemVerRange (tshow svr) `shouldBeR` svr + + it "should parse a semver with partial version into a range" $ property $ + \(abs -> maj :: Int, abs -> min :: Int) -> do + let expected = Geq (semver maj min 0) `And` Lt (semver maj (min + 1) 0) + parseIt = parseSemVerRange . T.intercalate "." + -- E.g. 1.2 =====> (>=1.2.0 <1.3) + parseIt [tshow maj, tshow min] `shouldBeR` expected + parseIt [tshow maj, tshow min, "X"] `shouldBeR` expected + parseIt [tshow maj, tshow min, "x"] `shouldBeR` expected + parseIt [tshow maj, tshow min, "*"] `shouldBeR` expected + + it "should parse a multi range" $ do + parseSemVerRange "1.2.3-pre+asdf - 2.4.3-pre+asdf" + `shouldBeR` Geq (semver'' 1 2 3 ["pre"] ["asdf"]) + `And` Lt (semver'' 2 4 3 ["pre"] ["asdf"]) + + it "poo" $ do + let svNoTags = semver 1 2 3 + svTags = semver' 1 2 3 ["pre"] + svTags' = semver' 2 4 3 ["pre"] + svNoTags >= svTags `shouldBe` True + let range = Geq svTags `And` Lt svTags' + range `matches` svNoTags `shouldBe` True + rangeTests + + +-- | These test cases were adapted from +-- https://github.com/npm/node-semver/blob/ +-- d21444a0658224b152ce54965d02dbe0856afb84/test/index.js#L134 +rangeTests :: Spec +rangeTests = describe "range tests" $ do + -- In each case, the range described in the first element of the + -- tuple should be satisfied by the concrete version described in + -- the second element of the tuple. + let testCases :: [(Text, Text)] = [ + ("1.0.0 - 2.0.0", "1.2.3"), + ("^1.2.3+build", "1.2.3"), + ("^1.2.3+build", "1.3.0"), + ("1.2.3-pre+asdf - 2.4.3-pre+asdf", "1.2.3"), + ("1.2.3-pre+asdf - 2.4.3pre+asdf", "1.2.3"), + ("1.2.3pre+asdf - 2.4.3pre+asdf", "1.2.3"), + ("1.2.3-pre+asdf - 2.4.3-pre+asdf", "1.2.3-pre.2"), + ("1.2.3-pre+asdf - 2.4.3-pre+asdf", "2.4.3-alpha"), + ("1.2.3+asdf - 2.4.3+asdf", "1.2.3"), + ("1.0.0", "1.0.0"), + (">=*", "0.2.4"), + ("", "1.0.0"), + ("*", "1.2.3"), + ("*", "v1.2.3"), + (">=1.0.0", "1.0.0"), + (">=1.0.0", "1.0.1"), + (">=1.0.0", "1.1.0"), + (">1.0.0", "1.0.1"), + (">1.0.0", "1.1.0"), + ("<=2.0.0", "2.0.0"), + ("<=2.0.0", "1.9999.9999"), + ("<=2.0.0", "0.2.9"), + ("<2.0.0", "1.9999.9999"), + ("<2.0.0", "0.2.9"), + (">= 1.0.0", "1.0.0"), + (">= 1.0.0", "1.0.1"), + (">= 1.0.0", "1.1.0"), + ("> 1.0.0", "1.0.1"), + ("> 1.0.0", "1.1.0"), + ("<= 2.0.0", "2.0.0"), + ("<= 2.0.0", "1.9999.9999"), + ("<= 2.0.0", "0.2.9"), + ("< 2.0.0", "1.9999.9999"), + ("<\t2.0.0", "0.2.9"), + (">=0.1.97", "v0.1.97"), + (">=0.1.97", "0.1.97"), + ("0.1.20 || 1.2.4", "1.2.4"), + (">=0.2.3 || <0.0.1", "0.0.0"), + (">=0.2.3 || <0.0.1", "0.2.3"), + (">=0.2.3 || <0.0.1", "0.2.4"), + ("||", "1.3.4"), + ("2.x.x", "2.1.3"), + ("1.2.x", "1.2.3"), + ("1.2.x || 2.x", "2.1.3"), + ("1.2.x || 2.x", "1.2.3"), + ("x", "1.2.3"), + ("2.*.*", "2.1.3"), + ("1.2.*", "1.2.3"), + ("1.2.* || 2.*", "2.1.3"), + ("1.2.* || 2.*", "1.2.3"), + ("*", "1.2.3"), + ("2", "2.1.2"), + ("2.3", "2.3.1"), + ("~2.4", "2.4.0"), + ("~2.4", "2.4.5"), + ("~>3.2.1", "3.2.2"), + ("~1", "1.2.3"), + ("~>1", "1.2.3"), + ("~> 1", "1.2.3"), + ("~1.0", "1.0.2"), + ("~ 1.0", "1.0.2"), + ("~ 1.0.3", "1.0.12"), + (">=1", "1.0.0"), + (">= 1", "1.0.0"), + ("<1.2", "1.1.1"), + ("< 1.2", "1.1.1"), + ("~v0.5.4-pre", "0.5.5"), + ("~v0.5.4-pre", "0.5.4"), + ("=0.7.x", "0.7.2"), + ("<=0.7.x", "0.7.2"), + (">=0.7.x", "0.7.2"), + ("<=0.7.x", "0.6.2"), + ("~1.2.1 >=1.2.3", "1.2.3"), + ("~1.2.1 =1.2.3", "1.2.3"), + ("~1.2.1 1.2.3", "1.2.3"), + ("~1.2.1 >=1.2.3 1.2.3", "1.2.3"), + ("~1.2.1 1.2.3 >=1.2.3", "1.2.3"), + ("~1.2.1 1.2.3", "1.2.3"), + (">=1.2.1 1.2.3", "1.2.3"), + ("1.2.3 >=1.2.1", "1.2.3"), + (">=1.2.3 >=1.2.1", "1.2.3"), + (">=1.2.1 >=1.2.3", "1.2.3"), + (">=1.2", "1.2.8"), + ("^1.2.3", "1.8.1"), + ("^0.1.2", "0.1.2"), + ("^0.1", "0.1.2"), + ("^1.2", "1.4.2"), + ("^1.2 ^1", "1.4.2"), + ("^1.2.3-alpha", "1.2.3-pre"), + ("^1.2.0-alpha", "1.2.0-pre"), + ("^0.0.1-alpha", "0.0.1-beta") + ] + forM_ testCases $ \(range, version) -> do + let fail_ = expectationFailure + it (show version <> " satisfies range " <> show range) $ do + case (parseSemVerRange range, parseSemVer version) of + (Left err, _) -> fail $ "Semver range parse failed: " <> show err + (_, Left err) -> fail $ "Semver parse failed: " <> show err + (Right range, Right version) -> case matches range version of + True -> True `shouldBe` True -- return () + False -> fail $ "Version " <> show version <> " didn't match range " + <> show range --`shouldBe` True