hasufell
/
ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Redo Settings as AppState

This commit is contained in:
Julian Ospald 2020-10-24 01:06:53 +02:00
parent 0d41d180d6
commit e250d6013f
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
10 changed files with 199 additions and 189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
app/ghcup-gen/Validate.hs
View File

@ -193,7 +193,7 @@ validateTarballs dls = do
where where
downloadAll dli = do downloadAll dli = do
dirs <- liftIO getDirs dirs <- liftIO getDirs
let settings = Settings True False Never Curl False dirs let settings = AppState (Settings True False Never Curl False) dirs
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr , colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ()) , rawOutter = (\_ -> pure ())

126
app/ghcup/BrickMain.hs
View File

@ -55,35 +55,35 @@ import qualified Data.Vector as V
data AppData = AppData data BrickData = BrickData
{ lr :: [ListResult] { lr :: [ListResult]
, dls :: GHCupDownloads , dls :: GHCupDownloads
, pfreq :: PlatformRequest , pfreq :: PlatformRequest
} }
deriving Show deriving Show
data AppSettings = AppSettings data BrickSettings = BrickSettings
{ showAll :: Bool { showAll :: Bool
} }
deriving Show deriving Show
data AppInternalState = AppInternalState data BrickInternalState = BrickInternalState
{ clr :: Vector ListResult { clr :: Vector ListResult
, ix :: Int , ix :: Int
} }
deriving Show deriving Show
data AppState = AppState data BrickState = BrickState
{ appData :: AppData { appData :: BrickData
, appSettings :: AppSettings , appSettings :: BrickSettings
, appState :: AppInternalState , appState :: BrickInternalState
} }
deriving Show deriving Show
keyHandlers :: [ ( Char keyHandlers :: [ ( Char
, AppSettings -> String , BrickSettings -> String
, AppState -> EventM n (Next AppState) , BrickState -> EventM n (Next BrickState)
) )
] ]
keyHandlers = keyHandlers =
@ -93,21 +93,21 @@ keyHandlers =
, ('s', const "Set" , withIOAction set') , ('s', const "Set" , withIOAction set')
, ('c', const "ChangeLog", withIOAction changelog') , ('c', const "ChangeLog", withIOAction changelog')
, ( 'a' , ( 'a'
, (\AppSettings {..} -> , (\BrickSettings {..} ->
if showAll then "Hide old versions" else "Show all versions" if showAll then "Hide old versions" else "Show all versions"
) )
, hideShowHandler , hideShowHandler
) )
] ]
where where
hideShowHandler (AppState {..}) = hideShowHandler (BrickState {..}) =
let newAppSettings = appSettings { showAll = not . showAll $ appSettings } let newAppSettings = appSettings { showAll = not . showAll $ appSettings }
newInternalState = constructList appData newAppSettings (Just appState) newInternalState = constructList appData newAppSettings (Just appState)
in continue (AppState appData newAppSettings newInternalState) in continue (BrickState appData newAppSettings newInternalState)
ui :: AppState -> Widget String ui :: BrickState -> Widget String
ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..} ui BrickState { appSettings = as@(BrickSettings {}), ..}
= ( padBottom Max = ( padBottom Max
$ ( withBorderStyle unicode $ ( withBorderStyle unicode
$ borderWithLabel (str "GHCup") $ borderWithLabel (str "GHCup")
@ -196,9 +196,9 @@ ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..}
-- available height. -- available height.
drawListElements :: (Int -> Bool -> ListResult -> Widget String) drawListElements :: (Int -> Bool -> ListResult -> Widget String)
-> Bool -> Bool
-> AppInternalState -> BrickInternalState
-> Widget String -> Widget String
drawListElements drawElem foc is@(AppInternalState clr _) = drawListElements drawElem foc is@(BrickInternalState clr _) =
Widget Greedy Greedy $ Widget Greedy Greedy $
let let
es = clr es = clr
@ -228,7 +228,7 @@ minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ') minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
app :: App AppState e String app :: App BrickState e String
app = App { appDraw = \st -> [ui st] app = App { appDraw = \st -> [ui st]
, appHandleEvent = eventHandler , appHandleEvent = eventHandler
, appStartEvent = return , appStartEvent = return
@ -261,14 +261,14 @@ dimAttributes = attrMap
, ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) , ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
] ]
eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState) eventHandler :: BrickState -> BrickEvent n e -> EventM n (Next BrickState)
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) = eventHandler BrickState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
continue (AppState { appState = (moveCursor appState Up), .. }) continue (BrickState { appState = (moveCursor appState Up), .. })
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) = eventHandler BrickState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
continue (AppState { appState = (moveCursor appState Down), .. }) continue (BrickState { appState = (moveCursor appState Down), .. })
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) = eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
case find (\(c', _, _) -> c' == c) keyHandlers of case find (\(c', _, _) -> c' == c) keyHandlers of
Nothing -> continue as Nothing -> continue as
@ -276,19 +276,19 @@ eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
eventHandler st _ = continue st eventHandler st _ = continue st
moveCursor :: AppInternalState -> Direction -> AppInternalState moveCursor :: BrickInternalState -> Direction -> BrickInternalState
moveCursor ais@(AppInternalState {..}) direction = moveCursor ais@(BrickInternalState {..}) direction =
let newIx = if direction == Down then ix + 1 else ix - 1 let newIx = if direction == Down then ix + 1 else ix - 1
in case clr !? newIx of in case clr !? newIx of
Just _ -> AppInternalState { ix = newIx, .. } Just _ -> BrickInternalState { ix = newIx, .. }
Nothing -> ais Nothing -> ais
-- | Suspend the current UI and run an IO action in terminal. If the -- | Suspend the current UI and run an IO action in terminal. If the
-- IO action returns a Left value, then it's thrown as userError. -- IO action returns a Left value, then it's thrown as userError.
withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a)) withIOAction :: (BrickState -> (Int, ListResult) -> IO (Either String a))
-> AppState -> BrickState
-> EventM n (Next AppState) -> EventM n (Next BrickState)
withIOAction action as = case listSelectedElement' (appState as) of withIOAction action as = case listSelectedElement' (appState as) of
Nothing -> continue as Nothing -> continue as
Just (ix, e) -> suspendAndResume $ do Just (ix, e) -> suspendAndResume $ do
@ -304,26 +304,26 @@ withIOAction action as = case listSelectedElement' (appState as) of
-- | Update app data and list internal state based on new evidence. -- | Update app data and list internal state based on new evidence.
-- This synchronises @AppInternalState@ with @AppData@ -- This synchronises @BrickInternalState@ with @BrickData@
-- and @AppSettings@. -- and @BrickSettings@.
updateList :: AppData -> AppState -> AppState updateList :: BrickData -> BrickState -> BrickState
updateList appD (AppState {..}) = updateList appD (BrickState {..}) =
let newInternalState = constructList appD appSettings (Just appState) let newInternalState = constructList appD appSettings (Just appState)
in AppState { appState = newInternalState in BrickState { appState = newInternalState
, appData = appD , appData = appD
, appSettings = appSettings , appSettings = appSettings
} }
constructList :: AppData constructList :: BrickData
-> AppSettings -> BrickSettings
-> Maybe AppInternalState -> Maybe BrickInternalState
-> AppInternalState -> BrickInternalState
constructList appD appSettings mapp = constructList appD appSettings mapp =
replaceLR (filterVisible (showAll appSettings)) (lr appD) mapp replaceLR (filterVisible (showAll appSettings)) (lr appD) mapp
listSelectedElement' :: AppInternalState -> Maybe (Int, ListResult) listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
listSelectedElement' (AppInternalState {..}) = fmap (ix, ) $ clr !? ix listSelectedElement' (BrickInternalState {..}) = fmap (ix, ) $ clr !? ix
selectLatest :: Vector ListResult -> Int selectLatest :: Vector ListResult -> Int
@ -338,8 +338,8 @@ selectLatest v =
-- When passed an existing @appState@, tries to keep the selected element. -- When passed an existing @appState@, tries to keep the selected element.
replaceLR :: (ListResult -> Bool) replaceLR :: (ListResult -> Bool)
-> [ListResult] -> [ListResult]
-> Maybe AppInternalState -> Maybe BrickInternalState
-> AppInternalState -> BrickInternalState
replaceLR filterF lr s = replaceLR filterF lr s =
let oldElem = s >>= listSelectedElement' let oldElem = s >>= listSelectedElement'
newVec = V.fromList . filter filterF $ lr newVec = V.fromList . filter filterF $ lr
@ -347,7 +347,7 @@ replaceLR filterF lr s =
case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of
Just ix -> ix Just ix -> ix
Nothing -> selectLatest newVec Nothing -> selectLatest newVec
in AppInternalState newVec newSelected in BrickInternalState newVec newSelected
where where
toolEqual e1 e2 = toolEqual e1 e2 =
lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2 lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
@ -359,8 +359,8 @@ filterVisible showAll e | lInstalled e = True
| otherwise = not (elem Old (lTag e)) | otherwise = not (elem Old (lTag e))
install' :: AppState -> (Int, ListResult) -> IO (Either String ()) install' :: BrickState -> (Int, ListResult) -> IO (Either String ())
install' AppState { appData = AppData {..} } (_, ListResult {..}) = do install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
settings <- readIORef settings' settings <- readIORef settings'
l <- readIORef logger' l <- readIORef logger'
let runLogger = myLoggerT l let runLogger = myLoggerT l
@ -406,7 +406,7 @@ install' AppState { appData = AppData {..} } (_, ListResult {..}) = do
Also check the logs in ~/.ghcup/logs|] Also check the logs in ~/.ghcup/logs|]
set' :: AppState -> (Int, ListResult) -> IO (Either String ()) set' :: BrickState -> (Int, ListResult) -> IO (Either String ())
set' _ (_, ListResult {..}) = do set' _ (_, ListResult {..}) = do
settings <- readIORef settings' settings <- readIORef settings'
l <- readIORef logger' l <- readIORef logger'
@ -429,7 +429,7 @@ set' _ (_, ListResult {..}) = do
VLeft e -> pure $ Left [i|#{e}|] VLeft e -> pure $ Left [i|#{e}|]
del' :: AppState -> (Int, ListResult) -> IO (Either String ()) del' :: BrickState -> (Int, ListResult) -> IO (Either String ())
del' _ (_, ListResult {..}) = do del' _ (_, ListResult {..}) = do
settings <- readIORef settings' settings <- readIORef settings'
l <- readIORef logger' l <- readIORef logger'
@ -449,8 +449,8 @@ del' _ (_, ListResult {..}) = do
VLeft e -> pure $ Left [i|#{e}|] VLeft e -> pure $ Left [i|#{e}|]
changelog' :: AppState -> (Int, ListResult) -> IO (Either String ()) changelog' :: BrickState -> (Int, ListResult) -> IO (Either String ())
changelog' AppState { appData = AppData {..} } (_, ListResult {..}) = do changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
case getChangeLog dls lTool (Left lVer) of case getChangeLog dls lTool (Left lVer) of
Nothing -> pure $ Left Nothing -> pure $ Left
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|] [i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
@ -469,17 +469,19 @@ uri' :: IORef (Maybe URI)
uri' = unsafePerformIO (newIORef Nothing) uri' = unsafePerformIO (newIORef Nothing)
settings' :: IORef Settings settings' :: IORef AppState
{-# NOINLINE settings' #-} {-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do settings' = unsafePerformIO $ do
dirs <- getDirs dirs <- getDirs
newIORef Settings { cache = True newIORef $ AppState (Settings { cache = True
, noVerify = False , noVerify = False
, keepDirs = Never , keepDirs = Never
, downloader = Curl , downloader = Curl
, verbose = False , verbose = False
, .. , ..
} })
dirs
logger' :: IORef LoggerConfig logger' :: IORef LoggerConfig
@ -492,7 +494,7 @@ logger' = unsafePerformIO
) )
brickMain :: Settings brickMain :: AppState
-> Maybe URI -> Maybe URI
-> LoggerConfig -> LoggerConfig
-> GHCupDownloads -> GHCupDownloads
@ -510,7 +512,7 @@ brickMain s muri l av pfreq' = do
Right ad -> Right ad ->
defaultMain defaultMain
app app
(AppState ad (BrickState ad
defaultAppSettings defaultAppSettings
(constructList ad defaultAppSettings Nothing) (constructList ad defaultAppSettings Nothing)
) )
@ -520,8 +522,8 @@ brickMain s muri l av pfreq' = do
exitWith $ ExitFailure 2 exitWith $ ExitFailure 2
defaultAppSettings :: AppSettings defaultAppSettings :: BrickSettings
defaultAppSettings = AppSettings { showAll = False } defaultAppSettings = BrickSettings { showAll = False }
getDownloads' :: IO (Either String GHCupDownloads) getDownloads' :: IO (Either String GHCupDownloads)
@ -546,7 +548,7 @@ getDownloads' = do
getAppData :: Maybe GHCupDownloads getAppData :: Maybe GHCupDownloads
-> PlatformRequest -> PlatformRequest
-> IO (Either String AppData) -> IO (Either String BrickData)
getAppData mg pfreq' = do getAppData mg pfreq' = do
settings <- readIORef settings' settings <- readIORef settings'
l <- readIORef logger' l <- readIORef logger'
@ -558,6 +560,6 @@ getAppData mg pfreq' = do
case r of case r of
Right dls -> do Right dls -> do
lV <- listVersions dls Nothing Nothing pfreq' lV <- listVersions dls Nothing Nothing pfreq'
pure $ Right $ (AppData (reverse lV) dls pfreq') pure $ Right $ (BrickData (reverse lV) dls pfreq')
Left e -> pure $ Left [i|#{e}|] Left e -> pure $ Left [i|#{e}|]

55
app/ghcup/Main.hs
View File

@ -856,7 +856,7 @@ bindistParser :: String -> Either String URI
bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
toSettings :: Options -> IO Settings toSettings :: Options -> IO AppState
toSettings Options {..} = do toSettings Options {..} = do
let cache = optCache let cache = optCache
noVerify = optNoVerify noVerify = optNoVerify
@ -864,7 +864,7 @@ toSettings Options {..} = do
downloader = optsDownloader downloader = optsDownloader
verbose = optVerbose verbose = optVerbose
dirs <- getDirs dirs <- getDirs
pure $ Settings { .. } pure $ AppState (Settings { .. }) dirs
upgradeOptsP :: Parser UpgradeOpts upgradeOptsP :: Parser UpgradeOpts
@ -940,13 +940,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(footerDoc (Just $ text main_footer)) (footerDoc (Just $ text main_footer))
) )
>>= \opt@Options {..} -> do >>= \opt@Options {..} -> do
settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt appstate@AppState{dirs = Dirs{..}, ..} <- toSettings opt
-- create ~/.ghcup dir -- create ~/.ghcup dir
createDirRecursive' baseDir createDirRecursive' baseDir
-- logger interpreter -- logger interpreter
logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|] logfile <- flip runReaderT appstate $ initGHCupFileLogging [rel|ghcup.log|]
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = optVerbose { lcPrintDebug = optVerbose
, colorOutter = B.hPut stderr , colorOutter = B.hPut stderr
@ -959,9 +959,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- Effect interpreters -- -- Effect interpreters --
------------------------- -------------------------
let runInstTool' settings' = let runInstTool' appstate' =
runLogger runLogger
. flip runReaderT settings' . flip runReaderT appstate'
. runResourceT . runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
@ -980,12 +980,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TarDirDoesNotExist , TarDirDoesNotExist
] ]
let runInstTool = runInstTool' settings let runInstTool = runInstTool' appstate
let let
runSetGHC = runSetGHC =
runLogger runLogger
. flip runReaderT settings . flip runReaderT appstate
. runE . runE
@'[ FileDoesNotExistError @'[ FileDoesNotExistError
, NotInstalled , NotInstalled
@ -995,7 +995,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let let
runSetCabal = runSetCabal =
runLogger runLogger
. flip runReaderT settings . flip runReaderT appstate
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
@ -1004,26 +1004,26 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let let
runSetHLS = runSetHLS =
runLogger runLogger
. flip runReaderT settings . flip runReaderT appstate
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
] ]
let runListGHC = runLogger . flip runReaderT settings let runListGHC = runLogger . flip runReaderT appstate
let runRm = let runRm =
runLogger . flip runReaderT settings . runE @'[NotInstalled] runLogger . flip runReaderT appstate . runE @'[NotInstalled]
let runDebugInfo = let runDebugInfo =
runLogger runLogger
. flip runReaderT settings . flip runReaderT appstate
. runE . runE
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC = let runCompileGHC =
runLogger runLogger
. flip runReaderT settings . flip runReaderT appstate
. runResourceT . runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
@ -1044,7 +1044,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runUpgrade = let runUpgrade =
runLogger runLogger
. flip runReaderT settings . flip runReaderT appstate
. runResourceT . runResourceT
. runE . runE
@'[ DigestError @'[ DigestError
@ -1072,7 +1072,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(GHCupInfo treq dls) <- (GHCupInfo treq dls) <-
( runLogger ( runLogger
. flip runReaderT settings . flip runReaderT appstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError] . runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE $ liftE
$ getDownloadsF (maybe GHCupURL OwnSource optUrlSource) $ getDownloadsF (maybe GHCupURL OwnSource optUrlSource)
@ -1086,7 +1086,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
case optCommand of case optCommand of
Upgrade _ _ -> pure () Upgrade _ _ -> pure ()
_ -> runLogger $ flip runReaderT settings $ checkForUpdates dls pfreq _ -> runLogger $ flip runReaderT appstate $ checkForUpdates dls pfreq
@ -1099,7 +1099,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Nothing -> runInstTool $ do Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> runInstTool' settings{noVerify = True} $ do Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} $ do
v <- liftE $ fromVersion dls instVer GHC v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBindist liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
@ -1115,7 +1115,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
[i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|] [i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|]
pure ExitSuccess pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of case keepDirs settings of
Never -> runLogger ($(logError) [i|Build failed with #{e}|]) Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> runLogger ($(logError) [i|Build failed with #{e} _ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues. Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
@ -1140,7 +1140,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Nothing -> runInstTool $ do Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> runInstTool' settings{noVerify = True} $ do Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do
v <- liftE $ fromVersion dls instVer Cabal v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBindist liftE $ installCabalBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
@ -1173,7 +1173,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Nothing -> runInstTool $ do Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer HLS v <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) liftE $ installHLSBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> runInstTool' settings{noVerify = True} $ do Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do
v <- liftE $ fromVersion dls instVer HLS v <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBindist liftE $ installHLSBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
@ -1272,7 +1272,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
res <- case optCommand of res <- case optCommand of
#if defined(BRICK) #if defined(BRICK)
Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess Interactive -> liftIO $ brickMain appstate optUrlSource loggerConfig dls pfreq >> pure ExitSuccess
#endif #endif
Install (Right iopts) -> do Install (Right iopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|]) runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
@ -1336,7 +1336,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
[i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|] [i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|]
pure ExitSuccess pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of case keepDirs settings of
Never -> runLogger ($(logError) [i|Build failed with #{e} Never -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at #{logsDir}|]) Check the logs at #{logsDir}|])
_ -> runLogger ($(logError) [i|Build failed with #{e} _ -> runLogger ($(logError) [i|Build failed with #{e}
@ -1602,7 +1602,14 @@ printListResult raw lr = do
| otherwise -> 1 | otherwise -> 1
checkForUpdates :: (MonadReader Settings m, MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m) checkForUpdates :: ( MonadReader AppState m
, MonadCatch m
, MonadLogger m
, MonadThrow m
, MonadIO m
, MonadFail m
, MonadLogger m
)
=> GHCupDownloads => GHCupDownloads
-> PlatformRequest -> PlatformRequest
-> m () -> m ()

74
lib/GHCup.hs
View File

@ -99,7 +99,7 @@ import qualified Data.Text.Encoding as E
installGHCBindist :: ( MonadFail m installGHCBindist :: ( MonadFail m
, MonadMask m , MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -142,7 +142,7 @@ installGHCBindist dlinfo ver pfreq = do
-- build system and nothing else. -- build system and nothing else.
installPackedGHC :: ( MonadMask m installPackedGHC :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -178,7 +178,7 @@ installPackedGHC dl msubdir inst ver pfreq@(PlatformRequest {..}) = do
-- | Install an unpacked GHC distribution. This only deals with the GHC -- | Install an unpacked GHC distribution. This only deals with the GHC
-- build system and nothing else. -- build system and nothing else.
installUnpackedGHC :: ( MonadReader Settings m installUnpackedGHC :: ( MonadReader AppState m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -214,7 +214,7 @@ installUnpackedGHC path inst ver (PlatformRequest {..}) = do
installGHCBin :: ( MonadFail m installGHCBin :: ( MonadFail m
, MonadMask m , MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -246,7 +246,7 @@ installGHCBin bDls ver pfreq = do
-- argument instead of looking it up from 'GHCupDownloads'. -- argument instead of looking it up from 'GHCupDownloads'.
installCabalBindist :: ( MonadMask m installCabalBindist :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -273,7 +273,7 @@ installCabalBindist :: ( MonadMask m
installCabalBindist dlinfo ver (PlatformRequest {..}) = do installCabalBindist dlinfo ver (PlatformRequest {..}) = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
whenM whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $ (lift (cabalInstalled ver) >>= \a -> liftIO $
@ -328,7 +328,7 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
-- the latest installed version. -- the latest installed version.
installCabalBin :: ( MonadMask m installCabalBin :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -361,7 +361,7 @@ installCabalBin bDls ver pfreq = do
-- argument instead of looking it up from 'GHCupDownloads'. -- argument instead of looking it up from 'GHCupDownloads'.
installHLSBindist :: ( MonadMask m installHLSBindist :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -388,7 +388,7 @@ installHLSBindist :: ( MonadMask m
installHLSBindist dlinfo ver (PlatformRequest {..}) = do installHLSBindist dlinfo ver (PlatformRequest {..}) = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|] lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
whenM (lift (hlsInstalled ver)) whenM (lift (hlsInstalled ver))
$ (throwE $ AlreadyInstalled HLS ver) $ (throwE $ AlreadyInstalled HLS ver)
@ -452,7 +452,7 @@ installHLSBindist dlinfo ver (PlatformRequest {..}) = do
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
installHLSBin :: ( MonadMask m installHLSBin :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -498,7 +498,7 @@ installHLSBin bDls ver pfreq = do
-- --
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@ -- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
-- for 'SetGHCOnly' constructor. -- for 'SetGHCOnly' constructor.
setGHC :: ( MonadReader Settings m setGHC :: ( MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -515,7 +515,7 @@ setGHC ver sghc = do
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))) whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer)))
-- symlink destination -- symlink destination
Settings { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
liftIO $ createDirRecursive' binDir liftIO $ createDirRecursive' binDir
-- first delete the old symlinks (this fixes compatibility issues -- first delete the old symlinks (this fixes compatibility issues
@ -556,12 +556,12 @@ setGHC ver sghc = do
where where
symlinkShareDir :: (MonadReader Settings m, MonadIO m, MonadLogger m) symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m)
=> Path Abs => Path Abs
-> ByteString -> ByteString
-> m () -> m ()
symlinkShareDir ghcdir verBS = do symlinkShareDir ghcdir verBS = do
Settings { dirs = Dirs {..} } <- ask AppState { dirs = Dirs {..} } <- ask
let destdir = baseDir let destdir = baseDir
case sghc of case sghc of
SetGHCOnly -> do SetGHCOnly -> do
@ -579,7 +579,7 @@ setGHC ver sghc = do
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink. -- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
setCabal :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) setCabal :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
setCabal ver = do setCabal ver = do
@ -587,7 +587,7 @@ setCabal ver = do
targetFile <- parseRel ("cabal-" <> verBS) targetFile <- parseRel ("cabal-" <> verBS)
-- symlink destination -- symlink destination
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
liftIO $ createDirRecursive' binDir liftIO $ createDirRecursive' binDir
whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile)) whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile))
@ -613,7 +613,7 @@ setCabal ver = do
-- | Set the haskell-language-server symlinks. -- | Set the haskell-language-server symlinks.
setHLS :: ( MonadCatch m setHLS :: ( MonadCatch m
, MonadReader Settings m , MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -622,7 +622,7 @@ setHLS :: ( MonadCatch m
=> Version => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
setHLS ver = do setHLS ver = do
Settings { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
liftIO $ createDirRecursive' binDir liftIO $ createDirRecursive' binDir
-- Delete old symlinks, since these might have different ghc versions than the -- Delete old symlinks, since these might have different ghc versions than the
@ -703,7 +703,7 @@ listVersions :: ( MonadCatch m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadReader Settings m , MonadReader AppState m
) )
=> GHCupDownloads => GHCupDownloads
-> Maybe Tool -> Maybe Tool
@ -736,7 +736,7 @@ listVersions av lt criteria pfreq = do
pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers) pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers)
where where
strayGHCs :: (MonadCatch m, MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m) strayGHCs :: (MonadCatch m, MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayGHCs avTools = do strayGHCs avTools = do
@ -778,7 +778,7 @@ listVersions av lt criteria pfreq = do
[i|Could not parse version of stray directory #{toFilePath e}|] [i|Could not parse version of stray directory #{toFilePath e}|]
pure Nothing pure Nothing
strayCabals :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) strayCabals :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayCabals avTools = do strayCabals avTools = do
@ -806,7 +806,7 @@ listVersions av lt criteria pfreq = do
[i|Could not parse version of stray directory #{toFilePath e}|] [i|Could not parse version of stray directory #{toFilePath e}|]
pure Nothing pure Nothing
strayHLS :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m) strayHLS :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayHLS avTools = do strayHLS avTools = do
@ -835,7 +835,7 @@ listVersions av lt criteria pfreq = do
pure Nothing pure Nothing
-- NOTE: this are not cross ones, because no bindists -- NOTE: this are not cross ones, because no bindists
toListResult :: (MonadReader Settings m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult toListResult :: (MonadReader AppState m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult
toListResult t (v, tags) = case t of toListResult t (v, tags) = case t of
GHC -> do GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
@ -904,7 +904,7 @@ listVersions av lt criteria pfreq = do
-- This may leave GHCup without a "set" version. -- This may leave GHCup without a "set" version.
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an -- Will try to fix the ghc-x.y symlink after removal (e.g. to an
-- older version). -- older version).
rmGHCVer :: ( MonadReader Settings m rmGHCVer :: ( MonadReader AppState m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -942,7 +942,7 @@ rmGHCVer ver = do
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver)) forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
Settings { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
liftIO liftIO
$ hideError doesNotExistErrorType $ hideError doesNotExistErrorType
@ -952,7 +952,7 @@ rmGHCVer ver = do
-- | Delete a cabal version. Will try to fix the @cabal@ symlink -- | Delete a cabal version. Will try to fix the @cabal@ symlink
-- after removal (e.g. setting it to an older version). -- after removal (e.g. setting it to an older version).
rmCabalVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m) rmCabalVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
=> Version => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmCabalVer ver = do rmCabalVer ver = do
@ -960,7 +960,7 @@ rmCabalVer ver = do
cSet <- lift $ cabalSet cSet <- lift $ cabalSet
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver) cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile) liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile)
@ -975,7 +975,7 @@ rmCabalVer ver = do
-- | Delete a hls version. Will try to fix the hls symlinks -- | Delete a hls version. Will try to fix the hls symlinks
-- after removal (e.g. setting it to an older version). -- after removal (e.g. setting it to an older version).
rmHLSVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m) rmHLSVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
=> Version => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmHLSVer ver = do rmHLSVer ver = do
@ -983,7 +983,7 @@ rmHLSVer ver = do
isHlsSet <- lift $ hlsSet isHlsSet <- lift $ hlsSet
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
bins <- lift $ hlsAllBinaries ver bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f) forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f)
@ -1008,13 +1008,13 @@ rmHLSVer ver = do
------------------ ------------------
getDebugInfo :: (MonadReader Settings m, MonadLogger m, MonadCatch m, MonadIO m) getDebugInfo :: (MonadReader AppState m, MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts => Excepts
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
m m
DebugInfo DebugInfo
getDebugInfo = do getDebugInfo = do
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
let diBaseDir = baseDir let diBaseDir = baseDir
let diBinDir = binDir let diBinDir = binDir
diGHCDir <- lift ghcupGHCBaseDir diGHCDir <- lift ghcupGHCBaseDir
@ -1034,7 +1034,7 @@ getDebugInfo = do
-- | Compile a GHC from source. This behaves wrt symlinks and installation -- | Compile a GHC from source. This behaves wrt symlinks and installation
-- the same as 'installGHCBin'. -- the same as 'installGHCBin'.
compileGHC :: ( MonadMask m compileGHC :: ( MonadMask m
, MonadReader Settings m , MonadReader AppState m
, MonadThrow m , MonadThrow m
, MonadResource m , MonadResource m
, MonadLogger m , MonadLogger m
@ -1135,7 +1135,7 @@ BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = NO HADDOCK_DOCS = NO
Stage1Only = YES|] Stage1Only = YES|]
compileBindist :: ( MonadReader Settings m compileBindist :: ( MonadReader AppState m
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
@ -1153,7 +1153,7 @@ Stage1Only = YES|]
lift $ $(logInfo) [i|configuring build|] lift $ $(logInfo) [i|configuring build|]
liftE $ checkBuildConfig liftE $ checkBuildConfig
Settings { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
@ -1270,7 +1270,7 @@ Stage1Only = YES|]
-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@, -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
-- if no path is provided. -- if no path is provided.
upgradeGHCup :: ( MonadMask m upgradeGHCup :: ( MonadMask m
, MonadReader Settings m , MonadReader AppState m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
@ -1292,7 +1292,7 @@ upgradeGHCup :: ( MonadMask m
m m
Version Version
upgradeGHCup dls mtarget force pfreq = do upgradeGHCup dls mtarget force pfreq = do
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
lift $ $(logInfo) [i|Upgrading GHCup...|] lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ getLatest dls GHCup let latestVer = fromJust $ getLatest dls GHCup
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
@ -1317,7 +1317,7 @@ upgradeGHCup dls mtarget force pfreq = do
-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for -- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
-- both installing from source and bindist. -- both installing from source and bindist.
postGHCInstall :: ( MonadReader Settings m postGHCInstall :: ( MonadReader AppState m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m

22
lib/GHCup/Download.hs
View File

@ -114,7 +114,7 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadReader Settings m , MonadReader AppState m
) )
=> URLSource => URLSource
-> Excepts -> Excepts
@ -133,7 +133,7 @@ getDownloadsF urlSource = do
(OwnSpec _) -> liftE $ getDownloads urlSource (OwnSpec _) -> liftE $ getDownloads urlSource
where where
readFromCache = do readFromCache = do
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
lift $ $(logWarn) lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|] [i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL let path = view pathL' ghcupURL
@ -155,7 +155,7 @@ getDownloads :: ( FromJSONKey Tool
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadReader Settings m , MonadReader AppState m
) )
=> URLSource => URLSource
-> Excepts '[JSONError , DownloadFailed] m GHCupInfo -> Excepts '[JSONError , DownloadFailed] m GHCupInfo
@ -185,7 +185,7 @@ getDownloads urlSource = do
, MonadIO m1 , MonadIO m1
, MonadFail m1 , MonadFail m1
, MonadLogger m1 , MonadLogger m1
, MonadReader Settings m1 , MonadReader AppState m1
) )
=> URI => URI
-> Excepts -> Excepts
@ -200,7 +200,7 @@ getDownloads urlSource = do
m1 m1
L.ByteString L.ByteString
smartDl uri' = do smartDl uri' = do
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
let path = view pathL' uri' let path = view pathL' uri'
json_file <- (cacheDir </>) <$> urlBaseName path json_file <- (cacheDir </>) <$> urlBaseName path
e <- liftIO $ doesFileExist json_file e <- liftIO $ doesFileExist json_file
@ -311,7 +311,7 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
-- --
-- The file must not exist. -- The file must not exist.
download :: ( MonadMask m download :: ( MonadMask m
, MonadReader Settings m , MonadReader AppState m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -383,7 +383,7 @@ downloadCached :: ( MonadMask m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadReader Settings m , MonadReader AppState m
) )
=> DownloadInfo => DownloadInfo
-> Maybe (Path Rel) -- ^ optional filename -> Maybe (Path Rel) -- ^ optional filename
@ -392,7 +392,7 @@ downloadCached dli mfn = do
cache <- lift getCache cache <- lift getCache
case cache of case cache of
True -> do True -> do
Settings {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
let cachfile = cacheDir </> fn let cachfile = cacheDir </> fn
fileExists <- liftIO $ doesFileExist cachfile fileExists <- liftIO $ doesFileExist cachfile
@ -416,7 +416,7 @@ downloadCached dli mfn = do
-- | This is used for downloading the JSON. -- | 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 => URI
-> Excepts -> Excepts
'[ FileDoesNotExistError '[ FileDoesNotExistError
@ -473,12 +473,12 @@ downloadBS uri'
#endif #endif
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader Settings m) checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m)
=> DownloadInfo => DownloadInfo
-> Path Abs -> Path Abs
-> Excepts '[DigestError] m () -> Excepts '[DigestError] m ()
checkDigest dli file = do checkDigest dli file = do
verify <- lift ask <&> (not . noVerify) verify <- lift ask <&> (not . noVerify . settings)
when verify $ do when verify $ do
p' <- toFilePath <$> basename file p' <- toFilePath <$> basename file
lift $ $(logInfo) [i|verifying digest of: #{p'}|] lift $ $(logInfo) [i|verifying digest of: #{p'}|]

11
lib/GHCup/Types.hs
View File

@ -193,16 +193,17 @@ data URLSource = GHCupURL
deriving (GHC.Generic, Show) deriving (GHC.Generic, Show)
data AppState = AppState
{ settings :: Settings
, dirs :: Dirs
} deriving (Show)
data Settings = Settings data Settings = Settings
{ -- set by user { cache :: Bool
cache :: Bool
, noVerify :: Bool , noVerify :: Bool
, keepDirs :: KeepDirs , keepDirs :: KeepDirs
, downloader :: Downloader , downloader :: Downloader
, verbose :: Bool , verbose :: Bool
-- set on app start
, dirs :: Dirs
} }
deriving Show deriving Show

82
lib/GHCup/Utils.hs
View File

@ -99,21 +99,21 @@ import qualified Text.Megaparsec as MP
-- | The symlink destination of a ghc tool. -- | 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. => ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
-> GHCTargetVersion -> GHCTargetVersion
-> m ByteString -> m ByteString
ghcLinkDestination tool ver = do ghcLinkDestination tool ver = do
Settings {dirs = Dirs {..}} <- ask AppState { dirs = Dirs {..} } <- ask
t <- parseRel tool t <- parseRel tool
ghcd <- ghcupGHCDir ver ghcd <- ghcupGHCDir ver
pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t)) pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t))
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5. -- | 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 rmMinorSymlinks GHCTargetVersion {..} = do
Settings {dirs = Dirs {..}} <- ask AppState { dirs = Dirs {..} } <- ask
files <- liftIO $ findFiles' files <- liftIO $ findFiles'
binDir binDir
@ -130,11 +130,11 @@ rmMinorSymlinks GHCTargetVersion {..} = do
-- | Removes the set ghc version for the given target, if any. -- | 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 => Maybe Text -- ^ target
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmPlain target = do rmPlain target = do
Settings {dirs = Dirs {..}} <- lift ask AppState { dirs = Dirs {..} } <- lift ask
mtv <- lift $ ghcSet target mtv <- lift $ ghcSet target
forM_ mtv $ \tv -> do forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
@ -149,11 +149,11 @@ rmPlain target = do
-- | Remove the major GHC symlink, e.g. ghc-8.6. -- | 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 => GHCTargetVersion
-> m () -> m ()
rmMajorSymlinks GHCTargetVersion {..} = do rmMajorSymlinks GHCTargetVersion {..} = do
Settings {dirs = Dirs {..}} <- ask AppState { dirs = Dirs {..} } <- ask
(mj, mi) <- getMajorMinorV _tvVersion (mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi let v' = intToText mj <> "." <> intToText mi
@ -179,26 +179,26 @@ rmMajorSymlinks GHCTargetVersion {..} = do
-- | Whethe the given GHC versin is installed. -- | 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 ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
liftIO $ doesDirectoryExist ghcdir liftIO $ doesDirectoryExist ghcdir
-- | Whether the given GHC version is installed from source. -- | 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 ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile) liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current. -- | 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 => Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf) -- (e.g. armv7-unknown-linux-gnueabihf)
-> m (Maybe GHCTargetVersion) -> m (Maybe GHCTargetVersion)
ghcSet mtarget = do ghcSet mtarget = do
Settings {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget) ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget)
let ghcBin = binDir </> ghc let ghcBin = binDir </> ghc
@ -231,7 +231,7 @@ ghcLinkVersion bs = do
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>. -- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left. -- 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 getInstalledGHCs = do
ghcdir <- ghcupGHCBaseDir ghcdir <- ghcupGHCBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
@ -241,10 +241,10 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@. -- | 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] => m [Either (Path Rel) Version]
getInstalledCabals = do getInstalledCabals = do
Settings {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString)) (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
@ -257,16 +257,16 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed. -- | 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 cabalInstalled ver = do
vers <- fmap rights $ getInstalledCabals vers <- fmap rights $ getInstalledCabals
pure $ elem ver $ vers pure $ elem ver $ vers
-- Return the currently set cabal version, if any. -- 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 cabalSet = do
Settings {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
let cabalbin = binDir </> [rel|cabal|] let cabalbin = binDir </> [rel|cabal|]
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
if if
@ -303,10 +303,10 @@ cabalSet = do
-- | Get all installed hls, by matching on -- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@. -- @~\/.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] => m [Either (Path Rel) Version]
getInstalledHLSs = do getInstalledHLSs = do
Settings { dirs = Dirs {..} } <- ask AppState { dirs = Dirs {..} } <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended (makeRegexOpts compExtended
@ -326,7 +326,7 @@ getInstalledHLSs = do
-- | Whether the given HLS version is installed. -- | 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 hlsInstalled ver = do
vers <- fmap rights $ getInstalledHLSs vers <- fmap rights $ getInstalledHLSs
pure $ elem ver $ vers pure $ elem ver $ vers
@ -334,9 +334,9 @@ hlsInstalled ver = do
-- Return the currently set hls version, if any. -- 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 hlsSet = do
Settings {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
let hlsBin = binDir </> [rel|haskell-language-server-wrapper|] let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
@ -357,7 +357,7 @@ hlsSet = do
-- | Return the GHC versions the currently selected HLS supports. -- | Return the GHC versions the currently selected HLS supports.
hlsGHCVersions :: ( MonadReader Settings m hlsGHCVersions :: ( MonadReader AppState m
, MonadIO m , MonadIO m
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
@ -383,11 +383,11 @@ hlsGHCVersions = do
-- | Get all server binaries for an hls version, if any. -- | Get all server binaries for an hls version, if any.
hlsServerBinaries :: (MonadReader Settings m, MonadIO m) hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
=> Version => Version
-> m [Path Rel] -> m [Path Rel]
hlsServerBinaries ver = do hlsServerBinaries ver = do
Settings { dirs = Dirs {..} } <- ask AppState { dirs = Dirs {..} } <- ask
liftIO $ handleIO (\_ -> pure []) $ findFiles liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts (makeRegexOpts
@ -399,11 +399,11 @@ hlsServerBinaries ver = do
-- | Get the wrapper binary for an hls version, if any. -- | 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 => Version
-> m (Maybe (Path Rel)) -> m (Maybe (Path Rel))
hlsWrapperBinary ver = do hlsWrapperBinary ver = do
Settings { dirs = Dirs {..} } <- ask AppState { dirs = Dirs {..} } <- ask
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts (makeRegexOpts
@ -420,7 +420,7 @@ hlsWrapperBinary ver = do
-- | Get all binaries for an hls version, if any. -- | 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 hlsAllBinaries ver = do
hls <- hlsServerBinaries ver hls <- hlsServerBinaries ver
wrapper <- hlsWrapperBinary ver wrapper <- hlsWrapperBinary ver
@ -428,9 +428,9 @@ hlsAllBinaries ver = do
-- | Get the active symlinks for hls. -- | 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 hlsSymlinks = do
Settings { dirs = Dirs {..} } <- ask AppState { dirs = Dirs {..} } <- ask
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended (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. -- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`. -- This reads `ghcupGHCBaseDir`.
getGHCForMajor :: (MonadReader Settings m, MonadIO m, MonadThrow m) getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m)
=> Int -- ^ major version component => Int -- ^ major version component
-> Int -- ^ minor version component -> Int -- ^ minor version component
-> Maybe Text -- ^ the target triple -> Maybe Text -- ^ the target triple
@ -603,16 +603,16 @@ getLatestBaseVersion av pvpVer =
----------------------- -----------------------
--[ Settings Getter ]-- --[ AppState Getter ]--
----------------------- -----------------------
getCache :: MonadReader Settings m => m Bool getCache :: MonadReader AppState m => m Bool
getCache = ask <&> cache getCache = ask <&> cache . settings
getDownloader :: MonadReader Settings m => m Downloader getDownloader :: MonadReader AppState m => m Downloader
getDownloader = ask <&> downloader getDownloader = ask <&> downloader . settings
@ -633,7 +633,7 @@ urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- Returns unversioned relative files, e.g.: -- Returns unversioned relative files, e.g.:
-- --
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@ -- - @["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 => GHCTargetVersion
-> Excepts '[NotInstalled] m [Path Rel] -> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ver = do ghcToolFiles ver = do
@ -686,7 +686,7 @@ ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
-- | Calls gmake if it exists in PATH, otherwise make. -- | 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] => [ByteString]
-> Maybe (Path Abs) -> Maybe (Path Abs)
-> m (Either ProcessError ()) -> m (Either ProcessError ())
@ -739,13 +739,13 @@ getChangeLog dls tool (Right tag) =
-- --
-- 1. the build directory, depending on the KeepDirs setting -- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed -- 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) => Path Abs -- ^ build directory (cleaned up depending on Settings)
-> Maybe (Path Abs) -- ^ dir to *always* clean up on exception -> Maybe (Path Abs) -- ^ dir to *always* clean up on exception
-> Excepts e m a -> Excepts e m a
-> Excepts '[BuildFailed] m a -> Excepts '[BuildFailed] m a
runBuildAction bdir instdir action = do runBuildAction bdir instdir action = do
Settings {..} <- lift ask AppState { settings = Settings {..} } <- lift ask
let exAction = do let exAction = do
forM_ instdir $ \dir -> forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir

8
lib/GHCup/Utils/Dirs.hs
View File

@ -152,17 +152,17 @@ getDirs = do
-- | ~/.ghcup/ghc by default. -- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader Settings m) => m (Path Abs) ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs)
ghcupGHCBaseDir = do ghcupGHCBaseDir = do
Settings {..} <- ask AppState { dirs = Dirs {..} } <- ask
pure (baseDir dirs </> [rel|ghc|]) pure (baseDir </> [rel|ghc|])
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'. -- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
-- The dir may be of the form -- The dir may be of the form
-- * armv7-unknown-linux-gnueabihf-8.8.3 -- * armv7-unknown-linux-gnueabihf-8.8.3
-- * 8.8.4 -- * 8.8.4
ghcupGHCDir :: (MonadReader Settings m, MonadThrow m) ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
=> GHCTargetVersion => GHCTargetVersion
-> m (Path Abs) -> m (Path Abs)
ghcupGHCDir ver = do ghcupGHCDir ver = do

4
lib/GHCup/Utils/File.hs
View File

@ -117,7 +117,7 @@ executeOut path args chdir = captureOutStreams $ do
SPPB.executeFile (toFilePath path) True args Nothing 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 => ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing -> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args 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 -> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> m (Either ProcessError ()) -> m (Either ProcessError ())
execLogged exe spath args lfile chdir env = do execLogged exe spath args lfile chdir env = do
Settings {dirs = Dirs {..}, ..} <- ask AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log") logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
closeFd closeFd

4
lib/GHCup/Utils/Logger.hs
View File

@ -65,9 +65,9 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
rawOutter outr 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 initGHCupFileLogging context = do
Settings {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
let logfile = logsDir </> context let logfile = logsDir </> context
liftIO $ do liftIO $ do
createDirRecursive' logsDir createDirRecursive' logsDir