parent
327b80cf56
commit
2c7176d998
GPG Key ID:
3786C5262ECB4A3F
@ -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
285
lib/GHCup.hs
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user