Allow to encode version ranges for distro versions

Fixes #84

.gitlab-ci.yml

@@ -60,7 +60,7 @@ variables:
   script:
     - ./.gitlab/script/ghcup_version.sh
   variables:
-    JSON_VERSION: "0.0.3"
+    JSON_VERSION: "0.0.4"
   artifacts:
     expire_in: 2 week
     paths:

CHANGELOG.md

@@ -12,6 +12,8 @@
   - see https://gitlab.haskell.org/haskell/ghcup-hs#configuration for a more in-depth explanation
 * add a `--set` switch to `ghcup install ghc` to automatically set as default after install
 * emit warnings when CC/LD is set wrt #82
+* add support for version ranges in distro specifiers wrt #84
+  - e.g. `"(>= 19 && <= 20) || ==0.2.2"` is a valid version key for distro
 
 ## 0.1.11 -- 2020-09-23
 

app/ghcup/Main.hs

@@ -752,9 +752,9 @@ cabalCompileOpts =
 
 
 toolVersionParser :: Parser ToolVersion
-toolVersionParser = verP <|> toolP
+toolVersionParser = verP' <|> toolP
  where
-  verP = ToolVersion <$> versionParser
+  verP' = ToolVersion <$> versionParser
   toolP =
     ToolTag
       <$> (option
@@ -882,17 +882,6 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
     , MP.chunk "exherbo" $> Exherbo
     , MP.chunk "unknown" $> UnknownLinux
     ]
-  verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning
-  verP suffix = do
-    ver <- parseUntil suffix
-    if T.null ver
-      then fail "empty version"
-      else do
-        rest <- MP.getInput
-        MP.setInput ver
-        v <- versioning'
-        MP.setInput rest
-        pure v
 
 
 bindistParser :: String -> Either String URI

lib/GHCup/Download.hs

@@ -57,6 +57,7 @@ import           Data.ByteString                ( ByteString )
 #if defined(INTERNAL_DOWNLOADER)
 import           Data.CaseInsensitive           ( CI )
 #endif
+import           Data.List                      ( find )
 import           Data.Maybe
 import           Data.String.Interpolate
 import           Data.Time.Clock
@@ -292,7 +293,8 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
   (case p of
     -- non-musl won't work on alpine
     Linux Alpine -> with_distro <|> without_distro_ver
-    _ -> with_distro <|> without_distro_ver <|> without_distro)
+    _            -> with_distro <|> without_distro_ver <|> without_distro
+  )
 
  where
   with_distro        = distro_preview id id
@@ -300,7 +302,18 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
   without_distro     = distro_preview (set _Linux UnknownLinux) (const Nothing)
 
   distro_preview f g =
-    preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
+    let platformVersionSpec =
+          preview (ix t % ix v % viArch % ix a % ix (f p)) dls
+        mv' = g mv
+    in  fmap snd
+          .   find
+                (\(mverRange, _) -> maybe
+                  (mv' == Nothing)
+                  (\range -> maybe False (flip versionRange range) mv')
+                  mverRange
+                )
+          .   M.toList
+          =<< platformVersionSpec
 
 
 -- | Tries to download from the given http or https url

lib/GHCup/Requirements.hs

@@ -14,8 +14,10 @@ module GHCup.Requirements where
 import           GHCup.Types
 import           GHCup.Types.JSON               ( )
 import           GHCup.Types.Optics
+import           GHCup.Version
 
 import           Control.Applicative
+import           Data.List                      ( find )
 import           Data.Maybe
 import           Optics
 import           Prelude                 hiding ( abs
@@ -23,6 +25,7 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 
+import qualified Data.Map.Strict               as M
 import qualified Data.Text                     as T
 
 
@@ -33,15 +36,25 @@ getCommonRequirements :: PlatformResult
                       -> ToolRequirements
                       -> Maybe Requirements
 getCommonRequirements pr tr =
-  preview (ix GHC % ix Nothing % ix (_platform pr) % ix (_distroVersion pr)) tr
+  with_distro <|> without_distro_ver <|> without_distro
-    <|> preview (ix GHC % ix Nothing % ix (_platform pr) % ix Nothing) tr
+ where
-    <|> preview
+  with_distro        = distro_preview _platform _distroVersion
-          ( ix GHC
+  without_distro_ver = distro_preview _platform (const Nothing)
-          % ix Nothing
+  without_distro     = distro_preview (set _Linux UnknownLinux . _platform) (const Nothing)
-          % ix (set _Linux UnknownLinux $ _platform pr)
+
-          % ix Nothing
+  distro_preview f g =
+    let platformVersionSpec =
+          preview (ix GHC % ix Nothing % ix (f pr)) tr
+        mv' = g pr
+    in  fmap snd
+          .   find
+                (\(mverRange, _) -> maybe
+                  (mv' == Nothing)
+                  (\range -> maybe False (flip versionRange range) mv')
+                  mverRange
                 )
-          tr
+          .   M.toList
+          =<< platformVersionSpec
 
 
 prettyRequirements :: Requirements -> T.Text

lib/GHCup/Types.hs

@@ -14,6 +14,7 @@ Portability : POSIX
 module GHCup.Types where
 
 import           Data.Map.Strict                ( Map )
+import           Data.List.NonEmpty             ( NonEmpty (..) )
 import           Data.Text                      ( Text )
 import           Data.Versions
 import           HPath
@@ -46,7 +47,7 @@ data GHCupInfo = GHCupInfo
 type ToolRequirements = Map Tool ToolReqVersionSpec
 type ToolReqVersionSpec = Map (Maybe Version) PlatformReqSpec
 type PlatformReqSpec = Map Platform PlatformReqVersionSpec
-type PlatformReqVersionSpec = Map (Maybe Versioning) Requirements
+type PlatformReqVersionSpec = Map (Maybe VersionRange) Requirements
 
 
 data Requirements = Requirements
@@ -70,7 +71,7 @@ type GHCupDownloads = Map Tool ToolVersionSpec
 type ToolVersionSpec = Map Version VersionInfo
 type ArchitectureSpec = Map Architecture PlatformSpec
 type PlatformSpec = Map Platform PlatformVersionSpec
-type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
+type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo
 
 
 -- | An installable tool.
@@ -307,7 +308,7 @@ data PlatformResult = PlatformResult
 
 prettyPlatform :: PlatformResult -> String
 prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
-  = show plat <> ", " <> show v'
+  = show plat <> ", " <> T.unpack (prettyV v')
 prettyPlatform PlatformResult { _platform = plat, _distroVersion = Nothing }
   = show plat
 
@@ -344,3 +345,19 @@ prettyTVer :: GHCTargetVersion -> Text
 prettyTVer (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v'
 prettyTVer (GHCTargetVersion Nothing  v') = prettyVer v'
 
+
+-- | A comparator and a version.
+data VersionCmp = VR_gt Versioning
+                | VR_gteq Versioning
+                | VR_lt Versioning
+                | VR_lteq Versioning
+                | VR_eq Versioning
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+
+-- | A version range. Supports && and ||, but not  arbitrary
+-- combinations. This is a little simplified.
+data VersionRange = SimpleRange (NonEmpty VersionCmp) -- And
+                  | OrRange (NonEmpty VersionCmp) VersionRange
+  deriving (Eq, GHC.Generic, Ord, Show)
+

lib/GHCup/Types/JSON.hs

@@ -22,22 +22,28 @@ Portability : POSIX
 module GHCup.Types.JSON where
 
 import           GHCup.Types
+import           GHCup.Utils.MegaParsec
 import           GHCup.Utils.Prelude
 
 import           Control.Applicative            ( (<|>) )
 import           Data.Aeson
 import           Data.Aeson.TH
 import           Data.Aeson.Types
+import           Data.List.NonEmpty             ( NonEmpty(..) )
 import           Data.Text.Encoding            as E
 import           Data.Versions
+import           Data.Void
 import           Data.Word8
 import           HPath
 import           URI.ByteString
 import           Text.Casing
 
 import qualified Data.ByteString               as BS
+import qualified Data.List.NonEmpty            as NE
 import qualified Data.Text                     as T
 import qualified Graphics.Vty                  as Vty
+import qualified Text.Megaparsec               as MP
+import qualified Text.Megaparsec.Char          as MPC
 
 
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
@@ -220,3 +226,101 @@ instance FromJSON TarDir where
     regexDir = withObject "TarDir" $ \o -> do
       r <- o .: "RegexDir"
       pure $ RegexDir r
+
+
+instance ToJSON VersionCmp where
+  toJSON = String . versionCmpToText
+
+instance FromJSON VersionCmp where
+  parseJSON = withText "VersionCmp" $ \t -> do
+    case MP.parse versionCmpP "" t of
+      Right r -> pure r
+      Left  e -> fail (MP.errorBundlePretty e)
+
+versionCmpToText :: VersionCmp -> T.Text
+versionCmpToText (VR_gt   ver') = "> " <> prettyV ver'
+versionCmpToText (VR_gteq ver') = ">= " <> prettyV ver'
+versionCmpToText (VR_lt   ver') = "< " <> prettyV ver'
+versionCmpToText (VR_lteq ver') = "<= " <> prettyV ver'
+versionCmpToText (VR_eq   ver') = "== " <> prettyV ver'
+
+versionCmpP :: MP.Parsec Void T.Text VersionCmp
+versionCmpP =
+  fmap VR_gt (MP.try $ MPC.space *> MP.chunk ">" *> MPC.space *> versioningEnd)
+    <|> fmap
+          VR_gteq
+          (MP.try $ MPC.space *> MP.chunk ">=" *> MPC.space *> versioningEnd)
+    <|> fmap
+          VR_lt
+          (MP.try $ MPC.space *> MP.chunk "<" *> MPC.space *> versioningEnd)
+    <|> fmap
+          VR_lteq
+          (MP.try $ MPC.space *> MP.chunk "<=" *> MPC.space *> versioningEnd)
+    <|> fmap
+          VR_eq
+          (MP.try $ MPC.space *> MP.chunk "==" *> MPC.space *> versioningEnd)
+    <|> fmap
+          VR_eq
+          (MP.try $ MPC.space *> versioningEnd)
+
+instance ToJSON VersionRange where
+  toJSON = String . verRangeToText
+
+verRangeToText :: VersionRange -> T.Text
+verRangeToText  (SimpleRange cmps) =
+  let inner = foldr1 (\x y -> x <> " && " <> y)
+                     (versionCmpToText <$> NE.toList cmps)
+  in  "( " <> inner <> " )"
+verRangeToText (OrRange cmps range) =
+  let left  = verRangeToText $ (SimpleRange cmps)
+      right = verRangeToText range
+  in  left <> " || " <> right
+
+instance FromJSON VersionRange where
+  parseJSON = withText "VersionRange" $ \t -> do
+    case MP.parse versionRangeP "" t of
+      Right r -> pure r
+      Left  e -> fail (MP.errorBundlePretty e)
+
+versionRangeP :: MP.Parsec Void T.Text VersionRange
+versionRangeP = go <* MP.eof
+ where
+  go =
+    MP.try orParse
+      <|> MP.try (fmap SimpleRange andParse)
+      <|> (fmap (SimpleRange . pure) versionCmpP)
+
+  orParse :: MP.Parsec Void T.Text VersionRange
+  orParse =
+    (\a o -> OrRange a o)
+      <$> (MP.try andParse <|> fmap pure versionCmpP)
+      <*> (MPC.space *> MP.chunk "||" *> MPC.space *> go)
+
+  andParse :: MP.Parsec Void T.Text (NonEmpty VersionCmp)
+  andParse =
+    fmap (\h t -> h :| t)
+         (MPC.space *> MP.chunk "(" *> MPC.space *> versionCmpP)
+      <*> ( MP.try
+          $ MP.many (MPC.space *> MP.chunk "&&" *> MPC.space *> versionCmpP)
+          )
+      <*  MPC.space
+      <*  MP.chunk ")"
+      <*  MPC.space
+
+versioningEnd :: MP.Parsec Void T.Text Versioning
+versioningEnd =
+  MP.try (verP (MP.chunk " " <|> MP.chunk ")" <|> MP.chunk "&&") <* MPC.space)
+    <|> versioning'
+
+instance ToJSONKey (Maybe VersionRange) where
+  toJSONKey = toJSONKeyText $ \case
+    Just x -> verRangeToText x
+    Nothing -> "unknown_versioning"
+
+instance FromJSONKey (Maybe VersionRange)  where
+  fromJSONKey = FromJSONKeyTextParser $ \t ->
+    if t == T.pack "unknown_versioning" then pure Nothing else just t
+   where
+    just t = case MP.parse versionRangeP "" t of
+      Right x -> pure $ Just x
+      Left  e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e

lib/GHCup/Utils/MegaParsec.hs

@@ -74,13 +74,13 @@ ghcTargetBinP t =
 ghcTargetVerP :: MP.Parsec Void Text GHCTargetVersion
 ghcTargetVerP =
   (\x y -> GHCTargetVersion x y)
-    <$> (MP.try (Just <$> (parseUntil1 (MP.chunk "-" *> verP)) <* MP.chunk "-")
+    <$> (MP.try (Just <$> (parseUntil1 (MP.chunk "-" *> verP')) <* MP.chunk "-")
         <|> (flip const Nothing <$> mempty)
         )
     <*> (version' <* MP.eof)
  where
-  verP :: MP.Parsec Void Text Text
+  verP' :: MP.Parsec Void Text Text
-  verP = do
+  verP' = do
     v <- version'
     let startsWithDigists =
           and
@@ -97,3 +97,16 @@ ghcTargetVerP =
     if startsWithDigists && not (isJust (_vEpoch v))
       then pure $ prettyVer v
       else fail "Oh"
+
+
+verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning
+verP suffix = do
+  ver <- parseUntil suffix
+  if T.null ver
+    then fail "empty version"
+    else do
+      rest <- MP.getInput
+      MP.setInput ver
+      v <- versioning'
+      MP.setInput rest
+      pure v

lib/GHCup/Version.hs

@@ -3,7 +3,7 @@
 
 {-|
 Module      : GHCup.Version
-Description : Static version information
+Description : Version information and version handling.
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
@@ -13,6 +13,7 @@ Portability : POSIX
 module GHCup.Version where
 
 import           GHCup.Utils.Version.QQ
+import           GHCup.Types
 
 import           Data.Versions
 import           URI.ByteString
@@ -22,7 +23,7 @@ import qualified Data.Text                     as T
 
 -- | This reflects the API version of the YAML.
 ghcupURL :: URI
-ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.3.yaml|]
+ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.4.yaml|]
 
 -- | The current ghcup version.
 ghcUpVer :: PVP
@@ -31,3 +32,16 @@ ghcUpVer = [pver|0.1.12|]
 -- | ghcup version as numeric string.
 numericVer :: String
 numericVer = T.unpack . prettyPVP $ ghcUpVer
+
+versionCmp :: Versioning -> VersionCmp -> Bool
+versionCmp ver1 (VR_gt ver2)   = ver1 > ver2
+versionCmp ver1 (VR_gteq ver2) = ver1 >= ver2
+versionCmp ver1 (VR_lt ver2)   = ver1 < ver2
+versionCmp ver1 (VR_lteq ver2) = ver1 <= ver2
+versionCmp ver1 (VR_eq ver2)   = ver1 == ver2
+
+versionRange :: Versioning -> VersionRange -> Bool
+versionRange ver' (SimpleRange cmps) = and $ fmap (versionCmp ver') cmps
+versionRange ver' (OrRange cmps range) = 
+  versionRange ver' (SimpleRange cmps) || versionRange ver' range
+

test/GHCup/ArbitraryTypes.hs

@@ -159,6 +159,18 @@ instance Arbitrary VersionInfo where
   arbitrary = genericArbitrary
   shrink    = genericShrink
 
+instance Arbitrary VersionRange where
+  arbitrary = genericArbitrary
+  shrink    = genericShrink
+
+instance Arbitrary (NonEmpty VersionCmp) where
+  arbitrary = genericArbitrary
+  shrink    = genericShrink
+
+instance Arbitrary VersionCmp where
+  arbitrary = genericArbitrary
+  shrink    = genericShrink
+
 instance Arbitrary (Path Rel) where
   arbitrary =
     (either (error . show) id . parseRel . E.encodeUtf8 . T.pack)