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

Redo Settings as AppState

Browse Source
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
downloadAll dli = do
dirs <- liftIO getDirs
let settings = Settings True False Never Curl False dirs
let settings = AppState (Settings True False Never Curl False) dirs
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())

116
app/ghcup/BrickMain.hs
View File

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

55
app/ghcup/Main.hs
View File

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

74
lib/GHCup.hs
View File

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

22
lib/GHCup/Download.hs
View File

@ -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'}|]

11
lib/GHCup/Types.hs
View File

@ -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

82
lib/GHCup/Utils.hs
View File

@ -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

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

@ -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

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
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

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

@ -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