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

Reduce number of os/dl lookups

This commit is contained in:
Julian Ospald 2020-07-13 18:27:21 +02:00
parent 1a64527e14
commit ef8e3bd940
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
3 changed files with 68 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
app/ghcup/BrickMain.hs
View File

@ -50,6 +50,7 @@ import qualified Data.Vector as V
data AppState = AppState { data AppState = AppState {
lr :: LR lr :: LR
, dls :: GHCupDownloads , dls :: GHCupDownloads
, pfreq :: PlatformRequest
} }
type LR = GenericList String Vector ListResult type LR = GenericList String Vector ListResult
@ -154,9 +155,9 @@ eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) = eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
continue (AppState (listMoveUp lr) dls) continue (AppState (listMoveUp lr) dls pfreq)
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) = eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
continue (AppState (listMoveDown lr) dls) continue (AppState (listMoveDown lr) dls pfreq)
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) = eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
case find (\(c', _, _) -> c' == c) keyHandlers of case find (\(c', _, _) -> c' == c) keyHandlers of
Nothing -> continue as Nothing -> continue as
@ -178,7 +179,7 @@ withIOAction action as = case listSelectedElement (lr as) of
Right _ -> do Right _ -> do
apps <- (fmap . fmap) apps <- (fmap . fmap)
(\AppState {..} -> AppState { lr = listMoveTo ix lr, .. }) (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
getAppState $ getAppState Nothing (pfreq as)
case apps of case apps of
Right nas -> do Right nas -> do
putStrLn "Press enter to continue" putStrLn "Press enter to continue"
@ -219,9 +220,9 @@ install' AppState {..} (_, ListResult {..}) = do
(run $ do (run $ do
case lTool of case lTool of
GHC -> liftE $ installGHCBin dls lVer Nothing GHC -> liftE $ installGHCBin dls lVer pfreq
Cabal -> liftE $ installCabalBin dls lVer Nothing Cabal -> liftE $ installCabalBin dls lVer pfreq
GHCup -> liftE $ upgradeGHCup dls Nothing False $> () GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> ()
) )
>>= \case >>= \case
VRight _ -> pure $ Right () VRight _ -> pure $ Right ()
@ -314,15 +315,15 @@ logger' = unsafePerformIO
) )
brickMain :: Settings -> Maybe URI -> LoggerConfig -> IO () brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
brickMain s muri l = do brickMain s muri l av pfreq' = do
writeIORef uri' muri writeIORef uri' muri
writeIORef settings' s writeIORef settings' s
-- logger interpreter -- logger interpreter
writeIORef logger' l writeIORef logger' l
let runLogger = myLoggerT l let runLogger = myLoggerT l
eApps <- getAppState eApps <- getAppState (Just av) pfreq'
case eApps of case eApps of
Right as -> defaultMain app (selectLatest as) $> () Right as -> defaultMain app (selectLatest as) $> ()
Left e -> do Left e -> do
@ -337,8 +338,8 @@ brickMain s muri l = do
$ (listElements lr) $ (listElements lr)
getAppState :: IO (Either String AppState) getAppState :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppState)
getAppState = do getAppState mg pfreq' = do
muri <- readIORef uri' muri <- readIORef uri'
settings <- readIORef settings' settings <- readIORef settings'
l <- readIORef logger' l <- readIORef logger'
@ -348,13 +349,12 @@ getAppState = do
runLogger runLogger
. flip runReaderT settings . flip runReaderT settings
. runE . runE
@'[JSONError, DownloadFailed, FileDoesNotExistError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] @'[JSONError, DownloadFailed, FileDoesNotExistError]
$ do $ do
(GHCupInfo _ dls) <- liftE dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
$ getDownloadsF (maybe GHCupURL OwnSource muri)
lV <- liftE $ listVersions dls Nothing Nothing lV <- lift $ listVersions dls Nothing Nothing pfreq'
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls) pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq')
case r of case r of
VRight a -> pure $ Right a VRight a -> pure $ Right a

82
app/ghcup/Main.hs
View File

@ -915,13 +915,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
, DistroNotFound
, FileDoesNotExistError , FileDoesNotExistError
, CopyError , CopyError
, NoCompatibleArch
, NoDownload , NoDownload
, NotInstalled , NotInstalled
, NoCompatiblePlatform
, BuildFailed , BuildFailed
, TagNotFound , TagNotFound
, DigestError , DigestError
@ -946,7 +943,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TagNotFound , TagNotFound
] ]
let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] let runListGHC = runLogger
let runRm = let runRm =
runLogger . flip runReaderT settings . runE @'[NotInstalled] runLogger . flip runReaderT settings . runE @'[NotInstalled]
@ -965,11 +962,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ AlreadyInstalled @'[ AlreadyInstalled
, BuildFailed , BuildFailed
, DigestError , DigestError
, DistroNotFound
, DownloadFailed , DownloadFailed
, GHCupSetError , GHCupSetError
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload , NoDownload
, NotFoundInPATH , NotFoundInPATH
, PatchFailed , PatchFailed
@ -988,10 +982,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, BuildFailed , BuildFailed
, CopyError , CopyError
, DigestError , DigestError
, DistroNotFound
, DownloadFailed , DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload , NoDownload
, NotInstalled , NotInstalled
, PatchFailed , PatchFailed
@ -1007,9 +998,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runResourceT . runResourceT
. runE . runE
@'[ DigestError @'[ DigestError
, DistroNotFound
, NoCompatiblePlatform
, NoCompatibleArch
, NoDownload , NoDownload
, NoUpdate , NoUpdate
, FileDoesNotExistError , FileDoesNotExistError
@ -1018,9 +1006,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
] ]
--------------------------- ----------------------------------------
-- Getting download info -- -- Getting download and platform info --
--------------------------- ----------------------------------------
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) [i|Error determining Platform: #{e}|])
exitWith (ExitFailure 2)
(GHCupInfo treq dls) <- (GHCupInfo treq dls) <-
( runLogger ( runLogger
@ -1035,14 +1033,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger runLogger
($(logError) [i|Error fetching download info: #{e}|]) ($(logError) [i|Error fetching download info: #{e}|])
exitWith (ExitFailure 2) exitWith (ExitFailure 2)
(runLogger runLogger $ checkForUpdates dls pfreq
. runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ checkForUpdates dls
)
>>= \case
VRight _ -> pure ()
VLeft e -> do
runLogger
($(logError) [i|Error checking for upgrades: #{e}|])
----------------------- -----------------------
@ -1052,7 +1044,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installGHC InstallOptions{..} = let installGHC InstallOptions{..} =
(runInstTool $ do (runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) -- FIXME: ugly sharing of tool version
) )
>>= \case >>= \case
VRight _ -> do VRight _ -> do
@ -1086,7 +1078,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installCabal InstallOptions{..} = let installCabal InstallOptions{..} =
(runInstTool $ do (runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) -- FIXME: ugly sharing of tool version
) )
>>= \case >>= \case
VRight _ -> do VRight _ -> do
@ -1159,7 +1151,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
res <- case optCommand of res <- case optCommand of
#if defined(BRICK) #if defined(BRICK)
Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig >> pure ExitSuccess Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess
#endif #endif
Install (Right iopts) -> do Install (Right iopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|]) runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
@ -1178,16 +1170,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
List (ListOptions {..}) -> List (ListOptions {..}) ->
(runListGHC $ do (runListGHC $ do
l <- listVersions dls lTool lCriteria l <- listVersions dls lTool lCriteria pfreq
pure l liftIO $ printListResult lRawFormat l
pure ExitSuccess
) )
>>= \case
VRight r -> do
liftIO $ printListResult lRawFormat r
pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 6
Rm (Right rmopts) -> do Rm (Right rmopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|]) runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|])
@ -1214,6 +1200,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
buildConfig buildConfig
patchDir patchDir
addConfArgs addConfArgs
pfreq
) )
>>= \case >>= \case
VRight _ -> do VRight _ -> do
@ -1238,7 +1225,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
Compile (CompileCabal CabalCompileOptions {..}) -> Compile (CompileCabal CabalCompileOptions {..}) ->
(runCompileCabal $ do (runCompileCabal $ do
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir pfreq
) )
>>= \case >>= \case
VRight _ -> do VRight _ -> do
@ -1269,7 +1256,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
bdir <- liftIO $ ghcupBinDir bdir <- liftIO $ ghcupBinDir
pure (Just (bdir </> [rel|ghcup|])) pure (Just (bdir </> [rel|ghcup|]))
(runUpgrade $ (liftE $ upgradeGHCup dls target force)) >>= \case (runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
VRight v' -> do VRight v' -> do
let pretty_v = prettyVer v' let pretty_v = prettyVer v'
runLogger $ $(logInfo) runLogger $ $(logInfo)
@ -1415,37 +1402,32 @@ printListResult raw lr = do
checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m) checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
=> GHCupDownloads => GHCupDownloads
-> Excepts -> PlatformRequest
'[ NoCompatiblePlatform -> m ()
, NoCompatibleArch checkForUpdates dls pfreq = do
, DistroNotFound
]
m
()
checkForUpdates dls = do
forM_ (getLatest dls GHCup) $ \l -> do forM_ (getLatest dls GHCup) $ \l -> do
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver) when (l > ghc_ver)
$ lift $ $(logWarn) $ $(logWarn)
[i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|] [i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|]
forM_ (getLatest dls GHC) $ \l -> do forM_ (getLatest dls GHC) $ \l -> do
mghc_ver <- latestInstalled GHC mghc_ver <- latestInstalled GHC
forM mghc_ver $ \ghc_ver -> forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver) when (l > ghc_ver)
$ lift $ $(logWarn) $ $(logWarn)
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|] [i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
forM_ (getLatest dls Cabal) $ \l -> do forM_ (getLatest dls Cabal) $ \l -> do
mcabal_ver <- latestInstalled Cabal mcabal_ver <- latestInstalled Cabal
forM mcabal_ver $ \cabal_ver -> forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver) when (l > cabal_ver)
$ lift $ $(logWarn) $ $(logWarn)
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|] [i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
where where
latestInstalled tool = (fmap lVer . lastMay) latestInstalled tool = (fmap lVer . lastMay)
<$> (listVersions dls (Just tool) (Just ListInstalled)) <$> (listVersions dls (Just tool) (Just ListInstalled) pfreq)
prettyDebugInfo :: DebugInfo -> String prettyDebugInfo :: DebugInfo -> String

64
lib/GHCup.hs
View File

@ -87,15 +87,12 @@ installGHCBin :: ( MonadFail m
) )
=> GHCupDownloads => GHCupDownloads
-> Version -> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform -> PlatformRequest
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
, DigestError , DigestError
, DistroNotFound
, DownloadFailed , DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload , NoDownload
, NotInstalled , NotInstalled
, UnknownArchive , UnknownArchive
@ -105,12 +102,11 @@ installGHCBin :: ( MonadFail m
] ]
m m
() ()
installGHCBin bDls ver mpfReq = do installGHCBin bDls ver pfreq@(PlatformRequest {..}) = do
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}|]
whenM (liftIO $ ghcInstalled tver) whenM (liftIO $ ghcInstalled tver)
$ (throwE $ AlreadyInstalled GHC ver) $ (throwE $ AlreadyInstalled GHC ver)
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
-- download (or use cached version) -- download (or use cached version)
dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls
@ -159,15 +155,12 @@ installCabalBin :: ( MonadMask m
) )
=> GHCupDownloads => GHCupDownloads
-> Version -> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform -> PlatformRequest
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
, DigestError , DigestError
, DistroNotFound
, DownloadFailed , DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload , NoDownload
, NotInstalled , NotInstalled
, UnknownArchive , UnknownArchive
@ -177,7 +170,7 @@ installCabalBin :: ( MonadMask m
] ]
m m
() ()
installCabalBin bDls ver mpfReq = do installCabalBin bDls ver pfreq@(PlatformRequest {..}) = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
bindir <- liftIO ghcupBinDir bindir <- liftIO ghcupBinDir
@ -191,8 +184,6 @@ installCabalBin bDls ver mpfReq = do
) )
$ (throwE $ AlreadyInstalled Cabal ver) $ (throwE $ AlreadyInstalled Cabal ver)
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
-- download (or use cached version) -- download (or use cached version)
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq bDls dlinfo <- lE $ getDownloadInfo Cabal ver pfreq bDls
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -386,31 +377,25 @@ listVersions :: ( MonadCatch m
=> GHCupDownloads => GHCupDownloads
-> Maybe Tool -> Maybe Tool
-> Maybe ListCriteria -> Maybe ListCriteria
-> Excepts -> PlatformRequest
'[ NoCompatiblePlatform -> m [ListResult]
, NoCompatibleArch listVersions av lt criteria pfreq = do
, DistroNotFound
]
m
[ListResult]
listVersions av lt criteria = do
pfreq <- platformRequest
case lt of case lt of
Just t -> do Just t -> do
-- get versions from GHCupDownloads -- get versions from GHCupDownloads
let avTools = availableToolVersions av t let avTools = availableToolVersions av t
lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult pfreq t) lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult t)
case t of case t of
-- append stray GHCs -- append stray GHCs
GHC -> do GHC -> do
slr <- lift $ strayGHCs avTools slr <- strayGHCs avTools
pure $ (sort (slr ++ lr)) pure $ (sort (slr ++ lr))
_ -> pure lr _ -> pure lr
Nothing -> do Nothing -> do
ghcvers <- listVersions av (Just GHC) criteria ghcvers <- listVersions av (Just GHC) criteria pfreq
cabalvers <- listVersions av (Just Cabal) criteria cabalvers <- listVersions av (Just Cabal) criteria pfreq
ghcupvers <- listVersions av (Just GHCup) criteria ghcupvers <- listVersions av (Just GHCup) criteria pfreq
pure (ghcvers <> cabalvers <> ghcupvers) pure (ghcvers <> cabalvers <> ghcupvers)
where where
@ -455,8 +440,8 @@ listVersions av 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 :: PlatformRequest -> Tool -> (Version, [Tag]) -> IO ListResult toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
toListResult pfreq t (v, tags) = case t of toListResult t (v, tags) = case t of
GHC -> do GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
let tver = mkTVer v let tver = mkTVer v
@ -606,15 +591,13 @@ compileGHC :: ( MonadMask m
-> Maybe (Path Abs) -- ^ build config -> Maybe (Path Abs) -- ^ build config
-> Maybe (Path Abs) -- ^ patch directory -> Maybe (Path Abs) -- ^ patch directory
-> [Text] -- ^ additional args to ./configure -> [Text] -- ^ additional args to ./configure
-> PlatformRequest
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
, DigestError , DigestError
, DistroNotFound
, DownloadFailed , DownloadFailed
, GHCupSetError , GHCupSetError
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload , NoDownload
, NotFoundInPATH , NotFoundInPATH
, PatchFailed , PatchFailed
@ -625,7 +608,7 @@ compileGHC :: ( MonadMask m
] ]
m m
() ()
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs = do compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|] lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
whenM (liftIO $ ghcInstalled tver) whenM (liftIO $ ghcInstalled tver)
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion)) (throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
@ -639,7 +622,6 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs = do
-- unpack -- unpack
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl liftE $ unpackToDir tmpUnpack dl
(PlatformRequest {..}) <- liftE $ platformRequest
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
bghc <- case bstrap of bghc <- case bstrap of
@ -787,15 +769,13 @@ compileCabal :: ( MonadReader Settings m
-> Either Version (Path Abs) -- ^ version to bootstrap with -> Either Version (Path Abs) -- ^ version to bootstrap with
-> Maybe Int -> Maybe Int
-> Maybe (Path Abs) -> Maybe (Path Abs)
-> PlatformRequest
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
, CopyError , CopyError
, DigestError , DigestError
, DistroNotFound
, DownloadFailed , DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload , NoDownload
, NotInstalled , NotInstalled
, PatchFailed , PatchFailed
@ -806,7 +786,7 @@ compileCabal :: ( MonadReader Settings m
] ]
m m
() ()
compileCabal dls tver bghc jobs patchdir = do compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|] lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
bindir <- liftIO ghcupBinDir bindir <- liftIO ghcupBinDir
@ -827,7 +807,6 @@ compileCabal dls tver bghc jobs patchdir = do
-- unpack -- unpack
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl liftE $ unpackToDir tmpUnpack dl
(PlatformRequest {..}) <- liftE $ platformRequest
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
@ -909,23 +888,20 @@ upgradeGHCup :: ( MonadMask m
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into -> Maybe (Path Abs) -- ^ full file destination to write ghcup into
-> Bool -- ^ whether to force update regardless -> Bool -- ^ whether to force update regardless
-- of currently installed version -- of currently installed version
-> PlatformRequest
-> Excepts -> Excepts
'[ CopyError '[ CopyError
, DigestError , DigestError
, DistroNotFound
, DownloadFailed , DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload , NoDownload
, NoUpdate , NoUpdate
] ]
m m
Version Version
upgradeGHCup dls mtarget force = do upgradeGHCup dls mtarget force pfreq = do
lift $ $(logInfo) [i|Upgrading GHCup...|] lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ getLatest dls GHCup let latestVer = fromJust $ getLatest dls GHCup
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
pfreq <- liftE platformRequest
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
let fn = [rel|ghcup|] let fn = [rel|ghcup|]