From cafedd73a2fbabb5e87850613bb8b91e17c9efac Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 5 Aug 2020 21:50:39 +0200 Subject: [PATCH] Use Settings to avoid querying dirs every time --- app/ghcup-gen/Validate.hs | 4 +- app/ghcup/BrickMain.hs | 7 ++- app/ghcup/Main.hs | 28 +++++---- lib/GHCup.hs | 119 ++++++++++++++++++++------------------ lib/GHCup/Download.hs | 10 ++-- lib/GHCup/Types.hs | 4 +- lib/GHCup/Utils.hs | 72 ++++++++++++----------- lib/GHCup/Utils/File.hs | 6 +- lib/GHCup/Utils/Logger.hs | 20 ++++--- 9 files changed, 140 insertions(+), 130 deletions(-) diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 4dc214f..cec2130 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -7,6 +7,7 @@ module Validate where import GHCup import GHCup.Download import GHCup.Types +import GHCup.Utils.Dirs import GHCup.Utils.Logger import Control.Exception.Safe @@ -180,7 +181,8 @@ validateTarballs dls = do where downloadAll dli = do - let settings = Settings True False Never Curl False + dirs <- liftIO getDirs + let settings = Settings True False Never Curl False dirs let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True , colorOutter = B.hPut stderr , rawOutter = (\_ -> pure ()) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index c3f526d..f563ced 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -297,14 +297,15 @@ uri' = unsafePerformIO (newIORef Nothing) settings' :: IORef Settings {-# NOINLINE settings' #-} -settings' = unsafePerformIO - (newIORef Settings { cache = True +settings' = unsafePerformIO $ do + dirs <- getDirs + newIORef Settings { cache = True , noVerify = False , keepDirs = Never , downloader = Curl , verbose = False + , .. } - ) logger' :: IORef LoggerConfig diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 5fd5172..7464ae5 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} @@ -818,14 +819,15 @@ bindistParser :: String -> Either String DownloadInfo bindistParser = eitherDecode . BLU.fromString -toSettings :: Options -> Settings -toSettings Options {..} = +toSettings :: Options -> IO Settings +toSettings Options {..} = do let cache = optCache noVerify = optNoVerify keepDirs = optKeepDirs downloader = optsDownloader verbose = optVerbose - in Settings { .. } + dirs <- getDirs + pure $ Settings { .. } upgradeOptsP :: Parser UpgradeOpts @@ -901,16 +903,13 @@ Report bugs at |] (footerDoc (Just $ text main_footer)) ) >>= \opt@Options {..} -> do - let settings@Settings{..} = toSettings opt - - logsDir <- toFilePath <$> ghcupLogsDir + settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt -- create ~/.ghcup dir - ghcdir <- ghcupBaseDir - createDirRecursive newDirPerms ghcdir + createDirRecursive newDirPerms baseDir -- logger interpreter - logfile <- initGHCupFileLogging [rel|ghcup.log|] + logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|] let loggerConfig = LoggerConfig { lcPrintDebug = optVerbose , colorOutter = B.hPut stderr @@ -956,12 +955,13 @@ Report bugs at |] let runSetCabal = runLogger + . flip runReaderT settings . runE @'[ NotInstalled , TagNotFound ] - let runListGHC = runLogger + let runListGHC = runLogger . flip runReaderT settings let runRm = runLogger . flip runReaderT settings . runE @'[NotInstalled] @@ -1054,7 +1054,7 @@ Report bugs at |] case optCommand of Upgrade _ _ -> pure () - _ -> runLogger $ checkForUpdates dls pfreq + _ -> runLogger $ flip runReaderT settings $ checkForUpdates dls pfreq @@ -1277,9 +1277,7 @@ Make sure to clean up #{tmpdir} afterwards.|]) p <- parseAbs . E.encodeUtf8 . T.pack $ efp pure $ Just p (UpgradeAt p) -> pure $ Just p - UpgradeGHCupDir -> do - bdir <- liftIO $ ghcupBinDir - pure (Just (bdir [rel|ghcup|])) + UpgradeGHCupDir -> pure (Just (binDir [rel|ghcup|])) (runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case VRight v' -> do @@ -1431,7 +1429,7 @@ printListResult raw lr = do True -> flip const False -> color -checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m) +checkForUpdates :: (MonadReader Settings m, MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m) => GHCupDownloads -> PlatformRequest -> m () diff --git a/lib/GHCup.hs b/lib/GHCup.hs index bdfacd5..84b993e 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -121,7 +121,7 @@ installGHCBindist :: ( MonadFail m installGHCBindist dlinfo ver (PlatformRequest {..}) = do let tver = (mkTVer ver) lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] - whenM (liftIO $ ghcInstalled tver) + whenM (lift $ ghcInstalled tver) $ (throwE $ AlreadyInstalled GHC ver) -- download (or use cached version) @@ -133,7 +133,7 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do void $ liftIO $ darwinNotarization _rPlatform tmpUnpack -- prepare paths - ghcdir <- liftIO $ ghcupGHCDir tver + ghcdir <- lift $ ghcupGHCDir tver -- the subdir of the archive where we do the work let workdir = maybe tmpUnpack (tmpUnpack ) (view dlSubdir dlinfo) @@ -230,14 +230,14 @@ installCabalBindist :: ( MonadMask m installCabalBindist dlinfo ver (PlatformRequest {..}) = do lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] - bindir <- liftIO ghcupBinDir + Settings {dirs = Dirs {..}} <- lift ask whenM - (liftIO $ cabalInstalled ver >>= \a -> + (lift (cabalInstalled ver) >>= \a -> liftIO $ handleIO (\_ -> pure False) $ fmap (\x -> a && isSymbolicLink x) -- ignore when the installation is a legacy cabal (binary, not symlink) - $ getSymbolicLinkStatus (toFilePath (bindir [rel|cabal|])) + $ getSymbolicLinkStatus (toFilePath (binDir [rel|cabal|])) ) $ (throwE $ AlreadyInstalled Cabal ver) @@ -252,10 +252,10 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do -- the subdir of the archive where we do the work let workdir = maybe tmpUnpack (tmpUnpack ) (view dlSubdir dlinfo) - liftE $ installCabal' workdir bindir + liftE $ installCabal' workdir binDir -- create symlink if this is the latest version - cVers <- liftIO $ fmap rights $ getInstalledCabals + cVers <- lift $ fmap rights $ getInstalledCabals let lInstCabal = headMay . reverse . sort $ cVers when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver @@ -328,17 +328,17 @@ installCabalBin bDls ver pfreq = do -- -- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\\/share symlink@ -- for 'SetGHCOnly' constructor. -setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) +setGHC :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) => GHCTargetVersion -> SetGHC -> Excepts '[NotInstalled] m GHCTargetVersion setGHC ver sghc = do let verBS = verToBS (_tvVersion ver) - ghcdir <- liftIO $ ghcupGHCDir ver + ghcdir <- lift $ ghcupGHCDir ver -- symlink destination - bindir <- liftIO $ ghcupBinDir - liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir + Settings {dirs = Dirs {..}} <- lift ask + liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir -- first delete the old symlinks (this fixes compatibility issues -- with old ghcup) @@ -359,8 +359,8 @@ setGHC ver sghc = do SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS) -- create symlink - let fullF = bindir targetFile - destL <- ghcLinkDestination (toFilePath file) ver + let fullF = binDir targetFile + destL <- lift $ ghcLinkDestination (toFilePath file) ver lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|] liftIO $ createSymlink fullF destL @@ -371,12 +371,13 @@ setGHC ver sghc = do where - symlinkShareDir :: (MonadIO m, MonadLogger m) + symlinkShareDir :: (MonadReader Settings m, MonadIO m, MonadLogger m) => Path Abs -> ByteString -> m () symlinkShareDir ghcdir verBS = do - destdir <- liftIO $ ghcupBaseDir + Settings {dirs = Dirs {..}} <- ask + let destdir = baseDir case sghc of SetGHCOnly -> do let sharedir = [rel|share|] @@ -393,7 +394,7 @@ setGHC ver sghc = do -- | Set the @~\/.ghcup\/bin\/cabal@ symlink. -setCabal :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) +setCabal :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) => Version -> Excepts '[NotInstalled] m () setCabal ver = do @@ -401,14 +402,14 @@ setCabal ver = do targetFile <- parseRel ("cabal-" <> verBS) -- symlink destination - bindir <- liftIO $ ghcupBinDir - liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir + Settings {dirs = Dirs {..}} <- lift ask + liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir - whenM (liftIO $ fmap not $ doesFileExist (bindir targetFile)) + whenM (liftIO $ fmap not $ doesFileExist (binDir targetFile)) $ throwE $ NotInstalled Cabal (prettyVer ver) - let cabalbin = bindir [rel|cabal|] + let cabalbin = binDir [rel|cabal|] -- delete old file (may be binary or symlink) lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|] @@ -467,6 +468,7 @@ listVersions :: ( MonadCatch m , MonadThrow m , MonadLogger m , MonadIO m + , MonadReader Settings m ) => GHCupDownloads -> Maybe Tool @@ -478,7 +480,7 @@ listVersions av lt criteria pfreq = do Just t -> do -- get versions from GHCupDownloads let avTools = availableToolVersions av t - lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult t) + lr <- filter' <$> forM (Map.toList avTools) (toListResult t) case t of -- append stray GHCs @@ -493,7 +495,7 @@ listVersions av lt criteria pfreq = do pure (ghcvers <> cabalvers <> ghcupvers) where - strayGHCs :: (MonadThrow m, MonadLogger m, MonadIO m) + strayGHCs :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m) => Map.Map Version [Tag] -> m [ListResult] strayGHCs avTools = do @@ -504,7 +506,7 @@ listVersions av lt criteria pfreq = do Just _ -> pure Nothing Nothing -> do lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing - fromSrc <- liftIO $ ghcSrcInstalled tver + fromSrc <- ghcSrcInstalled tver pure $ Just $ ListResult { lTool = GHC , lVer = _tvVersion @@ -517,7 +519,7 @@ listVersions av lt criteria pfreq = do } Right tver@GHCTargetVersion{ .. } -> do lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget - fromSrc <- liftIO $ ghcSrcInstalled tver + fromSrc <- ghcSrcInstalled tver pure $ Just $ ListResult { lTool = GHC , lVer = _tvVersion @@ -534,7 +536,7 @@ listVersions av lt criteria pfreq = do pure Nothing -- NOTE: this are not cross ones, because no bindists - toListResult :: Tool -> (Version, [Tag]) -> IO ListResult + toListResult :: (MonadReader Settings m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult toListResult t (v, tags) = case t of GHC -> do let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av @@ -587,12 +589,12 @@ listVersions av lt criteria pfreq = do -- This may leave GHCup without a "set" version. -- Will try to fix the ghc-x.y symlink after removal (e.g. to an -- older version). -rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m) +rmGHCVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m) => GHCTargetVersion -> Excepts '[NotInstalled] m () rmGHCVer ver = do - isSetGHC <- fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver) - dir <- liftIO $ ghcupGHCDir ver + isSetGHC <- lift $ fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver) + dir <- lift $ ghcupGHCDir ver let d' = toFilePath dir exists <- liftIO $ doesDirectoryExist dir @@ -615,36 +617,38 @@ rmGHCVer ver = do lift $ rmMajorSymlinks ver -- then fix them (e.g. with an earlier version) (mj, mi) <- getMajorMinorV (_tvVersion ver) - getGHCForMajor mj mi (_tvTarget ver) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) + lift (getGHCForMajor mj mi (_tvTarget ver)) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) + + Settings {dirs = Dirs {..}} <- lift ask liftIO - $ ghcupBaseDir - >>= hideError doesNotExistErrorType - . deleteFile - . ( [rel|share|]) + $ hideError doesNotExistErrorType + $ deleteFile + $ (baseDir [rel|share|]) else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer)) -- | Delete a cabal version. Will try to fix the @cabal@ symlink -- after removal (e.g. setting it to an older version). -rmCabalVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m) +rmCabalVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m) => Version -> Excepts '[NotInstalled] m () rmCabalVer ver = do - whenM (fmap not $ liftIO $ cabalInstalled ver) $ throwE (NotInstalled Cabal (prettyVer ver)) + whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (prettyVer ver)) - cSet <- liftIO cabalSet + cSet <- lift $ cabalSet + + Settings {dirs = Dirs {..}} <- lift ask - bindir <- liftIO ghcupBinDir cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver) - liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir cabalFile) + liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir cabalFile) when (maybe False (== ver) cSet) $ do - cVers <- liftIO $ fmap rights $ getInstalledCabals + cVers <- lift $ fmap rights $ getInstalledCabals case headMay . reverse . sort $ cVers of Just latestver -> setCabal latestver Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile - (bindir [rel|cabal|]) + (binDir [rel|cabal|]) @@ -653,18 +657,19 @@ rmCabalVer ver = do ------------------ -getDebugInfo :: (MonadLogger m, MonadCatch m, MonadIO m) +getDebugInfo :: (MonadReader Settings m, MonadLogger m, MonadCatch m, MonadIO m) => Excepts '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] m DebugInfo getDebugInfo = do - diBaseDir <- liftIO $ ghcupBaseDir - diBinDir <- liftIO $ ghcupBinDir - diGHCDir <- liftIO $ ghcupGHCBaseDir - diCacheDir <- liftIO $ ghcupCacheDir - diArch <- lE getArchitecture - diPlatform <- liftE $ getPlatform + Settings {dirs = Dirs {..}} <- lift ask + let diBaseDir = baseDir + let diBinDir = binDir + diGHCDir <- lift ghcupGHCBaseDir + let diCacheDir = cacheDir + diArch <- lE getArchitecture + diPlatform <- liftE $ getPlatform pure $ DebugInfo { .. } @@ -711,7 +716,7 @@ compileGHC :: ( MonadMask m () compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|] - whenM (liftIO $ ghcInstalled tver) + whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC (tver ^. tvVersion)) -- download source tarball @@ -729,7 +734,7 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} Right g -> pure $ Right g Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver) let workdir = maybe id (flip ()) (view dlSubdir dlInfo) $ tmpUnpack - ghcdir <- liftIO $ ghcupGHCDir tver + ghcdir <- lift $ ghcupGHCDir tver liftE $ runBuildAction tmpUnpack @@ -892,14 +897,14 @@ compileCabal :: ( MonadReader Settings m compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|] - bindir <- liftIO ghcupBinDir + Settings {dirs = Dirs {..}} <- lift ask whenM - (liftIO $ cabalInstalled tver >>= \a -> + (lift (cabalInstalled tver) >>= \a -> liftIO $ handleIO (\_ -> pure False) $ fmap (\x -> a && isSymbolicLink x) -- ignore when the installation is a legacy cabal (binary, not symlink) - $ getSymbolicLinkStatus (toFilePath (bindir [rel|cabal|])) + $ getSymbolicLinkStatus (toFilePath (binDir [rel|cabal|])) ) $ (throwE $ AlreadyInstalled Cabal tver) @@ -919,11 +924,11 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do destFileName <- lift $ parseRel ("cabal-" <> verToBS tver) handleIO (throwE . CopyError . show) $ liftIO $ copyFile cbin - (bindir destFileName) + (binDir destFileName) Overwrite -- create symlink if this is the latest version - cVers <- liftIO $ fmap rights $ getInstalledCabals + cVers <- lift $ fmap rights $ getInstalledCabals let lInstCabal = headMay . reverse . sort $ cVers when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver @@ -1004,6 +1009,7 @@ upgradeGHCup :: ( MonadMask m m Version upgradeGHCup dls mtarget force pfreq = do + Settings {dirs = Dirs {..}} <- lift ask lift $ $(logInfo) [i|Upgrading GHCup...|] let latestVer = fromJust $ getLatest dls GHCup when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate @@ -1016,7 +1022,6 @@ upgradeGHCup dls mtarget force pfreq = do `unionFileModes` ownerExecuteMode `unionFileModes` groupExecuteMode `unionFileModes` otherExecuteMode - binDir <- liftIO $ ghcupBinDir let fullDest = fromMaybe (binDir fn) mtarget liftIO $ hideError NoSuchThing $ deleteFile fullDest handleIO (throwE . CopyError . show) $ liftIO $ copyFile p @@ -1034,7 +1039,7 @@ upgradeGHCup dls mtarget force pfreq = do -- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for -- both installing from source and bindist. -postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) +postGHCInstall :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) => GHCTargetVersion -> Excepts '[NotInstalled] m () postGHCInstall ver@GHCTargetVersion{..} = do @@ -1043,4 +1048,4 @@ postGHCInstall ver@GHCTargetVersion{..} = do -- Create ghc-x.y symlinks. This may not be the current -- version, create it regardless. (mj, mi) <- getMajorMinorV _tvVersion - getGHCForMajor mj mi _tvTarget >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) + lift (getGHCForMajor mj mi _tvTarget) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 45ff181..ea59551 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -133,10 +133,10 @@ getDownloadsF urlSource = do (OwnSpec _) -> liftE $ getDownloads urlSource where readFromCache = do + Settings {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 - cacheDir <- liftIO $ ghcupCacheDir yaml_file <- (cacheDir ) <$> urlBaseName path bs <- handleIO' NoSuchThing @@ -200,8 +200,8 @@ getDownloads urlSource = do m1 L.ByteString smartDl uri' = do + Settings {dirs = Dirs {..}} <- lift ask let path = view pathL' uri' - cacheDir <- liftIO $ ghcupCacheDir json_file <- (cacheDir ) <$> urlBaseName path e <- liftIO $ doesFileExist json_file if e @@ -392,15 +392,15 @@ downloadCached dli mfn = do cache <- lift getCache case cache of True -> do - cachedir <- liftIO $ ghcupCacheDir + Settings {dirs = Dirs {..}} <- lift ask fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn - let cachfile = cachedir fn + let cachfile = cacheDir fn fileExists <- liftIO $ doesFileExist cachfile if | fileExists -> do liftE $ checkDigest dli cachfile pure $ cachfile - | otherwise -> liftE $ download dli cachedir mfn + | otherwise -> liftE $ download dli cacheDir mfn False -> do tmp <- lift withGHCupTmpDir liftE $ download dli tmp mfn diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 0a49cfc..2e8374a 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -158,14 +158,14 @@ data URLSource = GHCupURL data Settings = Settings - { -- * set by user + { -- set by user cache :: Bool , noVerify :: Bool , keepDirs :: KeepDirs , downloader :: Downloader , verbose :: Bool - -- * set on app start + -- set on app start , dirs :: Dirs } deriving Show diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 8c02886..445b187 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -97,24 +97,24 @@ import qualified Text.Megaparsec as MP -- | The symlink destination of a ghc tool. -ghcLinkDestination :: (MonadThrow m, MonadIO m) +ghcLinkDestination :: (MonadReader Settings m, MonadThrow m, MonadIO m) => ByteString -- ^ the tool, such as 'ghc', 'haddock' etc. -> GHCTargetVersion -> m ByteString ghcLinkDestination tool ver = do + Settings {dirs = Dirs {..}} <- ask t <- parseRel tool - bin <- liftIO ghcupBinDir - ghcd <- liftIO $ ghcupGHCDir ver - pure (relativeSymlink bin (ghcd [rel|bin|] t)) + ghcd <- ghcupGHCDir ver + pure (relativeSymlink binDir (ghcd [rel|bin|] t)) -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5. -rmMinorSymlinks :: (MonadIO m, MonadLogger m) => GHCTargetVersion -> m () +rmMinorSymlinks :: (MonadReader Settings m, MonadIO m, MonadLogger m) => GHCTargetVersion -> m () rmMinorSymlinks GHCTargetVersion {..} = do - bindir <- liftIO $ ghcupBinDir + Settings {dirs = Dirs {..}} <- ask files <- liftIO $ findFiles' - bindir + binDir ( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget *> parseUntil1 (MP.chunk $ prettyVer _tvVersion) *> (MP.chunk $ prettyVer _tvVersion) @@ -122,42 +122,41 @@ rmMinorSymlinks GHCTargetVersion {..} = do ) forM_ files $ \f -> do - let fullF = (bindir f) + let fullF = (binDir f) $(logDebug) [i|rm -f #{toFilePath fullF}|] liftIO $ hideError doesNotExistErrorType $ deleteFile fullF -- | Removes the set ghc version for the given target, if any. -rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) +rmPlain :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) => Maybe Text -- ^ target -> Excepts '[NotInstalled] m () rmPlain target = do - mtv <- ghcSet target + Settings {dirs = Dirs {..}} <- lift ask + mtv <- lift $ ghcSet target forM_ mtv $ \tv -> do files <- liftE $ ghcToolFiles tv - bindir <- liftIO $ ghcupBinDir forM_ files $ \f -> do - let fullF = (bindir f) + let fullF = (binDir f) lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|] liftIO $ hideError doesNotExistErrorType $ deleteFile fullF -- old ghcup - let hdc_file = (bindir [rel|haddock-ghc|]) + let hdc_file = (binDir [rel|haddock-ghc|]) lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|] liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file -- | Remove the major GHC symlink, e.g. ghc-8.6. -rmMajorSymlinks :: (MonadThrow m, MonadLogger m, MonadIO m) +rmMajorSymlinks :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m) => GHCTargetVersion -> m () rmMajorSymlinks GHCTargetVersion {..} = do + Settings {dirs = Dirs {..}} <- ask (mj, mi) <- getMajorMinorV _tvVersion let v' = intToText mj <> "." <> intToText mi - bindir <- liftIO ghcupBinDir - files <- liftIO $ findFiles' - bindir + binDir ( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget *> parseUntil1 (MP.chunk v') *> MP.chunk v' @@ -165,7 +164,7 @@ rmMajorSymlinks GHCTargetVersion {..} = do ) forM_ files $ \f -> do - let fullF = (bindir f) + let fullF = (binDir f) $(logDebug) [i|rm -f #{toFilePath fullF}|] liftIO $ hideError doesNotExistErrorType $ deleteFile fullF @@ -178,27 +177,28 @@ rmMajorSymlinks GHCTargetVersion {..} = do -- | Whethe the given GHC versin is installed. -ghcInstalled :: GHCTargetVersion -> IO Bool +ghcInstalled :: (MonadIO m, MonadReader Settings m, MonadThrow m) => GHCTargetVersion -> m Bool ghcInstalled ver = do ghcdir <- ghcupGHCDir ver - doesDirectoryExist ghcdir + liftIO $ doesDirectoryExist ghcdir -- | Whether the given GHC version is installed from source. -ghcSrcInstalled :: GHCTargetVersion -> IO Bool +ghcSrcInstalled :: (MonadIO m, MonadReader Settings m, MonadThrow m) => GHCTargetVersion -> m Bool ghcSrcInstalled ver = do ghcdir <- ghcupGHCDir ver - doesFileExist (ghcdir ghcUpSrcBuiltFile) + liftIO $ doesFileExist (ghcdir ghcUpSrcBuiltFile) -- | Whether the given GHC version is set as the current. -ghcSet :: (MonadThrow m, MonadIO m) +ghcSet :: (MonadReader Settings 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 ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget) - ghcBin <- ( ghc) <$> liftIO ghcupBinDir + let ghcBin = binDir ghc -- link destination is of the form ../ghc//bin/ghc -- for old ghcup, it is ../ghc//bin/ghc- @@ -229,9 +229,9 @@ ghcLinkVersion bs = do -- | Get all installed GHCs by reading ~/.ghcup/ghc/. -- If a dir cannot be parsed, returns left. -getInstalledGHCs :: MonadIO m => m [Either (Path Rel) GHCTargetVersion] +getInstalledGHCs :: (MonadReader Settings m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion] getInstalledGHCs = do - ghcdir <- liftIO $ ghcupGHCBaseDir + ghcdir <- ghcupGHCBaseDir fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir forM fs $ \f -> case parseGHCupGHCDir f of Right r -> pure $ Right r @@ -239,11 +239,12 @@ getInstalledGHCs = do -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@. -getInstalledCabals :: IO [Either (Path Rel) Version] +getInstalledCabals :: (MonadReader Settings m, MonadIO m, MonadCatch m) + => m [Either (Path Rel) Version] getInstalledCabals = do - bindir <- liftIO $ ghcupBinDir + Settings {dirs = Dirs {..}} <- ask bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles - bindir + binDir (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString)) vs <- forM bins $ \f -> case fmap version (fmap decUTF8Safe . B.stripPrefix "cabal-" . toFilePath $ f) of Just (Right r) -> pure $ Right r @@ -254,16 +255,17 @@ getInstalledCabals = do -- | Whether the given cabal version is installed. -cabalInstalled :: Version -> IO Bool +cabalInstalled :: (MonadIO m, MonadReader Settings 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 :: (MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) +cabalSet :: (MonadReader Settings m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) cabalSet = do - cabalbin <- ( [rel|cabal|]) <$> liftIO ghcupBinDir + Settings {dirs = Dirs {..}} <- ask + let cabalbin = binDir [rel|cabal|] b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin if | b -> do @@ -319,7 +321,7 @@ matchMajor v' major' minor' = case getMajorMinorV v' of -- | Get the latest installed full GHC version that satisfies X.Y. -- This reads `ghcupGHCBaseDir`. -getGHCForMajor :: (MonadIO m, MonadThrow m) +getGHCForMajor :: (MonadReader Settings m, MonadIO m, MonadThrow m) => Int -- ^ major version component -> Int -- ^ minor version component -> Maybe Text -- ^ the target triple @@ -463,11 +465,11 @@ 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 :: (MonadThrow m, MonadFail m, MonadIO m) +ghcToolFiles :: (MonadReader Settings m, MonadThrow m, MonadFail m, MonadIO m) => GHCTargetVersion -> Excepts '[NotInstalled] m [Path Rel] ghcToolFiles ver = do - ghcdir <- liftIO $ ghcupGHCDir ver + ghcdir <- lift $ ghcupGHCDir ver let bindir = ghcdir [rel|bin|] -- fail if ghc is not installed diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index be16bd5..8ddae18 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -17,7 +17,6 @@ Some of these functions use sophisticated logging. -} module GHCup.Utils.File where -import GHCup.Utils.Dirs import GHCup.Utils.Prelude import GHCup.Types @@ -123,9 +122,8 @@ 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 {..} <- ask - ldir <- liftIO ghcupLogsDir - logfile <- (ldir ) <$> parseRel (toFilePath lfile <> ".log") + Settings {dirs = Dirs {..}, ..} <- ask + logfile <- (logsDir ) <$> parseRel (toFilePath lfile <> ".log") liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) closeFd (action verbose) diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index 2e58cc1..0ff0004 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Utils/Logger.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} {-| Module : GHCup.Utils.Logger @@ -13,9 +14,11 @@ Here we define our main logger. -} module GHCup.Utils.Logger where -import GHCup.Utils +import GHCup.Types import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader import Control.Monad.Logger import HPath import HPath.IO @@ -61,11 +64,12 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger rawOutter outr -initGHCupFileLogging :: Path Rel -> IO (Path Abs) +initGHCupFileLogging :: (MonadIO m, MonadReader Settings m) => Path Rel -> m (Path Abs) initGHCupFileLogging context = do - logs <- ghcupLogsDir - let logfile = logs context - createDirRecursive newDirPerms logs - hideError doesNotExistErrorType $ deleteFile logfile - createRegularFile newFilePerms logfile - pure logfile + Settings {dirs = Dirs {..}} <- ask + let logfile = logsDir context + liftIO $ do + createDirRecursive newDirPerms logsDir + hideError doesNotExistErrorType $ deleteFile logfile + createRegularFile newFilePerms logfile + pure logfile