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

Fix handling of stray versions wrt #116

Browse Source
This commit is contained in:
Julian Ospald 2021-03-07 12:02:13 +01:00
parent ef978c1230
commit f6cc467e95
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
3 changed files with 34 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
app/ghcup/BrickMain.hs
View File

@ -16,7 +16,6 @@ import GHCup.Types
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.File import GHCup.Utils.File
import GHCup.Utils.Logger import GHCup.Utils.Logger
import GHCup.Utils.Prelude hiding ((!?))
import Brick import Brick
import Brick.Widgets.Border import Brick.Widgets.Border
@ -419,30 +418,26 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
, DownloadFailed , DownloadFailed
, NoUpdate , NoUpdate
, TarDirDoesNotExist , TarDirDoesNotExist
, VerNotFound
] ]
(run $ do (run $ do
case lTool of case lTool of
GHC -> do GHC -> do
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer GHC dls let vi = getVersionInfo lVer GHC dls
?? VerNotFound lVer GHC
liftE $ installGHCBin dls lVer pfreq $> vi liftE $ installGHCBin dls lVer pfreq $> vi
Cabal -> do Cabal -> do
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer Cabal dls let vi = getVersionInfo lVer Cabal dls
?? VerNotFound lVer Cabal
liftE $ installCabalBin dls lVer pfreq $> vi liftE $ installCabalBin dls lVer pfreq $> vi
GHCup -> do GHCup -> do
let vi = fromJust $ snd <$> getLatest dls GHCup let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup dls Nothing False pfreq $> vi liftE $ upgradeGHCup dls Nothing False pfreq $> vi
HLS -> do HLS -> do
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer HLS dls let vi = getVersionInfo lVer HLS dls
?? VerNotFound lVer HLS
liftE $ installHLSBin dls lVer pfreq $> vi liftE $ installHLSBin dls lVer pfreq $> vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
forM_ (_viPostInstall vi) $ \msg -> forM_ (join $ fmap _viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure $ Right () pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right () VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
@ -480,23 +475,21 @@ del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
l <- readIORef logger' l <- readIORef logger'
let runLogger = myLoggerT l let runLogger = myLoggerT l
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled, VerNotFound] let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
(run $ do (run $ do
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer lTool dls let vi = getVersionInfo lVer lTool dls
?? VerNotFound lVer lTool
case lTool of case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> Just vi GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
Cabal -> liftE $ rmCabalVer lVer $> Just vi Cabal -> liftE $ rmCabalVer lVer $> vi
HLS -> liftE $ rmHLSVer lVer $> Just vi HLS -> liftE $ rmHLSVer lVer $> vi
GHCup -> pure Nothing GHCup -> pure Nothing
) )
>>= \case >>= \case
VRight (Just vi) -> do VRight vi -> do
forM_ (_viPostRemove vi) $ \msg -> forM_ (join $ fmap _viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure $ Right () pure $ Right ()
VRight _ -> pure $ Right ()
VLeft e -> pure $ Left (prettyShow e) VLeft e -> pure $ Left (prettyShow e)

56
app/ghcup/Main.hs
View File

@ -1128,7 +1128,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NotInstalled , NotInstalled
, BuildFailed , BuildFailed
, TagNotFound , TagNotFound
, VerNotFound
, DigestError , DigestError
, DownloadFailed , DownloadFailed
, TarDirDoesNotExist , TarDirDoesNotExist
@ -1146,7 +1145,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ FileDoesNotExistError @'[ FileDoesNotExistError
, NotInstalled , NotInstalled
, TagNotFound , TagNotFound
, VerNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
] ]
@ -1158,7 +1156,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
, VerNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
] ]
@ -1170,7 +1167,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
, VerNotFound
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
] ]
@ -1178,7 +1174,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runListGHC = runLogger . flip runReaderT appstate let runListGHC = runLogger . flip runReaderT appstate
let runRm = let runRm =
runLogger . flip runReaderT appstate . runE @'[NotInstalled, VerNotFound] runLogger . flip runReaderT appstate . runE @'[NotInstalled]
let runDebugInfo = let runDebugInfo =
runLogger runLogger
@ -1202,7 +1198,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, UnknownArchive , UnknownArchive
, TarDirDoesNotExist , TarDirDoesNotExist
, NotInstalled , NotInstalled
, VerNotFound
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
@ -1279,7 +1274,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case >>= \case
VRight vi -> do VRight vi -> do
runLogger $ $(logInfo) ("GHC installation successful") runLogger $ $(logInfo) ("GHC installation successful")
forM_ (_viPostInstall vi) $ \msg -> forM_ (join $ fmap _viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
@ -1317,7 +1312,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case >>= \case
VRight vi -> do VRight vi -> do
runLogger $ $(logInfo) ("Cabal installation successful") runLogger $ $(logInfo) ("Cabal installation successful")
forM_ (_viPostInstall vi) $ \msg -> forM_ (join $ fmap _viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
@ -1347,7 +1342,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case >>= \case
VRight vi -> do VRight vi -> do
runLogger $ $(logInfo) ("HLS installation successful") runLogger $ $(logInfo) ("HLS installation successful")
forM_ (_viPostInstall vi) $ \msg -> forM_ (join $ fmap _viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
@ -1412,13 +1407,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(runRm $ do (runRm $ do
liftE $ liftE $
rmGHCVer ghcVer rmGHCVer ghcVer
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo (_tvVersion ghcVer) GHC dls pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
?? VerNotFound (_tvVersion ghcVer) GHC
pure vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
forM_ (_viPostRemove vi) $ \msg -> forM_ (join $ fmap _viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
@ -1429,13 +1422,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(runRm $ do (runRm $ do
liftE $ liftE $
rmCabalVer tv rmCabalVer tv
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo tv Cabal dls pure (getVersionInfo tv Cabal dls)
?? VerNotFound tv Cabal
pure vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
forM_ (_viPostRemove vi) $ \msg -> forM_ (join $ fmap _viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
@ -1446,13 +1437,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(runRm $ do (runRm $ do
liftE $ liftE $
rmHLSVer tv rmHLSVer tv
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo tv HLS dls pure (getVersionInfo tv HLS dls)
?? VerNotFound tv HLS
pure vi
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
forM_ (_viPostRemove vi) $ \msg -> forM_ (join $ fmap _viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
@ -1508,9 +1497,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Compile (CompileGHC GHCCompileOptions {..}) -> Compile (CompileGHC GHCCompileOptions {..}) ->
(runCompileGHC $ do (runCompileGHC $ do
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo targetVer GHC dls let vi = getVersionInfo targetVer GHC dls
?? VerNotFound targetVer GHC forM_ (join $ fmap _viPreCompile vi) $ \msg -> do
forM_ (_viPreCompile vi) $ \msg -> do
lift $ $(logInfo) msg lift $ $(logInfo) msg
lift $ $(logInfo) lift $ $(logInfo)
("...waiting for 5 seconds, you can still abort...") ("...waiting for 5 seconds, you can still abort...")
@ -1531,7 +1519,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight vi -> do VRight vi -> do
runLogger $ $(logInfo) runLogger $ $(logInfo)
("GHC successfully compiled and installed") ("GHC successfully compiled and installed")
forM_ (_viPostInstall vi) $ \msg -> forM_ (join $ fmap _viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
@ -1637,32 +1625,32 @@ fromVersion :: (MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, Mo
=> GHCupDownloads => GHCupDownloads
-> Maybe ToolVersion -> Maybe ToolVersion
-> Tool -> Tool
-> Excepts '[TagNotFound, VerNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, VersionInfo) -> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion av tv tool = fromVersion' av (toSetToolVer tv) tool fromVersion av tv tool = fromVersion' av (toSetToolVer tv) tool
fromVersion' :: (MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m) fromVersion' :: (MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
=> GHCupDownloads => GHCupDownloads
-> SetToolVersion -> SetToolVersion
-> Tool -> Tool
-> Excepts '[TagNotFound, VerNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, VersionInfo) -> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion' av SetRecommended tool = fromVersion' av SetRecommended tool =
(\(x, y) -> (mkTVer x, y)) <$> getRecommended av tool (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended av tool
?? TagNotFound Recommended tool ?? TagNotFound Recommended tool
fromVersion' av (SetToolVersion v) tool = do fromVersion' av (SetToolVersion v) tool = do
vi <- getVersionInfo (_tvVersion v) tool av ?? VerNotFound (_tvVersion v) tool let vi = getVersionInfo (_tvVersion v) tool av
case pvp $ prettyVer (_tvVersion v) of case pvp $ prettyVer (_tvVersion v) of
Left _ -> pure (v, vi) Left _ -> pure (v, vi)
Right (PVP (major' :|[minor'])) -> Right (PVP (major' :|[minor'])) ->
case getLatestGHCFor (fromIntegral major') (fromIntegral minor') av of case getLatestGHCFor (fromIntegral major') (fromIntegral minor') av of
Just (v', vi') -> pure (GHCTargetVersion (_tvTarget v) v', vi') Just (v', vi') -> pure (GHCTargetVersion (_tvTarget v) v', Just vi')
Nothing -> pure (v, vi) Nothing -> pure (v, vi)
Right _ -> pure (v, vi) Right _ -> pure (v, vi)
fromVersion' av (SetToolTag Latest) tool = fromVersion' av (SetToolTag Latest) tool =
(\(x, y) -> (mkTVer x, y)) <$> getLatest av tool ?? TagNotFound Latest tool (\(x, y) -> (mkTVer x, Just y)) <$> getLatest av tool ?? TagNotFound Latest tool
fromVersion' av (SetToolTag Recommended) tool = fromVersion' av (SetToolTag Recommended) tool =
(\(x, y) -> (mkTVer x, y)) <$> getRecommended av tool ?? TagNotFound Recommended tool (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended av tool ?? TagNotFound Recommended tool
fromVersion' av (SetToolTag (Base pvp'')) GHC = fromVersion' av (SetToolTag (Base pvp'')) GHC =
(\(x, y) -> (mkTVer x, y)) <$> getLatestBaseVersion av pvp'' ?? TagNotFound (Base pvp'') GHC (\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion av pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' av SetNext tool = do fromVersion' av SetNext tool = do
next <- case tool of next <- case tool of
GHC -> do GHC -> do
@ -1696,7 +1684,7 @@ fromVersion' av SetNext tool = do
. sort . sort
$ hlses) ?? NoToolVersionSet tool $ hlses) ?? NoToolVersionSet tool
GHCup -> fail "GHCup cannot be set" GHCup -> fail "GHCup cannot be set"
vi <- getVersionInfo (_tvVersion next) tool av ?? VerNotFound (_tvVersion next) tool let vi = getVersionInfo (_tvVersion next) tool av
pure (next, vi) pure (next, vi)
fromVersion' _ (SetToolTag t') tool = fromVersion' _ (SetToolTag t') tool =
throwE $ TagNotFound t' tool throwE $ TagNotFound t' tool

8
lib/GHCup/Errors.hs
View File

@ -115,14 +115,6 @@ instance Pretty TagNotFound where
pPrint (TagNotFound tag tool) = pPrint (TagNotFound tag tool) =
text "Unable to find tag" <+> pPrint tag <+> text [i|of tool "#{tool}"|] text "Unable to find tag" <+> pPrint tag <+> text [i|of tool "#{tool}"|]
-- | Unable to find a version of a tool.
data VerNotFound = VerNotFound Version Tool
deriving Show
instance Pretty VerNotFound where
pPrint (VerNotFound ver' tool) =
text [i|Unable to find version "#{prettyShow ver'}" of tool "#{tool}"|]
-- | Unable to find the next version of a tool (the one after the currently -- | Unable to find the next version of a tool (the one after the currently
-- set one). -- set one).
data NextVerNotFound = NextVerNotFound Tool data NextVerNotFound = NextVerNotFound Tool