Use LabelOptic and add LeanAppState

Wrt #186

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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
             (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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           (settings, keybindings) <- toSettings opt
 
           -- logger interpreter
-          logfile <- initGHCupFileLogging (logsDir dirs)
+          logfile <- initGHCupFileLogging logsDir
           let loggerConfig = LoggerConfig
                 { lcPrintDebug = verbose settings
                 , colorOutter  = B.hPut stderr
@@ -1240,16 +1240,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           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
+          -- Setting up appstate --
-                Whereis _ _ -> unsafeInterleaveIO
+          -------------------------
-                _ -> id
 
-          pfreq <- wrapIO $ (
+
+          let leanAppstate = LeanAppState settings dirs keybindings
+              appState = do
+                pfreq <- (
                   runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
                   ) >>= \case
                           VRight r -> pure r
@@ -1258,7 +1257,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                               ($(logError) $ T.pack $ prettyShow e)
                             exitWith (ExitFailure 2)
 
-          ghcupInfo <- wrapIO $
+                ghcupInfo <-
                   ( runLogger
                     . runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
                     $ liftE
@@ -1270,42 +1269,28 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             runLogger
                               ($(logError) $ T.pack $ prettyShow e)
                             exitWith (ExitFailure 2)
+                let s' = AppState settings dirs keybindings ghcupInfo pfreq
 
-
-
-          -------------------------
-          -- Setting up appstate --
-          -------------------------
-
-
-          let appstate@AppState{dirs = Dirs{..}
-                               , ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls, .. }
-                               } = AppState settings dirs keybindings ghcupInfo pfreq
-
-
-          ---------------------------
-          -- Running startup tasks --
-          ---------------------------
-
-          case optCommand of
-            Upgrade _ _ -> pure ()
-            Whereis _ _ -> pure ()
-            _ -> do
                 lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
-                Nothing -> runLogger $ flip runReaderT appstate $ checkForUpdates
+                  Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
                   Just _ -> pure ()
 
-
+                -- TODO: always run for windows
-          -- ensure global tools
+                (siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case
-          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)
+                pure s'
+
+
+              runLeanAppState = flip runReaderT leanAppstate
+              runAppState action' = do
+                s' <- liftIO appState
+                flip runReaderT s' action'
+                  
+
 
 
           -------------------------
@@ -1335,12 +1320,25 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                       , 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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                     ]
 
           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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           let
             runSetHLS =
               runLogger
-                . flip runReaderT appstate
+                . runAppState
                 . runE
                   @'[ NotInstalled
                     , TagNotFound
@@ -1371,20 +1379,30 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                     , 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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                       ]
 
           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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
 
           let runUpgrade =
                 runLogger
-                  . flip runReaderT appstate
+                  . runAppState
                   . runResourceT
                   . runE
                     @'[ DigestError
@@ -1439,7 +1467,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                        liftE $ installGHCBin (_tvVersion v)
                        when instSet $ void $ liftE $ setGHC v SetGHCOnly
                        pure vi
-                     Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} instPlatform $ do
+                     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-.*") "")
@@ -1477,7 +1507,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                      (v, vi) <- liftE $ fromVersion instVer Cabal
                      liftE $ installCabalBin (_tvVersion v)
                      pure vi
-                   Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
+                   Just uri -> do
+                     s' <- appState
+                     runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
                        (v, vi) <- liftE $ fromVersion instVer Cabal
                        liftE $ installCabalBindist
                            (DownloadInfo uri Nothing "")
@@ -1506,7 +1538,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                      (v, vi) <- liftE $ fromVersion instVer HLS
                      liftE $ installHLSBin (_tvVersion v)
                      pure vi
-                   Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
+                   Just uri -> do
+                     s' <- appState
+                     runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
                        (v, vi) <- liftE $ fromVersion instVer HLS
                        liftE $ installHLSBindist
                            (DownloadInfo uri Nothing "")
@@ -1535,7 +1569,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                      (v, vi) <- liftE $ fromVersion instVer Stack
                      liftE $ installStackBin (_tvVersion v)
                      pure vi
-                   Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
+                   Just uri -> do
+                     s' <- appState
+                     runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
                        (v, vi) <- liftE $ fromVersion instVer Stack
                        liftE $ installStackBindist
                            (DownloadInfo uri Nothing "")
@@ -1559,8 +1595,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                           pure $ ExitFailure 4
 
 
-          let setGHC' SetOptions{..} =
+          let setGHC' SetOptions{ sToolVer } =
-                runSetGHC (do
+                case sToolVer of
+                  (SetToolVersion v) -> runLeanSetGHC (liftE $ setGHC v SetGHCOnly >> pure v)
+                  _ -> runSetGHC (do
                       v <- liftE $ fst <$> fromVersion' sToolVer GHC
                       liftE $ setGHC v SetGHCOnly
                     )
@@ -1574,8 +1612,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                           runLogger $ $(logError) $ T.pack $ prettyShow e
                           pure $ ExitFailure 5
 
-          let setCabal' SetOptions{..} =
+          let setCabal' SetOptions{ sToolVer } =
-                runSetCabal (do
+                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
@@ -1590,8 +1630,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                           runLogger $ $(logError) $ T.pack $ prettyShow e
                           pure $ ExitFailure 14
 
-          let setHLS' SetOptions{..} =
+          let setHLS' SetOptions{ sToolVer } =
-                runSetHLS (do
+                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
@@ -1606,8 +1648,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                           runLogger $ $(logError) $ T.pack $ prettyShow e
                           pure $ ExitFailure 14
 
-          let setStack' SetOptions{..} =
+          let setStack' SetOptions{ sToolVer } =
-                runSetCabal (do
+                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
@@ -1626,6 +1670,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                 runRm (do
                     liftE $
                       rmGHCVer ghcVer
+                    GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
                     pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
                   )
                   >>= \case
@@ -1641,6 +1686,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                 runRm (do
                     liftE $
                       rmCabalVer tv
+                    GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
                     pure (getVersionInfo tv Cabal dls)
                   )
                   >>= \case
@@ -1656,6 +1702,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                 runRm (do
                     liftE $
                       rmHLSVer tv
+                    GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
                     pure (getVersionInfo tv HLS dls)
                   )
                   >>= \case
@@ -1671,6 +1718,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                 runRm (do
                     liftE $
                       rmStackVer tv
+                    GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
                     pure (getVersionInfo tv Stack dls)
                   )
                   >>= \case
@@ -1735,6 +1783,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
               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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             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,14 +1881,16 @@ Make sure to clean up #{tmpdir} afterwards.|])
                   runLogger $ $(logError) $ T.pack $ prettyShow e
                   pure $ ExitFailure 11
 
-            ToolRequirements ->
+            ToolRequirements -> do
-              flip runReaderT appstate
+              s' <- appState
+              flip runReaderT s'
                 $ runLogger
                   (runE
                     @'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
                   $ do
-                    platform <- liftE getPlatform
+                      GHCupInfo { .. } <- lift getGHCupInfo
-                    req      <- getCommonRequirements platform _toolRequirements ?? NoToolRequirements
+                      platform' <- liftE getPlatform
+                      req      <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
                       liftIO $ T.hPutStr stdout (prettyRequirements req)
                   )
                   >>= \case
@@ -1832,6 +1900,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
                           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,8 +1927,9 @@ Make sure to clean up #{tmpdir} afterwards.|])
                               Windows -> "start"
 
                   if clOpen
-                    then
+                    then do
-                      flip runReaderT appstate $
+                      s' <- appState
+                      flip runReaderT s' $
                         exec cmd
                              [T.unpack $ decUTF8Safe $ serializeURIRef' uri]
                              Nothing
@@ -1871,7 +1942,8 @@ Make sure to clean up #{tmpdir} afterwards.|])
 
             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
 

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
+  pfreq <- lift getPlatformReq
-           , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
+  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 {..}
+  PlatformRequest {..} <- lift getPlatformReq
-           , pfreq = PlatformRequest {..}
+  dirs@Dirs {..} <- lift getDirs
-           , settings } <- lift ask
+  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
+  pfreq <- lift getPlatformReq
-           , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
+  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 {..}
+  PlatformRequest {..} <- lift getPlatformReq
-           , pfreq = PlatformRequest {..}
+  dirs@Dirs {..} <- lift getDirs
-           , settings } <- lift ask
+  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
+  pfreq <- lift getPlatformReq
-           , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
+  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 {..}
+  PlatformRequest {..} <- lift getPlatformReq
-           , pfreq = PlatformRequest {..}
+  dirs@Dirs {..} <- lift getDirs
-           , settings
+  settings <- lift getSettings
-           } <- lift ask
 
   whenM (lift (stackInstalled ver))
     (throwE $ AlreadyInstalled Stack ver)
@@ -644,7 +682,8 @@ installStackBindist dlinfo ver = do
 --
 -- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/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
+    pfreq <- getPlatformReq
-             , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
+    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
+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 {..}
+    PlatformRequest { .. } <- lift getPlatformReq
-             , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }
+    GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
-             , settings
+    settings <- lift getSettings
-             , dirs } <- lift ask
+    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
@@ -1681,7 +1779,8 @@ HADDOCK_DOCS = YES|]
     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 {..}
+  Dirs {..} <- lift getDirs
-           , pfreq
+  pfreq <- lift getPlatformReq
-           , ghcupInfo = GHCupInfo { _ghcupDownloads = dls }
+  settings <- lift getSettings
-           , settings } <- lift ask
+  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-\<ver\>@
 --   * for stack, this reports @~\/.ghcup\/bin\/stack-\<ver\>@
 --   * 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
+
+
+

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
+  , ghcupInfo :: GHCupInfo
-  , pfreq :: ~PlatformRequest
+  , 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
 
-

lib/GHCup/Types/Optics.hs

@@ -1,4 +1,9 @@
 {-# 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
+

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/<dir>.
 -- 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,11 +491,11 @@ 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
+  Dirs {..}  <- getDirs
   wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
     binDir
     (makeRegexOpts
@@ -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")

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
+getAllDirs :: IO Dirs
-getDirs = do
+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

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

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)