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

Reduce number of os/dl lookups

Browse Source
This commit is contained in:
Julian Ospald
2020-07-13 18:27:21 +02:00
parent 1a64527e14
commit ef8e3bd940
3 changed files with 68 additions and 110 deletions
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