module Data.SemVer.Types where
import ClassyPrelude
import qualified Prelude as P
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Exts (IsList(..), Item)
data PrereleaseTag
= IntTag Int
| TextTag Text
deriving (Eq, Ord, Generic)
instance Show PrereleaseTag where
show (IntTag i) = show i
show (TextTag t) = T.unpack t
instance IsString PrereleaseTag where
fromString = TextTag . fromString
instance Hashable PrereleaseTag
newtype PrereleaseTags = PrereleaseTags [PrereleaseTag]
deriving (Show, Eq, Monoid, Generic)
instance IsList PrereleaseTags where
type Item PrereleaseTags = PrereleaseTag
fromList = PrereleaseTags
toList (PrereleaseTags tags) = tags
instance Hashable PrereleaseTags
instance Ord PrereleaseTags where
compare (PrereleaseTags prt1) (PrereleaseTags prt2) = case (prt1, prt2) of
([], _:_) -> GT
(_:_, []) -> GT
_ -> go $ zipMaybe prt1 prt2 where
zipMaybe (x:xs) (y:ys) = (Just x, Just y) : zipMaybe xs ys
zipMaybe xs [] = [(Just x, Nothing) | x <- xs]
zipMaybe [] ys = [(Nothing, Just y) | y <- ys]
go [] = EQ
go ((Nothing, Nothing):_) = EQ
go ((Just _, Nothing):_) = GT
go ((Nothing, Just _):_) = LT
go ((Just tag1, Just tag2):rest) = case compare tag1 tag2 of
EQ -> go rest
result -> result
type BuildMetaData = [Text]
data SemVer = SemVer {
svMajor :: !Int,
svMinor :: !Int,
svPatch :: !Int,
svTags :: !PrereleaseTags,
svBuildMetadata :: !BuildMetaData
} deriving (Eq, Generic)
instance Ord SemVer where
compare (SemVer maj1 min1 pat1 tags1 _) (SemVer maj2 min2 pat2 tags2 _) =
compare (maj1, min1, pat1, tags1) (maj2, min2, pat2, tags2)
instance Show SemVer where
show (SemVer x y z tags mdata) = base <> tags' <> mdata' where
base = show x <> "." <> show y <> "." <> show z
tags' = case tags of
PrereleaseTags [] -> mempty
PrereleaseTags tags -> "-" <> intercalate "." (map show tags)
mdata' = case mdata of
[] -> mempty
stuff -> "+" <> intercalate "." (map T.unpack stuff)
instance Hashable SemVer
data SemVerRange
= Eq SemVer
| Gt SemVer
| Lt SemVer
| Geq SemVer
| Leq SemVer
| And SemVerRange SemVerRange
| Or SemVerRange SemVerRange
deriving (Eq, Ord)
infixl 3 `And`
infixl 3 `Or`
infixl 4 `Eq`
infixl 4 `Gt`
infixl 4 `Geq`
infixl 4 `Lt`
infixl 4 `Leq`
instance Show SemVerRange where
show = \case
Eq sv -> "=" <> show sv
Gt sv -> ">" <> show sv
Lt sv -> "<" <> show sv
Geq sv -> ">=" <> show sv
Leq sv -> "<=" <> show sv
And svr1 svr2 -> show svr1 <> " " <> show svr2
Or svr1 svr2 -> show svr1 <> " || " <> show svr2
versionsOf :: SemVerRange -> [SemVer]
versionsOf = \case
Eq sv -> [sv]
Geq sv -> [sv]
Leq sv -> [sv]
Lt sv -> [sv]
Gt sv -> [sv]
And svr1 svr2 -> versionsOf svr1 <> versionsOf svr2
Or svr1 svr2 -> versionsOf svr1 <> versionsOf svr2
semver :: Int -> Int -> Int -> SemVer
semver major minor patch = semver' major minor patch []
semver' :: Int -> Int -> Int -> PrereleaseTags -> SemVer
semver' major minor patch tags = semver'' major minor patch tags []
semver'' :: Int -> Int -> Int -> PrereleaseTags -> BuildMetaData -> SemVer
semver'' = SemVer
toTuple :: SemVer -> (Int, Int, Int)
toTuple (SemVer a b c _ _) = (a, b, c)
tuplesOf :: SemVerRange -> [(Int, Int, Int)]
tuplesOf = map toTuple . versionsOf
rangePrereleaseTags :: SemVerRange -> PrereleaseTags
rangePrereleaseTags = concatMap svTags . versionsOf
sharedTags :: SemVerRange -> Maybe PrereleaseTags
sharedTags range = case map svTags $ versionsOf range of
[] -> Nothing
[]:_ -> Nothing
tagList:otherLists
| all (== tagList) otherLists -> Just tagList
| otherwise -> Nothing
anyVersion :: SemVerRange
anyVersion = Geq $ semver 0 0 0
renderSV :: SemVer -> Text
renderSV = pack . show
matches :: SemVerRange -> SemVer -> Bool
matches range ver = case range of
Eq sv -> ver == sv
Gt sv -> ver > sv
Lt sv -> ver < sv
Geq sv -> ver >= sv
Leq sv -> ver <= sv
And range1 range2 -> matches range1 ver && matches range2 ver
Or range1 range2 -> matches range1 ver || matches range2 ver
infixl 2 `matches`
matchesTags :: SemVerRange -> [PrereleaseTag] -> [PrereleaseTag] -> Bool
matchesTags range rangeTags verTags = case range of
Eq _ -> verTags == rangeTags
Gt _ -> verTags > rangeTags
Lt _ -> verTags < rangeTags
Geq _ -> verTags >= rangeTags
Leq _ -> verTags <= rangeTags
And svr1 svr2 -> matchesTags svr1 verTags rangeTags &&
matchesTags svr2 verTags rangeTags
Or svr1 svr2 -> matchesTags svr1 verTags rangeTags ||
matchesTags svr2 verTags rangeTags
bestMatch :: SemVerRange -> [SemVer] -> Either String SemVer
bestMatch range vs = case filter (matches range) vs of
[] -> Left "No matching versions"
vs -> Right $ P.maximum vs