{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module BDCS.NPM.SemVer(SemVer(..),
SemVerIdentifier(..),
SemVerRangePart,
SemVerRange,
SemVerRangeSet,
parseSemVer,
parseSemVerRangeSet,
satisfies,
toText)
where
import Control.Monad(void)
import Data.Char(isAsciiLower, isAsciiUpper, isDigit)
import Data.List(intersperse)
import Data.Monoid((<>))
import qualified Data.Text as T
import Text.Parsec
import Text.Parsec.Error(Message(..), newErrorMessage)
import Text.Parsec.Pos(initialPos)
import Text.Parsec.Text(Parser)
data SemVer = SemVer { major :: Integer,
minor :: Integer,
patch :: Integer,
preRelease :: [SemVerIdentifier],
buildMeta :: [SemVerIdentifier]
} deriving (Eq, Show)
instance Ord SemVer where
compare v1 v2 = major v1 `compare` major v2 <>
minor v1 `compare` minor v2 <>
patch v1 `compare` patch v2 <>
comparePreRelease (preRelease v1) (preRelease v2)
where
comparePreRelease :: [SemVerIdentifier] -> [SemVerIdentifier] -> Ordering
comparePreRelease [] (_:_) = GT
comparePreRelease (_:_) [] = LT
comparePreRelease l1 l2 = l1 `compare` l2
data SemVerIdentifier = NumericIdentifier Integer
| TextIdentifier T.Text
deriving(Eq, Show)
instance Ord SemVerIdentifier where
compare (NumericIdentifier _) (TextIdentifier _) = LT
compare (TextIdentifier _) (NumericIdentifier _) = GT
compare (NumericIdentifier n1) (NumericIdentifier n2) = n1 `compare` n2
compare (TextIdentifier t1) (TextIdentifier t2) = t1 `compare` t2
parseSemVer :: T.Text -> Either ParseError SemVer
parseSemVer input = case parse justPartialParsec "" input of
Left e -> Left e
Right PartialSemVer{partialMajor=Just major,
partialMinor=Just minor,
partialPatch=Just patch,
..} -> Right $ SemVer major minor patch partialPreReleaseTags partialBuildMeta
Right _ -> Left $ newErrorMessage (Message "Wildcards not permitted in SemVer") (initialPos "")
where
justPartialParsec :: Parser PartialSemVer
justPartialParsec = do
p <- partialParsec
eof
return p
initialVer :: SemVer
initialVer = SemVer 0 0 0 [] []
type SemVerRangePart = [(Ordering, SemVer)]
type SemVerRange = [SemVerRangePart]
type SemVerRangeSet = [SemVerRange]
parseSemVerRangeSet :: T.Text -> Either ParseError SemVerRangeSet
parseSemVerRangeSet input = parse rangeSet "" input
where
logicalOr :: Parser ()
logicalOr = void $ string "||"
hyphen :: Parser ()
hyphen = void $ char '-'
gt :: Parser ()
gt = void $ char '>'
gte :: Parser ()
gte = void $ string ">="
eq :: Parser ()
eq = void $ char '='
lte :: Parser ()
lte = void $ string "<="
lt :: Parser ()
lt = void $ char '<'
tilde :: Parser ()
tilde = void $ char '~'
caret :: Parser ()
caret = void $ char '^'
operator :: Parser SemVerOrdering
operator =
(try gte >> return GreaterThanEqual) <|>
(gt >> return GreaterThan) <|>
(eq >> return EqualTo) <|>
(try lte >> return LessThanEqual) <|>
(lt >> return LessThan)
operatorToOrdering :: SemVerOrdering -> [Ordering]
operatorToOrdering GreaterThanEqual = [GT, EQ]
operatorToOrdering GreaterThan = [GT]
operatorToOrdering EqualTo = [EQ]
operatorToOrdering LessThanEqual = [LT, EQ]
operatorToOrdering LessThan = [LT]
rangeSet :: Parser SemVerRangeSet
rangeSet = do
set <- range `sepBy1` try (spaces >> logicalOr >> spaces)
eof
return set
range :: Parser SemVerRange
range =
try hyphenRange <|>
try simpleList <|>
return [[(EQ, initialVer), (GT, initialVer)]]
hyphenRange :: Parser SemVerRange
hyphenRange = do
lowerVersion <- partialParsec
spaces
hyphen
spaces
upperVersion <- partialParsec
return [partialToLowerRange lowerVersion, partialToUpperRange upperVersion]
simpleList :: Parser SemVerRange
simpleList = do
s <- simpleParsec
l <- option [] $ try (spaces >> simpleList)
return (s ++ l)
simpleParsec :: Parser SemVerRange
simpleParsec =
primitive <|>
tildeVersion <|>
caretVersion <|>
standaloneVersion
primitive :: Parser SemVerRange
primitive = do
ordering <- operator
spaces
p <- partialParsec
return $ if isExact p then
[map (\o -> (o, partialToLower p)) (operatorToOrdering ordering)]
else
case ordering of
EqualTo -> [partialToLowerRange p, partialToUpperRange p]
GreaterThan -> [[(GT, partialToUpper p), (EQ, partialToUpper p)]]
LessThan -> [[(LT, partialToLower p)]]
LessThanEqual -> [[(LT, partialToUpper p)]]
GreaterThanEqual -> [[(GT, partialToLower p), (EQ, partialToLower p)]]
tildeVersion :: Parser SemVerRange
tildeVersion = do
tilde
spaces
optional gt
spaces
version <- partialParsec
return [partialToLowerRange version, partialToTilde version]
caretVersion :: Parser SemVerRange
caretVersion = do
caret
spaces
version <- partialParsec
return [partialToLowerRange version, partialToCaret version]
standaloneVersion :: Parser SemVerRange
standaloneVersion = do
version <- partialParsec
return [partialToLowerRange version, partialToUpperRange version]
satisfies :: SemVer -> SemVerRangeSet -> Bool
satisfies v1 set = any satisfiesRange set
where
satisfiesRange :: SemVerRange -> Bool
satisfiesRange range = let
normalCase = all satisfiesPart range
preReleaseCase = any matchesPart range
isPreRelease = (not . null) (preRelease v1)
in
if isPreRelease then
normalCase && preReleaseCase
else
normalCase
satisfiesPart :: SemVerRangePart -> Bool
satisfiesPart = any satisfiesExpr
satisfiesExpr :: (Ordering, SemVer) -> Bool
satisfiesExpr (o, v2) = compare v1 v2 == o
matchesPart :: SemVerRangePart -> Bool
matchesPart = any matchesExpr
matchesExpr :: (Ordering, SemVer) -> Bool
matchesExpr (_, v2) = (not . null) (preRelease v2) &&
(major v1 == major v2) &&
(minor v1 == minor v2) &&
(patch v1 == patch v2)
toText :: SemVer -> T.Text
toText SemVer{..} = let
mainver = [T.pack $ show major, ".",
T.pack $ show minor, ".",
T.pack $ show patch]
prever = if null preRelease then [] else "-":idsToText preRelease
buildver = if null buildMeta then [] else "+":idsToText buildMeta
in
T.concat $ mainver ++ prever ++ buildver
where
idsToText ids = intersperse "." $ map idToText ids
idToText (NumericIdentifier i) = T.pack $ show i
idToText (TextIdentifier t) = t
data PartialSemVer = PartialSemVer {
partialMajor :: Maybe Integer,
partialMinor :: Maybe Integer,
partialPatch :: Maybe Integer,
partialPreReleaseTags :: [SemVerIdentifier],
partialBuildMeta :: [SemVerIdentifier]
} deriving (Show)
data SemVerOrdering = LessThan
| EqualTo
| GreaterThan
| LessThanEqual
| GreaterThanEqual
partialParsec :: Parser PartialSemVer
partialParsec = do
let integer = Just <$> read <$> many1 digit
let parseWildCard = try integer <|>
(oneOf "xX*" >> return Nothing)
skipMany $ oneOf "v=" <|> space
major <- parseWildCard
minor <- option Nothing (char '.' >> parseWildCard)
(patch, preRelease, buildMeta) <-
option (Nothing, [], []) $ do
patch <- char '.' >> parseWildCard
preRelease <- option [] (optional (char '-') >> parseExtra)
buildMeta <- option [] (char '+' >> parseExtra)
return (patch, preRelease, buildMeta)
spaces
return $ PartialSemVer major minor patch preRelease buildMeta
where
parseExtra :: Parser [SemVerIdentifier]
parseExtra = parseExtraItem `sepBy1` char '.'
parseExtraItem :: Parser SemVerIdentifier
parseExtraItem = do
str <- many1 (satisfy isAsciiLower <|>
satisfy isAsciiUpper <|>
satisfy isDigit <|>
char '-')
return $ if all isDigit str then
NumericIdentifier (read str)
else
TextIdentifier (T.pack str)
isExact :: PartialSemVer -> Bool
isExact PartialSemVer{partialMajor=(Just _),
partialMinor=(Just _),
partialPatch=(Just _),
..} = True
isExact _ = False
partialToLower :: PartialSemVer -> SemVer
partialToLower PartialSemVer{..} = let
(major, minor, patch, prerelease) = case (partialMajor, partialMinor, partialPatch) of
(Nothing, _, _) -> (0, 0, 0, [])
(Just partMajor, Nothing, _) -> (partMajor, 0, 0, [])
(Just partMajor, Just partMinor, Nothing) -> (partMajor, partMinor, 0, [])
(Just partMajor, Just partMinor, Just partPatch) -> (partMajor, partMinor, partPatch, partialPreReleaseTags)
in
SemVer major minor patch prerelease []
partialToUpper :: PartialSemVer -> SemVer
partialToUpper PartialSemVer{partialMajor=Nothing} = initialVer
partialToUpper PartialSemVer{partialMajor=(Just major),
partialMinor=Nothing,
..} = SemVer (major+1) 0 0 [] []
partialToUpper PartialSemVer{partialMajor=(Just major),
partialMinor=(Just minor),
partialPatch=Nothing,
..} = SemVer major (minor+1) 0 [] []
partialToUpper PartialSemVer{partialMajor=(Just major),
partialMinor=(Just minor),
partialPatch=(Just patch),
..} = SemVer major minor (patch+1) [] []
partialToLowerRange :: PartialSemVer -> SemVerRangePart
partialToLowerRange p = let
semver = partialToLower p
in
[(EQ, semver), (GT, semver)]
partialToUpperRange :: PartialSemVer -> SemVerRangePart
partialToUpperRange PartialSemVer{partialMajor=Nothing, ..} = [(GT, initialVer), (EQ, initialVer)]
partialToUpperRange PartialSemVer{partialMajor=(Just major),
partialMinor=(Just minor),
partialPatch=(Just patch),
..} =
let s = SemVer major minor patch partialPreReleaseTags []
in [(EQ, s), (LT, s)]
partialToUpperRange p = [(LT, partialToUpper p)]
partialToTilde :: PartialSemVer -> SemVerRangePart
partialToTilde PartialSemVer{partialPatch=(Just _), ..} = partialToUpperRange $ PartialSemVer partialMajor partialMinor Nothing [] []
partialToTilde p = partialToUpperRange p
partialToCaret :: PartialSemVer -> SemVerRangePart
partialToCaret PartialSemVer{partialMajor=(Just 0), partialMinor=(Just 0), ..} = partialToUpperRange $ PartialSemVer (Just 0) (Just 0) partialPatch [] []
partialToCaret PartialSemVer{partialMajor=(Just 0), ..} = partialToUpperRange $ PartialSemVer (Just 0) partialMinor Nothing [] []
partialToCaret PartialSemVer{..} = partialToUpperRange $ PartialSemVer partialMajor Nothing Nothing [] []