From 2c7176d998c11ee2e74c68128eb28b9aed18f58e Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 18 Jul 2021 14:39:49 +0200 Subject: [PATCH] Use LabelOptic and add LeanAppState Wrt #186 --- app/ghcup/Main.hs | 417 ++++++++++++++++++++------------ lib/GHCup.hs | 285 +++++++++++++++------- lib/GHCup/Types.hs | 14 +- lib/GHCup/Types/Optics.hs | 87 ++++++- lib/GHCup/Utils.hs | 135 ++++++----- lib/GHCup/Utils/Dirs.hs | 13 +- lib/GHCup/Utils/File/Posix.hs | 10 +- lib/GHCup/Utils/File/Windows.hs | 8 +- 8 files changed, 644 insertions(+), 325 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 339d3c0..e43e41e 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -21,6 +21,7 @@ import GHCup.Errors import GHCup.Platform import GHCup.Requirements import GHCup.Types +import GHCup.Types.Optics import GHCup.Utils import GHCup.Utils.File import GHCup.Utils.Logger @@ -66,7 +67,6 @@ import System.Environment import System.Exit import System.FilePath import System.IO hiding ( appendFile ) -import System.IO.Unsafe ( unsafeInterleaveIO ) import Text.Read hiding ( lift ) import Text.PrettyPrint.HughesPJClass ( prettyShow ) import URI.ByteString @@ -942,7 +942,7 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar tagCompleter :: Tool -> [String] -> Completer tagCompleter tool add = listIOCompleter $ do - dirs' <- liftIO getDirs + dirs' <- liftIO getAllDirs let loggerConfig = LoggerConfig { lcPrintDebug = False , colorOutter = mempty @@ -962,7 +962,7 @@ tagCompleter tool add = listIOCompleter $ do versionCompleter :: Maybe ListCriteria -> Tool -> Completer versionCompleter criteria tool = listIOCompleter $ do - dirs' <- liftIO getDirs + dirs' <- liftIO getAllDirs let loggerConfig = LoggerConfig { lcPrintDebug = False , colorOutter = mempty @@ -1167,7 +1167,7 @@ describe_result :: String describe_result = $( LitE . StringL <$> runIO (do CapturedProcess{..} <- do - dirs <- liftIO getDirs + dirs <- liftIO getAllDirs let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings flip runReaderT settings $ executeOut "git" ["describe"] Nothing case _exitCode of @@ -1220,7 +1220,7 @@ Report bugs at |] (footerDoc (Just $ text main_footer)) ) >>= \opt@Options {..} -> do - dirs <- getDirs + dirs@Dirs{..} <- getAllDirs -- create ~/.ghcup dir ensureDirectories dirs @@ -1228,7 +1228,7 @@ Report bugs at |] (settings, keybindings) <- toSettings opt -- logger interpreter - logfile <- initGHCupFileLogging (logsDir dirs) + logfile <- initGHCupFileLogging logsDir let loggerConfig = LoggerConfig { lcPrintDebug = verbose settings , colorOutter = B.hPut stderr @@ -1240,72 +1240,57 @@ Report bugs at |] let runLogger = myLoggerT loggerConfig let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () } - ---------------------------------------- - -- Getting download and platform info -- - ---------------------------------------- - - -- for some commands we want lazy loading - let wrapIO = case optCommand of - Whereis _ _ -> unsafeInterleaveIO - _ -> id - - pfreq <- wrapIO $ ( - runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest - ) >>= \case - VRight r -> pure r - VLeft e -> do - runLogger - ($(logError) $ T.pack $ prettyShow e) - exitWith (ExitFailure 2) - - ghcupInfo <- wrapIO $ - ( runLogger - . runE @'[JSONError , DownloadFailed, FileDoesNotExistError] - $ liftE - $ getDownloadsF settings dirs - ) - >>= \case - VRight r -> pure r - VLeft e -> do - runLogger - ($(logError) $ T.pack $ prettyShow e) - exitWith (ExitFailure 2) - - ------------------------- -- Setting up appstate -- ------------------------- - let appstate@AppState{dirs = Dirs{..} - , ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls, .. } - } = AppState settings dirs keybindings ghcupInfo pfreq + let leanAppstate = LeanAppState settings dirs keybindings + appState = do + pfreq <- ( + runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest + ) >>= \case + VRight r -> pure r + VLeft e -> do + runLogger + ($(logError) $ T.pack $ prettyShow e) + exitWith (ExitFailure 2) + + ghcupInfo <- + ( runLogger + . runE @'[JSONError , DownloadFailed, FileDoesNotExistError] + $ liftE + $ getDownloadsF settings dirs + ) + >>= \case + VRight r -> pure r + VLeft e -> do + runLogger + ($(logError) $ T.pack $ prettyShow e) + exitWith (ExitFailure 2) + let s' = AppState settings dirs keybindings ghcupInfo pfreq + + lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case + Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates + Just _ -> pure () + + -- TODO: always run for windows + (siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case + VRight _ -> pure () + VLeft e -> do + runLogger + ($(logError) $ T.pack $ prettyShow e) + exitWith (ExitFailure 30) + pure s' - --------------------------- - -- Running startup tasks -- - --------------------------- + runLeanAppState = flip runReaderT leanAppstate + runAppState action' = do + s' <- liftIO appState + flip runReaderT s' action' + - case optCommand of - Upgrade _ _ -> pure () - Whereis _ _ -> pure () - _ -> do - lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case - Nothing -> runLogger $ flip runReaderT appstate $ checkForUpdates - Just _ -> pure () - - - -- ensure global tools - case optCommand of - Whereis _ _ -> pure () - _ -> do - (siletRunLogger $ flip runReaderT appstate $ runE ensureGlobalTools) >>= \case - VRight _ -> pure () - VLeft e -> do - runLogger - ($(logError) $ T.pack $ prettyShow e) - exitWith (ExitFailure 30) ------------------------- @@ -1335,12 +1320,25 @@ Report bugs at |] , NoToolVersionSet ] - let runInstTool = runInstTool' appstate + let runInstTool mInstPlatform action' = do + s' <- liftIO appState + runInstTool' s' mInstPlatform action' let + runLeanSetGHC = + runLogger + . runLeanAppState + . runE + @'[ FileDoesNotExistError + , NotInstalled + , TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] + runSetGHC = runLogger - . flip runReaderT appstate + . runAppState . runE @'[ FileDoesNotExistError , NotInstalled @@ -1350,9 +1348,19 @@ Report bugs at |] ] let + runLeanSetCabal = + runLogger + . runLeanAppState + . runE + @'[ NotInstalled + , TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] + runSetCabal = runLogger - . flip runReaderT appstate + . runAppState . runE @'[ NotInstalled , TagNotFound @@ -1363,7 +1371,7 @@ Report bugs at |] let runSetHLS = runLogger - . flip runReaderT appstate + . runAppState . runE @'[ NotInstalled , TagNotFound @@ -1371,20 +1379,30 @@ Report bugs at |] , NoToolVersionSet ] - let runListGHC = runLogger . flip runReaderT appstate + runLeanSetHLS = + runLogger + . runLeanAppState + . runE + @'[ NotInstalled + , TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] + + let runListGHC = runLogger . runAppState let runRm = - runLogger . flip runReaderT appstate . runE @'[NotInstalled] + runLogger . runAppState . runE @'[NotInstalled] let runDebugInfo = runLogger - . flip runReaderT appstate + . runAppState . runE @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] let runCompileGHC = runLogger - . flip runReaderT appstate + . runAppState . runResourceT . runE @'[ AlreadyInstalled @@ -1404,9 +1422,19 @@ Report bugs at |] ] let + runLeanWhereIs = + runLogger + . runLeanAppState + . runE + @'[ NotInstalled + , NoToolVersionSet + , NextVerNotFound + , TagNotFound + ] + runWhereIs = runLogger - . flip runReaderT appstate + . runAppState . runE @'[ NotInstalled , NoToolVersionSet @@ -1416,7 +1444,7 @@ Report bugs at |] let runUpgrade = runLogger - . flip runReaderT appstate + . runAppState . runResourceT . runE @'[ DigestError @@ -1439,13 +1467,15 @@ Report bugs at |] liftE $ installGHCBin (_tvVersion v) when instSet $ void $ liftE $ setGHC v SetGHCOnly pure vi - Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer GHC - liftE $ installGHCBindist - (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") - (_tvVersion v) - when instSet $ void $ liftE $ setGHC v SetGHCOnly - pure vi + Just uri -> do + s' <- liftIO appState + runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer GHC + liftE $ installGHCBindist + (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") + (_tvVersion v) + when instSet $ void $ liftE $ setGHC v SetGHCOnly + pure vi ) >>= \case VRight vi -> do @@ -1477,12 +1507,14 @@ Report bugs at |] (v, vi) <- liftE $ fromVersion instVer Cabal liftE $ installCabalBin (_tvVersion v) pure vi - Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Cabal - liftE $ installCabalBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Cabal + liftE $ installCabalBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + pure vi ) >>= \case VRight vi -> do @@ -1506,12 +1538,14 @@ Report bugs at |] (v, vi) <- liftE $ fromVersion instVer HLS liftE $ installHLSBin (_tvVersion v) pure vi - Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer HLS - liftE $ installHLSBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer HLS + liftE $ installHLSBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + pure vi ) >>= \case VRight vi -> do @@ -1535,12 +1569,14 @@ Report bugs at |] (v, vi) <- liftE $ fromVersion instVer Stack liftE $ installStackBin (_tvVersion v) pure vi - Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do - (v, vi) <- liftE $ fromVersion instVer Stack - liftE $ installStackBindist - (DownloadInfo uri Nothing "") - (_tvVersion v) - pure vi + Just uri -> do + s' <- appState + runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do + (v, vi) <- liftE $ fromVersion instVer Stack + liftE $ installStackBindist + (DownloadInfo uri Nothing "") + (_tvVersion v) + pure vi ) >>= \case VRight vi -> do @@ -1559,11 +1595,13 @@ Report bugs at |] pure $ ExitFailure 4 - let setGHC' SetOptions{..} = - runSetGHC (do - v <- liftE $ fst <$> fromVersion' sToolVer GHC - liftE $ setGHC v SetGHCOnly - ) + let setGHC' SetOptions{ sToolVer } = + case sToolVer of + (SetToolVersion v) -> runLeanSetGHC (liftE $ setGHC v SetGHCOnly >> pure v) + _ -> runSetGHC (do + v <- liftE $ fst <$> fromVersion' sToolVer GHC + liftE $ setGHC v SetGHCOnly + ) >>= \case VRight GHCTargetVersion{..} -> do runLogger @@ -1574,12 +1612,14 @@ Report bugs at |] runLogger $ $(logError) $ T.pack $ prettyShow e pure $ ExitFailure 5 - let setCabal' SetOptions{..} = - runSetCabal (do - v <- liftE $ fst <$> fromVersion' sToolVer Cabal - liftE $ setCabal (_tvVersion v) - pure v - ) + let setCabal' SetOptions{ sToolVer } = + case sToolVer of + (SetToolVersion v) -> runLeanSetCabal (liftE $ setCabal (_tvVersion v) >> pure v) + _ -> runSetCabal (do + v <- liftE $ fst <$> fromVersion' sToolVer Cabal + liftE $ setCabal (_tvVersion v) + pure v + ) >>= \case VRight GHCTargetVersion{..} -> do runLogger @@ -1590,12 +1630,14 @@ Report bugs at |] runLogger $ $(logError) $ T.pack $ prettyShow e pure $ ExitFailure 14 - let setHLS' SetOptions{..} = - runSetHLS (do - v <- liftE $ fst <$> fromVersion' sToolVer HLS - liftE $ setHLS (_tvVersion v) - pure v - ) + let setHLS' SetOptions{ sToolVer } = + case sToolVer of + (SetToolVersion v) -> runLeanSetHLS (liftE $ setHLS (_tvVersion v) >> pure v) + _ -> runSetHLS (do + v <- liftE $ fst <$> fromVersion' sToolVer HLS + liftE $ setHLS (_tvVersion v) + pure v + ) >>= \case VRight GHCTargetVersion{..} -> do runLogger @@ -1606,12 +1648,14 @@ Report bugs at |] runLogger $ $(logError) $ T.pack $ prettyShow e pure $ ExitFailure 14 - let setStack' SetOptions{..} = - runSetCabal (do - v <- liftE $ fst <$> fromVersion' sToolVer Stack - liftE $ setStack (_tvVersion v) - pure v - ) + let setStack' SetOptions{ sToolVer } = + case sToolVer of + (SetToolVersion v) -> runSetCabal (liftE $ setStack (_tvVersion v) >> pure v) + _ -> runSetCabal (do + v <- liftE $ fst <$> fromVersion' sToolVer Stack + liftE $ setStack (_tvVersion v) + pure v + ) >>= \case VRight GHCTargetVersion{..} -> do runLogger @@ -1626,6 +1670,7 @@ Report bugs at |] runRm (do liftE $ rmGHCVer ghcVer + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo pure (getVersionInfo (_tvVersion ghcVer) GHC dls) ) >>= \case @@ -1641,6 +1686,7 @@ Report bugs at |] runRm (do liftE $ rmCabalVer tv + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo pure (getVersionInfo tv Cabal dls) ) >>= \case @@ -1656,6 +1702,7 @@ Report bugs at |] runRm (do liftE $ rmHLSVer tv + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo pure (getVersionInfo tv HLS dls) ) >>= \case @@ -1671,6 +1718,7 @@ Report bugs at |] runRm (do liftE $ rmStackVer tv + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo pure (getVersionInfo tv Stack dls) ) >>= \case @@ -1735,6 +1783,7 @@ Report bugs at |] runCompileGHC (do case targetGhc of Left targetVer -> do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo targetVer GHC dls forM_ (_viPreCompile =<< vi) $ \msg -> do lift $ $(logInfo) msg @@ -1750,6 +1799,7 @@ Report bugs at |] buildConfig patchDir addConfArgs + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo (_tvVersion targetVer) GHC dls when setCompile $ void $ liftE $ setGHC targetVer SetGHCOnly @@ -1777,6 +1827,21 @@ Make sure to clean up #{tmpdir} afterwards.|]) runLogger $ $(logError) $ T.pack $ prettyShow e pure $ ExitFailure 9 + Whereis WhereisOptions{..} (WhereisTool tool (Just (ToolVersion v))) -> + runLeanWhereIs (do + loc <- liftE $ whereIsTool tool v + if directory + then pure $ takeDirectory loc + else pure loc + ) + >>= \case + VRight r -> do + putStr r + pure ExitSuccess + VLeft e -> do + runLogger $ $(logError) $ T.pack $ prettyShow e + pure $ ExitFailure 30 + Whereis WhereisOptions{..} (WhereisTool tool whereVer) -> runWhereIs (do (v, _) <- liftE $ fromVersion whereVer tool @@ -1801,6 +1866,7 @@ Make sure to clean up #{tmpdir} afterwards.|]) runUpgrade (liftE $ upgradeGHCup target force') >>= \case VRight v' -> do + GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo let pretty_v = prettyVer v' let vi = fromJust $ snd <$> getLatest dls GHCup runLogger $ $(logInfo) @@ -1815,23 +1881,26 @@ Make sure to clean up #{tmpdir} afterwards.|]) runLogger $ $(logError) $ T.pack $ prettyShow e pure $ ExitFailure 11 - ToolRequirements -> - flip runReaderT appstate - $ runLogger - (runE - @'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements] - $ do - platform <- liftE getPlatform - req <- getCommonRequirements platform _toolRequirements ?? NoToolRequirements - liftIO $ T.hPutStr stdout (prettyRequirements req) - ) - >>= \case - VRight _ -> pure ExitSuccess - VLeft e -> do - runLogger $ $(logError) $ T.pack $ prettyShow e - pure $ ExitFailure 12 + ToolRequirements -> do + s' <- appState + flip runReaderT s' + $ runLogger + (runE + @'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements] + $ do + GHCupInfo { .. } <- lift getGHCupInfo + platform' <- liftE getPlatform + req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements + liftIO $ T.hPutStr stdout (prettyRequirements req) + ) + >>= \case + VRight _ -> pure ExitSuccess + VLeft e -> do + runLogger $ $(logError) $ T.pack $ prettyShow e + pure $ ExitFailure 12 ChangeLog ChangeLogOptions{..} -> do + GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo let tool = fromMaybe GHC clTool ver' = maybe (Right Latest) @@ -1849,6 +1918,7 @@ Make sure to clean up #{tmpdir} afterwards.|]) ) pure ExitSuccess Just uri -> do + pfreq <- runAppState getPlatformReq let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri cmd = case _rPlatform pfreq of Darwin -> "open" @@ -1857,21 +1927,23 @@ Make sure to clean up #{tmpdir} afterwards.|]) Windows -> "start" if clOpen - then - flip runReaderT appstate $ - exec cmd - [T.unpack $ decUTF8Safe $ serializeURIRef' uri] - Nothing - Nothing - >>= \case - Right _ -> pure ExitSuccess - Left e -> runLogger ($(logError) [i|#{e}|]) - >> pure (ExitFailure 13) + then do + s' <- appState + flip runReaderT s' $ + exec cmd + [T.unpack $ decUTF8Safe $ serializeURIRef' uri] + Nothing + Nothing + >>= \case + Right _ -> pure ExitSuccess + Left e -> runLogger ($(logError) [i|#{e}|]) + >> pure (ExitFailure 13) else putStrLn uri' >> pure ExitSuccess Nuke -> runRm (do - void $ liftIO $ evaluate $ force appstate + s' <- liftIO appState + void $ liftIO $ evaluate $ force s' lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system." lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time." liftIO $ threadDelay 10000000 -- wait 10s @@ -1907,22 +1979,46 @@ Make sure to clean up #{tmpdir} afterwards.|]) pure () -fromVersion :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m) +fromVersion :: ( MonadLogger m + , MonadFail m + , MonadReader env m + , HasGHCupInfo env + , HasDirs env + , MonadThrow m + , MonadIO m + , MonadCatch m + ) => Maybe ToolVersion -> Tool - -> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo) + -> Excepts + '[ TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] m (GHCTargetVersion, Maybe VersionInfo) fromVersion tv = fromVersion' (toSetToolVer tv) -fromVersion' :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m) +fromVersion' :: ( MonadLogger m + , MonadFail m + , MonadReader env m + , HasGHCupInfo env + , HasDirs env + , MonadThrow m + , MonadIO m + , MonadCatch m + ) => SetToolVersion -> Tool - -> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo) + -> Excepts + '[ TagNotFound + , NextVerNotFound + , NoToolVersionSet + ] m (GHCTargetVersion, Maybe VersionInfo) fromVersion' SetRecommended tool = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool fromVersion' (SetToolVersion v) tool = do - ~AppState { ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls }} <- lift ask + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo (_tvVersion v) tool dls case pvp $ prettyVer (_tvVersion v) of Left _ -> pure (v, vi) @@ -1932,16 +2028,16 @@ fromVersion' (SetToolVersion v) tool = do Nothing -> pure (v, vi) Right _ -> pure (v, vi) fromVersion' (SetToolTag Latest) tool = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo (\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool fromVersion' (SetToolTag Recommended) tool = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool fromVersion' (SetToolTag (Base pvp'')) GHC = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo (\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC fromVersion' SetNext tool = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo next <- case tool of GHC -> do set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool @@ -2142,7 +2238,10 @@ printListResult raw lr = do | otherwise -> 1 -checkForUpdates :: ( MonadReader AppState m +checkForUpdates :: ( MonadReader env m + , HasGHCupInfo env + , HasDirs env + , HasPlatformReq env , MonadCatch m , MonadLogger m , MonadThrow m @@ -2152,7 +2251,7 @@ checkForUpdates :: ( MonadReader AppState m ) => m () checkForUpdates = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo lInstalled <- listVersions Nothing (Just ListInstalled) let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 943370b..4a8b248 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -106,7 +106,10 @@ import Control.Concurrent (threadDelay) installGHCBindist :: ( MonadFail m , MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env , MonadLogger m , MonadResource m , MonadIO m @@ -130,7 +133,8 @@ installGHCBindist :: ( MonadFail m m () installGHCBindist dlinfo ver = do - AppState { dirs , settings } <- lift ask + dirs <- lift getDirs + settings <- lift getSettings let tver = mkTVer ver lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] @@ -163,7 +167,10 @@ installGHCBindist dlinfo ver = do -- build system and nothing else. installPackedGHC :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasSettings env , MonadThrow m , MonadLogger m , MonadIO m @@ -182,7 +189,7 @@ installPackedGHC :: ( MonadMask m #endif ] m () installPackedGHC dl msubdir inst ver = do - AppState { pfreq = PlatformRequest {..} } <- lift ask + PlatformRequest {..} <- lift getPlatformReq -- unpack tmpUnpack <- lift mkGhcupTmpDir @@ -201,7 +208,10 @@ installPackedGHC dl msubdir inst ver = do -- | Install an unpacked GHC distribution. This only deals with the GHC -- build system and nothing else. -installUnpackedGHC :: ( MonadReader AppState m +installUnpackedGHC :: ( MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env , MonadThrow m , MonadLogger m , MonadIO m @@ -218,7 +228,7 @@ installUnpackedGHC path inst _ = do liftIO $ copyDirectoryRecursive path inst #else installUnpackedGHC path inst ver = do - AppState { pfreq = PlatformRequest {..} } <- lift ask + PlatformRequest {..} <- lift getPlatformReq let alpineArgs | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform @@ -250,7 +260,11 @@ installUnpackedGHC path inst ver = do installGHCBin :: ( MonadFail m , MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env , MonadLogger m , MonadResource m , MonadIO m @@ -273,8 +287,8 @@ installGHCBin :: ( MonadFail m m () installGHCBin ver = do - AppState { pfreq - , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + pfreq <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo dlinfo <- lE $ getDownloadInfo GHC ver pfreq dls installGHCBindist dlinfo ver @@ -283,7 +297,10 @@ installGHCBin ver = do -- argument instead of looking it up from 'GHCupDownloads'. installCabalBindist :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env , MonadLogger m , MonadResource m , MonadIO m @@ -310,9 +327,9 @@ installCabalBindist :: ( MonadMask m installCabalBindist dlinfo ver = do lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] - AppState { dirs = dirs@Dirs {..} - , pfreq = PlatformRequest {..} - , settings } <- lift ask + PlatformRequest {..} <- lift getPlatformReq + dirs@Dirs {..} <- lift getDirs + settings <- lift getSettings whenM (lift (cabalInstalled ver) >>= \a -> liftIO $ @@ -364,7 +381,11 @@ installCabalBindist dlinfo ver = do -- the latest installed version. installCabalBin :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env , MonadLogger m , MonadResource m , MonadIO m @@ -388,8 +409,9 @@ installCabalBin :: ( MonadMask m m () installCabalBin ver = do - AppState { pfreq - , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + pfreq <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + dlinfo <- lE $ getDownloadInfo Cabal ver pfreq dls installCabalBindist dlinfo ver @@ -398,7 +420,10 @@ installCabalBin ver = do -- argument instead of looking it up from 'GHCupDownloads'. installHLSBindist :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env , MonadLogger m , MonadResource m , MonadIO m @@ -425,9 +450,9 @@ installHLSBindist :: ( MonadMask m installHLSBindist dlinfo ver = do lift $ $(logDebug) [i|Requested to install hls version #{ver}|] - AppState { dirs = dirs@Dirs {..} - , pfreq = PlatformRequest {..} - , settings } <- lift ask + PlatformRequest {..} <- lift getPlatformReq + dirs@Dirs {..} <- lift getDirs + settings <- lift getSettings whenM (lift (hlsInstalled ver)) (throwE $ AlreadyInstalled HLS ver) @@ -488,7 +513,11 @@ installHLSBindist dlinfo ver = do -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. installHLSBin :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env , MonadLogger m , MonadResource m , MonadIO m @@ -512,8 +541,9 @@ installHLSBin :: ( MonadMask m m () installHLSBin ver = do - AppState { pfreq - , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + pfreq <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + dlinfo <- lE $ getDownloadInfo HLS ver pfreq dls installHLSBindist dlinfo ver @@ -523,7 +553,11 @@ installHLSBin ver = do -- the latest installed version. installStackBin :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env , MonadLogger m , MonadResource m , MonadIO m @@ -547,7 +581,9 @@ installStackBin :: ( MonadMask m m () installStackBin ver = do - AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask + pfreq <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + dlinfo <- lE $ getDownloadInfo Stack ver pfreq dls installStackBindist dlinfo ver @@ -556,7 +592,10 @@ installStackBin ver = do -- argument instead of looking it up from 'GHCupDownloads'. installStackBindist :: ( MonadMask m , MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env , MonadLogger m , MonadResource m , MonadIO m @@ -583,10 +622,9 @@ installStackBindist :: ( MonadMask m installStackBindist dlinfo ver = do lift $ $(logDebug) [i|Requested to install stack version #{ver}|] - AppState { dirs = dirs@Dirs {..} - , pfreq = PlatformRequest {..} - , settings - } <- lift ask + PlatformRequest {..} <- lift getPlatformReq + dirs@Dirs {..} <- lift getDirs + settings <- lift getSettings whenM (lift (stackInstalled ver)) (throwE $ AlreadyInstalled Stack ver) @@ -644,7 +682,8 @@ installStackBindist dlinfo ver = do -- -- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\\/share symlink@ -- for 'SetGHCOnly' constructor. -setGHC :: ( MonadReader AppState m +setGHC :: ( MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -663,7 +702,7 @@ setGHC ver sghc = do whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver)) -- symlink destination - AppState { dirs = Dirs {..} } <- lift ask + Dirs {..} <- lift getDirs -- first delete the old symlinks (this fixes compatibility issues -- with old ghcup) @@ -701,12 +740,15 @@ setGHC ver sghc = do where - symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m) + symlinkShareDir :: ( MonadReader env m + , HasDirs env + , MonadIO m + , MonadLogger m) => FilePath -> String -> m () symlinkShareDir ghcdir ver' = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs let destdir = baseDir case sghc of SetGHCOnly -> do @@ -733,7 +775,8 @@ setGHC ver sghc = do -- | Set the @~\/.ghcup\/bin\/cabal@ symlink. setCabal :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -745,7 +788,7 @@ setCabal ver = do let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt -- symlink destination - AppState {dirs = Dirs {..}} <- lift ask + Dirs {..} <- lift getDirs whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) $ throwE @@ -764,7 +807,8 @@ setCabal ver = do -- | Set the haskell-language-server symlinks. setHLS :: ( MonadCatch m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -775,7 +819,7 @@ setHLS :: ( MonadCatch m => Version -> Excepts '[NotInstalled] m () setHLS ver = do - AppState { dirs = Dirs {..} } <- lift ask + Dirs {..} <- lift getDirs -- Delete old symlinks, since these might have different ghc versions than the -- selected version, so we could end up with stray or incorrect symlinks. @@ -804,7 +848,8 @@ setHLS ver = do -- | Set the @~\/.ghcup\/bin\/stack@ symlink. setStack :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -817,7 +862,7 @@ setStack ver = do let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt -- symlink destination - AppState {dirs = Dirs {..}} <- lift ask + Dirs {..} <- lift getDirs whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) $ throwE @@ -872,7 +917,10 @@ listVersions :: ( MonadCatch m , MonadThrow m , MonadLogger m , MonadIO m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasGHCupInfo env ) => Maybe Tool -> Maybe ListCriteria @@ -891,7 +939,7 @@ listVersions lt' criteria = do go lt cSet cabals hlsSet' hlses sSet stacks = do case lt of Just t -> do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo -- get versions from GHCupDownloads let avTools = availableToolVersions dls t lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks) @@ -917,7 +965,13 @@ listVersions lt' criteria = do ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers) - strayGHCs :: (MonadCatch m, MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m) + strayGHCs :: ( MonadCatch m + , MonadReader env m + , HasDirs env + , MonadThrow m + , MonadLogger m + , MonadIO m + ) => Map.Map Version [Tag] -> m [ListResult] strayGHCs avTools = do @@ -959,7 +1013,13 @@ listVersions lt' criteria = do [i|Could not parse version of stray directory #{e}|] pure Nothing - strayCabals :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) + strayCabals :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , MonadLogger m + , MonadIO m + ) => Map.Map Version [Tag] -> Maybe Version -> [Either FilePath Version] @@ -988,7 +1048,12 @@ listVersions lt' criteria = do [i|Could not parse version of stray directory #{e}|] pure Nothing - strayHLS :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) + strayHLS :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , MonadLogger m + , MonadIO m) => Map.Map Version [Tag] -> m [ListResult] strayHLS avTools = do @@ -1016,7 +1081,13 @@ listVersions lt' criteria = do [i|Could not parse version of stray directory #{e}|] pure Nothing - strayStacks :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) + strayStacks :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , MonadLogger m + , MonadIO m + ) => Map.Map Version [Tag] -> m [ListResult] strayStacks avTools = do @@ -1045,7 +1116,14 @@ listVersions lt' criteria = do pure Nothing -- NOTE: this are not cross ones, because no bindists - toListResult :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m) + toListResult :: ( MonadLogger m + , MonadReader env m + , HasDirs env + , HasGHCupInfo env + , HasPlatformReq env + , MonadIO m + , MonadCatch m + ) => Tool -> Maybe Version -> [Either FilePath Version] @@ -1056,8 +1134,8 @@ listVersions lt' criteria = do -> (Version, [Tag]) -> m ListResult toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = do - AppState { pfreq - , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + pfreq <- getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo case t of GHC -> do @@ -1140,7 +1218,8 @@ listVersions lt' criteria = do -- This may leave GHCup without a "set" version. -- Will try to fix the ghc-x.y symlink after removal (e.g. to an -- older version). -rmGHCVer :: ( MonadReader AppState m +rmGHCVer :: ( MonadReader env m + , HasDirs env , MonadThrow m , MonadLogger m , MonadIO m @@ -1181,7 +1260,7 @@ rmGHCVer ver = do forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver)) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) - AppState { dirs = Dirs {..} } <- lift ask + Dirs {..} <- lift getDirs liftIO $ hideError doesNotExistErrorType @@ -1191,7 +1270,8 @@ rmGHCVer ver = do -- | Delete a cabal version. Will try to fix the @cabal@ symlink -- after removal (e.g. setting it to an older version). rmCabalVer :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadThrow m , MonadLogger m , MonadIO m @@ -1206,7 +1286,7 @@ rmCabalVer ver = do cSet <- lift cabalSet - AppState {dirs = Dirs {..}} <- lift ask + Dirs {..} <- lift getDirs let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt liftIO $ hideError doesNotExistErrorType $ rmFile (binDir cabalFile) @@ -1221,7 +1301,8 @@ rmCabalVer ver = do -- | Delete a hls version. Will try to fix the hls symlinks -- after removal (e.g. setting it to an older version). rmHLSVer :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadThrow m , MonadLogger m , MonadIO m @@ -1236,7 +1317,7 @@ rmHLSVer ver = do isHlsSet <- lift hlsSet - AppState {dirs = Dirs {..}} <- lift ask + Dirs {..} <- lift getDirs bins <- lift $ hlsAllBinaries ver forM_ bins $ \f -> liftIO $ rmFile (binDir f) @@ -1258,7 +1339,8 @@ rmHLSVer ver = do -- | Delete a stack version. Will try to fix the @stack@ symlink -- after removal (e.g. setting it to an older version). rmStackVer :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadThrow m , MonadLogger m , MonadIO m @@ -1273,7 +1355,7 @@ rmStackVer ver = do sSet <- lift stackSet - AppState {dirs = Dirs {..}} <- lift ask + Dirs {..} <- lift getDirs let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt liftIO $ hideError doesNotExistErrorType $ rmFile (binDir stackFile) @@ -1286,15 +1368,15 @@ rmStackVer ver = do -- assuming the current scheme of having just 1 ghcup bin, no version info is required. -rmGhcup :: ( MonadReader AppState m +rmGhcup :: ( MonadReader env m + , HasDirs env , MonadIO m , MonadCatch m , MonadLogger m ) => m () - rmGhcup = do - AppState {dirs = Dirs {binDir}} <- ask + Dirs {binDir} <- getDirs let ghcupFilename = "ghcup" <> exeExt let ghcupFilepath = binDir ghcupFilename @@ -1338,14 +1420,14 @@ rmGhcup = do <> path <> "\n you may have to uninstall it manually." -rmTool :: ( MonadReader AppState m - , MonadLogger m - , MonadFail m - , MonadMask m - , MonadUnliftIO m) - => ListResult - -> Excepts '[NotInstalled ] m () - +rmTool :: ( MonadReader env m + , HasDirs env + , MonadLogger m + , MonadFail m + , MonadMask m + , MonadUnliftIO m) + => ListResult + -> Excepts '[NotInstalled ] m () rmTool ListResult {lVer, lTool, lCross} = do case lTool of GHC -> @@ -1357,7 +1439,8 @@ rmTool ListResult {lVer, lTool, lCross} = do GHCup -> lift rmGhcup -rmGhcupDirs :: ( MonadReader AppState m +rmGhcupDirs :: ( MonadReader env m + , HasDirs env , MonadIO m , MonadLogger m , MonadCatch m @@ -1369,7 +1452,7 @@ rmGhcupDirs = do , binDir , logsDir , cacheDir - } <- asks dirs + } <- getDirs let envFilePath = baseDir "env" @@ -1477,13 +1560,20 @@ rmGhcupDirs = do ------------------ -getDebugInfo :: (Alternative m, MonadFail m, MonadReader AppState m, MonadLogger m, MonadCatch m, MonadIO m) +getDebugInfo :: ( Alternative m + , MonadFail m + , MonadReader env m + , HasDirs env + , MonadLogger m + , MonadCatch m + , MonadIO m + ) => Excepts '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] m DebugInfo getDebugInfo = do - AppState {dirs = Dirs {..}} <- lift ask + Dirs {..} <- lift getDirs let diBaseDir = baseDir let diBinDir = binDir diGHCDir <- lift ghcupGHCBaseDir @@ -1503,7 +1593,11 @@ getDebugInfo = do -- | Compile a GHC from source. This behaves wrt symlinks and installation -- the same as 'installGHCBin'. compileGHC :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasGHCupInfo env + , HasSettings env , MonadThrow m , MonadResource m , MonadLogger m @@ -1538,10 +1632,11 @@ compileGHC :: ( MonadMask m GHCTargetVersion compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs = do - AppState { pfreq = PlatformRequest {..} - , ghcupInfo = GHCupInfo { _ghcupDownloads = dls } - , settings - , dirs } <- lift ask + PlatformRequest { .. } <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + settings <- lift getSettings + dirs <- lift getDirs + (workdir, tmpUnpack, tver) <- case targetGhc of -- unpack from version tarball Left tver -> do @@ -1662,7 +1757,10 @@ BUILD_SPHINX_HTML = NO BUILD_SPHINX_PDF = NO HADDOCK_DOCS = YES|] - compileBindist :: ( MonadReader AppState m + compileBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env , MonadThrow m , MonadCatch m , MonadLogger m @@ -1680,8 +1778,9 @@ HADDOCK_DOCS = YES|] compileBindist bghc tver workdir ghcdir = do lift $ $(logInfo) [i|configuring build|] liftE checkBuildConfig - - AppState { dirs = Dirs {..}, pfreq } <- lift ask + + Dirs {..} <- lift getDirs + pfreq <- lift getPlatformReq forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir @@ -1805,7 +1904,11 @@ HADDOCK_DOCS = YES|] -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@, -- if no path is provided. upgradeGHCup :: ( MonadMask m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasGHCupInfo env + , HasSettings env , MonadCatch m , MonadLogger m , MonadThrow m @@ -1826,10 +1929,11 @@ upgradeGHCup :: ( MonadMask m m Version upgradeGHCup mtarget force' = do - AppState { dirs = Dirs {..} - , pfreq - , ghcupInfo = GHCupInfo { _ghcupDownloads = dls } - , settings } <- lift ask + Dirs {..} <- lift getDirs + pfreq <- lift getPlatformReq + settings <- lift getSettings + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + lift $ $(logInfo) [i|Upgrading GHCup...|] let latestVer = fromJust $ fst <$> getLatest dls GHCup when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate @@ -1878,7 +1982,8 @@ upgradeGHCup mtarget force' = do -- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for -- both installing from source and bindist. -postGHCInstall :: ( MonadReader AppState m +postGHCInstall :: ( MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -1909,7 +2014,8 @@ postGHCInstall ver@GHCTargetVersion {..} = do -- * for hls, this reports @~\/.ghcup\/bin\/haskell-language-server-wrapper-\@ -- * for stack, this reports @~\/.ghcup\/bin\/stack-\@ -- * for ghcup, this reports the location of the currently running executable -whereIsTool :: ( MonadReader AppState m +whereIsTool :: ( MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -1922,7 +2028,7 @@ whereIsTool :: ( MonadReader AppState m -> GHCTargetVersion -> Excepts '[NotInstalled] m FilePath whereIsTool tool ver@GHCTargetVersion {..} = do - AppState { dirs } <- lift ask + dirs <- lift getDirs case tool of GHC -> do @@ -1946,3 +2052,6 @@ whereIsTool tool ver@GHCTargetVersion {..} = do GHCup -> do currentRunningExecPath <- liftIO getExecutablePath liftIO $ canonicalizePath currentRunningExecPath + + + diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 65c7ed0..98ab2af 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -1,9 +1,12 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DuplicateRecordFields #-} {-| Module : GHCup.Types @@ -346,8 +349,14 @@ data AppState = AppState { settings :: Settings , dirs :: Dirs , keyBindings :: KeyBindings - , ghcupInfo :: ~GHCupInfo - , pfreq :: ~PlatformRequest + , ghcupInfo :: GHCupInfo + , pfreq :: PlatformRequest + } deriving (Show, GHC.Generic) + +data LeanAppState = LeanAppState + { settings :: Settings + , dirs :: Dirs + , keyBindings :: KeyBindings } deriving (Show, GHC.Generic) instance NFData AppState @@ -507,4 +516,3 @@ instance (Monad m, Alternative m) => Alternative (LoggingT m) where instance MonadLogger m => MonadLogger (Excepts e m) where monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d - diff --git a/lib/GHCup/Types/Optics.hs b/lib/GHCup/Types/Optics.hs index d971ccd..320e54b 100644 --- a/lib/GHCup/Types/Optics.hs +++ b/lib/GHCup/Types/Optics.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-| Module : GHCup.Types.Optics @@ -13,6 +18,7 @@ module GHCup.Types.Optics where import GHCup.Types +import Control.Monad.Reader import Data.ByteString ( ByteString ) import Optics import URI.ByteString @@ -58,3 +64,82 @@ pathL' = lensVL pathL queryL' :: Lens' (URIRef a) Query queryL' = lensVL queryL + + + + ---------------------- + --[ Lens utilities ]-- + ---------------------- + + +gets :: forall f a env m . (MonadReader env m, LabelOptic' f A_Lens env a) + => m a +gets = asks (^. labelOptic @f) + + +getAppState :: MonadReader AppState m => m AppState +getAppState = ask + + +getLeanAppState :: ( MonadReader env m + , LabelOptic' "settings" A_Lens env Settings + , LabelOptic' "dirs" A_Lens env Dirs + , LabelOptic' "keyBindings" A_Lens env KeyBindings + ) + => m LeanAppState +getLeanAppState = do + s <- gets @"settings" + d <- gets @"dirs" + k <- gets @"keyBindings" + pure (LeanAppState s d k) + + +getSettings :: ( MonadReader env m + , LabelOptic' "settings" A_Lens env Settings + ) + => m Settings +getSettings = gets @"settings" + + +getDirs :: ( MonadReader env m + , LabelOptic' "dirs" A_Lens env Dirs + ) + => m Dirs +getDirs = gets @"dirs" + + +getKeyBindings :: ( MonadReader env m + , LabelOptic' "keyBindings" A_Lens env KeyBindings + ) + => m KeyBindings +getKeyBindings = gets @"keyBindings" + + +getGHCupInfo :: ( MonadReader env m + , LabelOptic' "ghcupInfo" A_Lens env GHCupInfo + ) + => m GHCupInfo +getGHCupInfo = gets @"ghcupInfo" + + +getPlatformReq :: ( MonadReader env m + , LabelOptic' "pfreq" A_Lens env PlatformRequest + ) + => m PlatformRequest +getPlatformReq = gets @"pfreq" + + +type HasSettings env = (LabelOptic' "settings" A_Lens env Settings) +type HasDirs env = (LabelOptic' "dirs" A_Lens env Dirs) +type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings) +type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo) +type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest) + + +getCache :: (MonadReader env m, HasSettings env) => m Bool +getCache = getSettings <&> cache + + +getDownloader :: (MonadReader env m, HasSettings env) => m Downloader +getDownloader = getSettings <&> downloader + diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index c4fa5a5..c8885c3 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -103,28 +103,30 @@ import qualified Text.Megaparsec as MP -- | The symlink destination of a ghc tool. -ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m) +ghcLinkDestination :: ( MonadReader env m + , HasDirs env + , MonadThrow m, MonadIO m) => FilePath -- ^ the tool, such as 'ghc', 'haddock' etc. -> GHCTargetVersion -> m FilePath ghcLinkDestination tool ver = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs ghcd <- ghcupGHCDir ver pure (relativeSymlink binDir (ghcd "bin" tool)) -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5. -rmMinorSymlinks :: ( MonadReader AppState m +rmMinorSymlinks :: ( MonadReader env m + , HasDirs env , MonadIO m , MonadLogger m , MonadThrow m , MonadFail m - , MonadReader AppState m ) => GHCTargetVersion -> Excepts '[NotInstalled] m () rmMinorSymlinks tv@GHCTargetVersion{..} = do - AppState { dirs = Dirs {..} } <- lift ask + Dirs {..} <- lift getDirs files <- liftE $ ghcToolFiles tv forM_ files $ \f -> do @@ -135,7 +137,8 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do -- | Removes the set ghc version for the given target, if any. -rmPlain :: ( MonadReader AppState m +rmPlain :: ( MonadReader env m + , HasDirs env , MonadLogger m , MonadThrow m , MonadFail m @@ -144,7 +147,7 @@ rmPlain :: ( MonadReader AppState m => Maybe Text -- ^ target -> Excepts '[NotInstalled] m () rmPlain target = do - AppState { dirs = Dirs {..} } <- lift ask + Dirs {..} <- lift getDirs mtv <- lift $ ghcSet target forM_ mtv $ \tv -> do files <- liftE $ ghcToolFiles tv @@ -159,17 +162,17 @@ rmPlain target = do -- | Remove the major GHC symlink, e.g. ghc-8.6. -rmMajorSymlinks :: ( MonadReader AppState m +rmMajorSymlinks :: ( MonadReader env m + , HasDirs env , MonadIO m , MonadLogger m , MonadThrow m , MonadFail m - , MonadReader AppState m ) => GHCTargetVersion -> Excepts '[NotInstalled] m () rmMajorSymlinks tv@GHCTargetVersion{..} = do - AppState { dirs = Dirs {..} } <- lift ask + Dirs {..} <- lift getDirs (mj, mi) <- getMajorMinorV _tvVersion let v' = intToText mj <> "." <> intToText mi @@ -189,26 +192,26 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do -- | Whether the given GHC versin is installed. -ghcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool +ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcInstalled ver = do ghcdir <- ghcupGHCDir ver liftIO $ doesDirectoryExist ghcdir -- | Whether the given GHC version is installed from source. -ghcSrcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool +ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcSrcInstalled ver = do ghcdir <- ghcupGHCDir ver liftIO $ doesFileExist (ghcdir ghcUpSrcBuiltFile) -- | Whether the given GHC version is set as the current. -ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m) +ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) => Maybe Text -- ^ the target of the GHC version, if any -- (e.g. armv7-unknown-linux-gnueabihf) -> m (Maybe GHCTargetVersion) ghcSet mtarget = do - AppState {dirs = Dirs {..}} <- ask + Dirs {..} <- getDirs let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget let ghcBin = binDir ghc <> exeExt @@ -239,7 +242,7 @@ ghcSet mtarget = do -- | Get all installed GHCs by reading ~/.ghcup/ghc/. -- If a dir cannot be parsed, returns left. -getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either FilePath GHCTargetVersion] +getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion] getInstalledGHCs = do ghcdir <- ghcupGHCBaseDir fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir @@ -249,10 +252,15 @@ getInstalledGHCs = do -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@. -getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m) +getInstalledCabals :: ( MonadLogger m + , MonadReader env m + , HasDirs env + , MonadIO m + , MonadCatch m + ) => m [Either FilePath Version] getInstalledCabals = do - AppState {dirs = Dirs {..}} <- ask + Dirs {..} <- getDirs bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString)) @@ -264,16 +272,16 @@ getInstalledCabals = do -- | Whether the given cabal version is installed. -cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool +cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool cabalInstalled ver = do vers <- fmap rights getInstalledCabals pure $ elem ver vers -- Return the currently set cabal version, if any. -cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) +cabalSet :: (MonadLogger m, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) cabalSet = do - AppState {dirs = Dirs {..}} <- ask + Dirs {..} <- getDirs let cabalbin = binDir "cabal" <> exeExt handleIO' NoSuchThing (\_ -> pure Nothing) $ do @@ -317,10 +325,10 @@ cabalSet = do -- | Get all installed hls, by matching on -- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@. -getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m) +getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [Either FilePath Version] getInstalledHLSs = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended @@ -337,10 +345,10 @@ getInstalledHLSs = do -- | Get all installed stacks, by matching on -- @~\/.ghcup\/bin/stack-<\stackver\>@. -getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m) +getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [Either FilePath Version] getInstalledStacks = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended @@ -355,9 +363,9 @@ getInstalledStacks = do -- Return the currently set stack version, if any. -- TODO: there's a lot of code duplication here :> -stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version) +stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version) stackSet = do - AppState {dirs = Dirs {..}} <- ask + Dirs {..} <- getDirs let stackBin = binDir "stack" <> exeExt handleIO' NoSuchThing (\_ -> pure Nothing) $ do @@ -395,13 +403,13 @@ stackSet = do stripRelativePath = MP.many (MP.try stripPathComponet) -- | Whether the given Stack version is installed. -stackInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool +stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool stackInstalled ver = do vers <- fmap rights getInstalledStacks pure $ elem ver vers -- | Whether the given HLS version is installed. -hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool +hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool hlsInstalled ver = do vers <- fmap rights getInstalledHLSs pure $ elem ver vers @@ -409,9 +417,9 @@ hlsInstalled ver = do -- Return the currently set hls version, if any. -hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) +hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) hlsSet = do - AppState {dirs = Dirs {..}} <- ask + Dirs {..} <- getDirs let hlsBin = binDir "haskell-language-server-wrapper" <> exeExt liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do @@ -443,7 +451,8 @@ hlsSet = do -- | Return the GHC versions the currently selected HLS supports. -hlsGHCVersions :: ( MonadReader AppState m +hlsGHCVersions :: ( MonadReader env m + , HasDirs env , MonadIO m , MonadThrow m , MonadCatch m @@ -466,11 +475,11 @@ hlsGHCVersions = do -- | Get all server binaries for an hls version, if any. -hlsServerBinaries :: (MonadReader AppState m, MonadIO m) +hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m) => Version -> m [FilePath] hlsServerBinaries ver = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts @@ -482,12 +491,12 @@ hlsServerBinaries ver = do -- | Get the wrapper binary for an hls version, if any. -hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m) +hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) => Version -> m (Maybe FilePath) hlsWrapperBinary ver = do - AppState { dirs = Dirs {..} } <- ask - wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles + Dirs {..} <- getDirs + wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended @@ -503,7 +512,7 @@ hlsWrapperBinary ver = do -- | Get all binaries for an hls version, if any. -hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [FilePath] +hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath] hlsAllBinaries ver = do hls <- hlsServerBinaries ver wrapper <- hlsWrapperBinary ver @@ -511,9 +520,9 @@ hlsAllBinaries ver = do -- | Get the active symlinks for hls. -hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [FilePath] +hlsSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [FilePath] hlsSymlinks = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended @@ -549,7 +558,7 @@ matchMajor v' major' minor' = case getMajorMinorV v' of -- | Get the latest installed full GHC version that satisfies X.Y. -- This reads `ghcupGHCBaseDir`. -getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m) +getGHCForMajor :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Int -- ^ major version component -> Int -- ^ minor version component -> Maybe Text -- ^ the target triple @@ -729,19 +738,6 @@ getLatestBaseVersion av pvpVer = - ----------------------- - --[ AppState Getter ]-- - ----------------------- - - -getCache :: MonadReader AppState m => m Bool -getCache = ask <&> cache . settings - - -getDownloader :: MonadReader AppState m => m Downloader -getDownloader = ask <&> downloader . settings - - ------------- --[ Other ]-- @@ -754,7 +750,7 @@ getDownloader = ask <&> downloader . settings -- Returns unversioned relative files without extension, e.g.: -- -- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@ -ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m) +ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m) => GHCTargetVersion -> Excepts '[NotInstalled] m [FilePath] ghcToolFiles ver = do @@ -817,7 +813,12 @@ ghcUpSrcBuiltFile = ".ghcup_src_built" -- | Calls gmake if it exists in PATH, otherwise make. -make :: (MonadThrow m, MonadIO m, MonadReader AppState m) +make :: ( MonadThrow m + , MonadIO m + , MonadReader env m + , HasDirs env + , HasSettings env + ) => [String] -> Maybe FilePath -> m (Either ProcessError ()) @@ -827,7 +828,7 @@ make args workdir = do let mymake = if has_gmake then "gmake" else "make" execLogged mymake args workdir "ghc-make" Nothing -makeOut :: (MonadReader AppState m, MonadIO m) +makeOut :: (MonadReader env m, HasDirs env, MonadIO m) => [String] -> Maybe FilePath -> m CapturedProcess @@ -840,7 +841,7 @@ makeOut args workdir = do -- | Try to apply patches in order. Fails with 'PatchFailed' -- on first failure. -applyPatches :: (MonadReader AppState m, MonadLogger m, MonadIO m) +applyPatches :: (MonadReader env m, HasDirs env, MonadLogger m, MonadIO m) => FilePath -- ^ dir containing patches -> FilePath -- ^ dir to apply patches in -> Excepts '[PatchFailed] m () @@ -858,7 +859,7 @@ applyPatches pdir ddir = do -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353 -darwinNotarization :: (MonadReader AppState m, MonadIO m) +darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m) => Platform -> FilePath -> m (Either ProcessError ()) @@ -881,13 +882,13 @@ getChangeLog dls tool (Right tag) = -- -- 1. the build directory, depending on the KeepDirs setting -- 2. the install destination, depending on whether the build failed -runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m) +runBuildAction :: (Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m) => FilePath -- ^ build directory (cleaned up depending on Settings) -> Maybe FilePath -- ^ dir to *always* clean up on exception -> Excepts e m a -> Excepts '[BuildFailed] m a runBuildAction bdir instdir action = do - AppState { settings = Settings {..} } <- lift ask + Settings {..} <- lift getSettings let exAction = do forM_ instdir $ \dir -> liftIO $ hideError doesNotExistErrorType $ rmPath dir @@ -1016,7 +1017,8 @@ createLink :: ( MonadMask m , MonadThrow m , MonadLogger m , MonadIO m - , MonadReader AppState m + , MonadReader env m + , HasDirs env , MonadUnliftIO m , MonadFail m ) @@ -1025,7 +1027,7 @@ createLink :: ( MonadMask m -> m () createLink link exe = do #if defined(IS_WINDOWS) - AppState { dirs } <- ask + dirs <- getDirs let shimGen = cacheDir dirs "gs.exe" let shim = dropExtension exe <.> "shim" @@ -1054,14 +1056,19 @@ ensureGlobalTools :: ( MonadMask m , MonadThrow m , MonadLogger m , MonadIO m - , MonadReader AppState m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasGHCupInfo env , MonadUnliftIO m , MonadFail m ) => Excepts '[DigestError , DownloadFailed, NoDownload] m () ensureGlobalTools = do #if defined(IS_WINDOWS) - AppState { ghcupInfo = GHCupInfo _ _ gTools, settings, dirs } <- lift ask + (GHCupInfo _ _ gTools) <- lift getGHCupInfo + settings <- lift getSettings + dirs <- lift getDirs shimDownload <- liftE $ lE @_ @'[NoDownload] $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools let dl = downloadCached' settings dirs shimDownload (Just "gs.exe") diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index ec680e7..807bcc4 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -16,7 +16,7 @@ Stability : experimental Portability : portable -} module GHCup.Utils.Dirs - ( getDirs + ( getAllDirs , ghcupBaseDir , ghcupConfigFile , ghcupCacheDir @@ -37,6 +37,7 @@ where import GHCup.Errors import GHCup.Types import GHCup.Types.JSON ( ) +import GHCup.Types.Optics import GHCup.Utils.MegaParsec import GHCup.Utils.Prelude @@ -190,8 +191,8 @@ ghcupLogsDir = do #endif -getDirs :: IO Dirs -getDirs = do +getAllDirs :: IO Dirs +getAllDirs = do baseDir <- ghcupBaseDir binDir <- ghcupBinDir cacheDir <- ghcupCacheDir @@ -226,9 +227,9 @@ ghcupConfigFile = do -- | ~/.ghcup/ghc by default. -ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath +ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath ghcupGHCBaseDir = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs pure (baseDir "ghc") @@ -236,7 +237,7 @@ ghcupGHCBaseDir = do -- The dir may be of the form -- * armv7-unknown-linux-gnueabihf-8.8.3 -- * 8.8.4 -ghcupGHCDir :: (MonadReader AppState m, MonadThrow m) +ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m FilePath ghcupGHCDir ver = do diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs index 4885c8c..93fb1a8 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Utils/File/Posix.hs @@ -21,6 +21,7 @@ module GHCup.Utils.File.Posix where import GHCup.Utils.File.Common import GHCup.Utils.Prelude import GHCup.Types +import GHCup.Types.Optics import Control.Concurrent import Control.Concurrent.Async @@ -74,7 +75,11 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do SPP.executeFile path True args Nothing -execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m) +execLogged :: ( MonadReader env m + , HasSettings env + , HasDirs env + , MonadIO m + , MonadThrow m) => FilePath -- ^ thing to execute -> [String] -- ^ args for the thing -> Maybe FilePath -- ^ optionally chdir into this @@ -82,7 +87,8 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m) -> Maybe [(String, String)] -- ^ optional environment -> m (Either ProcessError ()) execLogged exe args chdir lfile env = do - AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask + Settings {..} <- getSettings + Dirs {..} <- getDirs let logfile = logsDir lfile <> ".log" liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True }) closeFd diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Utils/File/Windows.hs index ba2710a..b8af657 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Utils/File/Windows.hs @@ -146,7 +146,11 @@ executeOut path args chdir = do pure $ CapturedProcess exit out err -execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m) +execLogged :: ( MonadReader env m + , HasDirs env + , HasSettings env + , MonadIO m + , MonadThrow m) => FilePath -- ^ thing to execute -> [String] -- ^ args for the thing -> Maybe FilePath -- ^ optionally chdir into this @@ -154,7 +158,7 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m) -> Maybe [(String, String)] -- ^ optional environment -> m (Either ProcessError ()) execLogged exe args chdir lfile env = do - AppState { dirs = Dirs {..} } <- ask + Dirs {..} <- getDirs let stdoutLogfile = logsDir lfile <> ".stdout.log" stderrLogfile = logsDir lfile <> ".stderr.log" cp <- createProcessWithMingwPath ((proc exe args)