module Data.SemVer.Parser (
parseSemVer, parseSemVerRange, pSemVerRange, pSemVer,
fromHaskellVersion, matchText
) where
import qualified Prelude as P
import ClassyPrelude hiding (try)
import Text.Parsec hiding ((<|>), spaces, parse, State, uncons)
import qualified Text.Parsec as Parsec
import Data.Version (Version(..))
import Data.SemVer
type Parser = ParsecT String () Identity
parse :: Parser a -> Text -> Either ParseError a
parse p = Parsec.parse p "" . unpack
parseFull :: Parser a -> Text -> Either ParseError a
parseFull p = Parsec.parse (p <* eof) "" . unpack
spaces :: Parser String
spaces = many $ char ' '
spaces1 :: Parser String
spaces1 = many1 $ char ' '
sstring :: String -> Parser String
sstring = lexeme . string
schar :: Char -> Parser Char
schar = lexeme . char
lexeme :: Parser a -> Parser a
lexeme p = p <* spaces
pInt :: Parser Int
pInt = lexeme pInt'
pInt' :: Parser Int
pInt' = P.read <$> many1 digit
parseSemVerRange :: Text -> Either ParseError SemVerRange
parseSemVerRange = parse pSemVerRange
parseSemVer :: Text -> Either ParseError SemVer
parseSemVer = parse pSemVer
pSemVer :: Parser SemVer
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
cmp :: Parser String
cmp = choice $ fmap (try . sstring) [">=", "<=", ">", "<", "==", "="]
pSemVerRangeSingle :: Parser SemVerRange
pSemVerRangeSingle = choice [
wildcardToRange <$> pWildCard,
tildeToRange <$> pTildeRange,
caratToRange <$> pCaratRange,
pVersionComp
]
pJoinedSemVerRange :: Parser SemVerRange
pJoinedSemVerRange = do
first <- pSemVerRangeSingle
option first $ do
lookAhead (sstring "||" <|> cmp) >>= \case
"||" -> Or first <$> (sstring "||" *> pJoinedSemVerRange)
_ -> And first <$> pJoinedSemVerRange
pHyphen :: Parser SemVerRange
pHyphen = hyphenatedRange <$> pWildCard <*> (sstring "-" *> pWildCard)
pWildCard :: Parser Wildcard
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 '-'
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
w -> unexpected ("Invalid version " ++ show w)
spaces *> return res
pTildeRange :: Parser Wildcard
pTildeRange = do
sstring "~"
optional $ choice [try $ sstring ">=", sstring ">", sstring "="]
pWildCard
pCaratRange :: Parser Wildcard
pCaratRange = sstring "^" *> pWildCard
pSemVerRange :: Parser SemVerRange
pSemVerRange = try pHyphen <|> pJoinedSemVerRange
fromHaskellVersion :: Version -> Either Text SemVer
fromHaskellVersion v = case versionBranch v of
[x, y, z] -> return (x, y, z, [])
bad -> do
let badVer = intercalate "." (map show bad)
Left $ pack ("Not a SemVer version: " <> badVer)
matchText :: Text -> Text -> Either Text Bool
matchText rangeTxt verTxt = case parseSemVerRange rangeTxt of
Left err -> Left ("Could not parse range: " <> pack (show err))
Right range -> case parseSemVer verTxt of
Left err -> Left ("Could not parse version: " <> pack (show err))
Right version -> Right $ matches range version