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 {
lr :: LR
, dls :: GHCupDownloads
, pfreq :: PlatformRequest
}
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.KEsc _)) = halt st
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) _)) =
continue (AppState (listMoveDown lr) dls)
continue (AppState (listMoveDown lr) dls pfreq)
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
case find (\(c', _, _) -> c' == c) keyHandlers of
Nothing -> continue as
@ -178,7 +179,7 @@ withIOAction action as = case listSelectedElement (lr as) of
Right _ -> do
apps <- (fmap . fmap)
(\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
getAppState
$ getAppState Nothing (pfreq as)
case apps of
Right nas -> do
putStrLn "Press enter to continue"
@ -219,9 +220,9 @@ install' AppState {..} (_, ListResult {..}) = do
(run $ do
case lTool of
GHC -> liftE $ installGHCBin dls lVer Nothing
Cabal -> liftE $ installCabalBin dls lVer Nothing
GHCup -> liftE $ upgradeGHCup dls Nothing False $> ()
GHC -> liftE $ installGHCBin dls lVer pfreq
Cabal -> liftE $ installCabalBin dls lVer pfreq
GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> ()
)
>>= \case
VRight _ -> pure $ Right ()
@ -314,15 +315,15 @@ logger' = unsafePerformIO
)
brickMain :: Settings -> Maybe URI -> LoggerConfig -> IO ()
brickMain s muri l = do
brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
brickMain s muri l av pfreq' = do
writeIORef uri' muri
writeIORef settings' s
-- logger interpreter
writeIORef logger' l
let runLogger = myLoggerT l
eApps <- getAppState
eApps <- getAppState (Just av) pfreq'
case eApps of
Right as -> defaultMain app (selectLatest as) $> ()
Left e -> do
@ -337,8 +338,8 @@ brickMain s muri l = do
$ (listElements lr)
getAppState :: IO (Either String AppState)
getAppState = do
getAppState :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppState)
getAppState mg pfreq' = do
muri <- readIORef uri'
settings <- readIORef settings'
l <- readIORef logger'
@ -348,13 +349,12 @@ getAppState = do
runLogger
. flip runReaderT settings
. runE
@'[JSONError, DownloadFailed, FileDoesNotExistError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
@'[JSONError, DownloadFailed, FileDoesNotExistError]
$ do
(GHCupInfo _ dls) <- liftE
$ getDownloadsF (maybe GHCupURL OwnSource muri)
dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
lV <- liftE $ listVersions dls Nothing Nothing
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls)
lV <- lift $ listVersions dls Nothing Nothing pfreq'
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq')
case r of
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)
, ArchiveResult
#endif
, DistroNotFound
, FileDoesNotExistError
, CopyError
, NoCompatibleArch
, NoDownload
, NotInstalled
, NoCompatiblePlatform
, BuildFailed
, TagNotFound
, DigestError
@ -946,7 +943,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TagNotFound
]
let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
let runListGHC = runLogger
let runRm =
runLogger . flip runReaderT settings . runE @'[NotInstalled]
@ -965,11 +962,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ AlreadyInstalled
, BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, GHCupSetError
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotFoundInPATH
, PatchFailed
@ -988,10 +982,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, BuildFailed
, CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, PatchFailed
@ -1007,9 +998,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runResourceT
. runE
@'[ DigestError
, DistroNotFound
, NoCompatiblePlatform
, NoCompatibleArch
, NoDownload
, NoUpdate
, 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) <-
( runLogger
@ -1035,14 +1033,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger
($(logError) [i|Error fetching download info: #{e}|])
exitWith (ExitFailure 2)
(runLogger
. runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ checkForUpdates dls
)
>>= \case
VRight _ -> pure ()
VLeft e -> do
runLogger
($(logError) [i|Error checking for upgrades: #{e}|])
runLogger $ checkForUpdates dls pfreq
-----------------------
@ -1052,7 +1044,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installGHC InstallOptions{..} =
(runInstTool $ do
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
VRight _ -> do
@ -1086,7 +1078,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installCabal InstallOptions{..} =
(runInstTool $ do
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
VRight _ -> do
@ -1159,7 +1151,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
res <- case optCommand of
#if defined(BRICK)
Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig >> pure ExitSuccess
Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess
#endif
Install (Right iopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
@ -1178,16 +1170,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
List (ListOptions {..}) ->
(runListGHC $ do
l <- listVersions dls lTool lCriteria
pure l
l <- listVersions dls lTool lCriteria pfreq
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
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
patchDir
addConfArgs
pfreq
)
>>= \case
VRight _ -> do
@ -1238,7 +1225,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
Compile (CompileCabal CabalCompileOptions {..}) ->
(runCompileCabal $ do
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir pfreq
)
>>= \case
VRight _ -> do
@ -1269,7 +1256,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
bdir <- liftIO $ ghcupBinDir
pure (Just (bdir </> [rel|ghcup|]))
(runUpgrade $ (liftE $ upgradeGHCup dls target force)) >>= \case
(runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
VRight v' -> do
let pretty_v = prettyVer v'
runLogger $ $(logInfo)
@ -1415,37 +1402,32 @@ printListResult raw lr = do
checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
=> GHCupDownloads
-> Excepts
'[ NoCompatiblePlatform
, NoCompatibleArch
, DistroNotFound
]
m
()
checkForUpdates dls = do
-> PlatformRequest
-> m ()
checkForUpdates dls pfreq = do
forM_ (getLatest dls GHCup) $ \l -> do
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver)
$ lift $ $(logWarn)
$ $(logWarn)
[i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|]
forM_ (getLatest dls GHC) $ \l -> do
mghc_ver <- latestInstalled GHC
forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver)
$ lift $ $(logWarn)
$ $(logWarn)
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
forM_ (getLatest dls Cabal) $ \l -> do
mcabal_ver <- latestInstalled Cabal
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
$ lift $ $(logWarn)
$ $(logWarn)
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
where
latestInstalled tool = (fmap lVer . lastMay)
<$> (listVersions dls (Just tool) (Just ListInstalled))
<$> (listVersions dls (Just tool) (Just ListInstalled) pfreq)
prettyDebugInfo :: DebugInfo -> String

64
lib/GHCup.hs
View File

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