Redo Settings as AppState

2020-10-24 01:06:53 +02:00
parent 0d41d180d6
commit e250d6013f
10 changed files with 199 additions and 189 deletions
--- 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'}|]
--- 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

--- 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/<dir>.
 -- 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
--- 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/<ghcupGHCDir>'.
 -- 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
--- 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
--- 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