app/ghcup/GHCup/OptParse/Config.hs

@@ -14,26 +14,29 @@ module GHCup.OptParse.Config where
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Utils
-import           GHCup.Utils.Prelude
-import           GHCup.Utils.Logger
-import           GHCup.Utils.String.QQ
+import           GHCup.Prelude
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
+import           GHCup.OptParse.Common
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
 #endif
+import           Control.Exception              ( displayException )
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
-import           Data.Bifunctor
 import           Data.Functor
 import           Data.Maybe
 import           Haskus.Utils.Variant.Excepts
-import           Options.Applicative     hiding ( style )
+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
-import qualified Data.YAML.Aeson               as Y
+import qualified Data.Yaml.Aeson               as Y
 import Control.Exception.Safe (MonadMask)
 
 
@@ -46,8 +49,9 @@ import Control.Exception.Safe (MonadMask)
 
 data ConfigCommand
   = ShowConfig
-  | SetConfig String String
+  | SetConfig String (Maybe String)
   | InitConfig
+  | AddReleaseChannel URI
 
 
 
@@ -61,14 +65,17 @@ configP = subparser
       (  command "init" initP
       <> command "set"  setP -- [set] KEY VALUE at help lhs
       <> command "show" showP
+      <> command "add-release-channel" addP
       )
     <|> argsP -- add show for a single option
     <|> pure ShowConfig
  where
   initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml")
   showP = info (pure ShowConfig) (progDesc "Show current config (default)")
-  setP  = info argsP (progDesc "Set config KEY to VALUE")
-  argsP = SetConfig <$> argument str (metavar "KEY") <*> argument str (metavar "VALUE")
+  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 <$> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
+    (progDesc "Add a release channel from a URI")
 
 
 
@@ -88,7 +95,19 @@ configFooter = [s|Examples:
   ghcup config init
 
   # set <key> <value> configuration pair
-  ghcup config <key> <value>|]
+  ghcup config set <key> <value>|]
+
+
+configSetFooter :: String
+configSetFooter = [s|Examples:
+  # disable caching
+  ghcup config set cache false
+
+  # switch downloader to wget
+  ghcup config set downloader Wget
+
+  # set mirror for ghcup metadata
+  ghcup config set '{url-source: { OwnSource: "<url>"}}'|]
 
 
 
@@ -98,25 +117,22 @@ configFooter = [s|Examples:
 
 
 formatConfig :: UserSettings -> String
-formatConfig = UTF8.toString . Y.encode1Strict
+formatConfig = UTF8.toString . Y.encode
 
 
-updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings
-updateSettings config' settings = do
-  settings' <- lE' JSONDecodeError . first snd . Y.decode1Strict $ config'
-  pure $ mergeConf settings' settings
-  where
-   mergeConf :: UserSettings -> Settings -> Settings
-   mergeConf UserSettings{..} Settings{..} =
-     let cache'      = fromMaybe cache uCache
-         noVerify'   = fromMaybe noVerify uNoVerify
-         keepDirs'   = fromMaybe keepDirs uKeepDirs
-         downloader' = fromMaybe downloader uDownloader
-         verbose'    = fromMaybe verbose uVerbose
-         urlSource'  = fromMaybe urlSource uUrlSource
-         noNetwork'  = fromMaybe noNetwork uNoNetwork
-         gpgSetting' = fromMaybe gpgSetting uGPGSetting
-     in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
+updateSettings :: UserSettings -> Settings -> Settings
+updateSettings UserSettings{..} Settings{..} =
+   let cache'      = fromMaybe cache uCache
+       metaCache'  = fromMaybe metaCache uMetaCache
+       noVerify'   = fromMaybe noVerify uNoVerify
+       keepDirs'   = fromMaybe keepDirs uKeepDirs
+       downloader' = fromMaybe downloader uDownloader
+       verbose'    = fromMaybe verbose uVerbose
+       urlSource'  = fromMaybe urlSource uUrlSource
+       noNetwork'  = fromMaybe noNetwork uNoNetwork
+       gpgSetting' = fromMaybe gpgSetting uGPGSetting
+       platformOverride' = uPlatformOverride <|> platformOverride
+   in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride'
 
 
 
@@ -126,7 +142,7 @@ updateSettings config' settings = do
 
 
 
-config :: ( Monad m
+config :: forall m. ( Monad m
           , MonadMask m
           , MonadUnliftIO m
           , MonadFail m
@@ -147,22 +163,42 @@ config configCommand settings keybindings runLogger = case configCommand of
     liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings)
     pure ExitSuccess
 
-  (SetConfig k v) -> do
-    case v of
-      "" -> do
-        runLogger $ logError "Empty values are not allowed"
-        pure $ ExitFailure 55
-      _  -> do
-        r <- runE @'[JSONError] $ do
-          settings' <- updateSettings (UTF8.fromString (k <> ": " <> v <> "\n")) settings
-          path <- liftIO getConfigFilePath
-          liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
-          lift $ runLogger $ logDebug $ T.pack $ show settings'
+  (SetConfig k mv) -> do
+    r <- runE @'[JSONError, ParseError] $ do
+      case mv of
+        Just "" ->
+          throwE $ ParseError "Empty values are not allowed"
+        Nothing -> do
+          usersettings <- decodeSettings k
+          lift $ doConfig usersettings
+          pure ()
+        Just v -> do
+          usersettings <- decodeSettings (k <> ": " <> v <> "\n")
+          lift $ doConfig usersettings
           pure ()
+    case r of
+      VRight _ -> pure ExitSuccess
+      VLeft (V (JSONDecodeError e)) -> do
+        runLogger $ logError $ "Error decoding config: " <> T.pack e
+        pure $ ExitFailure 65
+      VLeft _ -> pure $ ExitFailure 65
+
+  AddReleaseChannel uri -> do
+    case urlSource settings of
+      AddSource xs -> do
+        doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (xs <> [Right uri]) })
+        pure ExitSuccess
+      _ -> do
+        doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
+        pure ExitSuccess
 
-        case r of
-            VRight _ -> pure ExitSuccess
-            VLeft (V (JSONDecodeError e)) -> do
-              runLogger $ logError $ "Error decoding config: " <> T.pack e
-              pure $ ExitFailure 65
-            VLeft _ -> pure $ ExitFailure 65
+ where
+  doConfig :: MonadIO m => UserSettings -> m ()
+  doConfig usersettings = do
+    let settings' = updateSettings usersettings settings
+    path <- liftIO getConfigFilePath
+    liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
+    runLogger $ logDebug $ T.pack $ show settings'
+    pure ()
+
+  decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString

app/ghcup/GHCup/OptParse/DInfo.hs

@@ -17,9 +17,10 @@ import           GHCup
 import           GHCup.Errors
 import           GHCup.Version
 import           GHCup.Types
-import           GHCup.Utils.Prelude
 import           GHCup.Utils.Dirs
-import           GHCup.Utils.Logger
+import           GHCup.Prelude
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.Process
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -36,7 +37,6 @@ import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
-import GHCup.Utils.File
 import Language.Haskell.TH
 
 
@@ -51,7 +51,7 @@ describe_result = $( LitE . StringL <$>
                      runIO (do
                              CapturedProcess{..} <-  do
                               dirs <- liftIO getAllDirs
-                              let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone False)
+                              let settings = AppState (defaultSettings { noNetwork = True })
                                                dirs
                                                defaultKeyBindings
                               flip runReaderT settings $ executeOut "git" ["describe"] Nothing

app/ghcup/GHCup/OptParse/GC.hs

@@ -14,8 +14,8 @@ module GHCup.OptParse.GC where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
-import           GHCup.Utils.String.QQ
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -56,26 +56,26 @@ data GCOptions = GCOptions
     --[ Parsers ]--
     ---------------
 
-          
+
 gcP :: Parser GCOptions
 gcP =
   GCOptions
-  <$> 
+  <$>
     switch
       (short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'")
-  <*> 
+  <*>
     switch
       (short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions")
-  <*> 
+  <*>
     switch
       (short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)")
-  <*> 
+  <*>
     switch
       (short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version")
-  <*> 
+  <*>
     switch
       (short 'c' <> long "cache" <> help "GC the GHCup cache")
-  <*> 
+  <*>
     switch
       (short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers")
 
@@ -98,7 +98,7 @@ gcFooter = [s|Discussion:
     ---------------------------
 
 
-type GCEffects = '[ NotInstalled ]
+type GCEffects = '[ NotInstalled, UninstallFailed ]
 
 
 runGC :: MonadUnliftIO m
@@ -129,10 +129,10 @@ gc :: ( Monad m
    -> (ReaderT LeanAppState m () -> m ())
    -> m ExitCode
 gc GCOptions{..} runAppState runLogger = runGC runAppState (do
-  when gcOldGHC rmOldGHC
+  when gcOldGHC (liftE rmOldGHC)
   lift $ when gcProfilingLibs rmProfilingLibs
   lift $ when gcShareDir rmShareDir
-  lift $ when gcHLSNoGHC rmHLSNoGHC
+  liftE $ when gcHLSNoGHC rmHLSNoGHC
   lift $ when gcCache rmCache
   lift $ when gcTmp rmTmp
    ) >>= \case

app/ghcup/GHCup/OptParse/List.hs

@@ -11,7 +11,7 @@ module GHCup.OptParse.List where
 
 
 import           GHCup
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude
 import           GHCup.Types
 import           GHCup.OptParse.Common
 
@@ -69,6 +69,7 @@ listOpts =
             (eitherReader toolParser)
             (short 't' <> long "tool" <> metavar "<ghc|cabal|hls|stack>" <> help
               "Tool to list versions for. Default is all"
+              <> completer (toolCompleter)
             )
           )
     <*> optional
@@ -78,6 +79,7 @@ listOpts =
             <> long "show-criteria"
             <> metavar "<installed|set|available>"
             <> help "Show only installed/set/available tool versions"
+              <> completer (listCompleter ["installed", "set", "available"])
             )
           )
     <*> switch
@@ -141,11 +143,11 @@ printListResult no_color raw lr = do
             )
         $ lr
   let cols =
-        foldr (\xs ys -> zipWith (:) xs ys) (replicate (length rows) []) rows
+        foldr (\xs ys -> zipWith (:) xs ys) (repeat []) rows
       lengths = fmap (maximum . fmap strWidth) cols
       padded  = fmap (\xs -> zipWith padTo xs lengths) rows
 
-  forM_ padded $ \row -> putStrLn $ unwords row
+  forM_ (if raw then rows else padded) $ \row -> putStrLn $ unwords row
  where
 
   padTo str' x =

app/ghcup/GHCup/OptParse/Nuke.hs

@@ -14,7 +14,7 @@ module GHCup.OptParse.Nuke where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
+import           GHCup.Prelude.Logger
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -42,7 +42,7 @@ import Control.Concurrent (threadDelay)
     ---------------------------
 
 
-type NukeEffects = '[ NotInstalled ]
+type NukeEffects = '[ NotInstalled, UninstallFailed ]
 
 
 runNuke :: AppState

app/ghcup/GHCup/OptParse/Rm.hs

@@ -18,9 +18,9 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
-import           GHCup.Utils.Logger
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
 import           GHCup.OptParse.Common
-import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -71,7 +71,7 @@ data RmOptions = RmOptions
     --[ Parsers ]--
     ---------------
 
-          
+
 rmParser :: Parser (Either RmCommand RmOptions)
 rmParser =
   (Left <$> subparser
@@ -103,7 +103,7 @@ rmParser =
 
 
 rmOpts :: Maybe Tool -> Parser RmOptions
-rmOpts tool = RmOptions <$> versionArgument (Just ListInstalled) tool
+rmOpts tool = RmOptions <$> ghcVersionArgument (Just ListInstalled) tool
 
 
 
@@ -127,7 +127,7 @@ rmFooter = [s|Discussion:
     ---------------------------
 
 
-type RmEffects = '[ NotInstalled ]
+type RmEffects = '[ NotInstalled, UninstallFailed ]
 
 
 runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))

app/ghcup/GHCup/OptParse/ToolRequirements.hs

@@ -4,13 +4,15 @@
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE QuasiQuotes #-}
 
 module GHCup.OptParse.ToolRequirements where
 
 
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -28,12 +30,47 @@ import qualified Data.Text.IO                  as T
 import Control.Exception.Safe (MonadMask)
 import GHCup.Types.Optics
 import GHCup.Platform
-import GHCup.Utils.Prelude
+import GHCup.Prelude
 import GHCup.Requirements
 import System.IO
 
 
 
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data ToolReqOpts = ToolReqOpts
+  { tlrRaw :: Bool
+  }
+
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+          
+toolReqP :: Parser ToolReqOpts
+toolReqP =
+  ToolReqOpts
+    <$> switch (short 'r' <> long "raw-format" <> help "machine-parsable format")
+
+
+
+
+    --------------
+    --[ Footer ]--
+    --------------
+
+
+toolReqFooter :: String
+toolReqFooter = [s|Discussion:
+  Print tool requirements on the current platform.
+  If you want to pass this to your package manage, use '--raw-format'.|]
+
 
 
     ---------------------------
@@ -66,14 +103,17 @@ toolRequirements :: ( Monad m
                     , MonadFail m
                     , Alternative m
                     )
-                 => (ReaderT AppState m (VEither ToolRequirementsEffects ()) -> m (VEither ToolRequirementsEffects ()))
+                 => ToolReqOpts
+                 -> (ReaderT AppState m (VEither ToolRequirementsEffects ()) -> m (VEither ToolRequirementsEffects ()))
                  -> (ReaderT LeanAppState m () -> m ())
                  -> m ExitCode
-toolRequirements runAppState runLogger = runToolRequirements runAppState (do
+toolRequirements ToolReqOpts{..} runAppState runLogger = runToolRequirements runAppState (do
     GHCupInfo { .. } <- lift getGHCupInfo
     platform' <- liftE getPlatform
-    req      <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
-    liftIO $ T.hPutStr stdout (prettyRequirements req)
+    req       <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
+    if tlrRaw
+    then liftIO $ T.hPutStr stdout (rawRequirements req)
+    else liftIO $ T.hPutStr stdout (prettyRequirements req)
   )
     >>= \case
           VRight _ -> pure ExitSuccess

app/ghcup/GHCup/OptParse/UnSet.hs

@@ -16,8 +16,8 @@ module GHCup.OptParse.UnSet where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
-import           GHCup.Utils.String.QQ
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

cabal.ghc8107.project

@@ -8,7 +8,14 @@ package ghcup
     tests: True
     flags: +tui
 
-constraints: http-io-streams -brotli
+source-repository-package
+  type: git
+  location: https://github.com/bgamari/terminal-size.git
+  tag: 34ea816bd63f75f800eedac12c6908c6f3736036
+
+constraints: http-io-streams -brotli,
+             any.Cabal ==3.6.2.0,
+             any.aeson >= 2.0.1.0,
 
 package libarchive
   flags: -system-libarchive
@@ -19,6 +26,12 @@ package aeson-pretty
 package cabal-plan
   flags: -exe
 
+package aeson
+  flags: +ordered-keymap
+
+package streamly
+  flags: +use-unliftio
+
 allow-newer: base, ghc-prim, template-haskell, language-c
 
 with-compiler: ghc-8.10.7

cabal.ghc901.project → cabal.ghc902.project

@@ -8,7 +8,14 @@ package ghcup
     tests: True
     flags: +tui
 
-constraints: http-io-streams -brotli
+source-repository-package
+  type: git
+  location: https://github.com/bgamari/terminal-size.git
+  tag: 34ea816bd63f75f800eedac12c6908c6f3736036
+
+constraints: http-io-streams -brotli,
+             any.Cabal ==3.6.2.0,
+             any.aeson >= 2.0.1.0,
 
 package libarchive
   flags: -system-libarchive
@@ -19,6 +26,12 @@ package aeson-pretty
 package cabal-plan
   flags: -exe
 
+package aeson
+  flags: +ordered-keymap
+
+package streamly
+  flags: +use-unliftio
+
 allow-newer: base, ghc-prim, template-haskell, language-c
 
-with-compiler: ghc-9.0.1
+with-compiler: ghc-9.0.2

cabal.ghc923.project

+packages: ./ghcup.cabal
+
+optional-packages: ./vendored/*/*.cabal
+
+optimization: 2
+
+package ghcup
+    tests: True
+    flags: +tui
+
+source-repository-package
+  type: git
+  location: https://github.com/bgamari/terminal-size.git
+  tag: 34ea816bd63f75f800eedac12c6908c6f3736036
+
+constraints: http-io-streams -brotli,
+             any.Cabal ==3.6.2.0,
+             any.aeson >= 2.0.1.0,
+
+package libarchive
+  flags: -system-libarchive
+
+package aeson-pretty
+  flags: +lib-only
+
+package cabal-plan
+  flags: -exe
+
+package aeson
+  flags: +ordered-keymap
+
+package streamly
+  flags: +use-unliftio
+
+allow-newer: base, ghc-prim, template-haskell, language-c
+
+with-compiler: ghc-9.2.3