packages feed

semver-range 0.1.1 → 0.2.2

raw patch · 5 files changed

+654/−234 lines, 5 filesdep +QuickCheckdep +hspecdep ~basedep ~classy-prelude

Dependencies added: QuickCheck, hspec

Dependency ranges changed: base, classy-prelude

Files

semver-range.cabal view
@@ -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
src/Data/SemVer.hs view
@@ -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
src/Data/SemVer/Parser.hs view
@@ -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)
+ src/Data/SemVer/Types.hs view
@@ -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
+ tests/Unit.hs view
@@ -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