module Stack.Types.Version
(Version
,Cabal.VersionRange
,IntersectingVersionRange(..)
,VersionCheck(..)
,versionParser
,parseVersion
,parseVersionFromString
,versionString
,versionText
,toCabalVersion
,fromCabalVersion
,mkVersion
,versionRangeText
,withinRange
,Stack.Types.Version.intersectVersionRanges
,toMajorVersion
,latestApplicableVersion
,checkVersion
,nextMajorVersion
,UpgradeTo(..)
,minorVersion
,stackVersion
,stackMinorVersion)
where
import Stack.Prelude hiding (Vector)
import Data.Aeson.Extended
import Data.Attoparsec.Text
import Data.Hashable (Hashable (..))
import Data.List
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Vector.Unboxed (Vector)
import qualified Data.Vector.Unboxed as V
import Distribution.Text (disp)
import qualified Distribution.Version as Cabal
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import qualified Paths_stack as Meta
import Text.PrettyPrint (render)
newtype VersionParseFail =
VersionParseFail Text
deriving (Typeable)
instance Exception VersionParseFail
instance Show VersionParseFail where
show (VersionParseFail bs) = "Invalid version: " ++ show bs
data UpgradeTo = Specific Version | Latest deriving (Show)
newtype Version =
Version {unVersion :: Vector Word}
deriving (Eq,Ord,Typeable,Data,Generic,Store,NFData)
instance Hashable Version where
hashWithSalt i = hashWithSalt i . V.toList . unVersion
instance Lift Version where
lift (Version n) =
appE (conE 'Version)
(appE (varE 'V.fromList)
(listE (map (litE . IntegerL . fromIntegral)
(V.toList n))))
instance Show Version where
show (Version v) =
intercalate "."
(map show (V.toList v))
instance ToJSON Version where
toJSON = toJSON . versionText
instance FromJSON Version where
parseJSON j =
do s <- parseJSON j
case parseVersionFromString s of
Nothing ->
fail ("Couldn't parse package version: " ++ s)
Just ver -> return ver
instance FromJSONKey Version where
fromJSONKey = FromJSONKeyTextParser $ \k ->
either (fail . show) return $ parseVersion k
newtype IntersectingVersionRange =
IntersectingVersionRange { getIntersectingVersionRange :: Cabal.VersionRange }
deriving Show
instance Monoid IntersectingVersionRange where
mempty = IntersectingVersionRange Cabal.anyVersion
mappend (IntersectingVersionRange l) (IntersectingVersionRange r) =
IntersectingVersionRange (l `Cabal.intersectVersionRanges` r)
versionParser :: Parser Version
versionParser =
do ls <- (:) <$> num <*> many num'
let !v = V.fromList ls
return (Version v)
where num = decimal
num' = point *> num
point = satisfy (== '.')
parseVersion :: MonadThrow m => Text -> m Version
parseVersion x = go x
where go =
either (const (throwM (VersionParseFail x))) return .
parseOnly (versionParser <* endOfInput)
parseVersionFromString :: MonadThrow m => String -> m Version
parseVersionFromString =
parseVersion . T.pack
versionString :: Version -> String
versionString (Version v) =
intercalate "."
(map show (V.toList v))
versionText :: Version -> Text
versionText (Version v) =
T.intercalate
"."
(map (T.pack . show)
(V.toList v))
toCabalVersion :: Version -> Cabal.Version
toCabalVersion (Version v) =
Cabal.mkVersion (map fromIntegral (V.toList v))
fromCabalVersion :: Cabal.Version -> Version
fromCabalVersion vs =
let !v = V.fromList (map fromIntegral (Cabal.versionNumbers vs))
in Version v
mkVersion :: String -> Q Exp
mkVersion s =
case parseVersionFromString s of
Nothing -> qRunIO $ throwString ("Invalid package version: " ++ show s)
Just pn -> [|pn|]
versionRangeText :: Cabal.VersionRange -> Text
versionRangeText = T.pack . render . disp
withinRange :: Version -> Cabal.VersionRange -> Bool
withinRange v r = toCabalVersion v `Cabal.withinRange` r
intersectVersionRanges :: Cabal.VersionRange -> Cabal.VersionRange -> Cabal.VersionRange
intersectVersionRanges x y = Cabal.simplifyVersionRange $ Cabal.intersectVersionRanges x y
toMajorVersion :: Version -> Version
toMajorVersion (Version v) =
case V.length v of
0 -> Version (V.fromList [0, 0])
1 -> Version (V.fromList [V.head v, 0])
_ -> Version (V.fromList [V.head v, v V.! 1])
latestApplicableVersion :: Cabal.VersionRange -> Set Version -> Maybe Version
latestApplicableVersion r = listToMaybe . filter (`withinRange` r) . Set.toDescList
nextMajorVersion :: Version -> Version
nextMajorVersion (Version v) =
case V.length v of
0 -> Version (V.fromList [0, 1])
1 -> Version (V.fromList [V.head v, 1])
_ -> Version (V.fromList [V.head v, (v V.! 1) + 1])
data VersionCheck
= MatchMinor
| MatchExact
| NewerMinor
deriving (Show, Eq, Ord)
instance ToJSON VersionCheck where
toJSON MatchMinor = String "match-minor"
toJSON MatchExact = String "match-exact"
toJSON NewerMinor = String "newer-minor"
instance FromJSON VersionCheck where
parseJSON = withText expected $ \t ->
case t of
"match-minor" -> return MatchMinor
"match-exact" -> return MatchExact
"newer-minor" -> return NewerMinor
_ -> fail ("Expected " ++ expected ++ ", but got " ++ show t)
where
expected = "VersionCheck value (match-minor, match-exact, or newer-minor)"
checkVersion :: VersionCheck -> Version -> Version -> Bool
checkVersion check (Version wanted) (Version actual) =
case check of
MatchMinor -> V.and (V.take 3 matching)
MatchExact -> V.length wanted == V.length actual && V.and matching
NewerMinor -> V.and (V.take 2 matching) && newerMinor
where
matching = V.zipWith (==) wanted actual
newerMinor =
case (wanted V.!? 2, actual V.!? 2) of
(Nothing, _) -> True
(Just _, Nothing) -> False
(Just w, Just a) -> a >= w
minorVersion :: Version -> Version
minorVersion (Version v) = Version (V.take 3 v)
stackVersion :: Version
stackVersion = fromCabalVersion (Cabal.mkVersion' Meta.version)
stackMinorVersion :: Version
stackMinorVersion = minorVersion stackVersion