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

Use LabelOptic and add LeanAppState 

Wrt #186
This commit is contained in:
Julian Ospald 2021-07-18 14:39:49 +02:00
parent 327b80cf56
commit 2c7176d998
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
8 changed files with 644 additions and 325 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

417
app/ghcup/Main.hs
View File

@ -21,6 +21,7 @@ import GHCup.Errors
import GHCup.Platform
import GHCup.Requirements
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger
@ -66,7 +67,6 @@ import System.Environment
import System.Exit
import System.FilePath
import System.IO hiding ( appendFile )
import System.IO.Unsafe ( unsafeInterleaveIO )
import Text.Read hiding ( lift )
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString
@ -942,7 +942,7 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getDirs
dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
@ -962,7 +962,7 @@ tagCompleter tool add = listIOCompleter $ do
versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter criteria tool = listIOCompleter $ do
dirs' <- liftIO getDirs
dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
@ -1167,7 +1167,7 @@ describe_result :: String
describe_result = $( LitE . StringL <$>
runIO (do
CapturedProcess{..} <- do
dirs <- liftIO getDirs
dirs <- liftIO getAllDirs
let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings
flip runReaderT settings $ executeOut "git" ["describe"] Nothing
case _exitCode of
@ -1220,7 +1220,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(footerDoc (Just $ text main_footer))
)
>>= \opt@Options {..} -> do
dirs <- getDirs
dirs@Dirs{..} <- getAllDirs
-- create ~/.ghcup dir
ensureDirectories dirs
@ -1228,7 +1228,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(settings, keybindings) <- toSettings opt
-- logger interpreter
logfile <- initGHCupFileLogging (logsDir dirs)
logfile <- initGHCupFileLogging logsDir
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr
@ -1240,72 +1240,57 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runLogger = myLoggerT loggerConfig
let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () }
----------------------------------------
-- Getting download and platform info --
----------------------------------------
-- for some commands we want lazy loading
let wrapIO = case optCommand of
Whereis _ _ -> unsafeInterleaveIO
_ -> id
pfreq <- wrapIO $ (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
ghcupInfo <- wrapIO $
( runLogger
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
$ getDownloadsF settings dirs
)
>>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
-------------------------
-- Setting up appstate --
-------------------------
let appstate@AppState{dirs = Dirs{..}
, ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls, .. }
} = AppState settings dirs keybindings ghcupInfo pfreq
let leanAppstate = LeanAppState settings dirs keybindings
appState = do
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
ghcupInfo <-
( runLogger
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
$ getDownloadsF settings dirs
)
>>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
let s' = AppState settings dirs keybindings ghcupInfo pfreq
lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
Just _ -> pure ()
-- TODO: always run for windows
(siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case
VRight _ -> pure ()
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 30)
pure s'
---------------------------
-- Running startup tasks --
---------------------------
runLeanAppState = flip runReaderT leanAppstate
runAppState action' = do
s' <- liftIO appState
flip runReaderT s' action'
case optCommand of
Upgrade _ _ -> pure ()
Whereis _ _ -> pure ()
_ -> do
lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> runLogger $ flip runReaderT appstate $ checkForUpdates
Just _ -> pure ()
-- ensure global tools
case optCommand of
Whereis _ _ -> pure ()
_ -> do
(siletRunLogger $ flip runReaderT appstate $ runE ensureGlobalTools) >>= \case
VRight _ -> pure ()
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 30)
-------------------------
@ -1335,12 +1320,25 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NoToolVersionSet
]
let runInstTool = runInstTool' appstate
let runInstTool mInstPlatform action' = do
s' <- liftIO appState
runInstTool' s' mInstPlatform action'
let
runLeanSetGHC =
runLogger
. runLeanAppState
. runE
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
runSetGHC =
runLogger
. flip runReaderT appstate
. runAppState
. runE
@'[ FileDoesNotExistError
, NotInstalled
@ -1350,9 +1348,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
let
runLeanSetCabal =
runLogger
. runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
runSetCabal =
runLogger
. flip runReaderT appstate
. runAppState
. runE
@'[ NotInstalled
, TagNotFound
@ -1363,7 +1371,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runSetHLS =
runLogger
. flip runReaderT appstate
. runAppState
. runE
@'[ NotInstalled
, TagNotFound
@ -1371,20 +1379,30 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NoToolVersionSet
]
let runListGHC = runLogger . flip runReaderT appstate
runLeanSetHLS =
runLogger
. runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
let runListGHC = runLogger . runAppState
let runRm =
runLogger . flip runReaderT appstate . runE @'[NotInstalled]
runLogger . runAppState . runE @'[NotInstalled]
let runDebugInfo =
runLogger
. flip runReaderT appstate
. runAppState
. runE
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC =
runLogger
. flip runReaderT appstate
. runAppState
. runResourceT
. runE
@'[ AlreadyInstalled
@ -1404,9 +1422,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
let
runLeanWhereIs =
runLogger
. runLeanAppState
. runE
@'[ NotInstalled
, NoToolVersionSet
, NextVerNotFound
, TagNotFound
]
runWhereIs =
runLogger
. flip runReaderT appstate
. runAppState
. runE
@'[ NotInstalled
, NoToolVersionSet
@ -1416,7 +1444,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runUpgrade =
runLogger
. flip runReaderT appstate
. runAppState
. runResourceT
. runE
@'[ DigestError
@ -1439,13 +1467,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
liftE $ installGHCBin (_tvVersion v)
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
Just uri -> do
s' <- liftIO appState
runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
)
>>= \case
VRight vi -> do
@ -1477,12 +1507,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin (_tvVersion v)
pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
Just uri -> do
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
)
>>= \case
VRight vi -> do
@ -1506,12 +1538,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin (_tvVersion v)
pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
Just uri -> do
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
)
>>= \case
VRight vi -> do
@ -1535,12 +1569,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin (_tvVersion v)
pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
Just uri -> do
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
)
>>= \case
VRight vi -> do
@ -1559,11 +1595,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 4
let setGHC' SetOptions{..} =
runSetGHC (do
v <- liftE $ fst <$> fromVersion' sToolVer GHC
liftE $ setGHC v SetGHCOnly
)
let setGHC' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runLeanSetGHC (liftE $ setGHC v SetGHCOnly >> pure v)
_ -> runSetGHC (do
v <- liftE $ fst <$> fromVersion' sToolVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
@ -1574,12 +1612,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 5
let setCabal' SetOptions{..} =
runSetCabal (do
v <- liftE $ fst <$> fromVersion' sToolVer Cabal
liftE $ setCabal (_tvVersion v)
pure v
)
let setCabal' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runLeanSetCabal (liftE $ setCabal (_tvVersion v) >> pure v)
_ -> runSetCabal (do
v <- liftE $ fst <$> fromVersion' sToolVer Cabal
liftE $ setCabal (_tvVersion v)
pure v
)
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
@ -1590,12 +1630,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 14
let setHLS' SetOptions{..} =
runSetHLS (do
v <- liftE $ fst <$> fromVersion' sToolVer HLS
liftE $ setHLS (_tvVersion v)
pure v
)
let setHLS' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runLeanSetHLS (liftE $ setHLS (_tvVersion v) >> pure v)
_ -> runSetHLS (do
v <- liftE $ fst <$> fromVersion' sToolVer HLS
liftE $ setHLS (_tvVersion v)
pure v
)
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
@ -1606,12 +1648,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 14
let setStack' SetOptions{..} =
runSetCabal (do
v <- liftE $ fst <$> fromVersion' sToolVer Stack
liftE $ setStack (_tvVersion v)
pure v
)
let setStack' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runSetCabal (liftE $ setStack (_tvVersion v) >> pure v)
_ -> runSetCabal (do
v <- liftE $ fst <$> fromVersion' sToolVer Stack
liftE $ setStack (_tvVersion v)
pure v
)
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
@ -1626,6 +1670,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runRm (do
liftE $
rmGHCVer ghcVer
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
)
>>= \case
@ -1641,6 +1686,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runRm (do
liftE $
rmCabalVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Cabal dls)
)
>>= \case
@ -1656,6 +1702,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runRm (do
liftE $
rmHLSVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv HLS dls)
)
>>= \case
@ -1671,6 +1718,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runRm (do
liftE $
rmStackVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Stack dls)
)
>>= \case
@ -1735,6 +1783,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runCompileGHC (do
case targetGhc of
Left targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ $(logInfo) msg
@ -1750,6 +1799,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
buildConfig
patchDir
addConfArgs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $
setGHC targetVer SetGHCOnly
@ -1777,6 +1827,21 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 9
Whereis WhereisOptions{..} (WhereisTool tool (Just (ToolVersion v))) ->
runLeanWhereIs (do
loc <- liftE $ whereIsTool tool v
if directory
then pure $ takeDirectory loc
else pure loc
)
>>= \case
VRight r -> do
putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 30
Whereis WhereisOptions{..} (WhereisTool tool whereVer) ->
runWhereIs (do
(v, _) <- liftE $ fromVersion whereVer tool
@ -1801,6 +1866,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
runUpgrade (liftE $ upgradeGHCup target force') >>= \case
VRight v' -> do
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup
runLogger $ $(logInfo)
@ -1815,23 +1881,26 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 11
ToolRequirements ->
flip runReaderT appstate
$ runLogger
(runE
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
$ do
platform <- liftE getPlatform
req <- getCommonRequirements platform _toolRequirements ?? NoToolRequirements
liftIO $ T.hPutStr stdout (prettyRequirements req)
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 12
ToolRequirements -> do
s' <- appState
flip runReaderT s'
$ runLogger
(runE
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
$ do
GHCupInfo { .. } <- lift getGHCupInfo
platform' <- liftE getPlatform
req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
liftIO $ T.hPutStr stdout (prettyRequirements req)
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 12
ChangeLog ChangeLogOptions{..} -> do
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
let tool = fromMaybe GHC clTool
ver' = maybe
(Right Latest)
@ -1849,6 +1918,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
)
pure ExitSuccess
Just uri -> do
pfreq <- runAppState getPlatformReq
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
cmd = case _rPlatform pfreq of
Darwin -> "open"
@ -1857,21 +1927,23 @@ Make sure to clean up #{tmpdir} afterwards.|])
Windows -> "start"
if clOpen
then
flip runReaderT appstate $
exec cmd
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
Nothing
Nothing
>>= \case
Right _ -> pure ExitSuccess
Left e -> runLogger ($(logError) [i|#{e}|])
>> pure (ExitFailure 13)
then do
s' <- appState
flip runReaderT s' $
exec cmd
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
Nothing
Nothing
>>= \case
Right _ -> pure ExitSuccess
Left e -> runLogger ($(logError) [i|#{e}|])
>> pure (ExitFailure 13)
else putStrLn uri' >> pure ExitSuccess
Nuke ->
runRm (do
void $ liftIO $ evaluate $ force appstate
s' <- liftIO appState
void $ liftIO $ evaluate $ force s'
lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
liftIO $ threadDelay 10000000 -- wait 10s
@ -1907,22 +1979,46 @@ Make sure to clean up #{tmpdir} afterwards.|])
pure ()
fromVersion :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
fromVersion :: ( MonadLogger m
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
, HasDirs env
, MonadThrow m
, MonadIO m
, MonadCatch m
)
=> Maybe ToolVersion
-> Tool
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
-> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion tv = fromVersion' (toSetToolVer tv)
fromVersion' :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
fromVersion' :: ( MonadLogger m
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
, HasDirs env
, MonadThrow m
, MonadIO m
, MonadCatch m
)
=> SetToolVersion
-> Tool
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
-> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion' SetRecommended tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool
?? TagNotFound Recommended tool
fromVersion' (SetToolVersion v) tool = do
~AppState { ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls }} <- lift ask
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion v) tool dls
case pvp $ prettyVer (_tvVersion v) of
Left _ -> pure (v, vi)
@ -1932,16 +2028,16 @@ fromVersion' (SetToolVersion v) tool = do
Nothing -> pure (v, vi)
Right _ -> pure (v, vi)
fromVersion' (SetToolTag Latest) tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
(\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolTag Recommended) tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool
fromVersion' (SetToolTag (Base pvp'')) GHC = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
(\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' SetNext tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
next <- case tool of
GHC -> do
set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool
@ -2142,7 +2238,10 @@ printListResult raw lr = do
| otherwise -> 1
checkForUpdates :: ( MonadReader AppState m
checkForUpdates :: ( MonadReader env m
, HasGHCupInfo env
, HasDirs env
, HasPlatformReq env
, MonadCatch m
, MonadLogger m
, MonadThrow m
@ -2152,7 +2251,7 @@ checkForUpdates :: ( MonadReader AppState m
)
=> m ()
checkForUpdates = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
lInstalled <- listVersions Nothing (Just ListInstalled)
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled

285
lib/GHCup.hs
View File

@ -106,7 +106,10 @@ import Control.Concurrent (threadDelay)
installGHCBindist :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadLogger m
, MonadResource m
, MonadIO m
@ -130,7 +133,8 @@ installGHCBindist :: ( MonadFail m
m
()
installGHCBindist dlinfo ver = do
AppState { dirs , settings } <- lift ask
dirs <- lift getDirs
settings <- lift getSettings
let tver = mkTVer ver
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
@ -163,7 +167,10 @@ installGHCBindist dlinfo ver = do
-- build system and nothing else.
installPackedGHC :: ( MonadMask m
, MonadCatch m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasSettings env
, MonadThrow m
, MonadLogger m
, MonadIO m
@ -182,7 +189,7 @@ installPackedGHC :: ( MonadMask m
#endif
] m ()
installPackedGHC dl msubdir inst ver = do
AppState { pfreq = PlatformRequest {..} } <- lift ask
PlatformRequest {..} <- lift getPlatformReq
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
@ -201,7 +208,10 @@ installPackedGHC dl msubdir inst ver = do
-- | Install an unpacked GHC distribution. This only deals with the GHC
-- build system and nothing else.
installUnpackedGHC :: ( MonadReader AppState m
installUnpackedGHC :: ( MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadThrow m
, MonadLogger m
, MonadIO m
@ -218,7 +228,7 @@ installUnpackedGHC path inst _ = do
liftIO $ copyDirectoryRecursive path inst
#else
installUnpackedGHC path inst ver = do
AppState { pfreq = PlatformRequest {..} } <- lift ask
PlatformRequest {..} <- lift getPlatformReq
let alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
@ -250,7 +260,11 @@ installUnpackedGHC path inst ver = do
installGHCBin :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader AppState m
, MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m
, MonadResource m
, MonadIO m
@ -273,8 +287,8 @@ installGHCBin :: ( MonadFail m
m
()
installGHCBin ver = do
AppState { pfreq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
pfreq <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
dlinfo <- lE $ getDownloadInfo GHC ver pfreq dls
installGHCBindist dlinfo ver
@ -283,7 +297,10 @@ installGHCBin ver = do
-- argument instead of looking it up from 'GHCupDownloads'.
installCabalBindist :: ( MonadMask m
, MonadCatch m
, MonadReader AppState m
, MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m
, MonadResource m
, MonadIO m
@ -310,9 +327,9 @@ installCabalBindist :: ( MonadMask m
installCabalBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
AppState { dirs = dirs@Dirs {..}
, pfreq = PlatformRequest {..}
, settings } <- lift ask
PlatformRequest {..} <- lift getPlatformReq
dirs@Dirs {..} <- lift getDirs
settings <- lift getSettings
whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $
@ -364,7 +381,11 @@ installCabalBindist dlinfo ver = do
-- the latest installed version.
installCabalBin :: ( MonadMask m
, MonadCatch m
, MonadReader AppState m
, MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m
, MonadResource m
, MonadIO m
@ -388,8 +409,9 @@ installCabalBin :: ( MonadMask m
m
()
installCabalBin ver = do
AppState { pfreq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
pfreq <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq dls
installCabalBindist dlinfo ver
@ -398,7 +420,10 @@ installCabalBin ver = do
-- argument instead of looking it up from 'GHCupDownloads'.
installHLSBindist :: ( MonadMask m
, MonadCatch m
, MonadReader AppState m
, MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m
, MonadResource m
, MonadIO m
@ -425,9 +450,9 @@ installHLSBindist :: ( MonadMask m
installHLSBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
AppState { dirs = dirs@Dirs {..}
, pfreq = PlatformRequest {..}
, settings } <- lift ask
PlatformRequest {..} <- lift getPlatformReq
dirs@Dirs {..} <- lift getDirs
settings <- lift getSettings
whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled HLS ver)
@ -488,7 +513,11 @@ installHLSBindist dlinfo ver = do
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
installHLSBin :: ( MonadMask m
, MonadCatch m
, MonadReader AppState m
, MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m
, MonadResource m
, MonadIO m
@ -512,8 +541,9 @@ installHLSBin :: ( MonadMask m
m
()
installHLSBin ver = do
AppState { pfreq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
pfreq <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
dlinfo <- lE $ getDownloadInfo HLS ver pfreq dls
installHLSBindist dlinfo ver
@ -523,7 +553,11 @@ installHLSBin ver = do
-- the latest installed version.
installStackBin :: ( MonadMask m
, MonadCatch m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, MonadLogger m
, MonadResource m
, MonadIO m
@ -547,7 +581,9 @@ installStackBin :: ( MonadMask m
m
()
installStackBin ver = do
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
pfreq <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
dlinfo <- lE $ getDownloadInfo Stack ver pfreq dls
installStackBindist dlinfo ver
@ -556,7 +592,10 @@ installStackBin ver = do
-- argument instead of looking it up from 'GHCupDownloads'.
installStackBindist :: ( MonadMask m
, MonadCatch m
, MonadReader AppState m
, MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m
, MonadResource m
, MonadIO m
@ -583,10 +622,9 @@ installStackBindist :: ( MonadMask m
installStackBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
AppState { dirs = dirs@Dirs {..}
, pfreq = PlatformRequest {..}
, settings
} <- lift ask
PlatformRequest {..} <- lift getPlatformReq
dirs@Dirs {..} <- lift getDirs
settings <- lift getSettings
whenM (lift (stackInstalled ver))
(throwE $ AlreadyInstalled Stack ver)
@ -644,7 +682,8 @@ installStackBindist dlinfo ver = do
--
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
-- for 'SetGHCOnly' constructor.
setGHC :: ( MonadReader AppState m
setGHC :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, MonadThrow m
, MonadFail m
@ -663,7 +702,7 @@ setGHC ver sghc = do
whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))
-- symlink destination
AppState { dirs = Dirs {..} } <- lift ask
Dirs {..} <- lift getDirs
-- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup)
@ -701,12 +740,15 @@ setGHC ver sghc = do
where
symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m)
symlinkShareDir :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m)
=> FilePath
-> String
-> m ()
symlinkShareDir ghcdir ver' = do
AppState { dirs = Dirs {..} } <- ask
Dirs {..} <- getDirs
let destdir = baseDir
case sghc of
SetGHCOnly -> do
@ -733,7 +775,8 @@ setGHC ver sghc = do
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
setCabal :: ( MonadMask m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, MonadLogger m
, MonadThrow m
, MonadFail m
@ -745,7 +788,7 @@ setCabal ver = do
let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
-- symlink destination
AppState {dirs = Dirs {..}} <- lift ask
Dirs {..} <- lift getDirs
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
$ throwE
@ -764,7 +807,8 @@ setCabal ver = do
-- | Set the haskell-language-server symlinks.
setHLS :: ( MonadCatch m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, MonadLogger m
, MonadThrow m
, MonadFail m
@ -775,7 +819,7 @@ setHLS :: ( MonadCatch m
=> Version
-> Excepts '[NotInstalled] m ()
setHLS ver = do
AppState { dirs = Dirs {..} } <- lift ask
Dirs {..} <- lift getDirs
-- Delete old symlinks, since these might have different ghc versions than the
-- selected version, so we could end up with stray or incorrect symlinks.
@ -804,7 +848,8 @@ setHLS ver = do
-- | Set the @~\/.ghcup\/bin\/stack@ symlink.
setStack :: ( MonadMask m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, MonadLogger m
, MonadThrow m
, MonadFail m
@ -817,7 +862,7 @@ setStack ver = do
let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
-- symlink destination
AppState {dirs = Dirs {..}} <- lift ask
Dirs {..} <- lift getDirs
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
$ throwE
@ -872,7 +917,10 @@ listVersions :: ( MonadCatch m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
)
=> Maybe Tool
-> Maybe ListCriteria
@ -891,7 +939,7 @@ listVersions lt' criteria = do
go lt cSet cabals hlsSet' hlses sSet stacks = do
case lt of
Just t -> do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
-- get versions from GHCupDownloads
let avTools = availableToolVersions dls t
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)
@ -917,7 +965,13 @@ listVersions lt' criteria = do
ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks
stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks
pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers)
strayGHCs :: (MonadCatch m, MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m)
strayGHCs :: ( MonadCatch m
, MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> Map.Map Version [Tag]
-> m [ListResult]
strayGHCs avTools = do
@ -959,7 +1013,13 @@ listVersions lt' criteria = do
[i|Could not parse version of stray directory #{e}|]
pure Nothing
strayCabals :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
strayCabals :: ( MonadReader env m
, HasDirs env
, MonadCatch m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> Map.Map Version [Tag]
-> Maybe Version
-> [Either FilePath Version]
@ -988,7 +1048,12 @@ listVersions lt' criteria = do
[i|Could not parse version of stray directory #{e}|]
pure Nothing
strayHLS :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
strayHLS :: ( MonadReader env m
, HasDirs env
, MonadCatch m
, MonadThrow m
, MonadLogger m
, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
strayHLS avTools = do
@ -1016,7 +1081,13 @@ listVersions lt' criteria = do
[i|Could not parse version of stray directory #{e}|]
pure Nothing
strayStacks :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
strayStacks :: ( MonadReader env m
, HasDirs env
, MonadCatch m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> Map.Map Version [Tag]
-> m [ListResult]
strayStacks avTools = do
@ -1045,7 +1116,14 @@ listVersions lt' criteria = do
pure Nothing
-- NOTE: this are not cross ones, because no bindists
toListResult :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
toListResult :: ( MonadLogger m
, MonadReader env m
, HasDirs env
, HasGHCupInfo env
, HasPlatformReq env
, MonadIO m
, MonadCatch m
)
=> Tool
-> Maybe Version
-> [Either FilePath Version]
@ -1056,8 +1134,8 @@ listVersions lt' criteria = do
-> (Version, [Tag])
-> m ListResult
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = do
AppState { pfreq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
pfreq <- getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
case t of
GHC -> do
@ -1140,7 +1218,8 @@ listVersions lt' criteria = do
-- This may leave GHCup without a "set" version.
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an
-- older version).
rmGHCVer :: ( MonadReader AppState m
rmGHCVer :: ( MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, MonadIO m
@ -1181,7 +1260,7 @@ rmGHCVer ver = do
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
AppState { dirs = Dirs {..} } <- lift ask
Dirs {..} <- lift getDirs
liftIO
$ hideError doesNotExistErrorType
@ -1191,7 +1270,8 @@ rmGHCVer ver = do
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
-- after removal (e.g. setting it to an older version).
rmCabalVer :: ( MonadMask m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, MonadIO m
@ -1206,7 +1286,7 @@ rmCabalVer ver = do
cSet <- lift cabalSet
AppState {dirs = Dirs {..}} <- lift ask
Dirs {..} <- lift getDirs
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile)
@ -1221,7 +1301,8 @@ rmCabalVer ver = do
-- | Delete a hls version. Will try to fix the hls symlinks
-- after removal (e.g. setting it to an older version).
rmHLSVer :: ( MonadMask m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, MonadIO m
@ -1236,7 +1317,7 @@ rmHLSVer ver = do
isHlsSet <- lift hlsSet
AppState {dirs = Dirs {..}} <- lift ask
Dirs {..} <- lift getDirs
bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> liftIO $ rmFile (binDir </> f)
@ -1258,7 +1339,8 @@ rmHLSVer ver = do
-- | Delete a stack version. Will try to fix the @stack@ symlink
-- after removal (e.g. setting it to an older version).
rmStackVer :: ( MonadMask m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, MonadIO m
@ -1273,7 +1355,7 @@ rmStackVer ver = do
sSet <- lift stackSet
AppState {dirs = Dirs {..}} <- lift ask
Dirs {..} <- lift getDirs
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile)
@ -1286,15 +1368,15 @@ rmStackVer ver = do
-- assuming the current scheme of having just 1 ghcup bin, no version info is required.
rmGhcup :: ( MonadReader AppState m
rmGhcup :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadCatch m
, MonadLogger m
)
=> m ()
rmGhcup = do
AppState {dirs = Dirs {binDir}} <- ask
Dirs {binDir} <- getDirs
let ghcupFilename = "ghcup" <> exeExt
let ghcupFilepath = binDir </> ghcupFilename
@ -1338,14 +1420,14 @@ rmGhcup = do
<> path <>
"\n you may have to uninstall it manually."
rmTool :: ( MonadReader AppState m
, MonadLogger m
, MonadFail m
, MonadMask m
, MonadUnliftIO m)
=> ListResult
-> Excepts '[NotInstalled ] m ()
rmTool :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, MonadFail m
, MonadMask m
, MonadUnliftIO m)
=> ListResult
-> Excepts '[NotInstalled ] m ()
rmTool ListResult {lVer, lTool, lCross} = do
case lTool of
GHC ->
@ -1357,7 +1439,8 @@ rmTool ListResult {lVer, lTool, lCross} = do
GHCup -> lift rmGhcup
rmGhcupDirs :: ( MonadReader AppState m
rmGhcupDirs :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m
, MonadCatch m
@ -1369,7 +1452,7 @@ rmGhcupDirs = do
, binDir
, logsDir
, cacheDir
} <- asks dirs
} <- getDirs
let envFilePath = baseDir </> "env"
@ -1477,13 +1560,20 @@ rmGhcupDirs = do
------------------
getDebugInfo :: (Alternative m, MonadFail m, MonadReader AppState m, MonadLogger m, MonadCatch m, MonadIO m)
getDebugInfo :: ( Alternative m
, MonadFail m
, MonadReader env m
, HasDirs env
, MonadLogger m
, MonadCatch m
, MonadIO m
)
=> Excepts
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
m
DebugInfo
getDebugInfo = do
AppState {dirs = Dirs {..}} <- lift ask
Dirs {..} <- lift getDirs
let diBaseDir = baseDir
let diBinDir = binDir
diGHCDir <- lift ghcupGHCBaseDir
@ -1503,7 +1593,11 @@ getDebugInfo = do
-- | Compile a GHC from source. This behaves wrt symlinks and installation
-- the same as 'installGHCBin'.
compileGHC :: ( MonadMask m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
, HasSettings env
, MonadThrow m
, MonadResource m
, MonadLogger m
@ -1538,10 +1632,11 @@ compileGHC :: ( MonadMask m
GHCTargetVersion
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
= do
AppState { pfreq = PlatformRequest {..}
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }
, settings
, dirs } <- lift ask
PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
settings <- lift getSettings
dirs <- lift getDirs
(workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball
Left tver -> do
@ -1662,7 +1757,10 @@ BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES|]
compileBindist :: ( MonadReader AppState m
compileBindist :: ( MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadThrow m
, MonadCatch m
, MonadLogger m
@ -1680,8 +1778,9 @@ HADDOCK_DOCS = YES|]
compileBindist bghc tver workdir ghcdir = do
lift $ $(logInfo) [i|configuring build|]
liftE checkBuildConfig
AppState { dirs = Dirs {..}, pfreq } <- lift ask
Dirs {..} <- lift getDirs
pfreq <- lift getPlatformReq
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
@ -1805,7 +1904,11 @@ HADDOCK_DOCS = YES|]
-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
-- if no path is provided.
upgradeGHCup :: ( MonadMask m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
, HasSettings env
, MonadCatch m
, MonadLogger m
, MonadThrow m
@ -1826,10 +1929,11 @@ upgradeGHCup :: ( MonadMask m
m
Version
upgradeGHCup mtarget force' = do
AppState { dirs = Dirs {..}
, pfreq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }
, settings } <- lift ask
Dirs {..} <- lift getDirs
pfreq <- lift getPlatformReq
settings <- lift getSettings
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ fst <$> getLatest dls GHCup
when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
@ -1878,7 +1982,8 @@ upgradeGHCup mtarget force' = do
-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
-- both installing from source and bindist.
postGHCInstall :: ( MonadReader AppState m
postGHCInstall :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, MonadThrow m
, MonadFail m
@ -1909,7 +2014,8 @@ postGHCInstall ver@GHCTargetVersion {..} = do
-- * for hls, this reports @~\/.ghcup\/bin\/haskell-language-server-wrapper-\<ver\>@
-- * for stack, this reports @~\/.ghcup\/bin\/stack-\<ver\>@
-- * for ghcup, this reports the location of the currently running executable
whereIsTool :: ( MonadReader AppState m
whereIsTool :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, MonadThrow m
, MonadFail m
@ -1922,7 +2028,7 @@ whereIsTool :: ( MonadReader AppState m
-> GHCTargetVersion
-> Excepts '[NotInstalled] m FilePath
whereIsTool tool ver@GHCTargetVersion {..} = do
AppState { dirs } <- lift ask
dirs <- lift getDirs
case tool of
GHC -> do
@ -1946,3 +2052,6 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
GHCup -> do
currentRunningExecPath <- liftIO getExecutablePath
liftIO $ canonicalizePath currentRunningExecPath

14
lib/GHCup/Types.hs
View File

@ -1,9 +1,12 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-|
Module : GHCup.Types
@ -346,8 +349,14 @@ data AppState = AppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
, ghcupInfo :: ~GHCupInfo
, pfreq :: ~PlatformRequest
, ghcupInfo :: GHCupInfo
, pfreq :: PlatformRequest
} deriving (Show, GHC.Generic)
data LeanAppState = LeanAppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
} deriving (Show, GHC.Generic)
instance NFData AppState
@ -507,4 +516,3 @@ instance (Monad m, Alternative m) => Alternative (LoggingT m) where
instance MonadLogger m => MonadLogger (Excepts e m) where
monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d

87
lib/GHCup/Types/Optics.hs
View File

@ -1,4 +1,9 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-|
Module : GHCup.Types.Optics
@ -13,6 +18,7 @@ module GHCup.Types.Optics where
import GHCup.Types
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Optics
import URI.ByteString
@ -58,3 +64,82 @@ pathL' = lensVL pathL
queryL' :: Lens' (URIRef a) Query
queryL' = lensVL queryL
----------------------
--[ Lens utilities ]--
----------------------
gets :: forall f a env m . (MonadReader env m, LabelOptic' f A_Lens env a)
=> m a
gets = asks (^. labelOptic @f)
getAppState :: MonadReader AppState m => m AppState
getAppState = ask
getLeanAppState :: ( MonadReader env m
, LabelOptic' "settings" A_Lens env Settings
, LabelOptic' "dirs" A_Lens env Dirs
, LabelOptic' "keyBindings" A_Lens env KeyBindings
)
=> m LeanAppState
getLeanAppState = do
s <- gets @"settings"
d <- gets @"dirs"
k <- gets @"keyBindings"
pure (LeanAppState s d k)
getSettings :: ( MonadReader env m
, LabelOptic' "settings" A_Lens env Settings
)
=> m Settings
getSettings = gets @"settings"
getDirs :: ( MonadReader env m
, LabelOptic' "dirs" A_Lens env Dirs
)
=> m Dirs
getDirs = gets @"dirs"
getKeyBindings :: ( MonadReader env m
, LabelOptic' "keyBindings" A_Lens env KeyBindings
)
=> m KeyBindings
getKeyBindings = gets @"keyBindings"
getGHCupInfo :: ( MonadReader env m
, LabelOptic' "ghcupInfo" A_Lens env GHCupInfo
)
=> m GHCupInfo
getGHCupInfo = gets @"ghcupInfo"
getPlatformReq :: ( MonadReader env m
, LabelOptic' "pfreq" A_Lens env PlatformRequest
)
=> m PlatformRequest
getPlatformReq = gets @"pfreq"
type HasSettings env = (LabelOptic' "settings" A_Lens env Settings)
type HasDirs env = (LabelOptic' "dirs" A_Lens env Dirs)
type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings)
type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo)
type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest)
getCache :: (MonadReader env m, HasSettings env) => m Bool
getCache = getSettings <&> cache
getDownloader :: (MonadReader env m, HasSettings env) => m Downloader
getDownloader = getSettings <&> downloader

135
lib/GHCup/Utils.hs
View File

@ -103,28 +103,30 @@ import qualified Text.Megaparsec as MP
-- | The symlink destination of a ghc tool.
ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m)
ghcLinkDestination :: ( MonadReader env m
, HasDirs env
, MonadThrow m, MonadIO m)
=> FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
-> GHCTargetVersion
-> m FilePath
ghcLinkDestination tool ver = do
AppState { dirs = Dirs {..} } <- ask
Dirs {..} <- getDirs
ghcd <- ghcupGHCDir ver
pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
rmMinorSymlinks :: ( MonadReader AppState m
rmMinorSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader AppState m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
rmMinorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask
Dirs {..} <- lift getDirs
files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do
@ -135,7 +137,8 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
-- | Removes the set ghc version for the given target, if any.
rmPlain :: ( MonadReader AppState m
rmPlain :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, MonadThrow m
, MonadFail m
@ -144,7 +147,7 @@ rmPlain :: ( MonadReader AppState m
=> Maybe Text -- ^ target
-> Excepts '[NotInstalled] m ()
rmPlain target = do
AppState { dirs = Dirs {..} } <- lift ask
Dirs {..} <- lift getDirs
mtv <- lift $ ghcSet target
forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv
@ -159,17 +162,17 @@ rmPlain target = do
-- | Remove the major GHC symlink, e.g. ghc-8.6.
rmMajorSymlinks :: ( MonadReader AppState m
rmMajorSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader AppState m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
rmMajorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask
Dirs {..} <- lift getDirs
(mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi
@ -189,26 +192,26 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
-- | Whether the given GHC versin is installed.
ghcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesDirectoryExist ghcdir
-- | Whether the given GHC version is installed from source.
ghcSrcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current.
ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m)
ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
=> Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf)
-> m (Maybe GHCTargetVersion)
ghcSet mtarget = do
AppState {dirs = Dirs {..}} <- ask
Dirs {..} <- getDirs
let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
let ghcBin = binDir </> ghc <> exeExt
@ -239,7 +242,7 @@ ghcSet mtarget = do
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left.
getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either FilePath GHCTargetVersion]
getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
getInstalledGHCs = do
ghcdir <- ghcupGHCBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
@ -249,10 +252,15 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
getInstalledCabals :: ( MonadLogger m
, MonadReader env m
, HasDirs env
, MonadIO m
, MonadCatch m
)
=> m [Either FilePath Version]
getInstalledCabals = do
AppState {dirs = Dirs {..}} <- ask
Dirs {..} <- getDirs
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
@ -264,16 +272,16 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed.
cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled ver = do
vers <- fmap rights getInstalledCabals
pure $ elem ver vers
-- Return the currently set cabal version, if any.
cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet :: (MonadLogger m, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet = do
AppState {dirs = Dirs {..}} <- ask
Dirs {..} <- getDirs
let cabalbin = binDir </> "cabal" <> exeExt
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@ -317,10 +325,10 @@ cabalSet = do
-- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m)
getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
=> m [Either FilePath Version]
getInstalledHLSs = do
AppState { dirs = Dirs {..} } <- ask
Dirs {..} <- getDirs
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
@ -337,10 +345,10 @@ getInstalledHLSs = do
-- | Get all installed stacks, by matching on
-- @~\/.ghcup\/bin/stack-<\stackver\>@.
getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m)
getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
=> m [Either FilePath Version]
getInstalledStacks = do
AppState { dirs = Dirs {..} } <- ask
Dirs {..} <- getDirs
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
@ -355,9 +363,9 @@ getInstalledStacks = do
-- Return the currently set stack version, if any.
-- TODO: there's a lot of code duplication here :>
stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version)
stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version)
stackSet = do
AppState {dirs = Dirs {..}} <- ask
Dirs {..} <- getDirs
let stackBin = binDir </> "stack" <> exeExt
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@ -395,13 +403,13 @@ stackSet = do
stripRelativePath = MP.many (MP.try stripPathComponet)
-- | Whether the given Stack version is installed.
stackInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
stackInstalled ver = do
vers <- fmap rights getInstalledStacks
pure $ elem ver vers
-- | Whether the given HLS version is installed.
hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
hlsInstalled ver = do
vers <- fmap rights getInstalledHLSs
pure $ elem ver vers
@ -409,9 +417,9 @@ hlsInstalled ver = do
-- Return the currently set hls version, if any.
hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet = do
AppState {dirs = Dirs {..}} <- ask
Dirs {..} <- getDirs
let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@ -443,7 +451,8 @@ hlsSet = do
-- | Return the GHC versions the currently selected HLS supports.
hlsGHCVersions :: ( MonadReader AppState m
hlsGHCVersions :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadThrow m
, MonadCatch m
@ -466,11 +475,11 @@ hlsGHCVersions = do
-- | Get all server binaries for an hls version, if any.
hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
=> Version
-> m [FilePath]
hlsServerBinaries ver = do
AppState { dirs = Dirs {..} } <- ask
Dirs {..} <- getDirs
liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
@ -482,12 +491,12 @@ hlsServerBinaries ver = do
-- | Get the wrapper binary for an hls version, if any.
hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m)
hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
=> Version
-> m (Maybe FilePath)
hlsWrapperBinary ver = do
AppState { dirs = Dirs {..} } <- ask
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
Dirs {..} <- getDirs
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
@ -503,7 +512,7 @@ hlsWrapperBinary ver = do
-- | Get all binaries for an hls version, if any.
hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [FilePath]
hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath]
hlsAllBinaries ver = do
hls <- hlsServerBinaries ver
wrapper <- hlsWrapperBinary ver
@ -511,9 +520,9 @@ hlsAllBinaries ver = do
-- | Get the active symlinks for hls.
hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [FilePath]
hlsSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [FilePath]
hlsSymlinks = do
AppState { dirs = Dirs {..} } <- ask
Dirs {..} <- getDirs
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
@ -549,7 +558,7 @@ matchMajor v' major' minor' = case getMajorMinorV v' of
-- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`.
getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m)
getGHCForMajor :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
=> Int -- ^ major version component
-> Int -- ^ minor version component
-> Maybe Text -- ^ the target triple
@ -729,19 +738,6 @@ getLatestBaseVersion av pvpVer =
-----------------------
--[ AppState Getter ]--
-----------------------
getCache :: MonadReader AppState m => m Bool
getCache = ask <&> cache . settings
getDownloader :: MonadReader AppState m => m Downloader
getDownloader = ask <&> downloader . settings
-------------
--[ Other ]--
@ -754,7 +750,7 @@ getDownloader = ask <&> downloader . settings
-- Returns unversioned relative files without extension, e.g.:
--
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m)
ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles ver = do
@ -817,7 +813,12 @@ ghcUpSrcBuiltFile = ".ghcup_src_built"
-- | Calls gmake if it exists in PATH, otherwise make.
make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
make :: ( MonadThrow m
, MonadIO m
, MonadReader env m
, HasDirs env
, HasSettings env
)
=> [String]
-> Maybe FilePath
-> m (Either ProcessError ())
@ -827,7 +828,7 @@ make args workdir = do
let mymake = if has_gmake then "gmake" else "make"
execLogged mymake args workdir "ghc-make" Nothing
makeOut :: (MonadReader AppState m, MonadIO m)
makeOut :: (MonadReader env m, HasDirs env, MonadIO m)
=> [String]
-> Maybe FilePath
-> m CapturedProcess
@ -840,7 +841,7 @@ makeOut args workdir = do
-- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure.
applyPatches :: (MonadReader AppState m, MonadLogger m, MonadIO m)
applyPatches :: (MonadReader env m, HasDirs env, MonadLogger m, MonadIO m)
=> FilePath -- ^ dir containing patches
-> FilePath -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m ()
@ -858,7 +859,7 @@ applyPatches pdir ddir = do
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
darwinNotarization :: (MonadReader AppState m, MonadIO m)
darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m)
=> Platform
-> FilePath
-> m (Either ProcessError ())
@ -881,13 +882,13 @@ getChangeLog dls tool (Right tag) =
--
-- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed
runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m)
runBuildAction :: (Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m)
=> FilePath -- ^ build directory (cleaned up depending on Settings)
-> Maybe FilePath -- ^ dir to *always* clean up on exception
-> Excepts e m a
-> Excepts '[BuildFailed] m a
runBuildAction bdir instdir action = do
AppState { settings = Settings {..} } <- lift ask
Settings {..} <- lift getSettings
let exAction = do
forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ rmPath dir
@ -1016,7 +1017,8 @@ createLink :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, MonadUnliftIO m
, MonadFail m
)
@ -1025,7 +1027,7 @@ createLink :: ( MonadMask m
-> m ()
createLink link exe = do
#if defined(IS_WINDOWS)
AppState { dirs } <- ask
dirs <- getDirs
let shimGen = cacheDir dirs </> "gs.exe"
let shim = dropExtension exe <.> "shim"
@ -1054,14 +1056,19 @@ ensureGlobalTools :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadReader AppState m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasGHCupInfo env
, MonadUnliftIO m
, MonadFail m
)
=> Excepts '[DigestError , DownloadFailed, NoDownload] m ()
ensureGlobalTools = do
#if defined(IS_WINDOWS)
AppState { ghcupInfo = GHCupInfo _ _ gTools, settings, dirs } <- lift ask
(GHCupInfo _ _ gTools) <- lift getGHCupInfo
settings <- lift getSettings
dirs <- lift getDirs
shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' settings dirs shimDownload (Just "gs.exe")

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

@ -16,7 +16,7 @@ Stability : experimental
Portability : portable
-}
module GHCup.Utils.Dirs
( getDirs
( getAllDirs
, ghcupBaseDir
, ghcupConfigFile
, ghcupCacheDir
@ -37,6 +37,7 @@ where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
@ -190,8 +191,8 @@ ghcupLogsDir = do
#endif
getDirs :: IO Dirs
getDirs = do
getAllDirs :: IO Dirs
getAllDirs = do
baseDir <- ghcupBaseDir
binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir
@ -226,9 +227,9 @@ ghcupConfigFile = do
-- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
ghcupGHCBaseDir = do
AppState { dirs = Dirs {..} } <- ask
Dirs {..} <- getDirs
pure (baseDir </> "ghc")
@ -236,7 +237,7 @@ ghcupGHCBaseDir = do
-- The dir may be of the form
-- * armv7-unknown-linux-gnueabihf-8.8.3
-- * 8.8.4
ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
=> GHCTargetVersion
-> m FilePath
ghcupGHCDir ver = do

10
lib/GHCup/Utils/File/Posix.hs
View File

@ -21,6 +21,7 @@ module GHCup.Utils.File.Posix where
import GHCup.Utils.File.Common
import GHCup.Utils.Prelude
import GHCup.Types
import GHCup.Types.Optics
import Control.Concurrent
import Control.Concurrent.Async
@ -74,7 +75,11 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do
SPP.executeFile path True args Nothing
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
execLogged :: ( MonadReader env m
, HasSettings env
, HasDirs env
, MonadIO m
, MonadThrow m)
=> FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
@ -82,7 +87,8 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
execLogged exe args chdir lfile env = do
AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
Settings {..} <- getSettings
Dirs {..} <- getDirs
let logfile = logsDir </> lfile <> ".log"
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
closeFd

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

@ -146,7 +146,11 @@ executeOut path args chdir = do
pure $ CapturedProcess exit out err
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
execLogged :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadThrow m)
=> FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
@ -154,7 +158,7 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
execLogged exe args chdir lfile env = do
AppState { dirs = Dirs {..} } <- ask
Dirs {..} <- getDirs
let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
stderrLogfile = logsDir </> lfile <> ".stderr.log"
cp <- createProcessWithMingwPath ((proc exe args)