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

Use LabelOptic and add LeanAppState

Browse Source 
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.Platform
import GHCup.Requirements import GHCup.Requirements
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.File import GHCup.Utils.File
import GHCup.Utils.Logger import GHCup.Utils.Logger
@ -66,7 +67,6 @@ import System.Environment
import System.Exit import System.Exit
import System.FilePath import System.FilePath
import System.IO hiding ( appendFile ) import System.IO hiding ( appendFile )
import System.IO.Unsafe ( unsafeInterleaveIO )
import Text.Read hiding ( lift ) import Text.Read hiding ( lift )
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString import URI.ByteString
@ -942,7 +942,7 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
tagCompleter :: Tool -> [String] -> Completer tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getDirs dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = False { lcPrintDebug = False
, colorOutter = mempty , colorOutter = mempty
@ -962,7 +962,7 @@ tagCompleter tool add = listIOCompleter $ do
versionCompleter :: Maybe ListCriteria -> Tool -> Completer versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter criteria tool = listIOCompleter $ do versionCompleter criteria tool = listIOCompleter $ do
dirs' <- liftIO getDirs dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = False { lcPrintDebug = False
, colorOutter = mempty , colorOutter = mempty
@ -1167,7 +1167,7 @@ describe_result :: String
describe_result = $( LitE . StringL <$> describe_result = $( LitE . StringL <$>
runIO (do runIO (do
CapturedProcess{..} <- do CapturedProcess{..} <- do
dirs <- liftIO getDirs dirs <- liftIO getAllDirs
let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings
flip runReaderT settings $ executeOut "git" ["describe"] Nothing flip runReaderT settings $ executeOut "git" ["describe"] Nothing
case _exitCode of case _exitCode of
@ -1220,7 +1220,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(footerDoc (Just $ text main_footer)) (footerDoc (Just $ text main_footer))
) )
>>= \opt@Options {..} -> do >>= \opt@Options {..} -> do
dirs <- getDirs dirs@Dirs{..} <- getAllDirs
-- create ~/.ghcup dir -- create ~/.ghcup dir
ensureDirectories dirs ensureDirectories dirs
@ -1228,7 +1228,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(settings, keybindings) <- toSettings opt (settings, keybindings) <- toSettings opt
-- logger interpreter -- logger interpreter
logfile <- initGHCupFileLogging (logsDir dirs) logfile <- initGHCupFileLogging logsDir
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings { lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr , colorOutter = B.hPut stderr
@ -1240,72 +1240,57 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runLogger = myLoggerT loggerConfig let runLogger = myLoggerT loggerConfig
let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () } 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 -- -- Setting up appstate --
------------------------- -------------------------
let appstate@AppState{dirs = Dirs{..} let leanAppstate = LeanAppState settings dirs keybindings
, ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls, .. } appState = do
} = AppState settings dirs keybindings ghcupInfo pfreq 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'
--------------------------- runLeanAppState = flip runReaderT leanAppstate
-- Running startup tasks -- 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 , NoToolVersionSet
] ]
let runInstTool = runInstTool' appstate let runInstTool mInstPlatform action' = do
s' <- liftIO appState
runInstTool' s' mInstPlatform action'
let let
runLeanSetGHC =
runLogger
. runLeanAppState
. runE
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
runSetGHC = runSetGHC =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runE . runE
@'[ FileDoesNotExistError @'[ FileDoesNotExistError
, NotInstalled , NotInstalled
@ -1350,9 +1348,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
] ]
let let
runLeanSetCabal =
runLogger
. runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
runSetCabal = runSetCabal =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
@ -1363,7 +1371,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let let
runSetHLS = runSetHLS =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
@ -1371,20 +1379,30 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NoToolVersionSet , NoToolVersionSet
] ]
let runListGHC = runLogger . flip runReaderT appstate runLeanSetHLS =
runLogger
. runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
, NextVerNotFound
, NoToolVersionSet
]
let runListGHC = runLogger . runAppState
let runRm = let runRm =
runLogger . flip runReaderT appstate . runE @'[NotInstalled] runLogger . runAppState . runE @'[NotInstalled]
let runDebugInfo = let runDebugInfo =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runE . runE
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC = let runCompileGHC =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runResourceT . runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
@ -1404,9 +1422,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
] ]
let let
runLeanWhereIs =
runLogger
. runLeanAppState
. runE
@'[ NotInstalled
, NoToolVersionSet
, NextVerNotFound
, TagNotFound
]
runWhereIs = runWhereIs =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, NoToolVersionSet , NoToolVersionSet
@ -1416,7 +1444,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runUpgrade = let runUpgrade =
runLogger runLogger
. flip runReaderT appstate . runAppState
. runResourceT . runResourceT
. runE . runE
@'[ DigestError @'[ DigestError
@ -1439,13 +1467,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
liftE $ installGHCBin (_tvVersion v) liftE $ installGHCBin (_tvVersion v)
when instSet $ void $ liftE $ setGHC v SetGHCOnly when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi pure vi
Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} instPlatform $ do Just uri -> do
(v, vi) <- liftE $ fromVersion instVer GHC s' <- liftIO appState
liftE $ installGHCBindist runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (v, vi) <- liftE $ fromVersion instVer GHC
(_tvVersion v) liftE $ installGHCBindist
when instSet $ void $ liftE $ setGHC v SetGHCOnly (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
pure vi (_tvVersion v)
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -1477,12 +1507,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(v, vi) <- liftE $ fromVersion instVer Cabal (v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin (_tvVersion v) liftE $ installCabalBin (_tvVersion v)
pure vi pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do Just uri -> do
(v, vi) <- liftE $ fromVersion instVer Cabal s' <- appState
liftE $ installCabalBindist runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(DownloadInfo uri Nothing "") (v, vi) <- liftE $ fromVersion instVer Cabal
(_tvVersion v) liftE $ installCabalBindist
pure vi (DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -1506,12 +1538,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(v, vi) <- liftE $ fromVersion instVer HLS (v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin (_tvVersion v) liftE $ installHLSBin (_tvVersion v)
pure vi pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do Just uri -> do
(v, vi) <- liftE $ fromVersion instVer HLS s' <- appState
liftE $ installHLSBindist runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(DownloadInfo uri Nothing "") (v, vi) <- liftE $ fromVersion instVer HLS
(_tvVersion v) liftE $ installHLSBindist
pure vi (DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -1535,12 +1569,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(v, vi) <- liftE $ fromVersion instVer Stack (v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin (_tvVersion v) liftE $ installStackBin (_tvVersion v)
pure vi pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} instPlatform $ do Just uri -> do
(v, vi) <- liftE $ fromVersion instVer Stack s' <- appState
liftE $ installStackBindist runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(DownloadInfo uri Nothing "") (v, vi) <- liftE $ fromVersion instVer Stack
(_tvVersion v) liftE $ installStackBindist
pure vi (DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -1559,11 +1595,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 4 pure $ ExitFailure 4
let setGHC' SetOptions{..} = let setGHC' SetOptions{ sToolVer } =
runSetGHC (do case sToolVer of
v <- liftE $ fst <$> fromVersion' sToolVer GHC (SetToolVersion v) -> runLeanSetGHC (liftE $ setGHC v SetGHCOnly >> pure v)
liftE $ setGHC v SetGHCOnly _ -> runSetGHC (do
) v <- liftE $ fst <$> fromVersion' sToolVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case >>= \case
VRight GHCTargetVersion{..} -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
@ -1574,12 +1612,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 5 pure $ ExitFailure 5
let setCabal' SetOptions{..} = let setCabal' SetOptions{ sToolVer } =
runSetCabal (do case sToolVer of
v <- liftE $ fst <$> fromVersion' sToolVer Cabal (SetToolVersion v) -> runLeanSetCabal (liftE $ setCabal (_tvVersion v) >> pure v)
liftE $ setCabal (_tvVersion v) _ -> runSetCabal (do
pure v v <- liftE $ fst <$> fromVersion' sToolVer Cabal
) liftE $ setCabal (_tvVersion v)
pure v
)
>>= \case >>= \case
VRight GHCTargetVersion{..} -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
@ -1590,12 +1630,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 14 pure $ ExitFailure 14
let setHLS' SetOptions{..} = let setHLS' SetOptions{ sToolVer } =
runSetHLS (do case sToolVer of
v <- liftE $ fst <$> fromVersion' sToolVer HLS (SetToolVersion v) -> runLeanSetHLS (liftE $ setHLS (_tvVersion v) >> pure v)
liftE $ setHLS (_tvVersion v) _ -> runSetHLS (do
pure v v <- liftE $ fst <$> fromVersion' sToolVer HLS
) liftE $ setHLS (_tvVersion v)
pure v
)
>>= \case >>= \case
VRight GHCTargetVersion{..} -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
@ -1606,12 +1648,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 14 pure $ ExitFailure 14
let setStack' SetOptions{..} = let setStack' SetOptions{ sToolVer } =
runSetCabal (do case sToolVer of
v <- liftE $ fst <$> fromVersion' sToolVer Stack (SetToolVersion v) -> runSetCabal (liftE $ setStack (_tvVersion v) >> pure v)
liftE $ setStack (_tvVersion v) _ -> runSetCabal (do
pure v v <- liftE $ fst <$> fromVersion' sToolVer Stack
) liftE $ setStack (_tvVersion v)
pure v
)
>>= \case >>= \case
VRight GHCTargetVersion{..} -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
@ -1626,6 +1670,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runRm (do runRm (do
liftE $ liftE $
rmGHCVer ghcVer rmGHCVer ghcVer
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo (_tvVersion ghcVer) GHC dls) pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
) )
>>= \case >>= \case
@ -1641,6 +1686,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runRm (do runRm (do
liftE $ liftE $
rmCabalVer tv rmCabalVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Cabal dls) pure (getVersionInfo tv Cabal dls)
) )
>>= \case >>= \case
@ -1656,6 +1702,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runRm (do runRm (do
liftE $ liftE $
rmHLSVer tv rmHLSVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv HLS dls) pure (getVersionInfo tv HLS dls)
) )
>>= \case >>= \case
@ -1671,6 +1718,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runRm (do runRm (do
liftE $ liftE $
rmStackVer tv rmStackVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Stack dls) pure (getVersionInfo tv Stack dls)
) )
>>= \case >>= \case
@ -1735,6 +1783,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runCompileGHC (do runCompileGHC (do
case targetGhc of case targetGhc of
Left targetVer -> do Left targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ $(logInfo) msg lift $ $(logInfo) msg
@ -1750,6 +1799,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
buildConfig buildConfig
patchDir patchDir
addConfArgs addConfArgs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $
setGHC targetVer SetGHCOnly setGHC targetVer SetGHCOnly
@ -1777,6 +1827,21 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 9 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) -> Whereis WhereisOptions{..} (WhereisTool tool whereVer) ->
runWhereIs (do runWhereIs (do
(v, _) <- liftE $ fromVersion whereVer tool (v, _) <- liftE $ fromVersion whereVer tool
@ -1801,6 +1866,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
runUpgrade (liftE $ upgradeGHCup target force') >>= \case runUpgrade (liftE $ upgradeGHCup target force') >>= \case
VRight v' -> do VRight v' -> do
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
let pretty_v = prettyVer v' let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup let vi = fromJust $ snd <$> getLatest dls GHCup
runLogger $ $(logInfo) runLogger $ $(logInfo)
@ -1815,23 +1881,26 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 11 pure $ ExitFailure 11
ToolRequirements -> ToolRequirements -> do
flip runReaderT appstate s' <- appState
$ runLogger flip runReaderT s'
(runE $ runLogger
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements] (runE
$ do @'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
platform <- liftE getPlatform $ do
req <- getCommonRequirements platform _toolRequirements ?? NoToolRequirements GHCupInfo { .. } <- lift getGHCupInfo
liftIO $ T.hPutStr stdout (prettyRequirements req) platform' <- liftE getPlatform
) req <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
>>= \case liftIO $ T.hPutStr stdout (prettyRequirements req)
VRight _ -> pure ExitSuccess )
VLeft e -> do >>= \case
runLogger $ $(logError) $ T.pack $ prettyShow e VRight _ -> pure ExitSuccess
pure $ ExitFailure 12 VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 12
ChangeLog ChangeLogOptions{..} -> do ChangeLog ChangeLogOptions{..} -> do
GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
let tool = fromMaybe GHC clTool let tool = fromMaybe GHC clTool
ver' = maybe ver' = maybe
(Right Latest) (Right Latest)
@ -1849,6 +1918,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
) )
pure ExitSuccess pure ExitSuccess
Just uri -> do Just uri -> do
pfreq <- runAppState getPlatformReq
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
cmd = case _rPlatform pfreq of cmd = case _rPlatform pfreq of
Darwin -> "open" Darwin -> "open"
@ -1857,21 +1927,23 @@ Make sure to clean up #{tmpdir} afterwards.|])
Windows -> "start" Windows -> "start"
if clOpen if clOpen
then then do
flip runReaderT appstate $ s' <- appState
exec cmd flip runReaderT s' $
[T.unpack $ decUTF8Safe $ serializeURIRef' uri] exec cmd
Nothing [T.unpack $ decUTF8Safe $ serializeURIRef' uri]
Nothing Nothing
>>= \case Nothing
Right _ -> pure ExitSuccess >>= \case
Left e -> runLogger ($(logError) [i|#{e}|]) Right _ -> pure ExitSuccess
>> pure (ExitFailure 13) Left e -> runLogger ($(logError) [i|#{e}|])
>> pure (ExitFailure 13)
else putStrLn uri' >> pure ExitSuccess else putStrLn uri' >> pure ExitSuccess
Nuke -> Nuke ->
runRm (do 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 "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." lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
liftIO $ threadDelay 10000000 -- wait 10s liftIO $ threadDelay 10000000 -- wait 10s
@ -1907,22 +1979,46 @@ Make sure to clean up #{tmpdir} afterwards.|])
pure () 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 => Maybe ToolVersion
-> Tool -> Tool
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo) -> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion tv = fromVersion' (toSetToolVer tv) 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 => SetToolVersion
-> Tool -> Tool
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo) -> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion' SetRecommended tool = do 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 (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool
?? TagNotFound Recommended tool ?? TagNotFound Recommended tool
fromVersion' (SetToolVersion v) tool = do fromVersion' (SetToolVersion v) tool = do
~AppState { ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls }} <- lift ask GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion v) tool dls let vi = getVersionInfo (_tvVersion v) tool dls
case pvp $ prettyVer (_tvVersion v) of case pvp $ prettyVer (_tvVersion v) of
Left _ -> pure (v, vi) Left _ -> pure (v, vi)
@ -1932,16 +2028,16 @@ fromVersion' (SetToolVersion v) tool = do
Nothing -> pure (v, vi) Nothing -> pure (v, vi)
Right _ -> pure (v, vi) Right _ -> pure (v, vi)
fromVersion' (SetToolTag Latest) tool = do 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 (\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolTag Recommended) tool = do 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 (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool
fromVersion' (SetToolTag (Base pvp'')) GHC = do 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 (\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' SetNext tool = do fromVersion' SetNext tool = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
next <- case tool of next <- case tool of
GHC -> do GHC -> do
set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool
@ -2142,7 +2238,10 @@ printListResult raw lr = do
| otherwise -> 1 | otherwise -> 1
checkForUpdates :: ( MonadReader AppState m checkForUpdates :: ( MonadReader env m
, HasGHCupInfo env
, HasDirs env
, HasPlatformReq env
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
@ -2152,7 +2251,7 @@ checkForUpdates :: ( MonadReader AppState m
) )
=> m () => m ()
checkForUpdates = do checkForUpdates = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
lInstalled <- listVersions Nothing (Just ListInstalled) lInstalled <- listVersions Nothing (Just ListInstalled)
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled 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 installGHCBindist :: ( MonadFail m
, MonadMask m , MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -130,7 +133,8 @@ installGHCBindist :: ( MonadFail m
m m
() ()
installGHCBindist dlinfo ver = do installGHCBindist dlinfo ver = do
AppState { dirs , settings } <- lift ask dirs <- lift getDirs
settings <- lift getSettings
let tver = mkTVer ver let tver = mkTVer ver
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
@ -163,7 +167,10 @@ installGHCBindist dlinfo ver = do
-- build system and nothing else. -- build system and nothing else.
installPackedGHC :: ( MonadMask m installPackedGHC :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasSettings env
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -182,7 +189,7 @@ installPackedGHC :: ( MonadMask m
#endif #endif
] m () ] m ()
installPackedGHC dl msubdir inst ver = do installPackedGHC dl msubdir inst ver = do
AppState { pfreq = PlatformRequest {..} } <- lift ask PlatformRequest {..} <- lift getPlatformReq
-- unpack -- unpack
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
@ -201,7 +208,10 @@ installPackedGHC dl msubdir inst ver = do
-- | Install an unpacked GHC distribution. This only deals with the GHC -- | Install an unpacked GHC distribution. This only deals with the GHC
-- build system and nothing else. -- build system and nothing else.
installUnpackedGHC :: ( MonadReader AppState m installUnpackedGHC :: ( MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -218,7 +228,7 @@ installUnpackedGHC path inst _ = do
liftIO $ copyDirectoryRecursive path inst liftIO $ copyDirectoryRecursive path inst
#else #else
installUnpackedGHC path inst ver = do installUnpackedGHC path inst ver = do
AppState { pfreq = PlatformRequest {..} } <- lift ask PlatformRequest {..} <- lift getPlatformReq
let alpineArgs let alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
@ -250,7 +260,11 @@ installUnpackedGHC path inst ver = do
installGHCBin :: ( MonadFail m installGHCBin :: ( MonadFail m
, MonadMask m , MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -273,8 +287,8 @@ installGHCBin :: ( MonadFail m
m m
() ()
installGHCBin ver = do installGHCBin ver = do
AppState { pfreq pfreq <- lift getPlatformReq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
dlinfo <- lE $ getDownloadInfo GHC ver pfreq dls dlinfo <- lE $ getDownloadInfo GHC ver pfreq dls
installGHCBindist dlinfo ver installGHCBindist dlinfo ver
@ -283,7 +297,10 @@ installGHCBin ver = do
-- argument instead of looking it up from 'GHCupDownloads'. -- argument instead of looking it up from 'GHCupDownloads'.
installCabalBindist :: ( MonadMask m installCabalBindist :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -310,9 +327,9 @@ installCabalBindist :: ( MonadMask m
installCabalBindist dlinfo ver = do installCabalBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
AppState { dirs = dirs@Dirs {..} PlatformRequest {..} <- lift getPlatformReq
, pfreq = PlatformRequest {..} dirs@Dirs {..} <- lift getDirs
, settings } <- lift ask settings <- lift getSettings
whenM whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $ (lift (cabalInstalled ver) >>= \a -> liftIO $
@ -364,7 +381,11 @@ installCabalBindist dlinfo ver = do
-- the latest installed version. -- the latest installed version.
installCabalBin :: ( MonadMask m installCabalBin :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -388,8 +409,9 @@ installCabalBin :: ( MonadMask m
m m
() ()
installCabalBin ver = do installCabalBin ver = do
AppState { pfreq pfreq <- lift getPlatformReq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq dls dlinfo <- lE $ getDownloadInfo Cabal ver pfreq dls
installCabalBindist dlinfo ver installCabalBindist dlinfo ver
@ -398,7 +420,10 @@ installCabalBin ver = do
-- argument instead of looking it up from 'GHCupDownloads'. -- argument instead of looking it up from 'GHCupDownloads'.
installHLSBindist :: ( MonadMask m installHLSBindist :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -425,9 +450,9 @@ installHLSBindist :: ( MonadMask m
installHLSBindist dlinfo ver = do installHLSBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|] lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
AppState { dirs = dirs@Dirs {..} PlatformRequest {..} <- lift getPlatformReq
, pfreq = PlatformRequest {..} dirs@Dirs {..} <- lift getDirs
, settings } <- lift ask settings <- lift getSettings
whenM (lift (hlsInstalled ver)) whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled HLS ver) (throwE $ AlreadyInstalled HLS ver)
@ -488,7 +513,11 @@ installHLSBindist dlinfo ver = do
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
installHLSBin :: ( MonadMask m installHLSBin :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -512,8 +541,9 @@ installHLSBin :: ( MonadMask m
m m
() ()
installHLSBin ver = do installHLSBin ver = do
AppState { pfreq pfreq <- lift getPlatformReq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
dlinfo <- lE $ getDownloadInfo HLS ver pfreq dls dlinfo <- lE $ getDownloadInfo HLS ver pfreq dls
installHLSBindist dlinfo ver installHLSBindist dlinfo ver
@ -523,7 +553,11 @@ installHLSBin ver = do
-- the latest installed version. -- the latest installed version.
installStackBin :: ( MonadMask m installStackBin :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -547,7 +581,9 @@ installStackBin :: ( MonadMask m
m m
() ()
installStackBin ver = do 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 dlinfo <- lE $ getDownloadInfo Stack ver pfreq dls
installStackBindist dlinfo ver installStackBindist dlinfo ver
@ -556,7 +592,10 @@ installStackBin ver = do
-- argument instead of looking it up from 'GHCupDownloads'. -- argument instead of looking it up from 'GHCupDownloads'.
installStackBindist :: ( MonadMask m installStackBindist :: ( MonadMask m
, MonadCatch m , MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m , MonadLogger m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -583,10 +622,9 @@ installStackBindist :: ( MonadMask m
installStackBindist dlinfo ver = do installStackBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install stack version #{ver}|] lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
AppState { dirs = dirs@Dirs {..} PlatformRequest {..} <- lift getPlatformReq
, pfreq = PlatformRequest {..} dirs@Dirs {..} <- lift getDirs
, settings settings <- lift getSettings
} <- lift ask
whenM (lift (stackInstalled ver)) whenM (lift (stackInstalled ver))
(throwE $ AlreadyInstalled Stack ver) (throwE $ AlreadyInstalled Stack ver)
@ -644,7 +682,8 @@ installStackBindist dlinfo ver = do
-- --
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@ -- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
-- for 'SetGHCOnly' constructor. -- for 'SetGHCOnly' constructor.
setGHC :: ( MonadReader AppState m setGHC :: ( MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -663,7 +702,7 @@ setGHC ver sghc = do
whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver)) whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))
-- symlink destination -- symlink destination
AppState { dirs = Dirs {..} } <- lift ask Dirs {..} <- lift getDirs
-- first delete the old symlinks (this fixes compatibility issues -- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup) -- with old ghcup)
@ -701,12 +740,15 @@ setGHC ver sghc = do
where where
symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m) symlinkShareDir :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m)
=> FilePath => FilePath
-> String -> String
-> m () -> m ()
symlinkShareDir ghcdir ver' = do symlinkShareDir ghcdir ver' = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
let destdir = baseDir let destdir = baseDir
case sghc of case sghc of
SetGHCOnly -> do SetGHCOnly -> do
@ -733,7 +775,8 @@ setGHC ver sghc = do
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink. -- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
setCabal :: ( MonadMask m setCabal :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -745,7 +788,7 @@ setCabal ver = do
let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
-- symlink destination -- symlink destination
AppState {dirs = Dirs {..}} <- lift ask Dirs {..} <- lift getDirs
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile)) whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
$ throwE $ throwE
@ -764,7 +807,8 @@ setCabal ver = do
-- | Set the haskell-language-server symlinks. -- | Set the haskell-language-server symlinks.
setHLS :: ( MonadCatch m setHLS :: ( MonadCatch m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -775,7 +819,7 @@ setHLS :: ( MonadCatch m
=> Version => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
setHLS ver = do setHLS ver = do
AppState { dirs = Dirs {..} } <- lift ask Dirs {..} <- lift getDirs
-- Delete old symlinks, since these might have different ghc versions than the -- Delete old symlinks, since these might have different ghc versions than the
-- selected version, so we could end up with stray or incorrect symlinks. -- 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. -- | Set the @~\/.ghcup\/bin\/stack@ symlink.
setStack :: ( MonadMask m setStack :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -817,7 +862,7 @@ setStack ver = do
let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
-- symlink destination -- symlink destination
AppState {dirs = Dirs {..}} <- lift ask Dirs {..} <- lift getDirs
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile)) whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
$ throwE $ throwE
@ -872,7 +917,10 @@ listVersions :: ( MonadCatch m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
) )
=> Maybe Tool => Maybe Tool
-> Maybe ListCriteria -> Maybe ListCriteria
@ -891,7 +939,7 @@ listVersions lt' criteria = do
go lt cSet cabals hlsSet' hlses sSet stacks = do go lt cSet cabals hlsSet' hlses sSet stacks = do
case lt of case lt of
Just t -> do Just t -> do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
-- get versions from GHCupDownloads -- get versions from GHCupDownloads
let avTools = availableToolVersions dls t let avTools = availableToolVersions dls t
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks) 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 ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks
stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks
pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers) 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] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayGHCs avTools = do strayGHCs avTools = do
@ -959,7 +1013,13 @@ listVersions lt' criteria = do
[i|Could not parse version of stray directory #{e}|] [i|Could not parse version of stray directory #{e}|]
pure Nothing 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] => Map.Map Version [Tag]
-> Maybe Version -> Maybe Version
-> [Either FilePath Version] -> [Either FilePath Version]
@ -988,7 +1048,12 @@ listVersions lt' criteria = do
[i|Could not parse version of stray directory #{e}|] [i|Could not parse version of stray directory #{e}|]
pure Nothing 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] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayHLS avTools = do strayHLS avTools = do
@ -1016,7 +1081,13 @@ listVersions lt' criteria = do
[i|Could not parse version of stray directory #{e}|] [i|Could not parse version of stray directory #{e}|]
pure Nothing 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] => Map.Map Version [Tag]
-> m [ListResult] -> m [ListResult]
strayStacks avTools = do strayStacks avTools = do
@ -1045,7 +1116,14 @@ listVersions lt' criteria = do
pure Nothing pure Nothing
-- NOTE: this are not cross ones, because no bindists -- 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 => Tool
-> Maybe Version -> Maybe Version
-> [Either FilePath Version] -> [Either FilePath Version]
@ -1056,8 +1134,8 @@ listVersions lt' criteria = do
-> (Version, [Tag]) -> (Version, [Tag])
-> m ListResult -> m ListResult
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = do toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = do
AppState { pfreq pfreq <- getPlatformReq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
case t of case t of
GHC -> do GHC -> do
@ -1140,7 +1218,8 @@ listVersions lt' criteria = do
-- This may leave GHCup without a "set" version. -- This may leave GHCup without a "set" version.
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an -- Will try to fix the ghc-x.y symlink after removal (e.g. to an
-- older version). -- older version).
rmGHCVer :: ( MonadReader AppState m rmGHCVer :: ( MonadReader env m
, HasDirs env
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -1181,7 +1260,7 @@ rmGHCVer ver = do
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver)) forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
AppState { dirs = Dirs {..} } <- lift ask Dirs {..} <- lift getDirs
liftIO liftIO
$ hideError doesNotExistErrorType $ hideError doesNotExistErrorType
@ -1191,7 +1270,8 @@ rmGHCVer ver = do
-- | Delete a cabal version. Will try to fix the @cabal@ symlink -- | Delete a cabal version. Will try to fix the @cabal@ symlink
-- after removal (e.g. setting it to an older version). -- after removal (e.g. setting it to an older version).
rmCabalVer :: ( MonadMask m rmCabalVer :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -1206,7 +1286,7 @@ rmCabalVer ver = do
cSet <- lift cabalSet cSet <- lift cabalSet
AppState {dirs = Dirs {..}} <- lift ask Dirs {..} <- lift getDirs
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile) liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile)
@ -1221,7 +1301,8 @@ rmCabalVer ver = do
-- | Delete a hls version. Will try to fix the hls symlinks -- | Delete a hls version. Will try to fix the hls symlinks
-- after removal (e.g. setting it to an older version). -- after removal (e.g. setting it to an older version).
rmHLSVer :: ( MonadMask m rmHLSVer :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -1236,7 +1317,7 @@ rmHLSVer ver = do
isHlsSet <- lift hlsSet isHlsSet <- lift hlsSet
AppState {dirs = Dirs {..}} <- lift ask Dirs {..} <- lift getDirs
bins <- lift $ hlsAllBinaries ver bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> liftIO $ rmFile (binDir </> f) 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 -- | Delete a stack version. Will try to fix the @stack@ symlink
-- after removal (e.g. setting it to an older version). -- after removal (e.g. setting it to an older version).
rmStackVer :: ( MonadMask m rmStackVer :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -1273,7 +1355,7 @@ rmStackVer ver = do
sSet <- lift stackSet sSet <- lift stackSet
AppState {dirs = Dirs {..}} <- lift ask Dirs {..} <- lift getDirs
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile) 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. -- 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 , MonadIO m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
) )
=> m () => m ()
rmGhcup = do rmGhcup = do
AppState {dirs = Dirs {binDir}} <- ask Dirs {binDir} <- getDirs
let ghcupFilename = "ghcup" <> exeExt let ghcupFilename = "ghcup" <> exeExt
let ghcupFilepath = binDir </> ghcupFilename let ghcupFilepath = binDir </> ghcupFilename
@ -1338,14 +1420,14 @@ rmGhcup = do
<> path <> <> path <>
"\n you may have to uninstall it manually." "\n you may have to uninstall it manually."
rmTool :: ( MonadReader AppState m rmTool :: ( MonadReader env m
, MonadLogger m , HasDirs env
, MonadFail m , MonadLogger m
, MonadMask m , MonadFail m
, MonadUnliftIO m) , MonadMask m
=> ListResult , MonadUnliftIO m)
-> Excepts '[NotInstalled ] m () => ListResult
-> Excepts '[NotInstalled ] m ()
rmTool ListResult {lVer, lTool, lCross} = do rmTool ListResult {lVer, lTool, lCross} = do
case lTool of case lTool of
GHC -> GHC ->
@ -1357,7 +1439,8 @@ rmTool ListResult {lVer, lTool, lCross} = do
GHCup -> lift rmGhcup GHCup -> lift rmGhcup
rmGhcupDirs :: ( MonadReader AppState m rmGhcupDirs :: ( MonadReader env m
, HasDirs env
, MonadIO m , MonadIO m
, MonadLogger m , MonadLogger m
, MonadCatch m , MonadCatch m
@ -1369,7 +1452,7 @@ rmGhcupDirs = do
, binDir , binDir
, logsDir , logsDir
, cacheDir , cacheDir
} <- asks dirs } <- getDirs
let envFilePath = baseDir </> "env" 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 => Excepts
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
m m
DebugInfo DebugInfo
getDebugInfo = do getDebugInfo = do
AppState {dirs = Dirs {..}} <- lift ask Dirs {..} <- lift getDirs
let diBaseDir = baseDir let diBaseDir = baseDir
let diBinDir = binDir let diBinDir = binDir
diGHCDir <- lift ghcupGHCBaseDir diGHCDir <- lift ghcupGHCBaseDir
@ -1503,7 +1593,11 @@ getDebugInfo = do
-- | Compile a GHC from source. This behaves wrt symlinks and installation -- | Compile a GHC from source. This behaves wrt symlinks and installation
-- the same as 'installGHCBin'. -- the same as 'installGHCBin'.
compileGHC :: ( MonadMask m compileGHC :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
, HasSettings env
, MonadThrow m , MonadThrow m
, MonadResource m , MonadResource m
, MonadLogger m , MonadLogger m
@ -1538,10 +1632,11 @@ compileGHC :: ( MonadMask m
GHCTargetVersion GHCTargetVersion
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
= do = do
AppState { pfreq = PlatformRequest {..} PlatformRequest { .. } <- lift getPlatformReq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls } GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
, settings settings <- lift getSettings
, dirs } <- lift ask dirs <- lift getDirs
(workdir, tmpUnpack, tver) <- case targetGhc of (workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball -- unpack from version tarball
Left tver -> do Left tver -> do
@ -1662,7 +1757,10 @@ BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES|] HADDOCK_DOCS = YES|]
compileBindist :: ( MonadReader AppState m compileBindist :: ( MonadReader env m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
@ -1680,8 +1778,9 @@ HADDOCK_DOCS = YES|]
compileBindist bghc tver workdir ghcdir = do compileBindist bghc tver workdir ghcdir = do
lift $ $(logInfo) [i|configuring build|] lift $ $(logInfo) [i|configuring build|]
liftE checkBuildConfig liftE checkBuildConfig
AppState { dirs = Dirs {..}, pfreq } <- lift ask Dirs {..} <- lift getDirs
pfreq <- lift getPlatformReq
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
@ -1805,7 +1904,11 @@ HADDOCK_DOCS = YES|]
-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@, -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
-- if no path is provided. -- if no path is provided.
upgradeGHCup :: ( MonadMask m upgradeGHCup :: ( MonadMask m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
, HasSettings env
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
@ -1826,10 +1929,11 @@ upgradeGHCup :: ( MonadMask m
m m
Version Version
upgradeGHCup mtarget force' = do upgradeGHCup mtarget force' = do
AppState { dirs = Dirs {..} Dirs {..} <- lift getDirs
, pfreq pfreq <- lift getPlatformReq
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls } settings <- lift getSettings
, settings } <- lift ask GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
lift $ $(logInfo) [i|Upgrading GHCup...|] lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ fst <$> getLatest dls GHCup let latestVer = fromJust $ fst <$> getLatest dls GHCup
when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate 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 -- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
-- both installing from source and bindist. -- both installing from source and bindist.
postGHCInstall :: ( MonadReader AppState m postGHCInstall :: ( MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -1909,7 +2014,8 @@ postGHCInstall ver@GHCTargetVersion {..} = do
-- * for hls, this reports @~\/.ghcup\/bin\/haskell-language-server-wrapper-\<ver\>@ -- * for hls, this reports @~\/.ghcup\/bin\/haskell-language-server-wrapper-\<ver\>@
-- * for stack, this reports @~\/.ghcup\/bin\/stack-\<ver\>@ -- * for stack, this reports @~\/.ghcup\/bin\/stack-\<ver\>@
-- * for ghcup, this reports the location of the currently running executable -- * for ghcup, this reports the location of the currently running executable
whereIsTool :: ( MonadReader AppState m whereIsTool :: ( MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -1922,7 +2028,7 @@ whereIsTool :: ( MonadReader AppState m
-> GHCTargetVersion -> GHCTargetVersion
-> Excepts '[NotInstalled] m FilePath -> Excepts '[NotInstalled] m FilePath
whereIsTool tool ver@GHCTargetVersion {..} = do whereIsTool tool ver@GHCTargetVersion {..} = do
AppState { dirs } <- lift ask dirs <- lift getDirs
case tool of case tool of
GHC -> do GHC -> do
@ -1946,3 +2052,6 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
GHCup -> do GHCup -> do
currentRunningExecPath <- liftIO getExecutablePath currentRunningExecPath <- liftIO getExecutablePath
liftIO $ canonicalizePath currentRunningExecPath liftIO $ canonicalizePath currentRunningExecPath

14
lib/GHCup/Types.hs
View File

@ -1,9 +1,12 @@
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-| {-|
Module : GHCup.Types Module : GHCup.Types
@ -346,8 +349,14 @@ data AppState = AppState
{ settings :: Settings { settings :: Settings
, dirs :: Dirs , dirs :: Dirs
, keyBindings :: KeyBindings , keyBindings :: KeyBindings
, ghcupInfo :: ~GHCupInfo , ghcupInfo :: GHCupInfo
, pfreq :: ~PlatformRequest , pfreq :: PlatformRequest
} deriving (Show, GHC.Generic)
data LeanAppState = LeanAppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
} deriving (Show, GHC.Generic) } deriving (Show, GHC.Generic)
instance NFData AppState instance NFData AppState
@ -507,4 +516,3 @@ instance (Monad m, Alternative m) => Alternative (LoggingT m) where
instance MonadLogger m => MonadLogger (Excepts e m) where instance MonadLogger m => MonadLogger (Excepts e m) where
monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d 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 Module : GHCup.Types.Optics
@ -13,6 +18,7 @@ module GHCup.Types.Optics where
import GHCup.Types import GHCup.Types
import Control.Monad.Reader
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Optics import Optics
import URI.ByteString import URI.ByteString
@ -58,3 +64,82 @@ pathL' = lensVL pathL
queryL' :: Lens' (URIRef a) Query queryL' :: Lens' (URIRef a) Query
queryL' = lensVL queryL 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. -- | 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. => FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
-> GHCTargetVersion -> GHCTargetVersion
-> m FilePath -> m FilePath
ghcLinkDestination tool ver = do ghcLinkDestination tool ver = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
ghcd <- ghcupGHCDir ver ghcd <- ghcupGHCDir ver
pure (relativeSymlink binDir (ghcd </> "bin" </> tool)) pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5. -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
rmMinorSymlinks :: ( MonadReader AppState m rmMinorSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m , MonadIO m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadReader AppState m
) )
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmMinorSymlinks tv@GHCTargetVersion{..} = do rmMinorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask Dirs {..} <- lift getDirs
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do forM_ files $ \f -> do
@ -135,7 +137,8 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
-- | Removes the set ghc version for the given target, if any. -- | Removes the set ghc version for the given target, if any.
rmPlain :: ( MonadReader AppState m rmPlain :: ( MonadReader env m
, HasDirs env
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
@ -144,7 +147,7 @@ rmPlain :: ( MonadReader AppState m
=> Maybe Text -- ^ target => Maybe Text -- ^ target
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmPlain target = do rmPlain target = do
AppState { dirs = Dirs {..} } <- lift ask Dirs {..} <- lift getDirs
mtv <- lift $ ghcSet target mtv <- lift $ ghcSet target
forM_ mtv $ \tv -> do forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
@ -159,17 +162,17 @@ rmPlain target = do
-- | Remove the major GHC symlink, e.g. ghc-8.6. -- | Remove the major GHC symlink, e.g. ghc-8.6.
rmMajorSymlinks :: ( MonadReader AppState m rmMajorSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m , MonadIO m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadReader AppState m
) )
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmMajorSymlinks tv@GHCTargetVersion{..} = do rmMajorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask Dirs {..} <- lift getDirs
(mj, mi) <- getMajorMinorV _tvVersion (mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi let v' = intToText mj <> "." <> intToText mi
@ -189,26 +192,26 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
-- | Whether the given GHC versin is installed. -- | 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 ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
liftIO $ doesDirectoryExist ghcdir liftIO $ doesDirectoryExist ghcdir
-- | Whether the given GHC version is installed from source. -- | Whether the given GHC version is installed from source.
ghcSrcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcSrcInstalled ver = do ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile) liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current. -- | Whether the given GHC version is set as the current.
ghcSet :: (MonadReader 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 => Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf) -- (e.g. armv7-unknown-linux-gnueabihf)
-> m (Maybe GHCTargetVersion) -> m (Maybe GHCTargetVersion)
ghcSet mtarget = do ghcSet mtarget = do
AppState {dirs = Dirs {..}} <- ask Dirs {..} <- getDirs
let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
let ghcBin = binDir </> ghc <> exeExt let ghcBin = binDir </> ghc <> exeExt
@ -239,7 +242,7 @@ ghcSet mtarget = do
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>. -- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left. -- If a dir cannot be parsed, returns left.
getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either FilePath GHCTargetVersion] getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
getInstalledGHCs = do getInstalledGHCs = do
ghcdir <- ghcupGHCBaseDir ghcdir <- ghcupGHCBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
@ -249,10 +252,15 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@. -- | 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] => m [Either FilePath Version]
getInstalledCabals = do getInstalledCabals = do
AppState {dirs = Dirs {..}} <- ask Dirs {..} <- getDirs
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString)) (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
@ -264,16 +272,16 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed. -- | 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 cabalInstalled ver = do
vers <- fmap rights getInstalledCabals vers <- fmap rights getInstalledCabals
pure $ elem ver vers pure $ elem ver vers
-- Return the currently set cabal version, if any. -- Return the currently set cabal version, if any.
cabalSet :: (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 cabalSet = do
AppState {dirs = Dirs {..}} <- ask Dirs {..} <- getDirs
let cabalbin = binDir </> "cabal" <> exeExt let cabalbin = binDir </> "cabal" <> exeExt
handleIO' NoSuchThing (\_ -> pure Nothing) $ do handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@ -317,10 +325,10 @@ cabalSet = do
-- | Get all installed hls, by matching on -- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@. -- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m) getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
=> m [Either FilePath Version] => m [Either FilePath Version]
getInstalledHLSs = do getInstalledHLSs = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended (makeRegexOpts compExtended
@ -337,10 +345,10 @@ getInstalledHLSs = do
-- | Get all installed stacks, by matching on -- | Get all installed stacks, by matching on
-- @~\/.ghcup\/bin/stack-<\stackver\>@. -- @~\/.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] => m [Either FilePath Version]
getInstalledStacks = do getInstalledStacks = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended (makeRegexOpts compExtended
@ -355,9 +363,9 @@ getInstalledStacks = do
-- Return the currently set stack version, if any. -- Return the currently set stack version, if any.
-- TODO: there's a lot of code duplication here :> -- 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 stackSet = do
AppState {dirs = Dirs {..}} <- ask Dirs {..} <- getDirs
let stackBin = binDir </> "stack" <> exeExt let stackBin = binDir </> "stack" <> exeExt
handleIO' NoSuchThing (\_ -> pure Nothing) $ do handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@ -395,13 +403,13 @@ stackSet = do
stripRelativePath = MP.many (MP.try stripPathComponet) stripRelativePath = MP.many (MP.try stripPathComponet)
-- | Whether the given Stack version is installed. -- | 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 stackInstalled ver = do
vers <- fmap rights getInstalledStacks vers <- fmap rights getInstalledStacks
pure $ elem ver vers pure $ elem ver vers
-- | Whether the given HLS version is installed. -- | 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 hlsInstalled ver = do
vers <- fmap rights getInstalledHLSs vers <- fmap rights getInstalledHLSs
pure $ elem ver vers pure $ elem ver vers
@ -409,9 +417,9 @@ hlsInstalled ver = do
-- Return the currently set hls version, if any. -- 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 hlsSet = do
AppState {dirs = Dirs {..}} <- ask Dirs {..} <- getDirs
let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@ -443,7 +451,8 @@ hlsSet = do
-- | Return the GHC versions the currently selected HLS supports. -- | Return the GHC versions the currently selected HLS supports.
hlsGHCVersions :: ( MonadReader AppState m hlsGHCVersions :: ( MonadReader env m
, HasDirs env
, MonadIO m , MonadIO m
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
@ -466,11 +475,11 @@ hlsGHCVersions = do
-- | Get all server binaries for an hls version, if any. -- | Get all server binaries for an hls version, if any.
hlsServerBinaries :: (MonadReader AppState m, MonadIO m) hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
=> Version => Version
-> m [FilePath] -> m [FilePath]
hlsServerBinaries ver = do hlsServerBinaries ver = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
liftIO $ handleIO (\_ -> pure []) $ findFiles liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts (makeRegexOpts
@ -482,12 +491,12 @@ hlsServerBinaries ver = do
-- | Get the wrapper binary for an hls version, if any. -- | Get the wrapper binary for an hls version, if any.
hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m) hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
=> Version => Version
-> m (Maybe FilePath) -> m (Maybe FilePath)
hlsWrapperBinary ver = do hlsWrapperBinary ver = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts (makeRegexOpts
compExtended compExtended
@ -503,7 +512,7 @@ hlsWrapperBinary ver = do
-- | Get all binaries for an hls version, if any. -- | 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 hlsAllBinaries ver = do
hls <- hlsServerBinaries ver hls <- hlsServerBinaries ver
wrapper <- hlsWrapperBinary ver wrapper <- hlsWrapperBinary ver
@ -511,9 +520,9 @@ hlsAllBinaries ver = do
-- | Get the active symlinks for hls. -- | 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 hlsSymlinks = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended (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. -- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`. -- 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 -- ^ major version component
-> Int -- ^ minor version component -> Int -- ^ minor version component
-> Maybe Text -- ^ the target triple -> 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 ]-- --[ Other ]--
@ -754,7 +750,7 @@ getDownloader = ask <&> downloader . settings
-- Returns unversioned relative files without extension, e.g.: -- Returns unversioned relative files without extension, e.g.:
-- --
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@ -- - @["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 => GHCTargetVersion
-> Excepts '[NotInstalled] m [FilePath] -> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles ver = do ghcToolFiles ver = do
@ -817,7 +813,12 @@ ghcUpSrcBuiltFile = ".ghcup_src_built"
-- | Calls gmake if it exists in PATH, otherwise make. -- | Calls gmake if it exists in PATH, otherwise make.
make :: (MonadThrow m, MonadIO m, MonadReader AppState m) make :: ( MonadThrow m
, MonadIO m
, MonadReader env m
, HasDirs env
, HasSettings env
)
=> [String] => [String]
-> Maybe FilePath -> Maybe FilePath
-> m (Either ProcessError ()) -> m (Either ProcessError ())
@ -827,7 +828,7 @@ make args workdir = do
let mymake = if has_gmake then "gmake" else "make" let mymake = if has_gmake then "gmake" else "make"
execLogged mymake args workdir "ghc-make" Nothing execLogged mymake args workdir "ghc-make" Nothing
makeOut :: (MonadReader AppState m, MonadIO m) makeOut :: (MonadReader env m, HasDirs env, MonadIO m)
=> [String] => [String]
-> Maybe FilePath -> Maybe FilePath
-> m CapturedProcess -> m CapturedProcess
@ -840,7 +841,7 @@ makeOut args workdir = do
-- | Try to apply patches in order. Fails with 'PatchFailed' -- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure. -- 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 containing patches
-> FilePath -- ^ dir to apply patches in -> FilePath -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m () -> Excepts '[PatchFailed] m ()
@ -858,7 +859,7 @@ applyPatches pdir ddir = do
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353 -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
darwinNotarization :: (MonadReader AppState m, MonadIO m) darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m)
=> Platform => Platform
-> FilePath -> FilePath
-> m (Either ProcessError ()) -> m (Either ProcessError ())
@ -881,13 +882,13 @@ getChangeLog dls tool (Right tag) =
-- --
-- 1. the build directory, depending on the KeepDirs setting -- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed -- 2. the install destination, depending on whether the build failed
runBuildAction :: (Show (V e), MonadReader 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) => FilePath -- ^ build directory (cleaned up depending on Settings)
-> Maybe FilePath -- ^ dir to *always* clean up on exception -> Maybe FilePath -- ^ dir to *always* clean up on exception
-> Excepts e m a -> Excepts e m a
-> Excepts '[BuildFailed] m a -> Excepts '[BuildFailed] m a
runBuildAction bdir instdir action = do runBuildAction bdir instdir action = do
AppState { settings = Settings {..} } <- lift ask Settings {..} <- lift getSettings
let exAction = do let exAction = do
forM_ instdir $ \dir -> forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ rmPath dir liftIO $ hideError doesNotExistErrorType $ rmPath dir
@ -1016,7 +1017,8 @@ createLink :: ( MonadMask m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
) )
@ -1025,7 +1027,7 @@ createLink :: ( MonadMask m
-> m () -> m ()
createLink link exe = do createLink link exe = do
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
AppState { dirs } <- ask dirs <- getDirs
let shimGen = cacheDir dirs </> "gs.exe" let shimGen = cacheDir dirs </> "gs.exe"
let shim = dropExtension exe <.> "shim" let shim = dropExtension exe <.> "shim"
@ -1054,14 +1056,19 @@ ensureGlobalTools :: ( MonadMask m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadReader AppState m , MonadReader env m
, HasDirs env
, HasSettings env
, HasGHCupInfo env
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
) )
=> Excepts '[DigestError , DownloadFailed, NoDownload] m () => Excepts '[DigestError , DownloadFailed, NoDownload] m ()
ensureGlobalTools = do ensureGlobalTools = do
#if defined(IS_WINDOWS) #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] shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' settings dirs shimDownload (Just "gs.exe") 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 Portability : portable
-} -}
module GHCup.Utils.Dirs module GHCup.Utils.Dirs
( getDirs ( getAllDirs
, ghcupBaseDir , ghcupBaseDir
, ghcupConfigFile , ghcupConfigFile
, ghcupCacheDir , ghcupCacheDir
@ -37,6 +37,7 @@ where
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils.MegaParsec import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
@ -190,8 +191,8 @@ ghcupLogsDir = do
#endif #endif
getDirs :: IO Dirs getAllDirs :: IO Dirs
getDirs = do getAllDirs = do
baseDir <- ghcupBaseDir baseDir <- ghcupBaseDir
binDir <- ghcupBinDir binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir cacheDir <- ghcupCacheDir
@ -226,9 +227,9 @@ ghcupConfigFile = do
-- | ~/.ghcup/ghc by default. -- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
ghcupGHCBaseDir = do ghcupGHCBaseDir = do
AppState { dirs = Dirs {..} } <- ask Dirs {..} <- getDirs
pure (baseDir </> "ghc") pure (baseDir </> "ghc")
@ -236,7 +237,7 @@ ghcupGHCBaseDir = do
-- The dir may be of the form -- The dir may be of the form
-- * armv7-unknown-linux-gnueabihf-8.8.3 -- * armv7-unknown-linux-gnueabihf-8.8.3
-- * 8.8.4 -- * 8.8.4
ghcupGHCDir :: (MonadReader AppState m, MonadThrow m) ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
=> GHCTargetVersion => GHCTargetVersion
-> m FilePath -> m FilePath
ghcupGHCDir ver = do 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.File.Common
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Async import Control.Concurrent.Async
@ -74,7 +75,11 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do
SPP.executeFile path True args Nothing 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 => FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing -> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this -> Maybe FilePath -- ^ optionally chdir into this
@ -82,7 +87,8 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
-> Maybe [(String, String)] -- ^ optional environment -> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ()) -> m (Either ProcessError ())
execLogged exe args chdir lfile env = do execLogged exe args chdir lfile env = do
AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask Settings {..} <- getSettings
Dirs {..} <- getDirs
let logfile = logsDir </> lfile <> ".log" let logfile = logsDir </> lfile <> ".log"
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True }) liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
closeFd closeFd

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

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