From 84d01b1091c0cb5e12f3684987571d89013d2c33 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 17 Mar 2022 21:08:03 +0100 Subject: [PATCH 1/7] Don't do padding for --raw-format --- app/ghcup/GHCup/OptParse/List.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/ghcup/GHCup/OptParse/List.hs b/app/ghcup/GHCup/OptParse/List.hs index 7212578..0b1c5ff 100644 --- a/app/ghcup/GHCup/OptParse/List.hs +++ b/app/ghcup/GHCup/OptParse/List.hs @@ -147,7 +147,7 @@ printListResult no_color raw lr = do 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 = From 71390c84daed509c5f02ae27a5c48368dfd85a6a Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 17 Mar 2022 21:09:35 +0100 Subject: [PATCH 2/7] Apply hlint --- app/ghcup/GHCup/OptParse/List.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/ghcup/GHCup/OptParse/List.hs b/app/ghcup/GHCup/OptParse/List.hs index 0b1c5ff..d1bfc65 100644 --- a/app/ghcup/GHCup/OptParse/List.hs +++ b/app/ghcup/GHCup/OptParse/List.hs @@ -143,7 +143,7 @@ printListResult no_color raw lr = do ) $ lr let cols = - foldr (\xs ys -> zipWith (:) xs ys) (cycle [[]]) rows + foldr (\xs ys -> zipWith (:) xs ys) (repeat []) rows lengths = fmap (maximum . fmap strWidth) cols padded = fmap (\xs -> zipWith padTo xs lengths) rows From fdcd6822c47079b1b97006d94afb1590c885a4d1 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 17 Mar 2022 21:11:39 +0100 Subject: [PATCH 3/7] Don't do update check on --no-verbose --- app/ghcup/Main.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index c48107c..7b31c40 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -235,7 +235,9 @@ Report bugs at |] Interactive -> pure () #endif -- check for new tools - _ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case + _ + | Just False <- optVerbose -> pure () + | otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do newTools <- lift checkForUpdates forM_ newTools $ \newTool@(t, l) -> do From 8eeb32c495a2b5ddebe66e5f7cb65b3deb8df740 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 10 Mar 2022 20:26:51 +0100 Subject: [PATCH 4/7] Overhaul metadata merging and add 'ghcup config add-release-channel URI' --- app/ghcup/GHCup/OptParse/Config.hs | 95 ++++++++++++++++++------------ app/ghcup/Main.hs | 2 +- data/config.yaml | 14 +++-- lib/GHCup/Download.hs | 35 +++++------ lib/GHCup/Types.hs | 4 +- lib/GHCup/Types/JSON.hs | 34 ++++++++++- 6 files changed, 118 insertions(+), 66 deletions(-) diff --git a/app/ghcup/GHCup/OptParse/Config.hs b/app/ghcup/GHCup/OptParse/Config.hs index 13014ef..c8072ab 100644 --- a/app/ghcup/GHCup/OptParse/Config.hs +++ b/app/ghcup/GHCup/OptParse/Config.hs @@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExplicitForAll #-} module GHCup.OptParse.Config where @@ -17,6 +18,7 @@ import GHCup.Utils import GHCup.Utils.Prelude import GHCup.Utils.Logger import GHCup.Utils.String.QQ +import GHCup.OptParse.Common #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -27,10 +29,11 @@ import Control.Monad.Trans.Resource 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 @@ -49,6 +52,7 @@ data ConfigCommand = ShowConfig | SetConfig String (Maybe String) | InitConfig + | AddReleaseChannel URI @@ -62,6 +66,7 @@ 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 @@ -70,6 +75,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 "") <*> optional (argument str (metavar "YAML_VALUE")) + addP = info (AddReleaseChannel <$> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri)) + (progDesc "Add a release channel from a URI") @@ -114,23 +121,18 @@ formatConfig :: UserSettings -> String formatConfig = UTF8.toString . Y.encode -updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings -updateSettings config' settings = do - settings' <- lE' (JSONDecodeError . displayException) . Y.decodeEither' $ config' - pure $ mergeConf settings' settings - where - mergeConf :: UserSettings -> Settings -> Settings - mergeConf 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 - in Settings cache' metaCache' 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 + in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor @@ -140,7 +142,7 @@ updateSettings config' settings = do -config :: ( Monad m +config :: forall m. ( Monad m , MonadMask m , MonadUnliftIO m , MonadFail m @@ -161,27 +163,42 @@ config configCommand settings keybindings runLogger = case configCommand of liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings) pure ExitSuccess - (SetConfig k (Just v)) -> - case v of - "" -> do - runLogger $ logError "Empty values are not allowed" - pure $ ExitFailure 55 - _ -> doConfig (k <> ": " <> v <> "\n") + (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 - (SetConfig json Nothing) -> doConfig json + 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 where - doConfig val = do - r <- runE @'[JSONError] $ do - settings' <- updateSettings (UTF8.fromString val) settings - path <- liftIO getConfigFilePath - liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings) - lift $ runLogger $ logDebug $ T.pack $ show settings' - pure () + 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 () - 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 + decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 7b31c40..b4748ee 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -82,7 +82,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 optUrlSource + urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg in (Settings {..}, keyBindings) diff --git a/data/config.yaml b/data/config.yaml index 3cca0ec..2bccf63 100644 --- a/data/config.yaml +++ b/data/config.yaml @@ -48,12 +48,16 @@ url-source: ## Example 1: Read download info from this location instead ## Accepts file/http/https scheme + ## 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 + ## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions. + ## Can also be an array of 'Either GHCupInfo URL', also see Example 3. # AddSource: # Left: - # toolRequirements: {} # this is ignored + # globalTools: {} + # toolRequirements: {} # ghcupDownloads: # GHC: # 9.10.2: @@ -66,6 +70,8 @@ url-source: # dlSubdir: ghc-7.10.3 # dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5 - ## Example 3: Add a custom download file to the default downloads, overwriting duplicate versions + ## Example 3: Add multiple custom download files to the default downloads via right-biased merge (overwriting duplicate + ## versions). # AddSource: - # Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml" + # - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml" + # - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml" diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index acb6e4d..8327c76 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -121,28 +121,25 @@ getDownloadsF = do Settings { urlSource } <- lift getSettings case urlSource of GHCupURL -> liftE $ getBase ghcupURL - (OwnSource url) -> liftE $ getBase url + (OwnSource exts) -> do + ext <- liftE $ mapM (either pure getBase) exts + mergeGhcupInfo ext (OwnSpec av) -> pure av - (AddSource (Left ext)) -> do + (AddSource exts) -> do base <- liftE $ getBase ghcupURL - pure (mergeGhcupInfo base ext) - (AddSource (Right uri)) -> do - base <- liftE $ getBase ghcupURL - ext <- liftE $ getBase uri - pure (mergeGhcupInfo base ext) + ext <- liftE $ mapM (either pure getBase) exts + mergeGhcupInfo (base:ext) - where - - mergeGhcupInfo :: GHCupInfo -- ^ base to merge with - -> GHCupInfo -- ^ extension overwriting the base - -> GHCupInfo - mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) = - let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of - Just a' -> M.union a' a - Nothing -> a - ) base - newGlobalTools = M.union base2 ext2 - in GHCupInfo tr newDownloads newGlobalTools + where + mergeGhcupInfo :: MonadFail m + => [GHCupInfo] + -> m GHCupInfo + mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo" + mergeGhcupInfo xs@(GHCupInfo{}: _) = + let newDownloads = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads <$> xs) + newGlobalTools = M.unionsWith (\_ a2 -> a2 ) (_globalTools <$> xs) + newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs) + in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 5633f78..cab0858 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -286,9 +286,9 @@ instance Pretty TarDir where -- | Where to fetch GHCupDownloads from. data URLSource = GHCupURL - | OwnSource URI + | OwnSource [Either GHCupInfo URI] -- ^ complete source list | OwnSpec GHCupInfo - | AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL + | AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL deriving (GHC.Generic, Show) instance NFData URLSource diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 8aafad9..8d7cd3b 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -79,6 +79,38 @@ instance FromJSON Tag where instance ToJSON URI where toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef' +instance FromJSON URLSource where + parseJSON v = + parseGHCupURL v + <|> parseOwnSourceLegacy v + <|> parseOwnSourceNew1 v + <|> parseOwnSourceNew2 v + <|> parseOwnSpec v + <|> legacyParseAddSource v + <|> newParseAddSource v + where + parseOwnSourceLegacy = withObject "URLSource" $ \o -> do + r :: URI <- o .: "OwnSource" + pure (OwnSource [Right r]) + parseOwnSourceNew1 = withObject "URLSource" $ \o -> do + r :: [URI] <- o .: "OwnSource" + pure (OwnSource (fmap Right r)) + parseOwnSourceNew2 = withObject "URLSource" $ \o -> do + r :: [Either GHCupInfo URI] <- o .: "OwnSource" + pure (OwnSource r) + parseOwnSpec = withObject "URLSource" $ \o -> do + r :: GHCupInfo <- o .: "OwnSpec" + pure (OwnSpec r) + parseGHCupURL = withObject "URLSource" $ \o -> do + _ :: [Value] <- o .: "GHCupURL" + pure GHCupURL + legacyParseAddSource = withObject "URLSource" $ \o -> do + r :: Either GHCupInfo URI <- o .: "AddSource" + pure (AddSource [r]) + newParseAddSource = withObject "URLSource" $ \o -> do + r :: [Either GHCupInfo URI] <- o .: "AddSource" + pure (AddSource r) + instance FromJSON URI where parseJSON = withText "URL" $ \t -> case parseURI strictURIParserOptions (encodeUtf8 t) of @@ -314,7 +346,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requir deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo -deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource +deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource 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 { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings From cfe6c47cd76c65013ca77162eea8f7a45ee2e481 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 17 Mar 2022 22:51:17 +0100 Subject: [PATCH 5/7] Fix max path issues on windows with 'ghcup run' --- lib/GHCup/Utils/Dirs.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index 15e6fcb..b2fb7eb 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -339,13 +339,15 @@ useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS" relativeSymlink :: FilePath -- ^ the path in which to create the symlink -> FilePath -- ^ the symlink destination -> FilePath -relativeSymlink p1 p2 = - let d1 = splitDirectories p1 - d2 = splitDirectories p2 - common = takeWhile (\(x, y) -> x == y) $ zip d1 d2 - cPrefix = drop (length common) d1 - in joinPath (replicate (length cPrefix) "..") - <> joinPath ([pathSeparator] : drop (length common) d2) +relativeSymlink p1 p2 + | isWindows = p2 -- windows quickly gets into MAX_PATH issues so we don't care about relative symlinks + | otherwise = + let d1 = splitDirectories p1 + d2 = splitDirectories p2 + common = takeWhile (\(x, y) -> x == y) $ zip d1 d2 + cPrefix = drop (length common) d1 + in joinPath (replicate (length cPrefix) "..") + <> joinPath ([pathSeparator] : drop (length common) d2) cleanupTrash :: ( MonadIO m From 70a451b63ea78ab3a3781ee22f617819a9b5cdde Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 17 Mar 2022 23:03:27 +0100 Subject: [PATCH 6/7] Prepare 0.1.17.6 --- CHANGELOG.md | 5 +++++ ghcup.cabal | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 43f2855..66e2f01 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,11 @@ * Vastly improve shell completions wrt [#242](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/242) * Fix 'ghcup install cabal/hls/stack --set' wrt [#324](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/324) * Fix bad error message wrt [#323](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/323) +* Use predictable /tmp names for `ghcup run`, fixes [#329](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/329) +* Fix bug with isolated installation of not previously installed versions +* Add `--no-set` to install commands, fixes [#330](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/330) +* Fix serious bug in `ghcup list --raw-format -t -c installed` +* Overhaul metadata merging and add `ghcup config add-release-channel URI` wrt [#328](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/328) ## 0.1.17.5 -- 2022-02-26 diff --git a/ghcup.cabal b/ghcup.cabal index d6a94ad..3926e95 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghcup -version: 0.1.17.5 +version: 0.1.17.6 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2020 From 92bd33355217b16430e958b90227f9690174b836 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 18 Mar 2022 00:42:48 +0100 Subject: [PATCH 7/7] Fix double appstate --- app/ghcup/GHCup/OptParse/Run.hs | 146 +++++++++++++++++++++++--------- app/ghcup/Main.hs | 2 +- 2 files changed, 105 insertions(+), 43 deletions(-) diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index bf6be83..5e4532f 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -15,7 +15,7 @@ import GHCup.Utils.File import GHCup.OptParse.Common import GHCup.Errors import GHCup.Types -import GHCup.Types.Optics ( getDirs ) +import GHCup.Types.Optics import GHCup.Utils.Logger import GHCup.Utils.String.QQ @@ -187,14 +187,16 @@ runLeanRUN leanAppstate = @RunEffects runRUN :: MonadUnliftIO m - => (ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a)) + => IO AppState -> Excepts RunEffects (ResourceT (ReaderT AppState m)) a -> m (VEither RunEffects a) -runRUN runAppState = - runAppState +runRUN appState action' = do + s' <- liftIO appState + flip runReaderT s' . runResourceT . runE @RunEffects + $ action' @@ -212,52 +214,77 @@ run :: forall m. , MonadUnliftIO m ) => RunOptions - -> (forall a. ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a)) + -> IO AppState -> LeanAppState -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode -run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do - toolchain <- Excepts resolveToolchain - tmp <- case runBinDir of - Just bindir -> do - liftIO $ createDirRecursive' bindir - liftIO $ canonicalizePath bindir - Nothing -> do - d <- liftIO $ predictableTmpDir toolchain - liftIO $ createDirRecursive' d - liftIO $ canonicalizePath d - Excepts $ installToolChain toolchain tmp - pure tmp - ) >>= \case - VRight tmp -> do - case runCOMMAND of - [] -> do - liftIO $ putStr tmp - pure ExitSuccess - (cmd:args) -> do - newEnv <- liftIO $ addToPath tmp +run RunOptions{..} runAppState leanAppstate runLogger = do + r <- if or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' + then runRUN runAppState $ do + toolchain <- liftE resolveToolchainFull + tmp <- case runBinDir of + Just bindir -> do + liftIO $ createDirRecursive' bindir + liftIO $ canonicalizePath bindir + Nothing -> do + d <- liftIO $ predictableTmpDir toolchain + liftIO $ createDirRecursive' d + liftIO $ canonicalizePath d + liftE $ installToolChainFull toolchain tmp + pure tmp + else runLeanRUN leanAppstate $ do + toolchain <- resolveToolchain + tmp <- case runBinDir of + Just bindir -> do + liftIO $ createDirRecursive' bindir + liftIO $ canonicalizePath bindir + Nothing -> do + d <- liftIO $ predictableTmpDir toolchain + liftIO $ createDirRecursive' d + liftIO $ canonicalizePath d + liftE $ installToolChain toolchain tmp + pure tmp + case r of + VRight tmp -> do + case runCOMMAND of + [] -> do + liftIO $ putStr tmp + pure ExitSuccess + (cmd:args) -> do + newEnv <- liftIO $ addToPath tmp #ifndef IS_WINDOWS - void $ liftIO $ SPP.executeFile cmd True args (Just newEnv) - pure ExitSuccess + void $ liftIO $ SPP.executeFile cmd True args (Just newEnv) + pure ExitSuccess #else - r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv) - case r' of - VRight _ -> pure ExitSuccess - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 28 + r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv) + case r' of + VRight _ -> pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 28 #endif - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 27 + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 27 + where + isToolTag :: ToolVersion -> Bool isToolTag (ToolTag _) = True isToolTag _ = False -- TODO: doesn't work for cross - resolveToolchain - | or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do + resolveToolchainFull :: ( MonadFail m + , MonadThrow m + , MonadIO m + , MonadCatch m + ) + => Excepts + '[ TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] (ResourceT (ReaderT AppState m)) Toolchain + resolveToolchainFull = do ghcVer <- forM runGHCVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) GHC pure v @@ -271,7 +298,8 @@ run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do (v, _) <- liftE $ fromVersion (Just ver) Stack pure v pure Toolchain{..} - | otherwise = runLeanRUN leanAppstate $ do + + resolveToolchain = do ghcVer <- case runGHCVer of Just (ToolVersion v) -> pure $ Just v Nothing -> pure Nothing @@ -290,8 +318,33 @@ run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do _ -> fail "Internal error" pure Toolchain{..} - installToolChain Toolchain{..} tmp - | or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do + installToolChainFull :: ( MonadFail m + , MonadThrow m + , MonadIO m + , MonadCatch m + ) + => Toolchain + -> FilePath + -> Excepts + '[ TagNotFound + , NextVerNotFound + , NoToolVersionSet + , UnknownArchive + , TarDirDoesNotExist + , ProcessError + , NotInstalled + , NoDownload + , GPGError + , DownloadFailed + , DirNotEmpty + , DigestError + , BuildFailed + , ArchiveResult + , AlreadyInstalled + , FileAlreadyExistsError + , CopyError + ] (ResourceT (ReaderT AppState m)) () + installToolChainFull Toolchain{..} tmp = do forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do isInstalled <- maybe (pure False) (\(tool, v) -> lift $ checkIfToolInstalled' tool v) mt case mt of @@ -320,7 +373,16 @@ run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do False setTool HLS v tmp _ -> pure () - | otherwise = runLeanRUN leanAppstate $ do + + installToolChain :: ( MonadFail m + , MonadThrow m + , MonadIO m + , MonadCatch m + ) + => Toolchain + -> FilePath + -> Excepts '[NotInstalled] (ReaderT LeanAppState m) () + installToolChain Toolchain{..} tmp = do forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do case mt of Just (GHC, v) -> setTool GHC v tmp diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index b4748ee..c52b066 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -315,7 +315,7 @@ Report bugs at |] Nuke -> nuke appState runLogger Prefetch pfCom -> prefetch pfCom runAppState runLogger GC gcOpts -> gc gcOpts runAppState runLogger - Run runCommand -> run runCommand runAppState leanAppstate runLogger + Run runCommand -> run runCommand appState leanAppstate runLogger case res of ExitSuccess -> pure ()