Improve stack metadata support wrt #892

app/ghcup/BrickMain.hs

@@ -11,7 +11,7 @@ module BrickMain where
 import           GHCup
 import           GHCup.Download
 import           GHCup.Errors
-import           GHCup.Types.Optics ( getDirs )
+import           GHCup.Types.Optics ( getDirs, getPlatformReq )
 import           GHCup.Types         hiding ( LeanAppState(..) )
 import           GHCup.Utils
 import           GHCup.OptParse.Common (logGHCPostRm)
@@ -30,6 +30,7 @@ import           Brick.Widgets.List             ( listSelectedFocusedAttr
                                                 , listAttr
                                                 )
 import           Codec.Archive
+import           Control.Applicative
 import           Control.Exception.Safe
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -94,7 +95,7 @@ data BrickState = BrickState
 
 
 keyHandlers :: KeyBindings
-            -> [ ( Vty.Key
+            -> [ ( KeyCombination
                  , BrickSettings -> String
                  , BrickState -> EventM String BrickState ()
                  )
@@ -131,6 +132,9 @@ showKey Vty.KUp = "↑"
 showKey Vty.KDown = "↓"
 showKey key = tail (show key)
 
+showMod :: Vty.Modifier -> String
+showMod = tail . show
+
 
 ui :: AttrMap -> BrickState -> Widget String
 ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
@@ -147,7 +151,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
       . txtWrap
       . T.pack
       . foldr1 (\x y -> x <> "  " <> y)
-      . fmap (\(key, s, _) -> showKey key <> ":" <> s as)
+      . fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as)
       $ keyHandlers appKeys
   header =
     minHSize 2 emptyWidget
@@ -321,12 +325,12 @@ eventHandler st@BrickState{..} ev = do
     (MouseDown _ Vty.BScrollDown _ _) ->
       put (BrickState { appState = moveCursor 1 appState Down, .. })
     (VtyEvent (Vty.EvResize _ _)) -> put st
-    (VtyEvent (Vty.EvKey Vty.KUp _)) ->
+    (VtyEvent (Vty.EvKey Vty.KUp [])) ->
       put BrickState{ appState = moveCursor 1 appState Up, .. }
-    (VtyEvent (Vty.EvKey Vty.KDown _)) ->
+    (VtyEvent (Vty.EvKey Vty.KDown [])) ->
       put BrickState{ appState = moveCursor 1 appState Down, .. }
-    (VtyEvent (Vty.EvKey key _)) ->
+    (VtyEvent (Vty.EvKey key mods)) ->
-      case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
+      case find (\(keyCombo, _, _) -> keyCombo == KeyCombination key mods) (keyHandlers kb) of
         Nothing -> put st
         Just (_, _, handler) -> handler st
     _ -> put st
@@ -432,7 +436,7 @@ filterVisible v t e | lInstalled e = True
                                   (lTool e `notElem` hiddenTools)
 
 
-install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
+install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
          => BrickState
          -> (Int, ListResult)
          -> m (Either String ())
@@ -463,6 +467,11 @@ install' _ (_, ListResult {..}) = do
               , ToolShadowed
               , UninstallFailed
               , MergeFileTreeError
+              , NoCompatiblePlatform
+              , GHCup.Errors.ParseError
+              , UnsupportedSetupCombo
+              , DistroNotFound
+              , NoCompatibleArch
               ]
 
   run (do
@@ -509,7 +518,7 @@ install' _ (_, ListResult {..}) = do
             <> "Also check the logs in ~/.ghcup/logs"
 
 
-set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
+set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
      => BrickState
      -> (Int, ListResult)
      -> m (Either String ())
@@ -651,8 +660,10 @@ getGHCupInfo = do
 
   r <-
     flip runReaderT settings
-    . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
+    . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError]
-    $ liftE getDownloadsF
+    $ do
+      pfreq <- lift getPlatformReq
+      liftE $ getDownloadsF pfreq
 
   case r of
     VRight a -> pure $ Right a

app/ghcup/Main.hs

@@ -42,7 +42,6 @@ import           Data.Aeson.Encode.Pretty       ( encodePretty )
 import           Data.Either
 import           Data.Functor
 import           Data.Maybe
-import           Data.Versions
 import           GHC.IO.Encoding
 import           Haskus.Utils.Variant.Excepts
 import           Language.Haskell.TH
@@ -85,7 +84,7 @@ toSettings options = do
          keepDirs    = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
          downloader  = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
          keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
-         urlSource   = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource
+         urlSource   = fromMaybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) optUrlSource
          noNetwork   = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
          gpgSetting  = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
          platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)
@@ -211,10 +210,9 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
                                             exitWith (ExitFailure 2)
 
                 ghcupInfo <-
-                  ( flip runReaderT leanAppstate
+                  ( flip runReaderT leanAppstate . runE @'[ContentLengthError, DigestError, DistroNotFound, DownloadFailed, FileDoesNotExistError, GPGError, JSONError, NoCompatibleArch, NoCompatiblePlatform, NoDownload, GHCup.Errors.ParseError, ProcessError, UnsupportedSetupCombo, StackPlatformDetectError] $ do
-                    . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
+                     liftE $ getDownloadsF pfreq
-                    $ liftE getDownloadsF
+                  )
-                    )
                     >>= \case
                           VRight r -> pure r
                           VLeft  e -> do
@@ -341,9 +339,9 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
                           ] m Bool
   alreadyInstalling (Install (Right InstallOptions{..}))                 (GHC, ver)   = cmp' GHC instVer ver
   alreadyInstalling (Install (Left (InstallGHC InstallOptions{..})))     (GHC, ver)   = cmp' GHC instVer ver
-  alreadyInstalling (Install (Left (InstallCabal InstallOptions{..})))   (Cabal, ver) = cmp' Cabal instVer ver
+  alreadyInstalling (Install (Left (InstallCabal InstallOptions{..})))   (Cabal, ver)    = cmp' Cabal instVer ver
-  alreadyInstalling (Install (Left (InstallHLS InstallOptions{..})))     (HLS, ver)   = cmp' HLS instVer ver
+  alreadyInstalling (Install (Left (InstallHLS InstallOptions{..})))     (HLS, ver)      = cmp' HLS instVer ver
-  alreadyInstalling (Install (Left (InstallStack InstallOptions{..})))   (Stack, ver) = cmp' Stack instVer ver
+  alreadyInstalling (Install (Left (InstallStack InstallOptions{..})))   (Stack, ver)    = cmp' Stack instVer ver
   alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over }))
     (GHC, ver)   = cmp' GHC (Just $ GHCVersion (mkTVer over)) ver
   alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = GHC.SourceDist tver }))
@@ -378,3 +376,4 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
   cmp' tool instVer ver = do
     (v, _) <- liftE $ fromVersion instVer tool
     pure (v == ver)
+

data/config.yaml

@@ -16,6 +16,11 @@ gpg-setting: GPGNone # GPGStrict | GPGLax | GPGNone
 # TUI key bindings,
 # see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key
 # for possible values.
+# It's also possible to define key+modifier, e.g.:
+#   quit:
+#     Key:
+#       KChar: c
+#     Mods: [MCtrl]
 key-bindings:
   up:
     KUp: []
@@ -46,41 +51,45 @@ meta-cache: 300 # in seconds
 #   2. Strict: fail hard
 meta-mode: Lax # Strict | Lax
 
-# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
+# Where to get GHC/cabal/hls download info/versions from. This is a list that performs
-# check the 'URLSource' type in the code.
+# union over tool versions, preferring the later entries.
 url-source:
   ## Use the internal download uri, this is the default
-  GHCupURL: []
+  - GHCupURL
 
-  ## Example 1: Read download info from this location instead
+  ## Prefer stack supplied metadata (will still use GHCup metadata for versions not existing in stack metadata)
-  ## Accepts file/http/https scheme
+  # - StackSetupURL
-  ## Can also be an array of URLs or an array of 'Either GHCupInfo URL', in
-  ## which case they are merged right-biased (overwriting duplicate versions).
-  # OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml"
 
-  ## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions.
+  ## Add pre-release channel
-  ## Can also be an array of 'Either GHCupInfo URL', also see Example 3.
+  # - https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
-  # AddSource:
+  ## Add nightly channel
-    # Left:
+  # - https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml
-      # globalTools: {}
+  ## Add cross compiler channel
-      # toolRequirements: {}
+  # - https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-cross-0.0.8.yaml
-      # ghcupDownloads:
-        # GHC:
-          # 9.10.2:
-            # viTags: []
-            # viArch:
-              # A_64:
-                # Linux_UnknownLinux:
-                  # unknown_versioning:
-                    # dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-deb8-linux.tar.bz2
-                    # dlSubdir: ghc-7.10.3
-                    # dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5
 
-  ## Example 3: Add multiple custom download files to the default downloads via right-biased merge (overwriting duplicate
+  ## Use dwarf bindist for 9.4.7 for ghcup metadata
-  ## versions).
+  # - ghcup-info:
-  # AddSource:
+  #     ghcupDownloads:
-    # - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml"
+  #       GHC:
-    # - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"
+  #         9.4.7:
+  #           viTags: []
+  #           viArch:
+  #             A_64:
+  #               Linux_UnknownLinux:
+  #                 unknown_versioning:
+  #                   dlUri: https://downloads.haskell.org/ghc/9.4.7/ghc-9.4.7-x86_64-deb10-linux-dwarf.tar.xz
+  #                   dlSubdir:
+  #                     RegexDir: "ghc-.*"
+  #                   dlHash: b261b3438ba455e3cf757f9c8dc3a06fdc061ea8ec287a65b7809e25fe18bad4
+
+  ## for stack metadata and the linux64-tinfo6 bindists, use static alpine for 9.8.1
+  # - setup-info:
+  #     ghc:
+  #       linux64-tinfo6:
+  #         9.8.1:
+  #           url: "https://downloads.haskell.org/~ghc/9.8.1/ghc-9.8.1-x86_64-alpine3_12-linux-static.tar.xz"
+  #           content-length: 229037440
+  #           sha256: b48f3d3a508d0c140d1c801e04afc65e80c0d25e7e939a8a41edb387b26b81b3
 
 # This is a way to override platform detection, e.g. when you're running
 # a Ubuntu derivate based on 18.04, you could do:

docs/guide.md

@@ -153,8 +153,7 @@ To use a mirror, set the following option in `~/.ghcup/config.yaml`:
 
 ```yml
 url-source:
-  # Accepts file/http/https scheme
+  - https://some-url/ghcup-0.0.6.yaml
-  OwnSource: "https://some-url/ghcup-0.0.6.yaml"
 ```
 
 See [config.yaml](https://github.com/haskell/ghcup-hs/blob/master/data/config.yaml)
@@ -184,8 +183,8 @@ This will result in `~/.ghcup/config.yaml` to contain this record:
 
 ```yml
 url-source:
-  AddSource:
+  - GHCupURL
-  - Right: https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
+  - https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
 ```
 
 You can add as many channels as you like. They are combined under *Last*, so versions from the prerelease channel
@@ -195,14 +194,13 @@ To remove the channel, delete the entire `url-source` section or set it back to
 
 ```yml
 url-source:
-  GHCupURL: []
+  - GHCupURL
 ```
 
 If you want to combine your release channel with a mirror, you'd do it like so:
 
 ```yml
 url-source:
-  OwnSource:
   # base metadata
   - "https://mirror.sjtu.edu.cn/ghcup/yaml/ghcup/data/ghcup-0.0.6.yaml"
   # prerelease channel
@@ -246,6 +244,46 @@ stack config set install-ghc false --global
 stack config set system-ghc  true  --global
 ```
 
+### Using stack's setup-info metadata to install GHC
+
+You can now use stack's [setup-info metadata](https://github.com/commercialhaskell/stackage-content/blob/master/stack/stack-setup-2.yaml)
+to install GHC. For that, you can invoke ghcup like so as a shorthand:
+
+```sh
+# ghcup will only see GHC now
+ghcup -s StackSetupURL install ghc 9.4.7
+# this combines both ghcup and stack metadata
+ghcup -s '["GHCupURL", "StackSetupURL"]' install ghc 9.4.7
+```
+
+To make this permanent and combine it with the GHCup metadata, you can add the following to your `~/.ghcup/config.yaml`:
+
+```yaml
+url-source:
+  - GHCupURL
+  # stack versions take precedence
+  # you'll still have access to GHCup provided versions and tools in case they don't exist in stack metadata
+  - StackSetupURL
+```
+
+You can customize or add sections to the setup-info similar to how the [stack documentation](https://docs.haskellstack.org/en/stable/yaml_configuration/#setup-info) explains it. E.g. to change the 9.4.7 bindist, you might do:
+
+```yaml
+url-source:
+  - GHCupURL
+  - StackSetupURL
+  - setup-info:
+      ghc:
+        linux64-tinfo6:
+          9.4.7:
+            url: "https://downloads.haskell.org/~ghc/9.4.7/ghc-9.4.7-x86_64-fedora27-linux.tar.xz"
+            content-length: 179117892
+            sha256: 216b76b7c6383e6ad9ba82533f323f8550e52893a8b9fa33c7b9dc4201ac766a
+```
+
+The main caveat with using this method is that there's no guarantee that GHCup will pick a compatible HLS bindist
+when you try to install HLS.
+
 ### Windows
 
 On windows, you may find the following config options useful too:

ghcup.cabal

@@ -117,7 +117,9 @@ library
     GHCup.Types
     GHCup.Types.JSON
     GHCup.Types.JSON.Utils
+    GHCup.Types.JSON.Versions
     GHCup.Types.Optics
+    GHCup.Types.Stack
     GHCup.Utils
     GHCup.Utils.Dirs
     GHCup.Version

lib-opt/GHCup/OptParse.hs

@@ -57,16 +57,13 @@ import           GHCup.Types
 import           Control.Monad.Fail             ( MonadFail )
 #endif
 import           Control.Monad.Reader
-import           Data.Bifunctor
 import           Data.Either
 import           Data.Functor
 import           Data.Maybe
 import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
-import           URI.ByteString
 
-import qualified Data.ByteString.UTF8          as UTF8
 
 
 data Options = Options
@@ -77,12 +74,13 @@ data Options = Options
   , optMetaCache   :: Maybe Integer
   , optMetaMode    :: Maybe MetaMode
   , optPlatform    :: Maybe PlatformRequest
-  , optUrlSource   :: Maybe URI
+  , optUrlSource   :: Maybe URLSource
   , optNoVerify    :: Maybe Bool
   , optKeepDirs    :: Maybe KeepDirs
   , optsDownloader :: Maybe Downloader
   , optNoNetwork   :: Maybe Bool
   , optGpg         :: Maybe GPGSetting
+  , optStackSetup  :: Maybe Bool
   -- commands
   , optCommand     :: Command
   }
@@ -134,13 +132,13 @@ opts =
       )
     <*> optional
           (option
-            (eitherReader parseUri)
+            (eitherReader parseUrlSource)
             (  short 's'
             <> long "url-source"
-            <> metavar "URL"
+            <> metavar "URL_SOURCE"
-            <> help "Alternative ghcup download info url"
+            <> help "Alternative ghcup download info"
             <> internal
-            <> completer fileUri
+            <> completer urlSourceCompleter
             )
           )
     <*> (fmap . fmap) not (invertableSwitch "verify" (Just 'n') True (help "Disable tarball checksum verification (default: enabled)"))
@@ -178,10 +176,9 @@ opts =
           "GPG verification (default: none)"
           <> completer (listCompleter ["strict", "lax", "none"])
           ))
+    <*> invertableSwitch "stack-setup" (Just 's') False (help "Use stack's setup info for discovering and installing GHC versions")
     <*> com
- where
+
-  parseUri s' =
-    first show $ parseURI strictURIParserOptions (UTF8.fromString s')
 
 
 com :: Parser Command

lib-opt/GHCup/OptParse/Common.hs

@@ -64,6 +64,8 @@ import           URI.ByteString
 import qualified Data.ByteString.UTF8          as UTF8
 import qualified Data.Map.Strict               as M
 import qualified Data.Text                     as T
+import qualified Data.Text.Lazy.Encoding       as LE
+import qualified Data.Text.Lazy                as LT
 import qualified Text.Megaparsec               as MP
 import qualified System.FilePath.Posix         as FP
 import GHCup.Version
@@ -322,6 +324,15 @@ toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"]
 gitFileUri :: [String] -> Completer
 gitFileUri add = mkCompleter $ fileUri' (["git://"] <> add)
 
+urlSourceCompleter :: Completer
+urlSourceCompleter = mkCompleter $ urlSourceCompleter' []
+
+urlSourceCompleter' :: [String] -> String -> IO [String]
+urlSourceCompleter' add str' = do
+  let static = ["GHCupURL", "StackSetupURL"]
+  file <- fileUri' add str'
+  pure $ static ++ file
+
 fileUri :: Completer
 fileUri = mkCompleter $ fileUri' []
 
@@ -450,13 +461,15 @@ tagCompleter tool add = listIOCompleter $ do
         defaultKeyBindings
         loggerConfig
 
-  mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
+  mpFreq <- flip runReaderT appState . runE $ platformRequest
-  case mGhcUpInfo of
+  forFold mpFreq $ \pfreq -> do
-    VRight ghcupInfo -> do
+    mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF pfreq
-      let allTags = filter (/= Old)
+    case mGhcUpInfo of
-            $ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
+      VRight ghcupInfo -> do
-      pure $ nub $ (add ++) $ fmap tagToString allTags
+        let allTags = filter (/= Old)
-    VLeft _ -> pure  (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
+              $ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
+        pure $ nub $ (add ++) $ fmap tagToString allTags
+      VLeft _ -> pure  (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
 
 versionCompleter :: [ListCriteria] -> Tool -> Completer
 versionCompleter criteria tool = versionCompleter' criteria tool (const True)
@@ -477,8 +490,8 @@ versionCompleter' criteria tool filter' = listIOCompleter $ do
                    defaultKeyBindings
                    loggerConfig
   mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
-  mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
   forFold mpFreq $ \pfreq -> do
+    mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF pfreq
     forFold mGhcUpInfo $ \ghcupInfo -> do
       let appState = AppState
             settings
@@ -817,3 +830,15 @@ logGHCPostRm ghcVer = do
   let storeGhcDir = cabalStore </> ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer))
   logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir
 
+parseUrlSource :: String -> Either String URLSource
+parseUrlSource "GHCupURL" = pure GHCupURL
+parseUrlSource "StackSetupURL" = pure StackSetupURL
+parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s')
+            <|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI strictURIParserOptions .UTF8.fromString $ s')
+
+parseNewUrlSource :: String -> Either String NewURLSource
+parseNewUrlSource "GHCupURL" = pure NewGHCupURL
+parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL
+parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s')
+            <|> (fmap NewURI . first show . parseURI strictURIParserOptions .UTF8.fromString $ s')
+

lib-opt/GHCup/OptParse/Config.hs

@@ -32,7 +32,6 @@ import           Options.Applicative     hiding ( style, ParseError )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
-import           URI.ByteString          hiding ( uriParser )
 
 import qualified Data.Text                     as T
 import qualified Data.ByteString.UTF8          as UTF8
@@ -51,7 +50,7 @@ data ConfigCommand
   = ShowConfig
   | SetConfig String (Maybe String)
   | InitConfig
-  | AddReleaseChannel Bool URI
+  | AddReleaseChannel Bool NewURLSource
   deriving (Eq, Show)
 
 
@@ -75,8 +74,8 @@ configP = subparser
   showP = info (pure ShowConfig) (progDesc "Show current config (default)")
   setP  = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter))
   argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))
-  addP  = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
+  addP  = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader parseNewUrlSource) (metavar "URL_SOURCE" <> completer urlSourceCompleter))
-    (progDesc "Add a release channel from a URI")
+    (progDesc "Add a release channel, e.g. from a URI")
 
 
 
@@ -207,27 +206,15 @@ config configCommand settings userConf keybindings runLogger = case configComman
         pure $ ExitFailure 65
       VLeft _ -> pure $ ExitFailure 65
 
-  AddReleaseChannel force uri -> do
+  AddReleaseChannel force new -> do
     r <- runE @'[DuplicateReleaseChannel] $ do
-      case urlSource settings of
+      let oldSources = fromURLSource (urlSource settings)
-        AddSource xs -> do
+      let merged = oldSources ++ [new]
-          case checkDuplicate xs (Right uri) of
+      case checkDuplicate oldSources new of
-            Duplicate
+        Duplicate
-              | not force -> throwE (DuplicateReleaseChannel uri)
+          | not force -> throwE (DuplicateReleaseChannel new)
-            DuplicateLast -> pure ()
+        DuplicateLast -> pure ()
-            _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (appendUnique xs (Right uri)) })
+        _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ SimpleList merged })
-        GHCupURL -> do
-          lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
-          pure ()
-        OwnSource xs -> do
-          case checkDuplicate xs (Right uri) of
-            Duplicate
-              | not force -> throwE (DuplicateReleaseChannel uri)
-            DuplicateLast -> pure ()
-            _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (appendUnique xs (Right uri)) })
-        OwnSpec spec -> do
-          lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource [Left spec, Right uri] })
-          pure ()
     case r of
       VRight _ -> do
         pure ExitSuccess
@@ -242,15 +229,6 @@ config configCommand settings userConf keybindings runLogger = case configComman
     | a `elem` xs  = Duplicate
     | otherwise    = NoDuplicate
 
-  -- appends the element to the end of the list, but also removes it from the existing list
-  appendUnique :: Eq a => [a] -> a -> [a]
-  appendUnique xs' e = go xs'
-   where
-    go [] = [e]
-    go (x:xs)
-      | x == e    =     go xs -- skip
-      | otherwise = x : go xs
-
   doConfig :: MonadIO m => UserSettings -> m ()
   doConfig usersettings = do
     let settings' = updateSettings usersettings userConf

lib-opt/GHCup/OptParse/Install.hs

@@ -63,7 +63,6 @@ data InstallCommand = InstallGHC InstallOptions
     --[ Options ]--
     ---------------
 
-
 data InstallOptions = InstallOptions
   { instVer      :: Maybe ToolVersion
   , instBindist  :: Maybe URI
@@ -134,7 +133,7 @@ installParser =
            )
       )
     )
-    <|> (Right <$> installOpts Nothing)
+    <|> (Right <$> installOpts (Just GHC))
  where
   installHLSFooter :: String
   installHLSFooter = [s|Discussion:
@@ -291,6 +290,11 @@ type InstallGHCEffects = '[ AlreadyInstalled
                           , UninstallFailed
                           , UnknownArchive
                           , InstallSetError
+                          , NoCompatiblePlatform
+                          , GHCup.Errors.ParseError
+                          , UnsupportedSetupCombo
+                          , DistroNotFound
+                          , NoCompatibleArch
                           ]
 
 runInstGHC :: AppState
@@ -310,13 +314,13 @@ runInstGHC appstate' =
 
 install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
 install installCommand settings getAppState' runLogger = case installCommand of
-  (Right iopts) -> do
+  (Right iGHCopts) -> do
     runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
-    installGHC iopts
+    installGHC iGHCopts
-  (Left (InstallGHC iopts)) -> installGHC iopts
+  (Left (InstallGHC iGHCopts)) -> installGHC iGHCopts
-  (Left (InstallCabal iopts)) -> installCabal iopts
+  (Left (InstallCabal iopts))  -> installCabal iopts
-  (Left (InstallHLS iopts)) -> installHLS iopts
+  (Left (InstallHLS iopts))    -> installHLS iopts
-  (Left (InstallStack iopts)) -> installStack iopts
+  (Left (InstallStack iopts))  -> installStack iopts
  where
   installGHC :: InstallOptions -> IO ExitCode
   installGHC InstallOptions{..} = do

lib-opt/GHCup/OptParse/Prefetch.hs

@@ -14,6 +14,7 @@ module GHCup.OptParse.Prefetch where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
+import           GHCup.Types.Optics
 import           GHCup.Prelude.File
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.String.QQ
@@ -157,7 +158,9 @@ type PrefetchEffects = '[ TagNotFound
                         , GPGError
                         , DownloadFailed
                         , JSONError
-                        , FileDoesNotExistError ]
+                        , FileDoesNotExistError
+                        , StackPlatformDetectError
+                        ]
 
 
 runPrefetch :: MonadUnliftIO m
@@ -210,7 +213,8 @@ prefetch prefetchCommand runAppState runLogger =
         (v, _) <- liftE $ fromVersion mt Stack
         liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
       PrefetchMetadata -> do
-        _ <- liftE getDownloadsF
+        pfreq <- lift getPlatformReq
+        _ <- liftE $ getDownloadsF pfreq
         pure ""
        ) >>= \case
                 VRight _ -> do

lib-opt/GHCup/OptParse/Run.hs

@@ -187,6 +187,11 @@ type RunEffects = '[ AlreadyInstalled
                    , ProcessError
                    , UninstallFailed
                    , MergeFileTreeError
+                   , NoCompatiblePlatform
+                   , GHCup.Errors.ParseError
+                   , UnsupportedSetupCombo
+                   , DistroNotFound
+                   , NoCompatibleArch
                    ]
 
 runLeanRUN :: (MonadUnliftIO m, MonadIO m)
@@ -226,6 +231,7 @@ run :: forall m .
        , MonadCatch m
        , MonadIO m
        , MonadUnliftIO m
+       , Alternative m
        )
    => RunOptions
    -> IO AppState
@@ -255,7 +261,9 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
                liftIO $ putStr tmp
                pure ExitSuccess
              (cmd:args) -> do
-               newEnv <- liftIO $ addToPath tmp runAppendPATH
+               newEnv <- liftIO $ addToPath [tmp] runAppendPATH
+               let pathVar = if isWindows then "Path" else "PATH"
+               forM_ (Map.lookup pathVar . Map.fromList $ newEnv) $ liftIO . setEnv pathVar
 #ifndef IS_WINDOWS
                void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
                pure ExitSuccess
@@ -329,6 +337,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
                            , MonadThrow m
                            , MonadIO m
                            , MonadCatch m
+                           , Alternative m
                            )
                         => Toolchain
                         -> FilePath
@@ -354,6 +363,11 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
                               , CopyError
                               , UninstallFailed
                               , MergeFileTreeError
+                              , NoCompatiblePlatform
+                              , GHCup.Errors.ParseError
+                              , UnsupportedSetupCombo
+                              , DistroNotFound
+                              , NoCompatibleArch
                               ] (ResourceT (ReaderT AppState m)) ()
    installToolChainFull Toolchain{..} tmp = do
          case ghcVer of

lib/GHCup/Download.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 
-
 {-|
 Module      : GHCup.Download
 Description : Downloading
@@ -31,9 +30,11 @@ import           GHCup.Download.Utils
 #endif
 import           GHCup.Errors
 import           GHCup.Types
+import qualified GHCup.Types.Stack                as Stack
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
 import           GHCup.Utils.Dirs
+import           GHCup.Platform
 import           GHCup.Prelude
 import           GHCup.Prelude.File
 import           GHCup.Prelude.Logger.Internal
@@ -55,6 +56,7 @@ import           Data.ByteString                ( ByteString )
 import           Data.CaseInsensitive           ( mk )
 #endif
 import           Data.Maybe
+import           Data.Either
 import           Data.List
 import           Data.Time.Clock
 import           Data.Time.Clock.POSIX
@@ -112,24 +114,71 @@ getDownloadsF :: ( FromJSONKey Tool
                  , MonadFail m
                  , MonadMask m
                  )
-              => Excepts
+              => PlatformRequest
-                   '[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
+              -> Excepts
+                   '[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError]
                    m
                    GHCupInfo
-getDownloadsF = do
+getDownloadsF pfreq@(PlatformRequest arch plat _) = do
   Settings { urlSource } <- lift getSettings
-  case urlSource of
+  let newUrlSources = fromURLSource urlSource
-    GHCupURL -> liftE $ getBase ghcupURL
+  infos <- liftE $ mapM dl' newUrlSources
-    (OwnSource exts) -> do
+  keys <- if any isRight infos
-      ext  <- liftE $ mapM (either pure getBase) exts
+          then liftE . reThrowAll @_ @_ @'[StackPlatformDetectError] StackPlatformDetectError $ getStackPlatformKey pfreq
-      mergeGhcupInfo ext
+          else pure []
-    (OwnSpec av) -> pure av
+  ghcupInfos <- fmap catMaybes $ forM infos $ \case
-    (AddSource exts) -> do
+    Left gi  -> pure (Just gi)
-      base <- liftE $ getBase ghcupURL
+    Right si -> pure $ fromStackSetupInfo si keys
-      ext  <- liftE $ mapM (either pure getBase) exts
+  mergeGhcupInfo ghcupInfos
-      mergeGhcupInfo (base:ext)
-
  where
+
+  dl' :: ( FromJSONKey Tool
+         , FromJSONKey Version
+         , FromJSON VersionInfo
+         , MonadReader env m
+         , HasSettings env
+         , HasDirs env
+         , MonadIO m
+         , MonadCatch m
+         , HasLog env
+         , MonadThrow m
+         , MonadFail m
+         , MonadMask m
+         )
+      => NewURLSource
+      -> Excepts
+           '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError]
+           m (Either GHCupInfo Stack.SetupInfo)
+  dl' NewGHCupURL       = fmap Left $ liftE $ getBase @GHCupInfo ghcupURL
+  dl' NewStackSetupURL  = fmap Right $ liftE $ getBase @Stack.SetupInfo stackSetupURL
+  dl' (NewGHCupInfo gi) = pure (Left gi)
+  dl' (NewSetupInfo si) = pure (Right si)
+  dl' (NewURI uri)      = catchE @JSONError (\(JSONDecodeError _) -> Right <$> getBase @Stack.SetupInfo uri)
+                            $ fmap Left $ getBase @GHCupInfo uri
+
+  fromStackSetupInfo :: MonadThrow m
+                     => Stack.SetupInfo
+                     -> [String]
+                     -> m GHCupInfo
+  fromStackSetupInfo (Stack.siGHCs -> ghcDli) keys = do
+    let ghcVersionsPerKey = (`M.lookup` ghcDli) <$> (T.pack <$> keys)
+        ghcVersions = fromMaybe mempty . listToMaybe . catMaybes $ ghcVersionsPerKey
+    (ghcupInfo' :: M.Map GHCTargetVersion DownloadInfo) <-
+      M.mapKeys mkTVer <$> M.traverseMaybeWithKey (\_ a -> pure $ fromStackDownloadInfo a) ghcVersions
+    let ghcupDownloads' = M.singleton GHC (M.map fromDownloadInfo ghcupInfo')
+    pure (GHCupInfo mempty ghcupDownloads' mempty)
+   where
+    fromDownloadInfo :: DownloadInfo -> VersionInfo
+    fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli))
+                           in VersionInfo [] Nothing Nothing Nothing Nothing aspec Nothing Nothing Nothing
+
+    fromStackDownloadInfo :: MonadThrow m => Stack.GHCDownloadInfo -> m DownloadInfo
+    fromStackDownloadInfo (Stack.GHCDownloadInfo { gdiDownloadInfo = Stack.DownloadInfo{..} }) = do
+      url <- either (\e -> throwM $ ParseError (show e)) pure $ parseURI strictURIParserOptions . E.encodeUtf8 $ downloadInfoUrl
+      sha256 <- maybe (throwM $ DigestMissing url) (pure . E.decodeUtf8) downloadInfoSha256
+      pure $ DownloadInfo url (Just $ RegexDir "ghc-.*") sha256 Nothing Nothing
+
+
   mergeGhcupInfo :: MonadFail m
                  => [GHCupInfo]
                  -> m GHCupInfo
@@ -141,6 +190,7 @@ getDownloadsF = do
     in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools
 
 
+
 yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
 yamlFromCache uri = do
   Dirs{..} <- getDirs
@@ -151,7 +201,7 @@ etagsFile :: FilePath -> FilePath
 etagsFile = (<.> "etags")
 
 
-getBase :: ( MonadReader env m
+getBase :: forall j m env . ( MonadReader env m
            , HasDirs env
            , HasSettings env
            , MonadFail m
@@ -159,9 +209,10 @@ getBase :: ( MonadReader env m
            , MonadCatch m
            , HasLog env
            , MonadMask m
+           , FromJSON j
            )
         => URI
-        -> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m GHCupInfo
+        -> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m j
 getBase uri = do
   Settings { noNetwork, downloader, metaMode } <- lift getSettings
 
@@ -246,7 +297,7 @@ getBase uri = do
     Settings { metaCache } <- lift getSettings
 
        -- for local files, let's short-circuit and ignore access time
-    if | scheme == "file" -> liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing Nothing (fromGHCupPath cacheDir) Nothing True
+    if | scheme == "file" -> liftE $ download uri' Nothing Nothing Nothing (fromGHCupPath cacheDir) Nothing True
        | e -> do
           accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
           let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
@@ -326,6 +377,7 @@ getDownloadInfo' t v = do
     )
 
 
+
 -- | Tries to download from the given http or https url
 -- and saves the result in continuous memory into a file.
 -- If the filename is not provided, then we:
@@ -352,20 +404,15 @@ download :: ( MonadReader env m
 download rawUri gpgUri eDigest eCSize dest mfn etags
   | scheme == "https" = liftE dl
   | scheme == "http"  = liftE dl
-  | scheme == "file"
-  , Just s <- gpgScheme
-  , s /= "file" = throwIO $ userError $ "gpg scheme does not match base file scheme: " <> (T.unpack . decUTF8Safe $ s)
   | scheme == "file"  = do
-      Settings{ gpgSetting } <- lift getSettings
       let destFile' = T.unpack . decUTF8Safe $ view pathL' rawUri
       lift $ logDebug $ "using local file: " <> T.pack destFile'
-      liftE $ verify gpgSetting destFile' (pure . T.unpack . decUTF8Safe . view pathL')
+      forM_ eDigest (liftE . flip checkDigest destFile')
       pure destFile'
   | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
 
  where
-  scheme    = view (uriSchemeL' % schemeBSL') rawUri
+  scheme = view (uriSchemeL' % schemeBSL') rawUri
-  gpgScheme = view (uriSchemeL' % schemeBSL') <$> gpgUri
   dl = do
     Settings{ mirrors } <- lift getSettings
     let uri = applyMirrors mirrors rawUri
@@ -407,14 +454,30 @@ download rawUri gpgUri eDigest eCSize dest mfn etags
                         else pure (\fp -> liftE . internalDL fp)
 #endif
               liftE $ downloadAction baseDestFile uri
-              liftE $ verify gpgSetting baseDestFile
+              case (gpgUri, gpgSetting) of
-                (\uri' -> do
+                (_, GPGNone) -> pure ()
-                  gpgDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri' Nothing
+                (Just gpgUri', _) -> do
-                  lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri' <> " as file " <> T.pack gpgDestFile
+                  gpgDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile gpgUri' Nothing
-                  flip onException (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile)) $
+                  liftE $ flip onException
-                    downloadAction gpgDestFile uri'
+                       (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile))
-                  pure gpgDestFile
+                   $ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError]
-                )
+                        (\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyHFError (GPGError e))
+                        ) $ do
+                      o' <- liftIO getGpgOpts
+                      lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') gpgUri' <> " as file " <> T.pack gpgDestFile
+                      liftE $ downloadAction gpgDestFile gpgUri'
+                      lift $ logInfo $ "verifying signature of: " <> T.pack baseDestFile
+                      let args = o' ++ ["--batch", "--verify", "--quiet", "--no-tty", gpgDestFile, baseDestFile]
+                      cp <- lift $ executeOut "gpg" args Nothing
+                      case cp of
+                        CapturedProcess { _exitCode = ExitFailure i, _stdErr } -> do
+                          lift $ logDebug $ decUTF8Safe' _stdErr
+                          throwE (GPGError @'[ProcessError] (V (NonZeroExit i "gpg" args)))
+                        CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr
+                _ -> pure ()
+
+              forM_ eCSize  (liftE . flip checkCSize  baseDestFile)
+              forM_ eDigest (liftE . flip checkDigest baseDestFile)
     pure baseDestFile
 
   curlDL :: ( MonadCatch m
@@ -612,41 +675,6 @@ download rawUri gpgUri eDigest eCSize dest mfn etags
       liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
       pure Nothing
 
-  verify :: ( MonadReader env m
-            , HasLog env
-            , HasDirs env
-            , HasSettings env
-            , MonadCatch m
-            , MonadMask m
-            , MonadIO m
-            )
-            => GPGSetting
-            -> FilePath
-            -> (URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m FilePath)
-            -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m ()
-  verify gpgSetting destFile' downloadAction' = do
-    case (gpgUri, gpgSetting) of
-      (_, GPGNone) -> pure ()
-      (Just gpgUri', _) -> do
-        liftE $ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError]
-              (\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyHFError (GPGError e))
-              ) $ do
-            o' <- liftIO getGpgOpts
-            gpgDestFile <- liftE $ downloadAction' gpgUri'
-            lift $ logInfo $ "verifying signature of: " <> T.pack destFile'
-            let args = o' ++ ["--batch", "--verify", "--quiet", "--no-tty", gpgDestFile, destFile']
-            cp <- lift $ executeOut "gpg" args Nothing
-            case cp of
-              CapturedProcess { _exitCode = ExitFailure i, _stdErr } -> do
-                lift $ logDebug $ decUTF8Safe' _stdErr
-                throwE (GPGError @'[ProcessError] (V (NonZeroExit i "gpg" args)))
-              CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr
-      _ -> pure ()
-
-    forM_ eCSize  (liftE . flip checkCSize  destFile')
-    forM_ eDigest (liftE . flip checkDigest destFile')
-
-
 
 -- | Download into tmpdir or use cached version, if it exists. If filename
 -- is omitted, infers the filename from the url.
@@ -666,7 +694,7 @@ downloadCached :: ( MonadReader env m
 downloadCached dli mfn = do
   Settings{ cache } <- lift getSettings
   case cache of
-    True -> liftE $ downloadCached' dli mfn Nothing
+    True -> downloadCached' dli mfn Nothing
     False -> do
       tmp <- lift withGHCupTmpDir
       liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) outputFileName False

lib/GHCup/Errors.hs

@@ -87,6 +87,7 @@ allHFError = unlines allErrors
     , let proxy = Proxy :: Proxy ToolShadowed in format proxy
     , let proxy = Proxy :: Proxy ContentLengthError in format proxy
     , let proxy = Proxy :: Proxy DuplicateReleaseChannel in format proxy
+    , let proxy = Proxy :: Proxy UnsupportedSetupCombo in format proxy
     , ""
     , "# high level errors (4000+)"
     , let proxy = Proxy :: Proxy DownloadFailed in format proxy
@@ -99,6 +100,7 @@ allHFError = unlines allErrors
     , let proxy = Proxy :: Proxy ParseError in format proxy
     , let proxy = Proxy :: Proxy UnexpectedListLength in format proxy
     , let proxy = Proxy :: Proxy NoUrlBase in format proxy
+    , let proxy = Proxy :: Proxy DigestMissing in format proxy
     , ""
     , "# orphans (800+)"
     , let proxy = Proxy :: Proxy URIParseError in format proxy
@@ -674,18 +676,29 @@ instance HFErrorProject ContentLengthError where
   eBase _ = 340
   eDesc _ = "File content length verification failed"
 
-data DuplicateReleaseChannel = DuplicateReleaseChannel URI
+data DuplicateReleaseChannel = DuplicateReleaseChannel NewURLSource
   deriving Show
 
 instance HFErrorProject DuplicateReleaseChannel where
   eBase _ = 350
-  eDesc _ = "Duplicate release channel detected when adding URI.\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)."
+  eDesc _ = "Duplicate release channel detected when adding new source.\nGiving up. You can use '--force' to remove and append the duplicate source (this may change order/semantics)."
 
 instance Pretty DuplicateReleaseChannel where
-  pPrint (DuplicateReleaseChannel uri) =
+  pPrint (DuplicateReleaseChannel source) =
     text $ "Duplicate release channel detected when adding: \n  "
-      <> (T.unpack . E.decodeUtf8With E.lenientDecode . serializeURIRef') uri
+      <> show source
-      <> "\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)."
+      <> "\nGiving up. You can use '--force' to remove and append the duplicate source (this may change order/semantics)."
+
+data UnsupportedSetupCombo = UnsupportedSetupCombo Architecture Platform
+  deriving Show
+
+instance Pretty UnsupportedSetupCombo where
+  pPrint (UnsupportedSetupCombo arch plat) =
+    text "Could not find a compatible setup combo for:" <+> pPrint arch <+> pPrint plat
+
+instance HFErrorProject UnsupportedSetupCombo where
+  eBase _ = 360
+  eDesc _ = "Could not find a compatible setup combo"
 
     -------------------------
     --[ High-level errors ]--
@@ -774,6 +787,22 @@ instance HFErrorProject GHCupSetError where
   eNum (GHCupSetError xs) = 9000 + eNum xs
   eDesc _ = "Setting the current version failed."
 
+-- | Executing stacks platform detection failed.
+data StackPlatformDetectError = forall es . (ToVariantMaybe StackPlatformDetectError es, PopVariant StackPlatformDetectError es, Show (V es), Pretty (V es), HFErrorProject (V es)) => StackPlatformDetectError (V es)
+
+instance Pretty StackPlatformDetectError where
+  pPrint (StackPlatformDetectError reason) =
+    case reason of
+      VMaybe (_ :: StackPlatformDetectError) -> pPrint reason
+      _ -> text "Running stack platform detection logic failed:" <+> pPrint reason
+
+deriving instance Show StackPlatformDetectError
+
+instance HFErrorProject StackPlatformDetectError where
+  eBase _ = 6000
+  eNum (StackPlatformDetectError xs) = 6000 + eNum xs
+  eDesc _ = "Running stack platform detection logic failed."
+
 
     ---------------------------------------------
     --[ True Exceptions (e.g. for MonadThrow) ]--
@@ -821,6 +850,18 @@ instance HFErrorProject NoUrlBase where
   eBase _ = 520
   eDesc _ = "URL does not have a base filename."
 
+data DigestMissing = DigestMissing URI
+  deriving Show
+
+instance Pretty DigestMissing where
+  pPrint (DigestMissing uri) =
+    text "Digest missing for:" <+> (text . T.unpack . E.decodeUtf8With E.lenientDecode . serializeURIRef') uri
+
+instance Exception DigestMissing
+
+instance HFErrorProject DigestMissing where
+  eBase _ = 530
+  eDesc _ = "An expected digest is missing."
 
 
     ------------------------

lib/GHCup/GHC.hs

@@ -74,6 +74,7 @@ import qualified Crypto.Hash.SHA256            as SHA256
 import qualified Data.ByteString.Base16        as B16
 import qualified Data.ByteString               as B
 import qualified Data.ByteString.Lazy          as BL
+import qualified Data.Map.Strict               as Map
 import qualified Data.Text                     as T
 import qualified Data.Text.IO                  as T
 import qualified Data.Text.Encoding            as E
@@ -216,7 +217,9 @@ testUnpackedGHC path tver addMakeArgs = do
   lift $ logInfo $ "Testing GHC version " <> tVerToText tver <> "!"
   ghcDir <- lift $ ghcupGHCDir tver
   let ghcBinDir = fromGHCupPath ghcDir </> "bin"
-  env <- liftIO $ addToPath ghcBinDir False
+  env <- liftIO $ addToPath [ghcBinDir] False
+  let pathVar = if isWindows then "Path" else "PATH"
+  forM_ (Map.lookup pathVar . Map.fromList $ env) $ liftIO . setEnv pathVar
 
   lEM $ make' (fmap T.unpack addMakeArgs)
               (Just $ fromGHCupPath path)
@@ -512,6 +515,7 @@ installGHCBin :: ( MonadFail m
                  , MonadResource m
                  , MonadIO m
                  , MonadUnliftIO m
+                 , Alternative m
                  )
               => GHCTargetVersion -- ^ the version to install
               -> InstallDir
@@ -533,6 +537,11 @@ installGHCBin :: ( MonadFail m
                     , ProcessError
                     , UninstallFailed
                     , MergeFileTreeError
+                    , NoCompatiblePlatform
+                    , ParseError
+                    , UnsupportedSetupCombo
+                    , DistroNotFound
+                    , NoCompatibleArch
                     ]
                    m
                    ()

lib/GHCup/Platform.hs

@@ -28,6 +28,8 @@ import           GHCup.Prelude
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.Process
 import           GHCup.Prelude.String.QQ
+import           GHCup.Prelude.Version.QQ
+import           GHCup.Prelude.MegaParsec
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -48,11 +50,18 @@ import           Prelude                 hiding ( abs
                                                 )
 import           System.Info
 import           System.OsRelease
+import           System.Exit
+import           System.FilePath
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           Text.Regex.Posix
 
+import qualified Text.Megaparsec               as MP
+
 import qualified Data.Text                     as T
 import qualified Data.Text.IO                  as T
+import           Data.Void
+import qualified Data.List                     as L
+
 
 
 
@@ -197,3 +206,155 @@ getLinuxDistro = do
   try_debian_version = do
     ver <- T.readFile debian_version
     pure (T.pack "debian", Just ver)
+
+
+getStackGhcBuilds :: (MonadReader env m, HasLog env, MonadIO m)
+                  => PlatformResult
+                  -> Excepts '[ParseError, NoCompatiblePlatform, DistroNotFound, ProcessError] m [String]
+getStackGhcBuilds PlatformResult{..} = do
+    case _platform of
+      Linux _ -> do
+        -- Some systems don't have ldconfig in the PATH, so make sure to look in
+        -- /sbin and /usr/sbin as well
+        sbinEnv <- liftIO $ addToPath sbinDirs False
+        ldConfig <- lift $ executeOut' "ldconfig" ["-p"] Nothing (Just sbinEnv)
+        firstWords <- case ldConfig of
+                        CapturedProcess ExitSuccess so _ ->
+                          pure . mapMaybe (listToMaybe . T.words) . T.lines . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ so
+                        CapturedProcess (ExitFailure _) _ _ ->
+                          -- throwE $ NonZeroExit c "ldconfig" ["-p" ]
+                          pure []
+        let checkLib :: (MonadReader env m, HasLog env, MonadIO m) => String -> m Bool
+            checkLib lib
+              | libT `elem` firstWords = do
+                  logDebug $ "Found shared library " <> libT <> " in 'ldconfig -p' output"
+                  pure True
+              | isWindows =
+                  -- Cannot parse /usr/lib on Windows
+                  pure False
+              | otherwise = hasMatches lib usrLibDirs
+              -- This is a workaround for the fact that libtinfo.so.x doesn't
+              -- appear in the 'ldconfig -p' output on Arch or Slackware even
+              -- when it exists. There doesn't seem to be an easy way to get the
+              -- true list of directories to scan for shared libs, but this
+              -- works for our particular cases.
+             where
+              libT = T.pack lib
+
+            hasMatches :: (MonadReader env m, HasLog env, MonadIO m) => String -> [FilePath] -> m Bool
+            hasMatches lib dirs = do
+              matches <- filterM (liftIO . doesFileExist . (</> lib)) dirs
+              case matches of
+                [] -> logDebug ("Did not find shared library " <> libT) >> pure False
+                (path:_) -> logDebug ("Found shared library " <> libT <> " in " <> T.pack path) >> pure True
+             where
+              libT = T.pack lib
+
+            getLibc6Version :: MonadIO m
+                            => Excepts '[ParseError, ProcessError] m Version
+            getLibc6Version = do
+              CapturedProcess{..} <- lift $ executeOut "ldd" ["--version"] Nothing
+              case _exitCode of
+                ExitSuccess -> either (throwE . ParseError . show) pure
+                                 . MP.parse lddVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
+                ExitFailure c -> throwE $ NonZeroExit c "ldd" ["--version" ]
+
+            -- Assumes the first line of ldd has the format:
+            --
+            -- ldd (...) nn.nn
+            --
+            -- where nn.nn corresponds to the version of libc6.
+            lddVersion :: MP.Parsec Void Text Version
+            lddVersion = do
+              skipWhile (/= ')')
+              skip (== ')')
+              skipSpace
+              version'
+
+        hasMusl <- hasMatches relFileLibcMuslx86_64So1 libDirs
+        mLibc6Version <- veitherToEither <$> runE getLibc6Version
+        case mLibc6Version of
+          Right libc6Version -> logDebug $ "Found shared library libc6 in version: " <> prettyVer libc6Version
+          Left _ -> logDebug "Did not find a version of shared library libc6."
+        let hasLibc6_2_32 = either (const False) (>= [vver|2.32|]) mLibc6Version
+        hastinfo5 <- checkLib relFileLibtinfoSo5
+        hastinfo6 <- checkLib relFileLibtinfoSo6
+        hasncurses6 <- checkLib relFileLibncurseswSo6
+        hasgmp5 <- checkLib relFileLibgmpSo10
+        hasgmp4 <- checkLib relFileLibgmpSo3
+        let libComponents = if hasMusl
+              then
+                [ ["musl"] ]
+              else
+                concat
+                  [ if hastinfo6 && hasgmp5
+                    then
+                      if hasLibc6_2_32
+                      then [["tinfo6"]]
+                      else [["tinfo6-libc6-pre232"]]
+                    else [[]]
+                  , [ [] | hastinfo5 && hasgmp5 ]
+                  , [ ["ncurses6"] | hasncurses6 && hasgmp5 ]
+                  , [ ["gmp4"] | hasgmp4 ]
+                  ]
+        pure $ map
+          (\c -> case c of
+            [] -> []
+            _ -> L.intercalate "-" c)
+          libComponents
+      FreeBSD ->
+        case _distroVersion of
+          Just fVer
+            | fVer >= [vers|12|] -> pure []
+          _ -> pure ["ino64"]
+      Darwin  -> pure []
+      Windows -> pure []
+ where
+
+  relFileLibcMuslx86_64So1 :: FilePath
+  relFileLibcMuslx86_64So1 = "libc.musl-x86_64.so.1"
+  libDirs :: [FilePath]
+  libDirs = ["/lib", "/lib64"]
+  usrLibDirs :: [FilePath]
+  usrLibDirs = ["/usr/lib", "/usr/lib64"]
+  sbinDirs :: [FilePath]
+  sbinDirs = ["/sbin", "/usr/sbin"]
+  relFileLibtinfoSo5 :: FilePath
+  relFileLibtinfoSo5 = "libtinfo.so.5"
+  relFileLibtinfoSo6 :: FilePath
+  relFileLibtinfoSo6 = "libtinfo.so.6"
+  relFileLibncurseswSo6 :: FilePath
+  relFileLibncurseswSo6 = "libncursesw.so.6"
+  relFileLibgmpSo10 :: FilePath
+  relFileLibgmpSo10 = "libgmp.so.10"
+  relFileLibgmpSo3 :: FilePath
+  relFileLibgmpSo3 = "libgmp.so.3"
+
+getStackOSKey :: Monad m => PlatformRequest -> Excepts '[UnsupportedSetupCombo] m String
+getStackOSKey PlatformRequest { .. } =
+  case (_rArch, _rPlatform) of
+    (A_32   , Linux _) -> pure "linux32"
+    (A_64   , Linux _) -> pure "linux64"
+    (A_32   , Darwin ) -> pure "macosx"
+    (A_64   , Darwin ) -> pure "macosx"
+    (A_32   , FreeBSD) -> pure "freebsd32"
+    (A_64   , FreeBSD) -> pure "freebsd64"
+    (A_32   , Windows) -> pure "windows32"
+    (A_64   , Windows) -> pure "windows64"
+    (A_ARM  , Linux _) -> pure "linux-armv7"
+    (A_ARM64, Linux _) -> pure "linux-aarch64"
+    (A_Sparc, Linux _) -> pure "linux-sparc"
+    (A_ARM64, Darwin ) -> pure "macosx-aarch64"
+    (A_ARM64, FreeBSD) -> pure "freebsd-aarch64"
+    (arch', os') -> throwE $ UnsupportedSetupCombo arch' os'
+
+getStackPlatformKey :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
+                    => PlatformRequest
+                    -> Excepts '[UnsupportedSetupCombo, ParseError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound, ProcessError] m [String]
+getStackPlatformKey pfreq@PlatformRequest{..} = do
+  osKey <- liftE  $ getStackOSKey pfreq
+  builds <- liftE $ getStackGhcBuilds (PlatformResult _rPlatform _rVersion)
+  let builds' = (\build -> if null build then osKey else osKey <> "-" <> build) <$> builds
+  logDebug $ "Potential GHC builds: " <> mconcat (L.intersperse ", " $ fmap T.pack builds')
+  pure builds'
+

lib/GHCup/Prelude.hs

@@ -43,6 +43,10 @@ import           Control.Monad.Reader
 import           Haskus.Utils.Variant.Excepts
 import           Text.PrettyPrint.HughesPJClass ( Pretty )
 import qualified Data.Text                     as T
+import System.Environment (getEnvironment)
+import qualified Data.Map.Strict               as Map
+import System.FilePath
+import Data.List (intercalate)
 
 
 
@@ -88,3 +92,25 @@ throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excep
 {-# INLINABLE throwSomeE #-}
 throwSomeE = Excepts . pure . VLeft . liftVariant
 #endif
+
+addToPath :: [FilePath]
+          -> Bool         -- ^ if False will prepend
+          -> IO [(String, String)]
+addToPath paths append = do
+ cEnv <- getEnvironment
+ return $ addToPath' cEnv paths append
+
+addToPath' :: [(String, String)]
+          -> [FilePath]
+          -> Bool         -- ^ if False will prepend
+          -> [(String, String)]
+addToPath' cEnv' newPaths append =
+  let cEnv           = Map.fromList cEnv'
+      paths          = ["PATH", "Path"]
+      curPaths       = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
+      {- HLINT ignore "Redundant bracket" -}
+      newPath        = intercalate [searchPathSeparator] (if append then (curPaths ++ newPaths) else (newPaths ++ curPaths))
+      envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
+      pathVar        = if isWindows then "Path" else "PATH"
+      envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
+  in envWithNewPath

lib/GHCup/Prelude/MegaParsec.hs

@@ -120,3 +120,17 @@ verP suffix = do
 
 pathSep :: MP.Parsec Void Text Char
 pathSep = MP.oneOf pathSeparators
+
+skipWhile :: (Char -> Bool) -> MP.Parsec Void Text ()
+skipWhile f = void $ MP.takeWhileP Nothing f
+
+skip :: (Char -> Bool) -> MP.Parsec Void Text ()
+skip f = void $ MP.satisfy f
+
+skipSpace :: MP.Parsec Void Text ()
+skipSpace = void $ MP.satisfy isSpace
+
+isSpace :: Char -> Bool
+isSpace c = (c == ' ') || ('\t' <= c && c <= '\r')
+{-# INLINE isSpace #-}
+

lib/GHCup/Prelude/Process.hs

@@ -11,6 +11,7 @@ Portability : portable
 -}
 module GHCup.Prelude.Process (
   executeOut,
+  executeOut',
   execLogged,
   exec,
   toProcessError,

lib/GHCup/Prelude/Process/Posix.hs

@@ -70,6 +70,16 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do
   maybe (pure ()) changeWorkingDirectory chdir
   SPP.executeFile path True args Nothing
 
+executeOut' :: MonadIO m
+            => FilePath          -- ^ command as filename, e.g. 'ls'
+            -> [String]          -- ^ arguments to the command
+            -> Maybe FilePath    -- ^ chdir to this path
+            -> Maybe [(String, String)]
+            -> m CapturedProcess
+executeOut' path args chdir env = liftIO $ captureOutStreams $ do
+  maybe (pure ()) changeWorkingDirectory chdir
+  SPP.executeFile path True args env
+
 
 execLogged :: ( MonadReader env m
               , HasSettings env

lib/GHCup/Prelude/Process/Windows.hs

@@ -140,8 +140,16 @@ executeOut :: MonadIO m
            -> [String]          -- ^ arguments to the command
            -> Maybe FilePath    -- ^ chdir to this path
            -> m CapturedProcess
-executeOut path args chdir = do
+executeOut path args chdir = executeOut' path args chdir Nothing
-  cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir })
+
+executeOut' :: MonadIO m
+            => FilePath          -- ^ command as filename, e.g. 'ls'
+            -> [String]          -- ^ arguments to the command
+            -> Maybe FilePath    -- ^ chdir to this path
+            -> Maybe [(String, String)]
+            -> m CapturedProcess
+executeOut' path args chdir env' = do
+  cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir, env = env' })
   (exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp ""
   pure $ CapturedProcess exit out err
 

lib/GHCup/Types.hs

@@ -22,10 +22,12 @@ module GHCup.Types
   ( module GHCup.Types
 #if defined(BRICK)
   , Key(..)
+  , Modifier(..)
 #endif
   )
   where
 
+import           GHCup.Types.Stack              ( SetupInfo )
 import {-# SOURCE #-} GHCup.Utils.Dirs          ( fromGHCupPath, GHCupPath )
 
 import           Control.DeepSeq                ( NFData, rnf )
@@ -39,14 +41,13 @@ import           Optics                         ( makeLenses )
 import           Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
 import           URI.ByteString
 #if defined(BRICK)
-import           Graphics.Vty                   ( Key(..) )
+import           Graphics.Vty                   ( Key(..), Modifier(..) )
 #endif
 
 import qualified Data.ByteString.Lazy          as BL
 import qualified Data.Text                     as T
 import qualified GHC.Generics                  as GHC
 import qualified Data.List.NonEmpty            as NE
-import           Data.Foldable                  (foldMap)
 
 #if !defined(BRICK)
 data Key = KEsc  | KChar Char | KBS | KEnter
@@ -55,8 +56,15 @@ data Key = KEsc  | KChar Char | KBS | KEnter
          | KFun Int | KBackTab | KPrtScr | KPause | KIns
          | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
     deriving (Eq,Show,Read,Ord,GHC.Generic)
+
+data Modifier = MShift | MCtrl | MMeta | MAlt
+    deriving (Eq,Show,Read,Ord,GHC.Generic)
 #endif
 
+data KeyCombination = KeyCombination { key :: Key, mods :: [Modifier] }
+    deriving (Eq,Show,Read,Ord,GHC.Generic)
+
+
 
     --------------------
     --[ GHCInfo Tree ]--
@@ -193,7 +201,7 @@ instance Pretty Tag where
   pPrint (Base       pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp''))
   pPrint (UnknownTag t    ) = text t
   pPrint LatestPrerelease   = text "latest-prerelease"
-  pPrint LatestNightly   = text "latest-prerelease"
+  pPrint LatestNightly      = text "latest-prerelease"
   pPrint Old                = mempty
 
 data Architecture = A_64
@@ -334,15 +342,41 @@ instance Pretty TarDir where
 
 -- | Where to fetch GHCupDownloads from.
 data URLSource = GHCupURL
-               | OwnSource [Either GHCupInfo URI] -- ^ complete source list
+               | StackSetupURL
-               | OwnSpec GHCupInfo
+               | OwnSource     [Either (Either GHCupInfo SetupInfo) URI] -- ^ complete source list
-               | AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL
+               | OwnSpec               (Either GHCupInfo SetupInfo)
-               deriving (GHC.Generic, Show)
+               | AddSource     [Either (Either GHCupInfo SetupInfo) URI] -- ^ merge with GHCupURL
+               | SimpleList    [NewURLSource]
+               deriving (Eq, GHC.Generic, Show)
+
+data NewURLSource = NewGHCupURL
+                  | NewStackSetupURL
+                  | NewGHCupInfo     GHCupInfo
+                  | NewSetupInfo     SetupInfo
+                  | NewURI           URI
+               deriving (Eq, GHC.Generic, Show)
+
+instance NFData NewURLSource
+
+fromURLSource :: URLSource -> [NewURLSource]
+fromURLSource GHCupURL              = [NewGHCupURL]
+fromURLSource StackSetupURL         = [NewStackSetupURL]
+fromURLSource (OwnSource arr)       = convert' <$> arr
+fromURLSource (AddSource arr)       = NewGHCupURL:(convert' <$> arr)
+fromURLSource (SimpleList arr)      = arr
+fromURLSource (OwnSpec (Left gi))   = [NewGHCupInfo gi]
+fromURLSource (OwnSpec (Right si)) = [NewSetupInfo si]
+
+convert' :: Either (Either GHCupInfo SetupInfo) URI -> NewURLSource
+convert' (Left (Left gi))  = NewGHCupInfo gi
+convert' (Left (Right si)) = NewSetupInfo si
+convert' (Right uri)       = NewURI uri
 
 instance NFData URLSource
 instance NFData (URIRef Absolute) where
   rnf (URI !_ !_ !_ !_ !_) = ()
 
+
 data MetaMode = Strict
               | Lax
   deriving (Show, Read, Eq, GHC.Generic)
@@ -415,47 +449,51 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
   }
 
 data UserKeyBindings = UserKeyBindings
-  { kUp        :: Maybe Key
+  { kUp           :: Maybe KeyCombination
-  , kDown      :: Maybe Key
+  , kDown         :: Maybe KeyCombination
-  , kQuit      :: Maybe Key
+  , kQuit         :: Maybe KeyCombination
-  , kInstall   :: Maybe Key
+  , kInstall      :: Maybe KeyCombination
-  , kUninstall :: Maybe Key
+  , kUninstall    :: Maybe KeyCombination
-  , kSet       :: Maybe Key
+  , kSet          :: Maybe KeyCombination
-  , kChangelog :: Maybe Key
+  , kChangelog    :: Maybe KeyCombination
-  , kShowAll   :: Maybe Key
+  , kShowAll      :: Maybe KeyCombination
-  , kShowAllTools :: Maybe Key
+  , kShowAllTools :: Maybe KeyCombination
   }
   deriving (Show, GHC.Generic)
 
 data KeyBindings = KeyBindings
-  { bUp        :: Key
+  { bUp              :: KeyCombination
-  , bDown      :: Key
+  , bDown            :: KeyCombination
-  , bQuit      :: Key
+  , bQuit            :: KeyCombination
-  , bInstall   :: Key
+  , bInstall         :: KeyCombination
-  , bUninstall :: Key
+  , bUninstall       :: KeyCombination
-  , bSet       :: Key
+  , bSet             :: KeyCombination
-  , bChangelog :: Key
+  , bChangelog       :: KeyCombination
-  , bShowAllVersions :: Key
+  , bShowAllVersions :: KeyCombination
-  , bShowAllTools :: Key
+  , bShowAllTools    :: KeyCombination
   }
   deriving (Show, GHC.Generic)
 
 instance NFData KeyBindings
 #if defined(IS_WINDOWS) || !defined(BRICK)
 instance NFData Key
+
+instance NFData Modifier
+
 #endif
+instance NFData KeyCombination
 
 defaultKeyBindings :: KeyBindings
 defaultKeyBindings = KeyBindings
-  { bUp = KUp
+  { bUp              = KeyCombination { key = KUp      , mods = [] }
-  , bDown = KDown
+  , bDown            = KeyCombination { key = KDown    , mods = [] }
-  , bQuit = KChar 'q'
+  , bQuit            = KeyCombination { key = KChar 'q', mods = [] }
-  , bInstall = KChar 'i'
+  , bInstall         = KeyCombination { key = KChar 'i', mods = [] }
-  , bUninstall = KChar 'u'
+  , bUninstall       = KeyCombination { key = KChar 'u', mods = [] }
-  , bSet = KChar 's'
+  , bSet             = KeyCombination { key = KChar 's', mods = [] }
-  , bChangelog = KChar 'c'
+  , bChangelog       = KeyCombination { key = KChar 'c', mods = [] }
-  , bShowAllVersions = KChar 'a'
+  , bShowAllVersions = KeyCombination { key = KChar 'a', mods = [] }
-  , bShowAllTools = KChar 't'
+  , bShowAllTools    = KeyCombination { key = KChar 't', mods = [] }
   }
 
 data AppState = AppState
@@ -749,3 +787,4 @@ instance Pretty ToolVersion where
 data BuildSystem = Hadrian
                  | Make
   deriving (Show, Eq)
+

lib/GHCup/Types/JSON.hs

@@ -22,7 +22,9 @@ Portability : portable
 module GHCup.Types.JSON where
 
 import           GHCup.Types
+import           GHCup.Types.Stack (SetupInfo)
 import           GHCup.Types.JSON.Utils
+import           GHCup.Types.JSON.Versions ()
 import           GHCup.Prelude.MegaParsec
 
 import           Control.Applicative            ( (<|>) )
@@ -31,7 +33,9 @@ import           Data.Aeson.TH
 import           Data.Aeson.Types        hiding (Key)
 import           Data.ByteString                ( ByteString )
 import           Data.List.NonEmpty             ( NonEmpty(..) )
+import           Data.Maybe
 import           Data.Text.Encoding            as E
+import           Data.Foldable
 import           Data.Versions
 import           Data.Void
 import           URI.ByteString
@@ -112,34 +116,6 @@ instance FromJSONKey GHCTargetVersion where
     Right x -> pure x
     Left  e -> fail $ "Failure in GHCTargetVersion (FromJSONKey)" <> show e
 
-instance ToJSON Versioning where
-  toJSON = toJSON . prettyV
-
-instance FromJSON Versioning where
-  parseJSON = withText "Versioning" $ \t -> case versioning t of
-    Right x -> pure x
-    Left  e -> fail $ "Failure in GHCTargetVersion (FromJSON)" <> show e
-
-instance ToJSONKey Versioning where
-  toJSONKey = toJSONKeyText $ \x -> prettyV x
-
-instance FromJSONKey Versioning where
-  fromJSONKey = FromJSONKeyTextParser $ \t -> case versioning t of
-    Right x -> pure x
-    Left  e -> fail $ "Failure in Versioning (FromJSONKey)" <> show e
-
-instance ToJSONKey (Maybe Versioning) where
-  toJSONKey = toJSONKeyText $ \case
-    Just x  -> prettyV x
-    Nothing -> T.pack "unknown_versioning"
-
-instance FromJSONKey (Maybe Versioning) where
-  fromJSONKey = FromJSONKeyTextParser $ \t ->
-    if t == T.pack "unknown_versioning" then pure Nothing else just t
-   where
-    just t = case versioning t of
-      Right x -> pure $ Just x
-      Left  e -> fail $ "Failure in (Maybe Versioning) (FromJSONKey)" <> show e
 
 instance ToJSONKey Platform where
   toJSONKey = toJSONKeyText $ \case
@@ -176,43 +152,6 @@ instance ToJSONKey Architecture where
 instance FromJSONKey Architecture where
   fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
 
-instance ToJSONKey (Maybe Version) where
-  toJSONKey = toJSONKeyText $ \case
-    Just x  -> prettyVer x
-    Nothing -> T.pack "unknown_version"
-
-instance FromJSONKey (Maybe Version) where
-  fromJSONKey = FromJSONKeyTextParser $ \t ->
-    if t == T.pack "unknown_version" then pure Nothing else just t
-   where
-    just t = case version t of
-      Right x -> pure $ Just x
-      Left  e -> fail $ "Failure in (Maybe Version) (FromJSONKey)" <> show e
-
-instance ToJSON Version where
-  toJSON = toJSON . prettyVer
-
-instance FromJSON Version where
-  parseJSON = withText "Version" $ \t -> case version t of
-    Right x -> pure x
-    Left  e -> fail $ "Failure in Version (FromJSON)" <> show e
-
-instance ToJSONKey Version where
-  toJSONKey = toJSONKeyText $ \x -> prettyVer x
-
-instance FromJSONKey Version where
-  fromJSONKey = FromJSONKeyTextParser $ \t -> case version t of
-    Right x -> pure x
-    Left  e -> fail $ "Failure in Version (FromJSONKey)" <> show e
-
-instance ToJSON PVP where
-  toJSON = toJSON . prettyPVP
-
-instance FromJSON PVP where
-  parseJSON = withText "PVP" $ \t -> case pvp t of
-    Right x -> pure x
-    Left  e -> fail $ "Failure in PVP (FromJSON)" <> show e
-
 instance ToJSONKey Tool where
   toJSONKey = genericToJSONKey defaultJSONKeyOptions
 
@@ -342,33 +281,64 @@ instance FromJSONKey (Maybe VersionRange)  where
       Left  e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e
 
 
-
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
+
-deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
+instance FromJSON GHCupInfo where
+  parseJSON = withObject "GHCupInfo" $ \o -> do
+    toolRequirements' <- o .:? "toolRequirements"
+    globalTools'      <- o .:? "globalTools"
+    ghcupDownloads'   <- o .:  "ghcupDownloads"
+    pure (GHCupInfo (fromMaybe mempty toolRequirements') ghcupDownloads' (fromMaybe mempty globalTools'))
+
+deriveToJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
+
+instance ToJSON NewURLSource where
+  toJSON NewGHCupURL       = String "GHCupURL"
+  toJSON NewStackSetupURL  = String "StackSetupURL"
+  toJSON (NewGHCupInfo gi) = object [ "ghcup-info" .= gi ]
+  toJSON (NewSetupInfo si) = object [ "setup-info" .= si ]
+  toJSON (NewURI uri)      = toJSON uri
+
+instance ToJSON URLSource where
+  toJSON = toJSON . fromURLSource
+
 deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
-deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
+deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Modifier
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Host
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''UserInfo
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' (T.unpack . T.toLower) . T.stripPrefix (T.pack "authority") . T.pack $ str' } ''Authority
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirror
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirrors
-deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
-deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
 
 instance FromJSON URLSource where
   parseJSON v =
         parseGHCupURL v
+    <|> parseStackURL v
     <|> parseOwnSourceLegacy v
     <|> parseOwnSourceNew1 v
     <|> parseOwnSourceNew2 v
     <|> parseOwnSpec v
     <|> legacyParseAddSource v
     <|> newParseAddSource v
+    -- new since Stack SetupInfo
+    <|> parseOwnSpecNew v
+    <|> parseOwnSourceNew3 v
+    <|> newParseAddSource2 v
+    -- more lenient versions
+    <|> parseOwnSpecLenient v
+    <|> parseOwnSourceLenient v
+    <|> parseAddSourceLenient v
+    -- simplified list
+    <|> parseNewUrlSource v
+    <|> parseNewUrlSource' v
    where
+    convert'' :: Either GHCupInfo URI -> Either (Either GHCupInfo SetupInfo) URI
+    convert'' (Left gi)  = Left (Left gi)
+    convert'' (Right uri) = Right uri
+
     parseOwnSourceLegacy = withObject "URLSource" $ \o -> do
       r :: URI <- o .: "OwnSource"
       pure (OwnSource [Right r])
@@ -377,18 +347,100 @@ instance FromJSON URLSource where
       pure (OwnSource (fmap Right r))
     parseOwnSourceNew2 = withObject "URLSource" $ \o -> do
       r :: [Either GHCupInfo URI] <- o .: "OwnSource"
-      pure (OwnSource r)
+      pure (OwnSource (convert'' <$> r))
     parseOwnSpec = withObject "URLSource" $ \o -> do
       r :: GHCupInfo <- o .: "OwnSpec"
-      pure (OwnSpec r)
+      pure (OwnSpec $ Left r)
     parseGHCupURL = withObject "URLSource" $ \o -> do
       _ :: [Value] <- o .: "GHCupURL"
       pure GHCupURL
+    parseStackURL = withObject "URLSource" $ \o -> do
+      _ :: [Value] <- o .: "StackSetupURL"
+      pure StackSetupURL
     legacyParseAddSource = withObject "URLSource" $ \o -> do
       r :: Either GHCupInfo URI <- o .: "AddSource"
-      pure (AddSource [r])
+      pure (AddSource [convert'' r])
     newParseAddSource = withObject "URLSource" $ \o -> do
       r :: [Either GHCupInfo URI] <- o .: "AddSource"
+      pure (AddSource (convert'' <$> r))
+
+    -- new since Stack SetupInfo
+    parseOwnSpecNew = withObject "URLSource" $ \o -> do
+      r :: Either GHCupInfo SetupInfo <- o .: "OwnSpec"
+      pure (OwnSpec r)
+    parseOwnSourceNew3 = withObject "URLSource" $ \o -> do
+      r :: [Either (Either GHCupInfo SetupInfo) URI] <- o .: "OwnSource"
+      pure (OwnSource r)
+    newParseAddSource2 = withObject "URLSource" $ \o -> do
+      r :: [Either (Either GHCupInfo SetupInfo) URI] <- o .: "AddSource"
       pure (AddSource r)
 
+    -- more lenient versions
+    parseOwnSpecLenient = withObject "URLSource" $ \o -> do
+      spec :: Object <- o .: "OwnSpec"
+      OwnSpec <$> lenientInfoParser spec
+    parseOwnSourceLenient = withObject "URLSource" $ \o -> do
+      mown :: Array <- o .: "OwnSource"
+      OwnSource . toList <$> mapM lenientInfoUriParser mown
+    parseAddSourceLenient = withObject "URLSource" $ \o -> do
+      madd :: Array <- o .: "AddSource"
+      AddSource . toList <$> mapM lenientInfoUriParser madd
+
+    -- simplified
+    parseNewUrlSource = withArray "URLSource" $ \a -> do
+      SimpleList . toList <$> mapM parseJSON a
+    parseNewUrlSource' v' = SimpleList .(:[]) <$> parseJSON v'
+
+
+lenientInfoUriParser :: Value -> Parser (Either (Either GHCupInfo SetupInfo) URI)
+lenientInfoUriParser (Object o) = Left <$> lenientInfoParser o
+lenientInfoUriParser v@(String _) = Right <$> parseJSON v
+lenientInfoUriParser _ = fail "Unexpected json in lenientInfoUriParser"
+
+
+lenientInfoParser :: Object -> Parser (Either GHCupInfo SetupInfo)
+lenientInfoParser o = do
+  setup_info :: Maybe Object <- o .:? "setup-info"
+  case setup_info of
+    Nothing -> do
+      r <- parseJSON (Object o)
+      pure $ Left r
+    Just setup_info' -> do
+      r <- parseJSON (Object setup_info')
+      pure $ Right r
+
+instance FromJSON NewURLSource where
+  parseJSON v = uri v <|> url v <|> gi v <|> si v
+   where
+    uri = withText "NewURLSource" $ \t -> NewURI <$> parseJSON (String t)
+    url = withText "NewURLSource" $ \t -> case T.unpack t of
+                                            "GHCupURL" -> pure NewGHCupURL
+                                            "StackSetupURL" -> pure NewStackSetupURL
+                                            t' -> fail $ "Unexpected text value in NewURLSource: " <> t'
+    gi = withObject "NewURLSource" $ \o -> do
+       ginfo :: GHCupInfo <- o .: "ghcup-info"
+       pure $ NewGHCupInfo ginfo
+
+    si = withObject "NewURLSource" $ \o -> do
+       sinfo :: SetupInfo <- o .: "setup-info"
+       pure $ NewSetupInfo sinfo
+
+
+instance FromJSON KeyCombination where
+  parseJSON v = proper v <|> simple v
+   where
+    simple = withObject "KeyCombination" $ \o -> do
+      k <- parseJSON (Object o)
+      pure (KeyCombination k [])
+    proper = withObject "KeyCombination" $ \o -> do
+      k <- o .: "Key"
+      m <- o .: "Mods"
+      pure $ KeyCombination k m
+
+instance ToJSON KeyCombination where
+  toJSON (KeyCombination k m) = object ["Key" .= k, "Mods" .= m]
+
+deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
+deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
+deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings

lib/GHCup/Types/JSON/Versions.hs

@@ -0,0 +1,90 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies          #-}
+
+{-|
+Module      : GHCup.Types.JSON.Versions
+Description : GHCup Version JSON types/instances
+Copyright   : (c) Julian Ospald, 2020
+License     : LGPL-3.0
+Maintainer  : hasufell@hasufell.de
+Stability   : experimental
+Portability : portable
+-}
+module GHCup.Types.JSON.Versions where
+
+import           Data.Aeson              hiding (Key)
+import           Data.Aeson.Types        hiding (Key)
+import           Data.Versions
+
+import qualified Data.Text                     as T
+
+instance ToJSON Versioning where
+  toJSON = toJSON . prettyV
+
+instance FromJSON Versioning where
+  parseJSON = withText "Versioning" $ \t -> case versioning t of
+    Right x -> pure x
+    Left  e -> fail $ "Failure in GHCTargetVersion (FromJSON)" <> show e
+
+instance ToJSONKey Versioning where
+  toJSONKey = toJSONKeyText $ \x -> prettyV x
+
+instance FromJSONKey Versioning where
+  fromJSONKey = FromJSONKeyTextParser $ \t -> case versioning t of
+    Right x -> pure x
+    Left  e -> fail $ "Failure in Versioning (FromJSONKey)" <> show e
+
+instance ToJSONKey (Maybe Versioning) where
+  toJSONKey = toJSONKeyText $ \case
+    Just x  -> prettyV x
+    Nothing -> T.pack "unknown_versioning"
+
+instance FromJSONKey (Maybe Versioning) where
+  fromJSONKey = FromJSONKeyTextParser $ \t ->
+    if t == T.pack "unknown_versioning" then pure Nothing else just t
+   where
+    just t = case versioning t of
+      Right x -> pure $ Just x
+      Left  e -> fail $ "Failure in (Maybe Versioning) (FromJSONKey)" <> show e
+
+instance ToJSONKey (Maybe Version) where
+  toJSONKey = toJSONKeyText $ \case
+    Just x  -> prettyVer x
+    Nothing -> T.pack "unknown_version"
+
+instance FromJSONKey (Maybe Version) where
+  fromJSONKey = FromJSONKeyTextParser $ \t ->
+    if t == T.pack "unknown_version" then pure Nothing else just t
+   where
+    just t = case version t of
+      Right x -> pure $ Just x
+      Left  e -> fail $ "Failure in (Maybe Version) (FromJSONKey)" <> show e
+
+instance ToJSON Version where
+  toJSON = toJSON . prettyVer
+
+instance FromJSON Version where
+  parseJSON = withText "Version" $ \t -> case version t of
+    Right x -> pure x
+    Left  e -> fail $ "Failure in Version (FromJSON)" <> show e
+
+instance ToJSONKey Version where
+  toJSONKey = toJSONKeyText $ \x -> prettyVer x
+
+instance FromJSONKey Version where
+  fromJSONKey = FromJSONKeyTextParser $ \t -> case version t of
+    Right x -> pure x
+    Left  e -> fail $ "Failure in Version (FromJSONKey)" <> show e
+
+instance ToJSON PVP where
+  toJSON = toJSON . prettyPVP
+
+instance FromJSON PVP where
+  parseJSON = withText "PVP" $ \t -> case pvp t of
+    Right x -> pure x
+    Left  e -> fail $ "Failure in PVP (FromJSON)" <> show e

lib/GHCup/Types/Stack.hs

@@ -0,0 +1,180 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+{-|
+Module      : GHCup.Types.Stack
+Description : GHCup types.Stack
+Copyright   : (c) Julian Ospald, 2023
+License     : LGPL-3.0
+Maintainer  : hasufell@hasufell.de
+Stability   : experimental
+Portability : portable
+-}
+module GHCup.Types.Stack where
+
+import           GHCup.Types.JSON.Versions ()
+
+import           Control.Applicative
+import           Control.DeepSeq                ( NFData )
+import           Data.ByteString
+import           Data.Aeson
+import           Data.Aeson.Types
+import           Data.Map.Strict                ( Map )
+import           Data.Text                      ( Text )
+import           Data.Text.Encoding
+import           Data.Versions
+
+import qualified Data.Map as Map
+import qualified GHC.Generics                  as GHC
+
+
+    --------------------------------------
+    --[ Stack download info copy pasta ]--
+    --------------------------------------
+
+data SetupInfo = SetupInfo
+  { siSevenzExe :: Maybe DownloadInfo
+  , siSevenzDll :: Maybe DownloadInfo
+  , siMsys2     :: Map Text VersionedDownloadInfo
+  , siGHCs      :: Map Text (Map Version GHCDownloadInfo)
+  , siStack     :: Map Text (Map Version DownloadInfo)
+  }
+  deriving (Show, Eq, GHC.Generic)
+
+instance NFData SetupInfo
+
+instance FromJSON SetupInfo where
+  parseJSON = withObject "SetupInfo" $ \o -> do
+    siSevenzExe <- o .:? "sevenzexe-info"
+    siSevenzDll <- o .:? "sevenzdll-info"
+    siMsys2     <- o .:? "msys2"          .!= mempty
+    siGHCs      <- o .:? "ghc"            .!= mempty
+    siStack     <- o .:? "stack"          .!= mempty
+    pure SetupInfo {..}
+
+instance ToJSON SetupInfo where
+  toJSON (SetupInfo {..}) = object [ "sevenzexe-info" .= siSevenzExe
+                                   , "sevenzdll-info" .= siSevenzDll
+                                   , "msys2"          .= siMsys2
+                                   , "ghc"            .= siGHCs
+                                   , "stack"          .= siStack
+                                   ]
+
+-- | For the @siGHCs@ field maps are deeply merged. For all fields the values
+-- from the first @SetupInfo@ win.
+instance Semigroup SetupInfo where
+  l <> r =
+    SetupInfo
+    { siSevenzExe = siSevenzExe l <|> siSevenzExe r
+    , siSevenzDll = siSevenzDll l <|> siSevenzDll r
+    , siMsys2     = siMsys2 l <> siMsys2 r
+    , siGHCs      = Map.unionWith (<>) (siGHCs l) (siGHCs r)
+    , siStack     = Map.unionWith (<>) (siStack l) (siStack r) }
+
+instance Monoid SetupInfo where
+  mempty =
+    SetupInfo
+    { siSevenzExe = Nothing
+    , siSevenzDll = Nothing
+    , siMsys2     = Map.empty
+    , siGHCs      = Map.empty
+    , siStack     = Map.empty
+    }
+  mappend = (<>)
+
+-- | Build of the compiler distribution (e.g. standard, gmp4, tinfo6)
+-- | Information for a file to download.
+data DownloadInfo = DownloadInfo
+  { downloadInfoUrl           :: Text
+    -- ^ URL or absolute file path
+  , downloadInfoContentLength :: Maybe Int
+  , downloadInfoSha1          :: Maybe ByteString
+  , downloadInfoSha256        :: Maybe ByteString
+  }
+  deriving (Show, Eq, GHC.Generic)
+
+instance ToJSON DownloadInfo where
+  toJSON (DownloadInfo {..}) = object [ "url"            .= downloadInfoUrl
+                                      , "content-length" .= downloadInfoContentLength
+                                      , "sha1"           .= (decodeUtf8 <$> downloadInfoSha1)
+                                      , "sha256"         .= (decodeUtf8 <$> downloadInfoSha256)
+                                      ]
+
+instance NFData DownloadInfo
+
+instance FromJSON DownloadInfo where
+  parseJSON = withObject "DownloadInfo" parseDownloadInfoFromObject
+
+-- | Parse JSON in existing object for 'DownloadInfo'
+parseDownloadInfoFromObject :: Object -> Parser DownloadInfo
+parseDownloadInfoFromObject o = do
+  url           <- o .: "url"
+  contentLength <- o .:? "content-length"
+  sha1TextMay   <- o .:? "sha1"
+  sha256TextMay <- o .:? "sha256"
+  pure
+    DownloadInfo
+    { downloadInfoUrl           = url
+    , downloadInfoContentLength = contentLength
+    , downloadInfoSha1          = fmap encodeUtf8 sha1TextMay
+    , downloadInfoSha256        = fmap encodeUtf8 sha256TextMay
+    }
+
+data VersionedDownloadInfo = VersionedDownloadInfo
+  { vdiVersion      :: Version
+  , vdiDownloadInfo :: DownloadInfo
+  }
+  deriving (Show, Eq, GHC.Generic)
+
+instance ToJSON VersionedDownloadInfo where
+  toJSON (VersionedDownloadInfo {vdiDownloadInfo = DownloadInfo{..}, ..})
+    = object [ "version"        .= vdiVersion
+             , "url"            .= downloadInfoUrl
+             , "content-length" .= downloadInfoContentLength
+             , "sha1"           .= (decodeUtf8 <$> downloadInfoSha1)
+             , "sha256"         .= (decodeUtf8 <$> downloadInfoSha256)
+             ]
+
+instance NFData VersionedDownloadInfo
+
+instance FromJSON VersionedDownloadInfo where
+  parseJSON = withObject "VersionedDownloadInfo" $ \o -> do
+    ver'         <- o .: "version"
+    downloadInfo <- parseDownloadInfoFromObject o
+    pure VersionedDownloadInfo
+      { vdiVersion      = ver'
+      , vdiDownloadInfo = downloadInfo
+      }
+
+data GHCDownloadInfo = GHCDownloadInfo
+  { gdiConfigureOpts :: [Text]
+  , gdiConfigureEnv  :: Map Text Text
+  , gdiDownloadInfo  :: DownloadInfo
+  }
+  deriving (Show, Eq, GHC.Generic)
+
+instance NFData GHCDownloadInfo
+
+instance ToJSON GHCDownloadInfo where
+  toJSON (GHCDownloadInfo {gdiDownloadInfo = DownloadInfo {..}, ..})
+    = object [ "configure-opts" .= gdiConfigureOpts
+             , "configure-env"  .= gdiConfigureEnv
+             , "url"            .= downloadInfoUrl
+             , "content-length" .= downloadInfoContentLength
+             , "sha1"           .= (decodeUtf8 <$> downloadInfoSha1)
+             , "sha256"         .= (decodeUtf8 <$> downloadInfoSha256)
+             ]
+
+instance FromJSON GHCDownloadInfo where
+  parseJSON = withObject "GHCDownloadInfo" $ \o -> do
+    configureOpts <- o .:? "configure-opts" .!= mempty
+    configureEnv  <- o .:? "configure-env"  .!= mempty
+    downloadInfo  <- parseDownloadInfoFromObject o
+    pure GHCDownloadInfo
+      { gdiConfigureOpts = configureOpts
+      , gdiConfigureEnv  = configureEnv
+      , gdiDownloadInfo  = downloadInfo
+      }
+

lib/GHCup/Utils.hs

@@ -49,7 +49,6 @@ import           GHCup.Prelude.Logger.Internal
 import           GHCup.Prelude.MegaParsec
 import           GHCup.Prelude.Process
 import           GHCup.Prelude.String.QQ
-
 import           Codec.Archive           hiding ( Directory )
 import           Control.Applicative
 import           Control.Exception.Safe
@@ -90,9 +89,9 @@ import qualified Data.Text.Encoding            as E
 import qualified Text.Megaparsec               as MP
 import qualified Data.List.NonEmpty            as NE
 import qualified Streamly.Prelude              as S
+
 import Control.DeepSeq (force)
 import GHC.IO (evaluate)
-import System.Environment (getEnvironment, setEnv)
 import Data.Time (Day(..), diffDays, addDays)
 
 
@@ -1321,22 +1320,6 @@ warnAboutHlsCompatibility = do
 
 
 
-addToPath :: FilePath
-          -> Bool         -- ^ if False will prepend
-          -> IO [(String, String)]
-addToPath path append = do
- cEnv <- Map.fromList <$> getEnvironment
- let paths          = ["PATH", "Path"]
-     curPaths       = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
-     {- HLINT ignore "Redundant bracket" -}
-     newPath        = intercalate [searchPathSeparator] (if append then (curPaths ++ [path]) else (path : curPaths))
-     envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
-     pathVar        = if isWindows then "Path" else "PATH"
-     envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
- liftIO $ setEnv pathVar newPath
- return envWithNewPath
-
-
     -----------
     --[ Git ]--
     -----------

lib/GHCup/Version.hs

@@ -36,6 +36,9 @@ import Data.Void (Void)
 ghcupURL :: URI
 ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.8.yaml|]
 
+stackSetupURL :: URI
+stackSetupURL = [uri|https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml|]
+
 -- | The current ghcup version.
 ghcUpVer :: V.PVP
 ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version

test/optparse-test/ConfigTest.hs

@@ -5,6 +5,7 @@ module ConfigTest where
 import Test.Tasty
 import Test.Tasty.HUnit
 import GHCup.OptParse
+import GHCup.Types (NewURLSource(..))
 import Utils
 import Control.Monad.IO.Class
 import URI.ByteString.QQ
@@ -23,7 +24,13 @@ checkList =
   , ("config init", InitConfig)
   , ("config show", ShowConfig)
   , ("config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml"
-    , AddReleaseChannel False [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml|]
+    , AddReleaseChannel False (NewURI [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml|])
+    )
+  , ("config add-release-channel GHCupURL"
+    , AddReleaseChannel False NewGHCupURL
+    )
+  , ("config add-release-channel StackSetupURL"
+    , AddReleaseChannel False NewStackSetupURL
     )
   , ("config set cache true", SetConfig "cache" (Just "true"))
   ]