{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
module Data.Versions
(
Versioning(..), isIdeal, isGeneral, isComplex
, SemVer(..)
, PVP(..)
, Version(..)
, Mess(..), messMajor, messMinor, messPatch, messPatchChunk
, MChunk(..)
, VUnit(..), digits, str
, VChunk
, VSep(..)
, ParsingError
, versioning, semver, pvp, version, mess
, versioning', semver', pvp', version', mess'
, prettyV, prettySemVer, prettyPVP, prettyVer, prettyMess, errorBundlePretty
, Lens'
, Traversal'
, Semantic(..)
, _Versioning, _SemVer, _Version, _Mess
, _Ideal, _General, _Complex
, epoch
, _Digits, _Str
) where
import qualified Control.Applicative.Combinators.NonEmpty as PC
import Control.DeepSeq
import Control.Monad (void)
import Data.Bool (bool)
import Data.Char (isAlpha)
import Data.Foldable (fold)
import Data.Hashable (Hashable)
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Void (Void)
import GHC.Generics (Generic)
import Text.Megaparsec hiding (chunk)
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif
data Versioning = Ideal SemVer | General Version | Complex Mess
deriving (Eq, Show, Generic, NFData, Hashable)
isIdeal :: Versioning -> Bool
isIdeal (Ideal _) = True
isIdeal _ = False
isGeneral :: Versioning -> Bool
isGeneral (General _) = True
isGeneral _ = False
isComplex :: Versioning -> Bool
isComplex (Complex _) = True
isComplex _ = False
instance Ord Versioning where
compare (Ideal s) (Ideal s') = compare s s'
compare (General v) (General v') = compare v v'
compare (Complex m) (Complex m') = compare m m'
compare (Ideal s) (General v) = compare (vFromS s) v
compare (General v) (Ideal s) = opposite $ compare (vFromS s) v
compare (General v) (Complex m) = compare (mFromV v) m
compare (Complex m) (General v) = opposite $ compare (mFromV v) m
compare (Ideal s) (Complex m) = semverAndMess s m
compare (Complex m) (Ideal s) = opposite $ semverAndMess s m
vFromS :: SemVer -> Version
vFromS (SemVer ma mi pa re me) =
Version Nothing ((Digits ma :| []) :| [(Digits mi :| []), Digits pa :| []]) re me
mFromV :: Version -> Mess
mFromV (Version e v m r) = maybe affix (\a -> Mess (MDigit a (showt a) :| []) $ Just (VColon, affix)) e
where
affix :: Mess
affix = Mess (chunksAsM v) m'
m' :: Maybe (VSep, Mess)
m' = case NEL.nonEmpty m of
Nothing -> r'
Just m'' -> Just (VPlus, Mess (chunksAsM m'') r')
r' :: Maybe (VSep, Mess)
r' = case NEL.nonEmpty r of
Nothing -> Nothing
Just r'' -> Just (VHyphen, Mess (chunksAsM r'') Nothing)
semverAndMess :: SemVer -> Mess -> Ordering
semverAndMess s@(SemVer ma mi pa _ _) m = case compare ma <$> messMajor m of
Nothing -> fallback
Just LT -> LT
Just GT -> GT
Just EQ -> case compare mi <$> messMinor m of
Nothing -> fallback
Just LT -> LT
Just GT -> GT
Just EQ -> case compare pa <$> messPatch m of
Just LT -> LT
Just GT -> GT
Just EQ -> fallback
Nothing -> case messPatchChunk m of
Nothing -> fallback
Just (Digits pa':|_) -> case compare pa pa' of
LT -> LT
GT -> GT
EQ -> GT
Just _ -> fallback
where
fallback :: Ordering
fallback = compare (General $ vFromS s) (Complex m)
instance Semantic Versioning where
major f (Ideal v) = Ideal <$> major f v
major f (General v) = General <$> major f v
major f (Complex v) = Complex <$> major f v
{-# INLINE major #-}
minor f (Ideal v) = Ideal <$> minor f v
minor f (General v) = General <$> minor f v
minor f (Complex v) = Complex <$> minor f v
{-# INLINE minor #-}
patch f (Ideal v) = Ideal <$> patch f v
patch f (General v) = General <$> patch f v
patch f (Complex v) = Complex <$> patch f v
{-# INLINE patch #-}
release f (Ideal v) = Ideal <$> release f v
release f (General v) = General <$> release f v
release f (Complex v) = Complex <$> release f v
{-# INLINE release #-}
meta f (Ideal v) = Ideal <$> meta f v
meta f (General v) = General <$> meta f v
meta f (Complex v) = Complex <$> meta f v
{-# INLINE meta #-}
semantic f (Ideal v) = Ideal <$> semantic f v
semantic f (General v) = General <$> semantic f v
semantic f (Complex v) = Complex <$> semantic f v
{-# INLINE semantic #-}
_Versioning :: Traversal' Text Versioning
_Versioning f t = either (const (pure t)) (fmap prettyV . f) $ versioning t
{-# INLINE _Versioning #-}
_SemVer :: Traversal' Text SemVer
_SemVer f t = either (const (pure t)) (fmap prettySemVer . f) $ semver t
{-# INLINE _SemVer #-}
_Version :: Traversal' Text Version
_Version f t = either (const (pure t)) (fmap prettyVer . f) $ version t
{-# INLINE _Version #-}
_Mess :: Traversal' Text Mess
_Mess f t = either (const (pure t)) (fmap prettyMess . f) $ mess t
{-# INLINE _Mess #-}
_Ideal :: Traversal' Versioning SemVer
_Ideal f (Ideal s) = Ideal <$> f s
_Ideal _ v = pure v
{-# INLINE _Ideal #-}
_General :: Traversal' Versioning Version
_General f (General v) = General <$> f v
_General _ v = pure v
{-# INLINE _General #-}
_Complex :: Traversal' Versioning Mess
_Complex f (Complex m) = Complex <$> f m
_Complex _ v = pure v
{-# INLINE _Complex #-}
type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s
class Semantic v where
major :: Traversal' v Word
minor :: Traversal' v Word
patch :: Traversal' v Word
release :: Traversal' v [VChunk]
meta :: Traversal' v [VChunk]
semantic :: Traversal' v SemVer
instance Semantic Text where
major = _Versioning . major
minor = _Versioning . minor
patch = _Versioning . patch
release = _Versioning . release
meta = _Versioning . meta
semantic = _SemVer
data SemVer = SemVer
{ _svMajor :: !Word
, _svMinor :: !Word
, _svPatch :: !Word
, _svPreRel :: ![VChunk]
, _svMeta :: ![VChunk] }
deriving stock (Show, Generic)
deriving anyclass (NFData, Hashable)
instance Eq SemVer where
(SemVer ma mi pa pr _) == (SemVer ma' mi' pa' pr' _) =
(ma,mi,pa,pr) == (ma',mi',pa',pr')
instance Ord SemVer where
compare (SemVer ma mi pa pr _) (SemVer ma' mi' pa' pr' _) =
case compare (ma,mi,pa) (ma',mi',pa') of
LT -> LT
GT -> GT
EQ -> case (pr,pr') of
([],[]) -> EQ
([],_) -> GT
(_,[]) -> LT
_ -> compare pr pr'
instance Semigroup SemVer where
SemVer mj mn pa p m <> SemVer mj' mn' pa' p' m' =
SemVer (mj + mj') (mn + mn') (pa + pa') (p ++ p') (m ++ m')
instance Monoid SemVer where
mempty = SemVer 0 0 0 [] []
#if !MIN_VERSION_base(4,11,0)
mappend = (<>)
#endif
instance Semantic SemVer where
major f sv = fmap (\ma -> sv { _svMajor = ma }) (f $ _svMajor sv)
{-# INLINE major #-}
minor f sv = fmap (\mi -> sv { _svMinor = mi }) (f $ _svMinor sv)
{-# INLINE minor #-}
patch f sv = fmap (\pa -> sv { _svPatch = pa }) (f $ _svPatch sv)
{-# INLINE patch #-}
release f sv = fmap (\pa -> sv { _svPreRel = pa }) (f $ _svPreRel sv)
{-# INLINE release #-}
meta f sv = fmap (\pa -> sv { _svMeta = pa }) (f $ _svMeta sv)
{-# INLINE meta #-}
semantic = ($)
{-# INLINE semantic #-}
data VUnit = Digits Word | Str Text
deriving stock (Eq, Show, Read, Ord, Generic)
deriving anyclass (NFData, Hashable)
instance Semigroup VUnit where
Digits n <> Digits m = Digits $ n + m
Str t <> Str s = Str $ t <> s
Digits n <> _ = Digits n
_ <> Digits n = Digits n
instance Monoid VUnit where
mempty = Str ""
#if !MIN_VERSION_base(4,11,0)
mappend = (<>)
#endif
digits :: Word -> VUnit
digits = Digits
str :: Text -> Maybe VUnit
str t = bool Nothing (Just $ Str t) $ T.all isAlpha t
_Digits :: Traversal' VUnit Word
_Digits f (Digits i) = Digits <$> f i
_Digits _ v = pure v
{-# INLINE _Digits #-}
_Str :: Traversal' VUnit Text
_Str f (Str t) = Str . (\t' -> bool t t' (T.all isAlpha t')) <$> f t
_Str _ v = pure v
{-# INLINE _Str #-}
type VChunk = NonEmpty VUnit
newtype PVP = PVP { _pComponents :: NonEmpty Word }
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (NFData, Hashable)
instance Semigroup PVP where
PVP (m :| r) <> PVP (m' :| r') = PVP $ (m + m') :| f r r'
where
f a [] = a
f [] b = b
f (a:as) (b:bs) = (a + b) : f as bs
instance Monoid PVP where
mempty = PVP (0 :| [])
#if !MIN_VERSION_base(4,11,0)
mappend = (<>)
#endif
instance Semantic PVP where
major f (PVP (m :| rs)) = (\ma -> PVP $ ma :| rs) <$> f m
{-# INLINE major #-}
minor f (PVP (m :| mi : rs)) = (\mi' -> PVP $ m :| mi' : rs) <$> f mi
minor f (PVP (m :| [])) = (\mi' -> PVP $ m :| [mi']) <$> f 0
{-# INLINE minor #-}
patch f (PVP (m :| mi : pa : rs)) = (\pa' -> PVP $ m :| mi : pa' : rs) <$> f pa
patch f (PVP (m :| mi : [])) = (\pa' -> PVP $ m :| mi : [pa']) <$> f 0
patch f (PVP (m :| [])) = (\pa' -> PVP $ m :| 0 : [pa']) <$> f 0
{-# INLINE patch #-}
release f p = const p <$> f []
{-# INLINE release #-}
meta f p = const p <$> f []
{-# INLINE meta #-}
semantic f (PVP (m :| rs)) = (\(SemVer ma mi pa _ _) -> PVP $ ma :| [mi, pa]) <$> f s
where
s = case rs of
mi : pa : _ -> SemVer m mi pa [] []
mi : _ -> SemVer m mi 0 [] []
[] -> SemVer m 0 0 [] []
{-# INLINE semantic #-}
data Version = Version
{ _vEpoch :: !(Maybe Word)
, _vChunks :: !(NonEmpty VChunk)
, _vMeta :: ![VChunk]
, _vRel :: ![VChunk] }
deriving stock (Eq, Show, Generic)
deriving anyclass (NFData, Hashable)
instance Semigroup Version where
Version e c m r <> Version e' c' m' r' = Version ((+) <$> e <*> e') (c <> c') (m <> m') (r <> r')
instance Ord Version where
compare (Version ae as _ rs) (Version be bs _ rs') = case compare (fromMaybe 0 ae) (fromMaybe 0 be) of
EQ -> case g (NEL.toList as) (NEL.toList bs) of
EQ -> g rs rs'
ord -> ord
ord -> ord
where
g :: [VChunk] -> [VChunk] -> Ordering
g [] [] = EQ
g [] ((Str _ :| _):_) = GT
g ((Str _ :| _):_) [] = LT
g _ [] = GT
g [] _ = LT
g (x:xs) (y:ys) = case f (NEL.toList x) (NEL.toList y) of
EQ -> g xs ys
res -> res
f :: [VUnit] -> [VUnit] -> Ordering
f [] [] = EQ
f [] _ = GT
f _ [] = LT
f (Digits n:ns) (Digits m:ms) | n > m = GT
| n < m = LT
| otherwise = f ns ms
f (Str n:ns) (Str m:ms) | n > m = GT
| n < m = LT
| otherwise = f ns ms
f (Digits _ :_) (Str _ :_) = GT
f (Str _ :_ ) (Digits _ :_) = LT
instance Semantic Version where
major f (Version e ((Digits n :| []) :| cs) me rs) =
(\n' -> Version e ((Digits n' :| []) :| cs) me rs) <$> f n
major _ v = pure v
{-# INLINE major #-}
minor f (Version e (c :| (Digits n :| []) : cs) me rs) =
(\n' -> Version e (c :| (Digits n' :| []) : cs) me rs) <$> f n
minor _ v = pure v
{-# INLINE minor #-}
patch f (Version e (c :| d : (Digits n :| []) : cs) me rs) =
(\n' -> Version e (c :| d : (Digits n' :| []) : cs) me rs) <$> f n
patch _ v = pure v
{-# INLINE patch #-}
release f v = fmap (\vr -> v { _vRel = vr }) (f $ _vRel v)
{-# INLINE release #-}
meta _ v = pure v
{-# INLINE meta #-}
semantic f (Version _ ((Digits a:|[]) :| (Digits b:|[]) : (Digits c:|[]) : _) me rs) =
vFromS <$> f (SemVer a b c me rs)
semantic _ v = pure v
{-# INLINE semantic #-}
epoch :: Lens' Version (Maybe Word)
epoch f v = fmap (\ve -> v { _vEpoch = ve }) (f $ _vEpoch v)
{-# INLINE epoch #-}
data MChunk
= MDigit Word Text
| MRev Word Text
| MPlain Text
deriving stock (Eq, Show, Generic)
deriving anyclass (NFData, Hashable)
instance Ord MChunk where
compare (MDigit a _) (MDigit b _) = compare a b
compare (MRev a _) (MRev b _) = compare a b
compare (MPlain a) (MPlain b) = compare a b
compare a b = compare (mchunkText a) (mchunkText b)
mchunkText :: MChunk -> Text
mchunkText (MDigit _ t) = t
mchunkText (MRev _ t) = t
mchunkText (MPlain t) = t
data Mess = Mess !(NonEmpty MChunk) !(Maybe (VSep, Mess))
deriving stock (Eq, Show, Generic)
deriving anyclass (NFData, Hashable)
messMajor :: Mess -> Maybe Word
messMajor (Mess (MDigit i _ :| _) _) = Just i
messMajor _ = Nothing
messMinor :: Mess -> Maybe Word
messMinor (Mess (_ :| MDigit i _ : _) _) = Just i
messMinor _ = Nothing
messPatch :: Mess -> Maybe Word
messPatch (Mess (_ :| _ : MDigit i _ : _) _) = Just i
messPatch _ = Nothing
messPatchChunk :: Mess -> Maybe VChunk
messPatchChunk (Mess (_ :| _ : MPlain p : _) _) = hush $ parse chunk "Chunk" p
messPatchChunk _ = Nothing
instance Ord Mess where
compare (Mess t1 Nothing) (Mess t2 Nothing) = compare t1 t2
compare (Mess t1 m1) (Mess t2 m2) = case compare t1 t2 of
EQ -> case (m1, m2) of
(Just (_, v1), Just (_, v2)) -> compare v1 v2
(Just (_, _), Nothing) -> GT
(Nothing, Just (_, _)) -> LT
(Nothing, Nothing) -> EQ
res -> res
instance Semantic Mess where
major f (Mess (MDigit n _ :| ts) m) = (\n' -> Mess (MDigit n' (showt n') :| ts) m) <$> f n
major _ v = pure v
{-# INLINE major #-}
minor f (Mess (t0 :| MDigit n _ : ts) m) = (\n' -> Mess (t0 :| MDigit n' (showt n') : ts) m) <$> f n
minor _ v = pure v
{-# INLINE minor #-}
patch f (Mess (t0 :| t1 : MDigit n _ : ts) m) = (\n' -> Mess (t0 :| t1 : MDigit n' (showt n') : ts) m) <$> f n
patch _ v = pure v
{-# INLINE patch #-}
release _ v = pure v
{-# INLINE release #-}
meta _ v = pure v
{-# INLINE meta #-}
semantic f (Mess (MDigit t0 _ :| MDigit t1 _ : MDigit t2 _ : _) _) =
mFromV . vFromS <$> (f $ SemVer t0 t1 t2 [] [])
semantic _ v = pure v
{-# INLINE semantic #-}
data VSep = VColon | VHyphen | VPlus | VUnder
deriving stock (Eq, Show, Generic)
deriving anyclass (NFData, Hashable)
type ParsingError = ParseErrorBundle Text Void
versioning :: Text -> Either ParsingError Versioning
versioning = parse versioning' "versioning"
versioning' :: Parsec Void Text Versioning
versioning' = choice [ try (fmap Ideal semver'' <* eof)
, try (fmap General version'' <* eof)
, fmap Complex mess'' <* eof ]
semver :: Text -> Either ParsingError SemVer
semver = parse (semver'' <* eof) "Semantic Version"
semver' :: Parsec Void Text SemVer
semver' = L.lexeme space semver''
semver'' :: Parsec Void Text SemVer
semver'' = SemVer <$> majorP <*> minorP <*> patchP <*> preRel <*> metaData
digitsP :: Parsec Void Text Word
digitsP = read <$> ((T.unpack <$> string "0") <|> some digitChar)
majorP :: Parsec Void Text Word
majorP = digitsP <* char '.'
minorP :: Parsec Void Text Word
minorP = majorP
patchP :: Parsec Void Text Word
patchP = digitsP
preRel :: Parsec Void Text [VChunk]
preRel = (char '-' *> chunks) <|> pure []
metaData :: Parsec Void Text [VChunk]
metaData = (char '+' *> chunks) <|> pure []
chunksNE :: Parsec Void Text (NonEmpty VChunk)
chunksNE = chunk `PC.sepBy1` char '.'
chunks :: Parsec Void Text [VChunk]
chunks = chunk `sepBy` char '.'
chunk :: Parsec Void Text VChunk
chunk = try zeroWithLetters <|> oneZero <|> PC.some (iunit <|> sunit)
where oneZero = (:|[]) . Digits . read . T.unpack <$> string "0"
zeroWithLetters = do
z <- Digits . read . T.unpack <$> string "0"
s <- PC.some sunit
c <- optional chunk
case c of
Nothing -> pure $ NEL.cons z s
Just c' -> pure $ NEL.cons z s <> c'
iunit :: Parsec Void Text VUnit
iunit = Digits . read <$> some digitChar
sunit :: Parsec Void Text VUnit
sunit = Str . T.pack <$> some letterChar
pvp :: Text -> Either ParsingError PVP
pvp = parse (pvp' <* eof) "PVP"
pvp' :: Parsec Void Text PVP
pvp' = L.lexeme space (PVP . NEL.fromList <$> L.decimal `sepBy` char '.')
version :: Text -> Either ParsingError Version
version = parse (version'' <* eof) "Version"
version' :: Parsec Void Text Version
version' = L.lexeme space version''
version'' :: Parsec Void Text Version
version'' = Version <$> optional (try epochP) <*> chunksNE <*> metaData <*> preRel
epochP :: Parsec Void Text Word
epochP = read <$> (some digitChar <* char ':')
mess :: Text -> Either ParsingError Mess
mess = parse (mess'' <* eof) "Mess"
mess' :: Parsec Void Text Mess
mess' = L.lexeme space mess''
mess'' :: Parsec Void Text Mess
mess'' = Mess <$> mchunks <*> optional ((,) <$> sep <*> mess')
mchunks :: Parsec Void Text (NonEmpty MChunk)
mchunks = mchunk `PC.sepBy1` char '.'
mchunk :: Parsec Void Text MChunk
mchunk = choice [ try $ (\(t, i) -> MDigit i t) <$> match (L.decimal <* next)
, try $ (\(t, i) -> MRev i t) <$> (match (single 'r' *> L.decimal <* next))
, MPlain . T.pack <$> some (letterChar <|> digitChar) ]
where
next :: Parsec Void Text ()
next = lookAhead (void (single '.') <|> void sep <|> eof)
sep :: Parsec Void Text VSep
sep = choice [ VColon <$ char ':'
, VHyphen <$ char '-'
, VPlus <$ char '+'
, VUnder <$ char '_' ]
sepCh :: VSep -> Char
sepCh VColon = ':'
sepCh VHyphen = '-'
sepCh VPlus = '+'
sepCh VUnder = '_'
prettyV :: Versioning -> Text
prettyV (Ideal sv) = prettySemVer sv
prettyV (General v) = prettyVer v
prettyV (Complex m) = prettyMess m
prettySemVer :: SemVer -> Text
prettySemVer (SemVer ma mi pa pr me) = mconcat $ ver <> pr' <> me'
where
ver = intersperse "." [ showt ma, showt mi, showt pa ]
pr' = foldable [] ("-" :) $ intersperse "." (chunksAsT pr)
me' = foldable [] ("+" :) $ intersperse "." (chunksAsT me)
prettyPVP :: PVP -> Text
prettyPVP (PVP (m :| rs)) = T.intercalate "." . map showt $ m : rs
prettyVer :: Version -> Text
prettyVer (Version ep cs me pr) = ep' <> mconcat (ver <> me' <> pr')
where
ver = intersperse "." . chunksAsT $ NEL.toList cs
me' = foldable [] ("+" :) $ intersperse "." (chunksAsT me)
pr' = foldable [] ("-" :) $ intersperse "." (chunksAsT pr)
ep' = maybe "" (\e -> showt e <> ":") ep
prettyMess :: Mess -> Text
prettyMess (Mess t m) = case m of
Nothing -> t'
Just (s, v) -> T.snoc t' (sepCh s) <> prettyMess v
where
t' :: Text
t' = fold . NEL.intersperse "." $ NEL.map mchunkText t
chunksAsT :: Functor t => t VChunk -> t Text
chunksAsT = fmap (foldMap f)
where
f :: VUnit -> Text
f (Digits i) = showt i
f (Str s) = s
chunksAsM :: Functor t => t VChunk -> t MChunk
chunksAsM = fmap f
where
f :: VChunk -> MChunk
f (Digits i :| []) = MDigit i $ showt i
f (Str "r" :| [Digits i]) = MRev i . T.cons 'r' $ showt i
f vc = MPlain . T.concat $ chunksAsT [vc]
foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b
foldable d g f | null f = d
| otherwise = g f
opposite :: Ordering -> Ordering
opposite EQ = EQ
opposite LT = GT
opposite GT = LT
showt :: Show a => a -> Text
showt = T.pack . show
hush :: Either a b -> Maybe b
hush (Left _) = Nothing
hush (Right b) = Just b