{-# 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 (isRight, isLeft)
import Test.Hspec
import Test.QuickCheck (property, Arbitrary(..), oneof)
import qualified Data.Text as T
import Data.SemVer
-- | 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`
shouldBeL :: (Show a, Show b, Eq a) => Either a b -> IO ()
shouldBeL x = shouldSatisfy x isLeft
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 "should parse semvers with && instead of spaces" $ do
let expected = Geq (semver 2 0 0) `And` Leq (semver 2 15 0)
parseSemVerRange ">= 2 && <= 2.14" `shouldBeR` expected
it "should fail when it's wrong" $ do
shouldBeL (parseSemVerRange "xyz")
rangeTests
cleanTests
-- | These test cases were adapted from
-- https://github.com/npm/node-semver/blob/master/test/clean.js
cleanTests :: Spec
cleanTests = describe "unclean version strings" $ do
let examples :: [(Text, Maybe Text)] = [
("1.2.3", Just "1.2.3"),
(" 1.2.3 ", Just "1.2.3"),
(" 1.2.3-4 ", Just "1.2.3-4"),
(" 1.2.3-pre ", Just "1.2.3-pre"),
(" =v1.2.3 ", Just "1.2.3"),
("v1.2.3", Just "1.2.3"),
(" v1.2.3 ", Just "1.2.3"),
("\t1.2.3", Just "1.2.3"),
(">1.2.3", Nothing),
("~1.2.3", Nothing),
("<=1.2.3", Nothing)
-- The example below is given in the tests but this doesn't
-- seem like an error to me, so there.
-- ("1.2.x", Nothing)
]
forM_ examples $ \(string, result) -> case result of
Just string' -> do
it ("should parse " <> show string <> " same as " <> show string') $ do
parseSemVer string `shouldSatisfy` isRight
parseSemVer string `shouldBe` parseSemVer string'
Nothing -> do
it ("should not parse " <> show string) $ do
parseSemVer string `shouldSatisfy` isLeft
-- | These test cases were adapted from
-- https://github.com/npm/node-semver/blob/master/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 :: [(Bool, Text, Text)] = [
-- Range constraints with pre-release tags require that any
-- version satisfying the constraint must be equivalent (in
-- its semantic version tuple) to the minimum of all semantic
-- versions within the range. In this case the minimum of the
-- range is "1.2.3" and the version's semantic version tuple
-- is "1.2.4", therefore it does not satisfy the constraints
-- of the range given the presence of pre-release tags.
(False, "1.2.3-pre+asdf - 2.4.3-pre+asdf", "1.2.4-pre+asdf"),
(False, "1.2.3-pre+asdf - 2.4.3-pre+asdf", "2.4.3-alpha"),
(False, ">=0.0.1-alpha <0.2.0-alpha", "0.1.1-alpha"),
(False, "^0.0.1-alpha", "0.0.4-alpha"),
-- Range constraints without prerelease tags are very strict
-- about not admitting versions *with* prerelease tags
(False, "^0.1.2", "0.1.2-beta1"),
(False, "^0.1.2", "0.1.4-beta1"),
-- Despite the numeric quantity, these versions have
-- prerelease tags and are therefore subjected to the same
-- invariant checking.
(False, "^1.2.3-1", "1.8.1-1"),
(False, "^1.2.3-1", "1.8.1-4"),
-- If we ever have an exact version tuple match at the top of
-- a given range then it must satisfy the range constraint!
--
-- e.g. "^1.2.3-alpha" translates to ">=1.2.3-alpha
-- <2.0.0-alpha" and the version to check is "2.0.0-alpha". In
-- this case the version tuples are equivalent, sans
-- prerelease tags, but it does not satisfy the upper-bound
-- less-than relation.
(False, "^1.2.3-alpha", "2.0.0-alpha"),
(True, "1.2.3-pre+asdf - 2.4.3-pre+asdf", "1.2.3-pre+asdf"),
(True, "", "1.0.0"),
(True, "*", "1.2.3"),
(True, "*", "1.2.3"),
(True, "*", "v1.2.3"),
(True, "0.1.20 || 1.2.4", "1.2.4"),
(True, "1.0.0 - 2.0.0", "1.2.3"),
(True, "1.0.0", "1.0.0"),
(True, "1.2.* || 2.*", "1.2.3"),
(True, "1.2.* || 2.*", "2.1.3"),
(True, "1.2.*", "1.2.3"),
(True, "1.2.3 - 2.4.3", "1.2.4"),
(True, "1.2.3 >=1.2.1", "1.2.3"),
(True, "1.2.3+asdf - 2.4.3+asdf", "1.2.3"),
(True, "1.2.3-pre+asdf - 2.4.3-pre+asdf", "1.2.3"),
(True, "1.2.3-pre+asdf - 2.4.3-pre+asdf", "1.2.3-pre.2"),
(True, "1.2.3-pre+asdf - 2.4.3-pre+asdf", "1.2.3-pred"),
(True, "1.2.3-pre+asdf - 2.4.3pre+asdf", "1.2.3"),
(True, "1.2.3pre+asdf - 2.4.3pre+asdf", "1.2.3"),
(True, "1.2.x || 2.x", "1.2.3"),
(True, "1.2.x || 2.x", "2.1.3"),
(True, "1.2.x", "1.2.3"),
(True, "2", "2.1.2"),
(True, "2.*.*", "2.1.3"),
(True, "2.3", "2.3.1"),
(True, "2.x.x", "2.1.3"),
(True, "< 2.0.0", "1.9999.9999"),
(True, "< 1.2", "1.1.1"),
(True, "<1.2", "1.1.1"),
(True, "<2.0.0", "0.2.9"),
(True, "<2.0.0", "1.9999.9999"),
(True, "<= 2.0.0", "2.0.0"),
(True, "<= 2.0.0", "0.2.9"),
(True, "<= 2.0.0", "1.9999.9999"),
(True, "<=0.7.x", "0.6.2"),
(True, "<=0.7.x", "0.7.2"),
(True, "<=2.0.0", "0.2.9"),
(True, "<=2.0.0", "1.9999.9999"),
(True, "<=2.0.0", "2.0.0"),
(True, "<\t2.0.0", "0.2.9"),
(True, "=0.7.x", "0.7.2"),
(True, "> 1.0.0", "1.1.0"),
(True, "> 1.0.0", "1.0.1"),
(True, ">1.0.0", "1.0.1"),
(True, ">1.0.0", "1.1.0"),
(True, ">= 1.0.0", "1.1.0"),
(True, ">= 1.0.0", "1.0.1"),
(True, ">= 1", "1.0.0"),
(True, ">= 1.0.0", "1.0.0"),
(True, ">= 4.0.0 <4.1.0-0", "4.0.1"),
(True, ">=*", "0.2.4"),
(True, ">=0.1.97", "0.1.97"),
(True, ">=0.1.97", "v0.1.97"),
(True, ">=0.2.3 || <0.0.1", "0.0.0"),
(True, ">=0.2.3 || <0.0.1", "0.2.3"),
(True, ">=0.2.3 || <0.0.1", "0.2.4"),
(True, ">=0.7.x", "0.7.2"),
(True, ">=1", "1.0.0"),
(True, ">=1.0.0", "1.0.0"),
(True, ">=1.0.0", "1.0.1"),
(True, ">=1.0.0", "1.1.0"),
(True, ">=1.2", "1.2.8"),
(True, ">=1.2.1 1.2.3", "1.2.3"),
(True, ">=1.2.1 >=1.2.3", "1.2.3"),
(True, ">=1.2.3 >=1.2.1", "1.2.3"),
(True, "^0.0.1-alpha", "0.0.1-beta"),
(True, "^0.0.1-alpha.1", "0.0.1-alpha.t"),
(True, "^0.0.1-alpha.1", "0.0.1-alpha.tdff.dddddddddd"),
(True, "^0.1", "0.1.2"),
(True, "^0.1.2", "0.1.2"),
(True, "^1.2 ^1", "1.4.2"),
(True, "^1.2", "1.4.2"),
(True, "^1.2.0-alpha", "1.2.0-pre"),
(True, "^1.2.3", "1.8.1"),
(True, "^1.2.3+build", "1.2.3"),
(True, "^1.2.3+build", "1.3.0"),
(True, "^1.2.3-alpha", "1.2.3-pre"),
(True, "^1.2.3-alpha.1", "1.2.3-alpha.7"),
(True, "^1.2.3-boop", "1.2.4"),
(True, "x", "1.2.3"),
(True, "||", "1.3.4"),
(True, "~ 1.0", "1.0.2"),
(True, "~ 1.0.3", "1.0.12"),
(True, "~1", "1.2.3"),
(True, "~1.0", "1.0.2"),
(True, "~1.2.1 1.2.3 >=1.2.3", "1.2.3"),
(True, "~1.2.1 1.2.3", "1.2.3"),
(True, "~1.2.1 1.2.3", "1.2.3"),
(True, "~1.2.1 =1.2.3", "1.2.3"),
(True, "~1.2.1 >=1.2.3 1.2.3", "1.2.3"),
(True, "~1.2.1 >=1.2.3", "1.2.3"),
(True, "~2.4", "2.4.0"),
(True, "~2.4", "2.4.5"),
(True, "~> 1", "1.2.3"),
(True, "~>1", "1.2.3"),
(True, "~v0.5.4-pre", "0.5.4"),
(True, "~v0.5.4-pre", "0.5.5"),
(True, "~>3.2.1", "3.2.2")
]
forM_ testCases $ \(expectedMatchBool, 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) -> matches range version `shouldBe` expectedMatchBool