a bunch of passing unit tests

src/Data/SemVer/Parser.hs

@@ -3,10 +3,10 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedLists #-}
 
-module Data.SemVer.Parser (
-    parseSemVer, parseSemVerRange, pSemVerRange, pSemVer,
-    fromHaskellVersion, matchText
-  ) where
+module Data.SemVer.Parser where -- (
+  --   parseSemVer, parseSemVerRange, pSemVerRange, pSemVer, p
+  --   fromHaskellVersion, matchText
+  -- ) where
 
 import qualified Prelude as P
 import ClassyPrelude hiding (try, many)
@@ -28,15 +28,15 @@ type Parser = ParsecT String () Identity
 data Wildcard = Any
               | One Int
               | Two Int Int
-              | Three Int Int Int PrereleaseTags
+              | 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 (Three n m o tags) = semver' n m o tags
+wildcardToSemver (Full sv) = sv
 
 -- | Translates a wildcard (partially specified version) to a range.
 -- Ex: 2 := >=2.0.0 <3.0.0
@@ -46,32 +46,31 @@ 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)
-  Three n m o tags -> Eq (semver' n m o tags)
+  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 (Three 0 0 0 [])
+  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
-  Three n m o [] -> Geq (semver n m o) `And` Lt (semver n (m+1) 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
-  Three n m o tags -> Geq (semver' n m o tags) `And` Lt (semver n (m+1) 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)
-  Three 0 0 n tags -> Eq (semver' 0 0 n tags)
-  Three 0 n m tags -> Geq (semver' 0 n m tags) `And` Lt (semver' 0 (n+1) 0 tags)
-  Three n m o tags -> Geq (semver' n m o tags) `And` Lt (semver' (n+1) 0 0 tags)
+  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
@@ -82,11 +81,11 @@ 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)
-                    Three n m o tags -> Geq (semver' n m o tags)
+                    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)
-                    Three n m o tags -> Lt (semver' n m o tags)
+                    Full sv -> Lt sv
 
 -- | Given a parser and a string, attempts to parse the string.
 parse :: Parser a -> Text -> Either ParseError a
@@ -140,28 +139,35 @@ pSemVer :: Parser SemVer
 pSemVer = wildcardToSemver <$> pWildCard
 
 pVersionComp :: Parser SemVerRange
-pVersionComp = do
-  comparator <- cmp
-  let func = case comparator of
-        "=" -> Eq
-        ">" -> Gt
-        "<" -> Lt
-        ">=" -> Geq
-        "<=" -> Leq
-        "==" -> Eq
-  ver <- pSemVer
-  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
   ]
 
@@ -186,39 +192,42 @@ pWildCard = try $ do
   let getTag t = case readMaybe t of
         Just i -> IntTag i
         _ -> TextTag $ pack t
-  let tag = getTag <$> many1 (letter <|> digit <|> char '-' <|> char '+')
+  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
+    [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 <- tag `sepBy1` char '.'
-      return $ Three n m o (PrereleaseTags tags)
+      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

tests/Unit.hs

@@ -34,6 +34,14 @@ 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
@@ -50,7 +58,7 @@ instance Arbitrary Text where
   arbitrary = pack <$> arbitrary
 
 instance Arbitrary PrereleaseTag where
-  arbitrary = oneof [IntTag <$> arbitrary]
+  arbitrary = oneof [IntTag . abs <$> arbitrary]
 
 instance Arbitrary PrereleaseTags where
   arbitrary = PrereleaseTags <$> arbitrary
@@ -87,7 +95,7 @@ main = hspec $ do
       parseSemVer (tshow sv) `shouldBeR` sv
 
     it "should parse a semver with metadata" $ do
-      True `shouldBe` True
+      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
@@ -110,6 +118,11 @@ main = hspec $ do
       -- 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)
@@ -122,8 +135,8 @@ main = hspec $ do
 
     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"])
+        `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
@@ -244,5 +257,5 @@ rangeTests = describe "range tests" $ do
         (_, 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 "
+          False -> fail $ "Version " <> show version <> " didn't match range "
                        <> show range --`shouldBe` True