Fix handling of stray versions wrt #116
This commit is contained in:
parent
ef978c1230
commit
f6cc467e95
@ -16,7 +16,6 @@ import GHCup.Types
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.Prelude hiding ((!?))
|
||||
|
||||
import Brick
|
||||
import Brick.Widgets.Border
|
||||
@ -419,30 +418,26 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
|
||||
, DownloadFailed
|
||||
, NoUpdate
|
||||
, TarDirDoesNotExist
|
||||
, VerNotFound
|
||||
]
|
||||
|
||||
(run $ do
|
||||
case lTool of
|
||||
GHC -> do
|
||||
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer GHC dls
|
||||
?? VerNotFound lVer GHC
|
||||
let vi = getVersionInfo lVer GHC dls
|
||||
liftE $ installGHCBin dls lVer pfreq $> vi
|
||||
Cabal -> do
|
||||
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer Cabal dls
|
||||
?? VerNotFound lVer Cabal
|
||||
let vi = getVersionInfo lVer Cabal dls
|
||||
liftE $ installCabalBin dls lVer pfreq $> vi
|
||||
GHCup -> do
|
||||
let vi = fromJust $ snd <$> getLatest dls GHCup
|
||||
let vi = snd <$> getLatest dls GHCup
|
||||
liftE $ upgradeGHCup dls Nothing False pfreq $> vi
|
||||
HLS -> do
|
||||
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer HLS dls
|
||||
?? VerNotFound lVer HLS
|
||||
let vi = getVersionInfo lVer HLS dls
|
||||
liftE $ installHLSBin dls lVer pfreq $> vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
forM_ (_viPostInstall vi) $ \msg ->
|
||||
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure $ Right ()
|
||||
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
|
||||
@ -480,23 +475,21 @@ del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
|
||||
l <- readIORef logger'
|
||||
let runLogger = myLoggerT l
|
||||
|
||||
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled, VerNotFound]
|
||||
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
|
||||
|
||||
(run $ do
|
||||
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer lTool dls
|
||||
?? VerNotFound lVer lTool
|
||||
let vi = getVersionInfo lVer lTool dls
|
||||
case lTool of
|
||||
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> Just vi
|
||||
Cabal -> liftE $ rmCabalVer lVer $> Just vi
|
||||
HLS -> liftE $ rmHLSVer lVer $> Just vi
|
||||
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
|
||||
Cabal -> liftE $ rmCabalVer lVer $> vi
|
||||
HLS -> liftE $ rmHLSVer lVer $> vi
|
||||
GHCup -> pure Nothing
|
||||
)
|
||||
>>= \case
|
||||
VRight (Just vi) -> do
|
||||
forM_ (_viPostRemove vi) $ \msg ->
|
||||
VRight vi -> do
|
||||
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure $ Right ()
|
||||
VRight _ -> pure $ Right ()
|
||||
VLeft e -> pure $ Left (prettyShow e)
|
||||
|
||||
|
||||
|
||||
@ -1128,7 +1128,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
, NotInstalled
|
||||
, BuildFailed
|
||||
, TagNotFound
|
||||
, VerNotFound
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, TarDirDoesNotExist
|
||||
@ -1146,7 +1145,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
@'[ FileDoesNotExistError
|
||||
, NotInstalled
|
||||
, TagNotFound
|
||||
, VerNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
]
|
||||
@ -1158,7 +1156,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, TagNotFound
|
||||
, VerNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
]
|
||||
@ -1170,7 +1167,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
. runE
|
||||
@'[ NotInstalled
|
||||
, TagNotFound
|
||||
, VerNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
]
|
||||
@ -1178,7 +1174,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
let runListGHC = runLogger . flip runReaderT appstate
|
||||
|
||||
let runRm =
|
||||
runLogger . flip runReaderT appstate . runE @'[NotInstalled, VerNotFound]
|
||||
runLogger . flip runReaderT appstate . runE @'[NotInstalled]
|
||||
|
||||
let runDebugInfo =
|
||||
runLogger
|
||||
@ -1202,7 +1198,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
, NotInstalled
|
||||
, VerNotFound
|
||||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
@ -1279,7 +1274,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ $(logInfo) ("GHC installation successful")
|
||||
forM_ (_viPostInstall vi) $ \msg ->
|
||||
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
@ -1317,7 +1312,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ $(logInfo) ("Cabal installation successful")
|
||||
forM_ (_viPostInstall vi) $ \msg ->
|
||||
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
@ -1347,7 +1342,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ $(logInfo) ("HLS installation successful")
|
||||
forM_ (_viPostInstall vi) $ \msg ->
|
||||
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
@ -1412,13 +1407,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(runRm $ do
|
||||
liftE $
|
||||
rmGHCVer ghcVer
|
||||
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo (_tvVersion ghcVer) GHC dls
|
||||
?? VerNotFound (_tvVersion ghcVer) GHC
|
||||
pure vi
|
||||
pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
forM_ (_viPostRemove vi) $ \msg ->
|
||||
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
@ -1429,13 +1422,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(runRm $ do
|
||||
liftE $
|
||||
rmCabalVer tv
|
||||
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo tv Cabal dls
|
||||
?? VerNotFound tv Cabal
|
||||
pure vi
|
||||
pure (getVersionInfo tv Cabal dls)
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
forM_ (_viPostRemove vi) $ \msg ->
|
||||
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
@ -1446,13 +1437,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(runRm $ do
|
||||
liftE $
|
||||
rmHLSVer tv
|
||||
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo tv HLS dls
|
||||
?? VerNotFound tv HLS
|
||||
pure vi
|
||||
pure (getVersionInfo tv HLS dls)
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
forM_ (_viPostRemove vi) $ \msg ->
|
||||
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
@ -1508,9 +1497,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
|
||||
Compile (CompileGHC GHCCompileOptions {..}) ->
|
||||
(runCompileGHC $ do
|
||||
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo targetVer GHC dls
|
||||
?? VerNotFound targetVer GHC
|
||||
forM_ (_viPreCompile vi) $ \msg -> do
|
||||
let vi = getVersionInfo targetVer GHC dls
|
||||
forM_ (join $ fmap _viPreCompile vi) $ \msg -> do
|
||||
lift $ $(logInfo) msg
|
||||
lift $ $(logInfo)
|
||||
("...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
|
||||
runLogger $ $(logInfo)
|
||||
("GHC successfully compiled and installed")
|
||||
forM_ (_viPostInstall vi) $ \msg ->
|
||||
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
@ -1637,32 +1625,32 @@ fromVersion :: (MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, Mo
|
||||
=> GHCupDownloads
|
||||
-> Maybe ToolVersion
|
||||
-> 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' :: (MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
|
||||
=> GHCupDownloads
|
||||
-> SetToolVersion
|
||||
-> Tool
|
||||
-> Excepts '[TagNotFound, VerNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, VersionInfo)
|
||||
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
|
||||
fromVersion' av SetRecommended tool =
|
||||
(\(x, y) -> (mkTVer x, y)) <$> getRecommended av tool
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended av tool
|
||||
?? TagNotFound Recommended tool
|
||||
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
|
||||
Left _ -> pure (v, vi)
|
||||
Right (PVP (major' :|[minor'])) ->
|
||||
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)
|
||||
Right _ -> pure (v, vi)
|
||||
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 =
|
||||
(\(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 =
|
||||
(\(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
|
||||
next <- case tool of
|
||||
GHC -> do
|
||||
@ -1696,7 +1684,7 @@ fromVersion' av SetNext tool = do
|
||||
. sort
|
||||
$ hlses) ?? NoToolVersionSet tool
|
||||
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)
|
||||
fromVersion' _ (SetToolTag t') tool =
|
||||
throwE $ TagNotFound t' tool
|
||||
|
||||
@ -115,14 +115,6 @@ instance Pretty TagNotFound where
|
||||
pPrint (TagNotFound tag 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
|
||||
-- set one).
|
||||
data NextVerNotFound = NextVerNotFound Tool
|
||||
|
||||
Loading…
Reference in New Issue
Block a user