From ef978c1230fac945564a0681c0d8e2c340277252 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 7 Mar 2021 11:59:45 +0100 Subject: [PATCH 1/2] Add test case for issue #116 --- .gitlab/script/ghcup_version.sh | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 1aab66a..3151fcc 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -107,6 +107,10 @@ fi eghcup rm $(ghc --numeric-version) +# https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116 +eghcup install cabal -u https://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz 3.4.0.0-rc4 +eghcup rm cabal 3.4.0.0-rc4 + eghcup upgrade eghcup upgrade -f From f6cc467e951e34433cebee2844bf0e364d9146ef Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 7 Mar 2021 12:02:13 +0100 Subject: [PATCH 2/2] Fix handling of stray versions wrt #116 --- app/ghcup/BrickMain.hs | 31 +++++++++-------------- app/ghcup/Main.hs | 56 +++++++++++++++++------------------------- lib/GHCup/Errors.hs | 8 ------ 3 files changed, 34 insertions(+), 61 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 0d56930..5eba211 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -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) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 2575f4c..3253216 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1128,7 +1128,6 @@ Report bugs at |] , NotInstalled , BuildFailed , TagNotFound - , VerNotFound , DigestError , DownloadFailed , TarDirDoesNotExist @@ -1146,7 +1145,6 @@ Report bugs at |] @'[ FileDoesNotExistError , NotInstalled , TagNotFound - , VerNotFound , NextVerNotFound , NoToolVersionSet ] @@ -1158,7 +1156,6 @@ Report bugs at |] . runE @'[ NotInstalled , TagNotFound - , VerNotFound , NextVerNotFound , NoToolVersionSet ] @@ -1170,7 +1167,6 @@ Report bugs at |] . runE @'[ NotInstalled , TagNotFound - , VerNotFound , NextVerNotFound , NoToolVersionSet ] @@ -1178,7 +1174,7 @@ Report bugs at |] 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 |] , UnknownArchive , TarDirDoesNotExist , NotInstalled - , VerNotFound #if !defined(TAR) , ArchiveResult #endif @@ -1279,7 +1274,7 @@ Report bugs at |] >>= \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 |] >>= \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 |] >>= \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 |] (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 |] (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 |] (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 |] 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 |] 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 diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 66f9ffc..65f0a57 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -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