From e250d6013faa5054ebe437241050cb4f19a9ee7f Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 24 Oct 2020 01:06:53 +0200 Subject: [PATCH] Redo Settings as AppState --- app/ghcup-gen/Validate.hs | 2 +- app/ghcup/BrickMain.hs | 126 +++++++++++++++++++------------------- app/ghcup/Main.hs | 55 +++++++++-------- lib/GHCup.hs | 74 +++++++++++----------- lib/GHCup/Download.hs | 22 +++---- lib/GHCup/Types.hs | 11 ++-- lib/GHCup/Utils.hs | 82 ++++++++++++------------- lib/GHCup/Utils/Dirs.hs | 8 +-- lib/GHCup/Utils/File.hs | 4 +- lib/GHCup/Utils/Logger.hs | 4 +- 10 files changed, 199 insertions(+), 189 deletions(-) diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index f54eb97..3bed66b 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -193,7 +193,7 @@ validateTarballs dls = do where downloadAll dli = do dirs <- liftIO getDirs - let settings = Settings True False Never Curl False dirs + let settings = AppState (Settings True False Never Curl False) dirs let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True , colorOutter = B.hPut stderr , rawOutter = (\_ -> pure ()) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index b3b40d1..091c2fd 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -55,35 +55,35 @@ import qualified Data.Vector as V -data AppData = AppData +data BrickData = BrickData { lr :: [ListResult] , dls :: GHCupDownloads , pfreq :: PlatformRequest } deriving Show -data AppSettings = AppSettings +data BrickSettings = BrickSettings { showAll :: Bool } deriving Show -data AppInternalState = AppInternalState +data BrickInternalState = BrickInternalState { clr :: Vector ListResult , ix :: Int } deriving Show -data AppState = AppState - { appData :: AppData - , appSettings :: AppSettings - , appState :: AppInternalState +data BrickState = BrickState + { appData :: BrickData + , appSettings :: BrickSettings + , appState :: BrickInternalState } deriving Show keyHandlers :: [ ( Char - , AppSettings -> String - , AppState -> EventM n (Next AppState) + , BrickSettings -> String + , BrickState -> EventM n (Next BrickState) ) ] keyHandlers = @@ -93,21 +93,21 @@ keyHandlers = , ('s', const "Set" , withIOAction set') , ('c', const "ChangeLog", withIOAction changelog') , ( 'a' - , (\AppSettings {..} -> + , (\BrickSettings {..} -> if showAll then "Hide old versions" else "Show all versions" ) , hideShowHandler ) ] where - hideShowHandler (AppState {..}) = + hideShowHandler (BrickState {..}) = let newAppSettings = appSettings { showAll = not . showAll $ appSettings } newInternalState = constructList appData newAppSettings (Just appState) - in continue (AppState appData newAppSettings newInternalState) + in continue (BrickState appData newAppSettings newInternalState) -ui :: AppState -> Widget String -ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..} +ui :: BrickState -> Widget String +ui BrickState { appSettings = as@(BrickSettings {}), ..} = ( padBottom Max $ ( withBorderStyle unicode $ borderWithLabel (str "GHCup") @@ -196,9 +196,9 @@ ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..} -- available height. drawListElements :: (Int -> Bool -> ListResult -> Widget String) -> Bool - -> AppInternalState + -> BrickInternalState -> Widget String - drawListElements drawElem foc is@(AppInternalState clr _) = + drawListElements drawElem foc is@(BrickInternalState clr _) = Widget Greedy Greedy $ let es = clr @@ -228,7 +228,7 @@ minHSize :: Int -> Widget n -> Widget n minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ') -app :: App AppState e String +app :: App BrickState e String app = App { appDraw = \st -> [ui st] , appHandleEvent = eventHandler , appStartEvent = return @@ -261,14 +261,14 @@ dimAttributes = attrMap , ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) ] -eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState) +eventHandler :: BrickState -> BrickEvent n e -> EventM n (Next BrickState) eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st -eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) = - continue (AppState { appState = (moveCursor appState Up), .. }) -eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) = - continue (AppState { appState = (moveCursor appState Down), .. }) +eventHandler BrickState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) = + continue (BrickState { appState = (moveCursor appState Up), .. }) +eventHandler BrickState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) = + continue (BrickState { appState = (moveCursor appState Down), .. }) eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) = case find (\(c', _, _) -> c' == c) keyHandlers of Nothing -> continue as @@ -276,19 +276,19 @@ eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) = eventHandler st _ = continue st -moveCursor :: AppInternalState -> Direction -> AppInternalState -moveCursor ais@(AppInternalState {..}) direction = +moveCursor :: BrickInternalState -> Direction -> BrickInternalState +moveCursor ais@(BrickInternalState {..}) direction = let newIx = if direction == Down then ix + 1 else ix - 1 in case clr !? newIx of - Just _ -> AppInternalState { ix = newIx, .. } + Just _ -> BrickInternalState { ix = newIx, .. } Nothing -> ais -- | Suspend the current UI and run an IO action in terminal. If the -- IO action returns a Left value, then it's thrown as userError. -withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a)) - -> AppState - -> EventM n (Next AppState) +withIOAction :: (BrickState -> (Int, ListResult) -> IO (Either String a)) + -> BrickState + -> EventM n (Next BrickState) withIOAction action as = case listSelectedElement' (appState as) of Nothing -> continue as Just (ix, e) -> suspendAndResume $ do @@ -304,26 +304,26 @@ withIOAction action as = case listSelectedElement' (appState as) of -- | Update app data and list internal state based on new evidence. --- This synchronises @AppInternalState@ with @AppData@ --- and @AppSettings@. -updateList :: AppData -> AppState -> AppState -updateList appD (AppState {..}) = +-- This synchronises @BrickInternalState@ with @BrickData@ +-- and @BrickSettings@. +updateList :: BrickData -> BrickState -> BrickState +updateList appD (BrickState {..}) = let newInternalState = constructList appD appSettings (Just appState) - in AppState { appState = newInternalState + in BrickState { appState = newInternalState , appData = appD , appSettings = appSettings } -constructList :: AppData - -> AppSettings - -> Maybe AppInternalState - -> AppInternalState +constructList :: BrickData + -> BrickSettings + -> Maybe BrickInternalState + -> BrickInternalState constructList appD appSettings mapp = replaceLR (filterVisible (showAll appSettings)) (lr appD) mapp -listSelectedElement' :: AppInternalState -> Maybe (Int, ListResult) -listSelectedElement' (AppInternalState {..}) = fmap (ix, ) $ clr !? ix +listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult) +listSelectedElement' (BrickInternalState {..}) = fmap (ix, ) $ clr !? ix selectLatest :: Vector ListResult -> Int @@ -338,8 +338,8 @@ selectLatest v = -- When passed an existing @appState@, tries to keep the selected element. replaceLR :: (ListResult -> Bool) -> [ListResult] - -> Maybe AppInternalState - -> AppInternalState + -> Maybe BrickInternalState + -> BrickInternalState replaceLR filterF lr s = let oldElem = s >>= listSelectedElement' newVec = V.fromList . filter filterF $ lr @@ -347,7 +347,7 @@ replaceLR filterF lr s = case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of Just ix -> ix Nothing -> selectLatest newVec - in AppInternalState newVec newSelected + in BrickInternalState newVec newSelected where toolEqual e1 e2 = lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2 @@ -359,8 +359,8 @@ filterVisible showAll e | lInstalled e = True | otherwise = not (elem Old (lTag e)) -install' :: AppState -> (Int, ListResult) -> IO (Either String ()) -install' AppState { appData = AppData {..} } (_, ListResult {..}) = do +install' :: BrickState -> (Int, ListResult) -> IO (Either String ()) +install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do settings <- readIORef settings' l <- readIORef logger' let runLogger = myLoggerT l @@ -406,7 +406,7 @@ install' AppState { appData = AppData {..} } (_, ListResult {..}) = do Also check the logs in ~/.ghcup/logs|] -set' :: AppState -> (Int, ListResult) -> IO (Either String ()) +set' :: BrickState -> (Int, ListResult) -> IO (Either String ()) set' _ (_, ListResult {..}) = do settings <- readIORef settings' l <- readIORef logger' @@ -429,7 +429,7 @@ set' _ (_, ListResult {..}) = do VLeft e -> pure $ Left [i|#{e}|] -del' :: AppState -> (Int, ListResult) -> IO (Either String ()) +del' :: BrickState -> (Int, ListResult) -> IO (Either String ()) del' _ (_, ListResult {..}) = do settings <- readIORef settings' l <- readIORef logger' @@ -449,8 +449,8 @@ del' _ (_, ListResult {..}) = do VLeft e -> pure $ Left [i|#{e}|] -changelog' :: AppState -> (Int, ListResult) -> IO (Either String ()) -changelog' AppState { appData = AppData {..} } (_, ListResult {..}) = do +changelog' :: BrickState -> (Int, ListResult) -> IO (Either String ()) +changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do case getChangeLog dls lTool (Left lVer) of Nothing -> pure $ Left [i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|] @@ -469,17 +469,19 @@ uri' :: IORef (Maybe URI) uri' = unsafePerformIO (newIORef Nothing) -settings' :: IORef Settings +settings' :: IORef AppState {-# NOINLINE settings' #-} settings' = unsafePerformIO $ do dirs <- getDirs - newIORef Settings { cache = True - , noVerify = False - , keepDirs = Never - , downloader = Curl - , verbose = False - , .. - } + newIORef $ AppState (Settings { cache = True + , noVerify = False + , keepDirs = Never + , downloader = Curl + , verbose = False + , .. + }) + dirs + logger' :: IORef LoggerConfig @@ -492,7 +494,7 @@ logger' = unsafePerformIO ) -brickMain :: Settings +brickMain :: AppState -> Maybe URI -> LoggerConfig -> GHCupDownloads @@ -510,7 +512,7 @@ brickMain s muri l av pfreq' = do Right ad -> defaultMain app - (AppState ad + (BrickState ad defaultAppSettings (constructList ad defaultAppSettings Nothing) ) @@ -520,8 +522,8 @@ brickMain s muri l av pfreq' = do exitWith $ ExitFailure 2 -defaultAppSettings :: AppSettings -defaultAppSettings = AppSettings { showAll = False } +defaultAppSettings :: BrickSettings +defaultAppSettings = BrickSettings { showAll = False } getDownloads' :: IO (Either String GHCupDownloads) @@ -546,7 +548,7 @@ getDownloads' = do getAppData :: Maybe GHCupDownloads -> PlatformRequest - -> IO (Either String AppData) + -> IO (Either String BrickData) getAppData mg pfreq' = do settings <- readIORef settings' l <- readIORef logger' @@ -558,6 +560,6 @@ getAppData mg pfreq' = do case r of Right dls -> do lV <- listVersions dls Nothing Nothing pfreq' - pure $ Right $ (AppData (reverse lV) dls pfreq') + pure $ Right $ (BrickData (reverse lV) dls pfreq') Left e -> pure $ Left [i|#{e}|] diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index ec67ce1..6efab75 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -856,7 +856,7 @@ bindistParser :: String -> Either String URI bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString -toSettings :: Options -> IO Settings +toSettings :: Options -> IO AppState toSettings Options {..} = do let cache = optCache noVerify = optNoVerify @@ -864,7 +864,7 @@ toSettings Options {..} = do downloader = optsDownloader verbose = optVerbose dirs <- getDirs - pure $ Settings { .. } + pure $ AppState (Settings { .. }) dirs upgradeOptsP :: Parser UpgradeOpts @@ -940,13 +940,13 @@ Report bugs at |] (footerDoc (Just $ text main_footer)) ) >>= \opt@Options {..} -> do - settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt + appstate@AppState{dirs = Dirs{..}, ..} <- toSettings opt -- create ~/.ghcup dir createDirRecursive' baseDir -- logger interpreter - logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|] + logfile <- flip runReaderT appstate $ initGHCupFileLogging [rel|ghcup.log|] let loggerConfig = LoggerConfig { lcPrintDebug = optVerbose , colorOutter = B.hPut stderr @@ -959,9 +959,9 @@ Report bugs at |] -- Effect interpreters -- ------------------------- - let runInstTool' settings' = + let runInstTool' appstate' = runLogger - . flip runReaderT settings' + . flip runReaderT appstate' . runResourceT . runE @'[ AlreadyInstalled @@ -980,12 +980,12 @@ Report bugs at |] , TarDirDoesNotExist ] - let runInstTool = runInstTool' settings + let runInstTool = runInstTool' appstate let runSetGHC = runLogger - . flip runReaderT settings + . flip runReaderT appstate . runE @'[ FileDoesNotExistError , NotInstalled @@ -995,7 +995,7 @@ Report bugs at |] let runSetCabal = runLogger - . flip runReaderT settings + . flip runReaderT appstate . runE @'[ NotInstalled , TagNotFound @@ -1004,26 +1004,26 @@ Report bugs at |] let runSetHLS = runLogger - . flip runReaderT settings + . flip runReaderT appstate . runE @'[ NotInstalled , TagNotFound ] - let runListGHC = runLogger . flip runReaderT settings + let runListGHC = runLogger . flip runReaderT appstate let runRm = - runLogger . flip runReaderT settings . runE @'[NotInstalled] + runLogger . flip runReaderT appstate . runE @'[NotInstalled] let runDebugInfo = runLogger - . flip runReaderT settings + . flip runReaderT appstate . runE @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] let runCompileGHC = runLogger - . flip runReaderT settings + . flip runReaderT appstate . runResourceT . runE @'[ AlreadyInstalled @@ -1044,7 +1044,7 @@ Report bugs at |] let runUpgrade = runLogger - . flip runReaderT settings + . flip runReaderT appstate . runResourceT . runE @'[ DigestError @@ -1072,7 +1072,7 @@ Report bugs at |] (GHCupInfo treq dls) <- ( runLogger - . flip runReaderT settings + . flip runReaderT appstate . runE @'[JSONError , DownloadFailed, FileDoesNotExistError] $ liftE $ getDownloadsF (maybe GHCupURL OwnSource optUrlSource) @@ -1086,7 +1086,7 @@ Report bugs at |] case optCommand of Upgrade _ _ -> pure () - _ -> runLogger $ flip runReaderT settings $ checkForUpdates dls pfreq + _ -> runLogger $ flip runReaderT appstate $ checkForUpdates dls pfreq @@ -1099,7 +1099,7 @@ Report bugs at |] Nothing -> runInstTool $ do v <- liftE $ fromVersion dls instVer GHC liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) - Just uri -> runInstTool' settings{noVerify = True} $ do + Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} $ do v <- liftE $ fromVersion dls instVer GHC liftE $ installGHCBindist (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") @@ -1115,7 +1115,7 @@ Report bugs at |] [i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|] pure ExitSuccess VLeft (V (BuildFailed tmpdir e)) -> do - case keepDirs of + case keepDirs settings of Never -> runLogger ($(logError) [i|Build failed with #{e}|]) _ -> runLogger ($(logError) [i|Build failed with #{e} Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues. @@ -1140,7 +1140,7 @@ Report bugs at |] Nothing -> runInstTool $ do v <- liftE $ fromVersion dls instVer Cabal liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) - Just uri -> runInstTool' settings{noVerify = True} $ do + Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do v <- liftE $ fromVersion dls instVer Cabal liftE $ installCabalBindist (DownloadInfo uri Nothing "") @@ -1173,7 +1173,7 @@ Report bugs at |] Nothing -> runInstTool $ do v <- liftE $ fromVersion dls instVer HLS liftE $ installHLSBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) - Just uri -> runInstTool' settings{noVerify = True} $ do + Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do v <- liftE $ fromVersion dls instVer HLS liftE $ installHLSBindist (DownloadInfo uri Nothing "") @@ -1272,7 +1272,7 @@ Report bugs at |] res <- case optCommand of #if defined(BRICK) - Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess + Interactive -> liftIO $ brickMain appstate optUrlSource loggerConfig dls pfreq >> pure ExitSuccess #endif Install (Right iopts) -> do runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|]) @@ -1336,7 +1336,7 @@ Report bugs at |] [i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|] pure ExitSuccess VLeft (V (BuildFailed tmpdir e)) -> do - case keepDirs of + case keepDirs settings of Never -> runLogger ($(logError) [i|Build failed with #{e} Check the logs at #{logsDir}|]) _ -> runLogger ($(logError) [i|Build failed with #{e} @@ -1602,7 +1602,14 @@ printListResult raw lr = do | otherwise -> 1 -checkForUpdates :: (MonadReader Settings m, MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m) +checkForUpdates :: ( MonadReader AppState m + , MonadCatch m + , MonadLogger m + , MonadThrow m + , MonadIO m + , MonadFail m + , MonadLogger m + ) => GHCupDownloads -> PlatformRequest -> m () diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 75e3c20..e2a71c9 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -99,7 +99,7 @@ import qualified Data.Text.Encoding as E installGHCBindist :: ( MonadFail m , MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadResource m , MonadIO m @@ -142,7 +142,7 @@ installGHCBindist dlinfo ver pfreq = do -- build system and nothing else. installPackedGHC :: ( MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadThrow m , MonadLogger m , MonadIO m @@ -178,7 +178,7 @@ installPackedGHC dl msubdir inst ver pfreq@(PlatformRequest {..}) = do -- | Install an unpacked GHC distribution. This only deals with the GHC -- build system and nothing else. -installUnpackedGHC :: ( MonadReader Settings m +installUnpackedGHC :: ( MonadReader AppState m , MonadThrow m , MonadLogger m , MonadIO m @@ -214,7 +214,7 @@ installUnpackedGHC path inst ver (PlatformRequest {..}) = do installGHCBin :: ( MonadFail m , MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadResource m , MonadIO m @@ -246,7 +246,7 @@ installGHCBin bDls ver pfreq = do -- argument instead of looking it up from 'GHCupDownloads'. installCabalBindist :: ( MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadResource m , MonadIO m @@ -273,7 +273,7 @@ installCabalBindist :: ( MonadMask m installCabalBindist dlinfo ver (PlatformRequest {..}) = do lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask whenM (lift (cabalInstalled ver) >>= \a -> liftIO $ @@ -328,7 +328,7 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do -- the latest installed version. installCabalBin :: ( MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadResource m , MonadIO m @@ -361,7 +361,7 @@ installCabalBin bDls ver pfreq = do -- argument instead of looking it up from 'GHCupDownloads'. installHLSBindist :: ( MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadResource m , MonadIO m @@ -388,7 +388,7 @@ installHLSBindist :: ( MonadMask m installHLSBindist dlinfo ver (PlatformRequest {..}) = do lift $ $(logDebug) [i|Requested to install hls version #{ver}|] - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask whenM (lift (hlsInstalled ver)) $ (throwE $ AlreadyInstalled HLS ver) @@ -452,7 +452,7 @@ installHLSBindist dlinfo ver (PlatformRequest {..}) = do -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. installHLSBin :: ( MonadMask m , MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadResource m , MonadIO m @@ -498,7 +498,7 @@ installHLSBin bDls ver pfreq = do -- -- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\\/share symlink@ -- for 'SetGHCOnly' constructor. -setGHC :: ( MonadReader Settings m +setGHC :: ( MonadReader AppState m , MonadLogger m , MonadThrow m , MonadFail m @@ -515,7 +515,7 @@ setGHC ver sghc = do whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))) -- symlink destination - Settings { dirs = Dirs {..} } <- lift ask + AppState { dirs = Dirs {..} } <- lift ask liftIO $ createDirRecursive' binDir -- first delete the old symlinks (this fixes compatibility issues @@ -556,12 +556,12 @@ setGHC ver sghc = do where - symlinkShareDir :: (MonadReader Settings m, MonadIO m, MonadLogger m) + symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m) => Path Abs -> ByteString -> m () symlinkShareDir ghcdir verBS = do - Settings { dirs = Dirs {..} } <- ask + AppState { dirs = Dirs {..} } <- ask let destdir = baseDir case sghc of SetGHCOnly -> do @@ -579,7 +579,7 @@ setGHC ver sghc = do -- | Set the @~\/.ghcup\/bin\/cabal@ symlink. -setCabal :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) +setCabal :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) => Version -> Excepts '[NotInstalled] m () setCabal ver = do @@ -587,7 +587,7 @@ setCabal ver = do targetFile <- parseRel ("cabal-" <> verBS) -- symlink destination - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask liftIO $ createDirRecursive' binDir whenM (liftIO $ fmap not $ doesFileExist (binDir targetFile)) @@ -613,7 +613,7 @@ setCabal ver = do -- | Set the haskell-language-server symlinks. setHLS :: ( MonadCatch m - , MonadReader Settings m + , MonadReader AppState m , MonadLogger m , MonadThrow m , MonadFail m @@ -622,7 +622,7 @@ setHLS :: ( MonadCatch m => Version -> Excepts '[NotInstalled] m () setHLS ver = do - Settings { dirs = Dirs {..} } <- lift ask + AppState { dirs = Dirs {..} } <- lift ask liftIO $ createDirRecursive' binDir -- Delete old symlinks, since these might have different ghc versions than the @@ -703,7 +703,7 @@ listVersions :: ( MonadCatch m , MonadThrow m , MonadLogger m , MonadIO m - , MonadReader Settings m + , MonadReader AppState m ) => GHCupDownloads -> Maybe Tool @@ -736,7 +736,7 @@ listVersions av lt criteria pfreq = do pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers) where - strayGHCs :: (MonadCatch m, MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m) + strayGHCs :: (MonadCatch m, MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m) => Map.Map Version [Tag] -> m [ListResult] strayGHCs avTools = do @@ -778,7 +778,7 @@ listVersions av lt criteria pfreq = do [i|Could not parse version of stray directory #{toFilePath e}|] pure Nothing - strayCabals :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) + strayCabals :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) => Map.Map Version [Tag] -> m [ListResult] strayCabals avTools = do @@ -806,7 +806,7 @@ listVersions av lt criteria pfreq = do [i|Could not parse version of stray directory #{toFilePath e}|] pure Nothing - strayHLS :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) + strayHLS :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) => Map.Map Version [Tag] -> m [ListResult] strayHLS avTools = do @@ -835,7 +835,7 @@ listVersions av lt criteria pfreq = do pure Nothing -- NOTE: this are not cross ones, because no bindists - toListResult :: (MonadReader Settings m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult + toListResult :: (MonadReader AppState m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult toListResult t (v, tags) = case t of GHC -> do let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av @@ -904,7 +904,7 @@ listVersions av lt criteria pfreq = 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 Settings m +rmGHCVer :: ( MonadReader AppState m , MonadThrow m , MonadLogger m , MonadIO m @@ -942,7 +942,7 @@ rmGHCVer ver = do forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver)) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) - Settings { dirs = Dirs {..} } <- lift ask + AppState { dirs = Dirs {..} } <- lift ask liftIO $ hideError doesNotExistErrorType @@ -952,7 +952,7 @@ 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 :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m) +rmCabalVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m) => Version -> Excepts '[NotInstalled] m () rmCabalVer ver = do @@ -960,7 +960,7 @@ rmCabalVer ver = do cSet <- lift $ cabalSet - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver) liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir cabalFile) @@ -975,7 +975,7 @@ 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 :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m) +rmHLSVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m) => Version -> Excepts '[NotInstalled] m () rmHLSVer ver = do @@ -983,7 +983,7 @@ rmHLSVer ver = do isHlsSet <- lift $ hlsSet - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask bins <- lift $ hlsAllBinaries ver forM_ bins $ \f -> liftIO $ deleteFile (binDir f) @@ -1008,13 +1008,13 @@ rmHLSVer ver = do ------------------ -getDebugInfo :: (MonadReader Settings m, MonadLogger m, MonadCatch m, MonadIO m) +getDebugInfo :: (MonadReader AppState m, MonadLogger m, MonadCatch m, MonadIO m) => Excepts '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] m DebugInfo getDebugInfo = do - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask let diBaseDir = baseDir let diBinDir = binDir diGHCDir <- lift ghcupGHCBaseDir @@ -1034,7 +1034,7 @@ getDebugInfo = do -- | Compile a GHC from source. This behaves wrt symlinks and installation -- the same as 'installGHCBin'. compileGHC :: ( MonadMask m - , MonadReader Settings m + , MonadReader AppState m , MonadThrow m , MonadResource m , MonadLogger m @@ -1135,7 +1135,7 @@ BUILD_SPHINX_PDF = NO HADDOCK_DOCS = NO Stage1Only = YES|] - compileBindist :: ( MonadReader Settings m + compileBindist :: ( MonadReader AppState m , MonadThrow m , MonadCatch m , MonadLogger m @@ -1153,7 +1153,7 @@ Stage1Only = YES|] lift $ $(logInfo) [i|configuring build|] liftE $ checkBuildConfig - Settings { dirs = Dirs {..} } <- lift ask + AppState { dirs = Dirs {..} } <- lift ask forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir @@ -1270,7 +1270,7 @@ Stage1Only = YES|] -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@, -- if no path is provided. upgradeGHCup :: ( MonadMask m - , MonadReader Settings m + , MonadReader AppState m , MonadCatch m , MonadLogger m , MonadThrow m @@ -1292,7 +1292,7 @@ upgradeGHCup :: ( MonadMask m m Version upgradeGHCup dls mtarget force pfreq = do - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask lift $ $(logInfo) [i|Upgrading GHCup...|] let latestVer = fromJust $ getLatest dls GHCup when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate @@ -1317,7 +1317,7 @@ upgradeGHCup dls mtarget force pfreq = do -- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for -- both installing from source and bindist. -postGHCInstall :: ( MonadReader Settings m +postGHCInstall :: ( MonadReader AppState m , MonadLogger m , MonadThrow m , MonadFail m diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index af8aa16..18a2c5c 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -114,7 +114,7 @@ getDownloadsF :: ( FromJSONKey Tool , MonadLogger m , MonadThrow m , MonadFail m - , MonadReader Settings m + , MonadReader AppState m ) => URLSource -> Excepts @@ -133,7 +133,7 @@ getDownloadsF urlSource = do (OwnSpec _) -> liftE $ getDownloads urlSource where readFromCache = do - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask lift $ $(logWarn) [i|Could not get download info, trying cached version (this may not be recent!)|] let path = view pathL' ghcupURL @@ -155,7 +155,7 @@ getDownloads :: ( FromJSONKey Tool , MonadLogger m , MonadThrow m , MonadFail m - , MonadReader Settings m + , MonadReader AppState m ) => URLSource -> Excepts '[JSONError , DownloadFailed] m GHCupInfo @@ -185,7 +185,7 @@ getDownloads urlSource = do , MonadIO m1 , MonadFail m1 , MonadLogger m1 - , MonadReader Settings m1 + , MonadReader AppState m1 ) => URI -> Excepts @@ -200,7 +200,7 @@ getDownloads urlSource = do m1 L.ByteString smartDl uri' = do - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask let path = view pathL' uri' json_file <- (cacheDir ) <$> urlBaseName path e <- liftIO $ doesFileExist json_file @@ -311,7 +311,7 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe -- -- The file must not exist. download :: ( MonadMask m - , MonadReader Settings m + , MonadReader AppState m , MonadThrow m , MonadLogger m , MonadIO m @@ -383,7 +383,7 @@ downloadCached :: ( MonadMask m , MonadThrow m , MonadLogger m , MonadIO m - , MonadReader Settings m + , MonadReader AppState m ) => DownloadInfo -> Maybe (Path Rel) -- ^ optional filename @@ -392,7 +392,7 @@ downloadCached dli mfn = do cache <- lift getCache case cache of True -> do - Settings {dirs = Dirs {..}} <- lift ask + AppState {dirs = Dirs {..}} <- lift ask fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn let cachfile = cacheDir fn fileExists <- liftIO $ doesFileExist cachfile @@ -416,7 +416,7 @@ downloadCached dli mfn = do -- | This is used for downloading the JSON. -downloadBS :: (MonadReader Settings m, MonadCatch m, MonadIO m, MonadLogger m) +downloadBS :: (MonadReader AppState m, MonadCatch m, MonadIO m, MonadLogger m) => URI -> Excepts '[ FileDoesNotExistError @@ -473,12 +473,12 @@ downloadBS uri' #endif -checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader Settings m) +checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m) => DownloadInfo -> Path Abs -> Excepts '[DigestError] m () checkDigest dli file = do - verify <- lift ask <&> (not . noVerify) + verify <- lift ask <&> (not . noVerify . settings) when verify $ do p' <- toFilePath <$> basename file lift $ $(logInfo) [i|verifying digest of: #{p'}|] diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 9857cf3..2da0a7c 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -193,16 +193,17 @@ data URLSource = GHCupURL deriving (GHC.Generic, Show) +data AppState = AppState + { settings :: Settings + , dirs :: Dirs + } deriving (Show) + data Settings = Settings - { -- set by user - cache :: Bool + { cache :: Bool , noVerify :: Bool , keepDirs :: KeepDirs , downloader :: Downloader , verbose :: Bool - - -- set on app start - , dirs :: Dirs } deriving Show diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index db0c148..0603efa 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -99,21 +99,21 @@ import qualified Text.Megaparsec as MP -- | The symlink destination of a ghc tool. -ghcLinkDestination :: (MonadReader Settings m, MonadThrow m, MonadIO m) +ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m) => ByteString -- ^ the tool, such as 'ghc', 'haddock' etc. -> GHCTargetVersion -> m ByteString ghcLinkDestination tool ver = do - Settings {dirs = Dirs {..}} <- ask + AppState { dirs = Dirs {..} } <- ask t <- parseRel tool ghcd <- ghcupGHCDir ver pure (relativeSymlink binDir (ghcd [rel|bin|] t)) -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5. -rmMinorSymlinks :: (MonadReader Settings m, MonadIO m, MonadLogger m) => GHCTargetVersion -> m () +rmMinorSymlinks :: (MonadReader AppState m, MonadIO m, MonadLogger m) => GHCTargetVersion -> m () rmMinorSymlinks GHCTargetVersion {..} = do - Settings {dirs = Dirs {..}} <- ask + AppState { dirs = Dirs {..} } <- ask files <- liftIO $ findFiles' binDir @@ -130,11 +130,11 @@ rmMinorSymlinks GHCTargetVersion {..} = do -- | Removes the set ghc version for the given target, if any. -rmPlain :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) +rmPlain :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) => Maybe Text -- ^ target -> Excepts '[NotInstalled] m () rmPlain target = do - Settings {dirs = Dirs {..}} <- lift ask + AppState { dirs = Dirs {..} } <- lift ask mtv <- lift $ ghcSet target forM_ mtv $ \tv -> do files <- liftE $ ghcToolFiles tv @@ -149,11 +149,11 @@ rmPlain target = do -- | Remove the major GHC symlink, e.g. ghc-8.6. -rmMajorSymlinks :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m) +rmMajorSymlinks :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m) => GHCTargetVersion -> m () rmMajorSymlinks GHCTargetVersion {..} = do - Settings {dirs = Dirs {..}} <- ask + AppState { dirs = Dirs {..} } <- ask (mj, mi) <- getMajorMinorV _tvVersion let v' = intToText mj <> "." <> intToText mi @@ -179,26 +179,26 @@ rmMajorSymlinks GHCTargetVersion {..} = do -- | Whethe the given GHC versin is installed. -ghcInstalled :: (MonadIO m, MonadReader Settings m, MonadThrow m) => GHCTargetVersion -> m Bool +ghcInstalled :: (MonadIO m, MonadReader AppState m, 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 Settings m, MonadThrow m) => GHCTargetVersion -> m Bool +ghcSrcInstalled :: (MonadIO m, MonadReader AppState m, 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 Settings m, MonadThrow m, MonadIO m) +ghcSet :: (MonadReader AppState m, 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 - Settings {dirs = Dirs {..}} <- ask + AppState {dirs = Dirs {..}} <- ask ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget) let ghcBin = binDir ghc @@ -231,7 +231,7 @@ ghcLinkVersion bs = do -- | Get all installed GHCs by reading ~/.ghcup/ghc/. -- If a dir cannot be parsed, returns left. -getInstalledGHCs :: (MonadReader Settings m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion] +getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion] getInstalledGHCs = do ghcdir <- ghcupGHCBaseDir fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir @@ -241,10 +241,10 @@ getInstalledGHCs = do -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@. -getInstalledCabals :: (MonadReader Settings m, MonadIO m, MonadCatch m) +getInstalledCabals :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [Either (Path Rel) Version] getInstalledCabals = do - Settings {dirs = Dirs {..}} <- ask + AppState {dirs = Dirs {..}} <- ask bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString)) @@ -257,16 +257,16 @@ getInstalledCabals = do -- | Whether the given cabal version is installed. -cabalInstalled :: (MonadIO m, MonadReader Settings m, MonadCatch m) => Version -> m Bool +cabalInstalled :: (MonadIO m, MonadReader AppState m, 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 :: (MonadReader Settings m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) +cabalSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) cabalSet = do - Settings {dirs = Dirs {..}} <- ask + AppState {dirs = Dirs {..}} <- ask let cabalbin = binDir [rel|cabal|] b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin if @@ -303,10 +303,10 @@ cabalSet = do -- | Get all installed hls, by matching on -- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@. -getInstalledHLSs :: (MonadReader Settings m, MonadIO m, MonadCatch m) +getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [Either (Path Rel) Version] getInstalledHLSs = do - Settings { dirs = Dirs {..} } <- ask + AppState { dirs = Dirs {..} } <- ask bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended @@ -326,7 +326,7 @@ getInstalledHLSs = do -- | Whether the given HLS version is installed. -hlsInstalled :: (MonadIO m, MonadReader Settings m, MonadCatch m) => Version -> m Bool +hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool hlsInstalled ver = do vers <- fmap rights $ getInstalledHLSs pure $ elem ver $ vers @@ -334,9 +334,9 @@ hlsInstalled ver = do -- Return the currently set hls version, if any. -hlsSet :: (MonadReader Settings m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) +hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) hlsSet = do - Settings {dirs = Dirs {..}} <- ask + AppState {dirs = Dirs {..}} <- ask let hlsBin = binDir [rel|haskell-language-server-wrapper|] liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do @@ -357,7 +357,7 @@ hlsSet = do -- | Return the GHC versions the currently selected HLS supports. -hlsGHCVersions :: ( MonadReader Settings m +hlsGHCVersions :: ( MonadReader AppState m , MonadIO m , MonadThrow m , MonadCatch m @@ -383,11 +383,11 @@ hlsGHCVersions = do -- | Get all server binaries for an hls version, if any. -hlsServerBinaries :: (MonadReader Settings m, MonadIO m) +hlsServerBinaries :: (MonadReader AppState m, MonadIO m) => Version -> m [Path Rel] hlsServerBinaries ver = do - Settings { dirs = Dirs {..} } <- ask + AppState { dirs = Dirs {..} } <- ask liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts @@ -399,11 +399,11 @@ hlsServerBinaries ver = do -- | Get the wrapper binary for an hls version, if any. -hlsWrapperBinary :: (MonadReader Settings m, MonadThrow m, MonadIO m) +hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m) => Version -> m (Maybe (Path Rel)) hlsWrapperBinary ver = do - Settings { dirs = Dirs {..} } <- ask + AppState { dirs = Dirs {..} } <- ask wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts @@ -420,7 +420,7 @@ hlsWrapperBinary ver = do -- | Get all binaries for an hls version, if any. -hlsAllBinaries :: (MonadReader Settings m, MonadIO m, MonadThrow m) => Version -> m [Path Rel] +hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [Path Rel] hlsAllBinaries ver = do hls <- hlsServerBinaries ver wrapper <- hlsWrapperBinary ver @@ -428,9 +428,9 @@ hlsAllBinaries ver = do -- | Get the active symlinks for hls. -hlsSymlinks :: (MonadReader Settings m, MonadIO m, MonadCatch m) => m [Path Rel] +hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [Path Rel] hlsSymlinks = do - Settings { dirs = Dirs {..} } <- ask + AppState { dirs = Dirs {..} } <- ask oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended @@ -467,7 +467,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 Settings m, MonadIO m, MonadThrow m) +getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Int -- ^ major version component -> Int -- ^ minor version component -> Maybe Text -- ^ the target triple @@ -603,16 +603,16 @@ getLatestBaseVersion av pvpVer = ----------------------- - --[ Settings Getter ]-- + --[ AppState Getter ]-- ----------------------- -getCache :: MonadReader Settings m => m Bool -getCache = ask <&> cache +getCache :: MonadReader AppState m => m Bool +getCache = ask <&> cache . settings -getDownloader :: MonadReader Settings m => m Downloader -getDownloader = ask <&> downloader +getDownloader :: MonadReader AppState m => m Downloader +getDownloader = ask <&> downloader . settings @@ -633,7 +633,7 @@ urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False -- Returns unversioned relative files, e.g.: -- -- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@ -ghcToolFiles :: (MonadReader Settings m, MonadThrow m, MonadFail m, MonadIO m) +ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m) => GHCTargetVersion -> Excepts '[NotInstalled] m [Path Rel] ghcToolFiles ver = do @@ -686,7 +686,7 @@ ghcUpSrcBuiltFile = [rel|.ghcup_src_built|] -- | Calls gmake if it exists in PATH, otherwise make. -make :: (MonadThrow m, MonadIO m, MonadReader Settings m) +make :: (MonadThrow m, MonadIO m, MonadReader AppState m) => [ByteString] -> Maybe (Path Abs) -> m (Either ProcessError ()) @@ -739,13 +739,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 Settings m, MonadIO m, MonadMask m) +runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m) => Path Abs -- ^ build directory (cleaned up depending on Settings) -> Maybe (Path Abs) -- ^ dir to *always* clean up on exception -> Excepts e m a -> Excepts '[BuildFailed] m a runBuildAction bdir instdir action = do - Settings {..} <- lift ask + AppState { settings = Settings {..} } <- lift ask let exAction = do forM_ instdir $ \dir -> liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index 2704e42..8558a75 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -152,17 +152,17 @@ getDirs = do -- | ~/.ghcup/ghc by default. -ghcupGHCBaseDir :: (MonadReader Settings m) => m (Path Abs) +ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs) ghcupGHCBaseDir = do - Settings {..} <- ask - pure (baseDir dirs [rel|ghc|]) + AppState { dirs = Dirs {..} } <- ask + pure (baseDir [rel|ghc|]) -- | Gets '~/.ghcup/ghc/'. -- The dir may be of the form -- * armv7-unknown-linux-gnueabihf-8.8.3 -- * 8.8.4 -ghcupGHCDir :: (MonadReader Settings m, MonadThrow m) +ghcupGHCDir :: (MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m (Path Abs) ghcupGHCDir ver = do diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 928390b..e5301a0 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -117,7 +117,7 @@ executeOut path args chdir = captureOutStreams $ do SPPB.executeFile (toFilePath path) True args Nothing -execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m) +execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m) => ByteString -- ^ thing to execute -> Bool -- ^ whether to search PATH for the thing -> [ByteString] -- ^ args for the thing @@ -126,7 +126,7 @@ execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m) -> Maybe [(ByteString, ByteString)] -- ^ optional environment -> m (Either ProcessError ()) execLogged exe spath args lfile chdir env = do - Settings {dirs = Dirs {..}, ..} <- ask + AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask logfile <- (logsDir ) <$> parseRel (toFilePath lfile <> ".log") liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) closeFd diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index 5dece20..53043b4 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Utils/Logger.hs @@ -65,9 +65,9 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger rawOutter outr -initGHCupFileLogging :: (MonadIO m, MonadReader Settings m) => Path Rel -> m (Path Abs) +initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => Path Rel -> m (Path Abs) initGHCupFileLogging context = do - Settings {dirs = Dirs {..}} <- ask + AppState {dirs = Dirs {..}} <- ask let logfile = logsDir context liftIO $ do createDirRecursive' logsDir