Better logging WIP

.gitlab/before_script/darwin/install_deps.sh

@@ -10,8 +10,8 @@ curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup > ./gh
 chmod +x ghcup-bin
 
 ./ghcup-bin upgrade -i -f
-./ghcup-bin install ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
-./ghcup-bin set ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
-./ghcup-bin install-cabal ${CABAL_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
 
 exit 0

.gitlab/before_script/freebsd/install_deps.sh

@@ -12,8 +12,8 @@ curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > .
 chmod +x ghcup-bin
 
 ./ghcup-bin upgrade -i -f
-./ghcup-bin install ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
-./ghcup-bin set ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
-./ghcup-bin install-cabal ${CABAL_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
 
 exit 0

.gitlab/before_script/linux/alpine/install_deps.sh

@@ -28,8 +28,8 @@ else
 fi
 chmod +x ghcup-bin
 ./ghcup-bin upgrade -i -f
-./ghcup-bin install ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
-./ghcup-bin install-cabal ${CABAL_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
 
 # utils
 apk add --no-cache \

.gitlab/before_script/linux/install_deps.sh

@@ -13,7 +13,7 @@ curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > ./ghcup-bin
 chmod +x ghcup-bin
 
 ./ghcup-bin upgrade -i -f
-./ghcup-bin install ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
-./ghcup-bin set ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
-./ghcup-bin install-cabal ${CABAL_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
 

.gitlab/script/ghcup_version.sh

@@ -96,19 +96,14 @@ eghcup set ${GHC_VERSION}
 eghcup rm 8.10.3
 [ "$(ghc --numeric-version)" = "${ghc_ver}" ]
 
+# install hls
 if [ "${OS}" = "DARWIN" ] ; then
 	eghcup install hls
 	haskell-language-server-wrapper --version
-
-	eghcup install stack
-	stack --version
 elif [ "${OS}" = "LINUX" ] ; then
 	if [ "${ARCH}" = "64" ] ; then
 		eghcup install hls
 		haskell-language-server-wrapper --version
-
-		eghcup install stack
-		stack --version
 	fi
 fi
 

CHANGELOG.md

@@ -5,11 +5,6 @@
 * Add date to GHC bindist names created by ghcup
 * Warn when /tmp doesn't have 5GB or more of disk space
 * Allow to compile GHC from git repo wrt [#126](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/126)
-* Add stack support
-
-## 0.1.14.2 -- 2021-05-12
-
-* Remove dead dependency on ascii-string
 
 ## 0.1.14.1 -- 2021-04-11
 

app/ghcup/BrickMain.hs

@@ -66,8 +66,7 @@ data BrickData = BrickData
   deriving Show
 
 data BrickSettings = BrickSettings
-  { showAllVersions :: Bool
+  { showAll :: Bool
-  , showAllTools    :: Bool
   }
   deriving Show
 
@@ -98,22 +97,17 @@ keyHandlers KeyBindings {..} =
   , (bUninstall, const "Uninstall", withIOAction del')
   , (bSet, const "Set"      , withIOAction set')
   , (bChangelog, const "ChangeLog", withIOAction changelog')
-  , ( bShowAllVersions
+  , ( bShowAll
     , \BrickSettings {..} ->
-       if showAllVersions then "Don't show all versions" else "Show all versions"
+       if showAll then "Hide old versions" else "Show all versions"
-    , hideShowHandler (not . showAllVersions) showAllTools
+    , hideShowHandler
-    )
-  , ( bShowAllTools
-    , \BrickSettings {..} ->
-       if showAllTools then "Don't show all tools" else "Show all tools"
-    , hideShowHandler showAllVersions (not . showAllTools)
     )
   , (bUp, const "Up", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Up, .. })
   , (bDown, const "Down", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Down, .. })
   ]
  where
-  hideShowHandler f p BrickState{..} =
+  hideShowHandler BrickState{..} =
-    let newAppSettings   = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
+    let newAppSettings   = appSettings { showAll = not . showAll $ appSettings }
         newInternalState = constructList appData newAppSettings (Just appState)
     in  continue (BrickState appData newAppSettings newInternalState appKeys)
 
@@ -148,12 +142,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
       <+> minHSize 15 (str "Version")
       <+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
       <+> padLeft (Pad 5) (str "Notes")
-  renderList' = withDefAttr listAttr . drawListElements renderItem True . filterStack
+  renderList' = withDefAttr listAttr . drawListElements renderItem True
-  filterStack appState'
-    | showAllTools as = appState'
-    | let v = clr appState'
-          nv = V.filter (\ListResult{..} -> lTool /= Stack) v
-    , otherwise = BrickInternalState { clr = nv, ix = ix appState' }
   renderItem _ b listResult@ListResult{..} =
     let marks = if
           | lSet       -> (withAttr "set" $ str "✔✔")
@@ -205,7 +194,6 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
   printTool GHC = str "GHC"
   printTool GHCup = str "GHCup"
   printTool HLS = str "HLS"
-  printTool Stack = str "Stack"
 
   printNotes ListResult {..} =
     (if hlsPowered then [withAttr "hls-powered" $ str "hls-powered"] else mempty
@@ -363,7 +351,7 @@ constructList :: BrickData
               -> Maybe BrickInternalState
               -> BrickInternalState
 constructList appD appSettings =
-  replaceLR (filterVisible (showAllVersions appSettings)) (lr appD)
+  replaceLR (filterVisible (showAll appSettings)) (lr appD)
 
 listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
 listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
@@ -397,9 +385,9 @@ replaceLR filterF lr s =
 
 
 filterVisible :: Bool -> ListResult -> Bool
-filterVisible showAllVersions e | lInstalled e = True
+filterVisible showAll e | lInstalled e = True
-                                | showAllVersions = True
+                        | showAll      = True
-                                | otherwise    = not (elem Old (lTag e))
+                        | otherwise    = not (elem Old (lTag e))
 
 
 install' :: BrickState -> (Int, ListResult) -> IO (Either String ())
@@ -444,9 +432,6 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
         HLS   -> do
           let vi = getVersionInfo lVer HLS dls
           liftE $ installHLSBin dls lVer pfreq $> vi
-        Stack -> do
-          let vi = getVersionInfo lVer Stack dls
-          liftE $ installStackBin dls lVer pfreq $> vi
     )
     >>= \case
           VRight vi                         -> do
@@ -475,7 +460,6 @@ set' _ (_, ListResult {..}) = do
         GHC   -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
         Cabal -> liftE $ setCabal lVer $> ()
         HLS   -> liftE $ setHLS lVer $> ()
-        Stack -> liftE $ setStack lVer $> ()
         GHCup -> pure ()
     )
     >>= \case
@@ -497,7 +481,6 @@ del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
         GHC   -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
         Cabal -> liftE $ rmCabalVer lVer $> vi
         HLS   -> liftE $ rmHLSVer lVer $> vi
-        Stack -> liftE $ rmStackVer lVer $> vi
         GHCup -> pure Nothing
     )
     >>= \case
@@ -581,7 +564,7 @@ brickMain s l av pfreq' = do
 
 
 defaultAppSettings :: BrickSettings
-defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
+defaultAppSettings = BrickSettings { showAll = False }
 
 
 getDownloads' :: IO (Either String GHCupDownloads)

app/ghcup/Main.hs

@@ -126,7 +126,6 @@ toSetToolVer Nothing = SetRecommended
 data InstallCommand = InstallGHC InstallOptions
                     | InstallCabal InstallOptions
                     | InstallHLS InstallOptions
-                    | InstallStack InstallOptions
 
 data InstallOptions = InstallOptions
   { instVer      :: Maybe ToolVersion
@@ -138,7 +137,6 @@ data InstallOptions = InstallOptions
 data SetCommand = SetGHC SetOptions
                 | SetCabal SetOptions
                 | SetHLS SetOptions
-                | SetStack SetOptions
 
 -- a superset of ToolVersion
 data SetToolVersion = SetToolVersion GHCTargetVersion
@@ -159,7 +157,6 @@ data ListOptions = ListOptions
 data RmCommand = RmGHC RmOptions
                | RmCabal Version
                | RmHLS Version
-               | RmStack Version
 
 data RmOptions = RmOptions
   { ghcVer :: GHCTargetVersion
@@ -435,15 +432,6 @@ installParser =
                  <> footerDoc (Just $ text installHLSFooter)
                  )
            )
-      <> command
-           "stack"
-           (   InstallStack
-           <$> info
-                 (installOpts (Just Stack) <**> helper)
-                 (  progDesc "Install stack"
-                 <> footerDoc (Just $ text installStackFooter)
-                 )
-           )
       )
     )
     <|> (Right <$> installOpts Nothing)
@@ -454,17 +442,9 @@ installParser =
   into "~/.ghcup/bin"
 
 Examples:
-  # install recommended HLS
+  # install recommended GHC
   ghcup install hls|]
 
-  installStackFooter :: String
-  installStackFooter = [s|Discussion:
-  Installs stack binaries into "~/.ghcup/bin"
-
-Examples:
-  # install recommended Stack
-  ghcup install stack|]
-
   installGHCFooter :: String
   installGHCFooter = [s|Discussion:
   Installs the specified GHC version (or a recommended default one) into
@@ -548,15 +528,6 @@ setParser =
                  <> footerDoc (Just $ text setHLSFooter)
                  )
            )
-      <> command
-           "stack"
-           (   SetStack
-           <$> info
-                 (setOpts (Just Stack) <**> helper)
-                 (  progDesc "Set stack version"
-                 <> footerDoc (Just $ text setStackFooter)
-                 )
-           )
       )
     )
     <|> (Right <$> setOpts Nothing)
@@ -571,10 +542,6 @@ setParser =
   setCabalFooter = [s|Discussion:
     Sets the the current Cabal version.|]
 
-  setStackFooter :: String
-  setStackFooter = [s|Discussion:
-    Sets the the current Stack version.|]
-
   setHLSFooter :: String
   setHLSFooter = [s|Discussion:
     Sets the the current haskell-language-server version.|]
@@ -627,12 +594,6 @@ rmParser =
            <$> info (versionParser' (Just ListInstalled) (Just HLS) <**> helper)
                     (progDesc "Remove haskell-language-server version")
            )
-      <> command
-           "stack"
-           (   RmStack
-           <$> info (versionParser' (Just ListInstalled) (Just Stack) <**> helper)
-                    (progDesc "Remove stack version")
-           )
       )
     )
     <|> (Right <$> rmOpts Nothing)
@@ -654,7 +615,6 @@ changelogP =
                 "ghc"   -> Right GHC
                 "cabal" -> Right Cabal
                 "ghcup" -> Right GHCup
-                "stack" -> Right Stack
                 e       -> Left e
               )
             )
@@ -1026,8 +986,7 @@ toSettings options = do
          , bUninstall = fromMaybe bUninstall kUninstall
          , bSet = fromMaybe bSet kSet
          , bChangelog = fromMaybe bChangelog kChangelog
-         , bShowAllVersions = fromMaybe bShowAllVersions kShowAll
+         , bShowAll = fromMaybe bShowAll kShowAll
-         , bShowAllTools = fromMaybe bShowAllTools kShowAllTools
          }
 
 
@@ -1366,36 +1325,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             $(logError) [i|Also check the logs in #{logsDir}|]
                           pure $ ExitFailure 4
 
-          let installStack InstallOptions{..} =
-                (case instBindist of
-                   Nothing -> runInstTool $ do
-                     (v, vi) <- liftE $ fromVersion dls instVer Stack
-                     liftE $ installStackBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
-                     pure vi
-                   Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do
-                     (v, vi) <- liftE $ fromVersion dls instVer Stack
-                     liftE $ installStackBindist
-                         (DownloadInfo uri Nothing "")
-                         (_tvVersion v)
-                         (fromMaybe pfreq instPlatform)
-                     pure vi
-                  )
-                  >>= \case
-                        VRight vi -> do
-                          runLogger $ $(logInfo) "Stack installation successful"
-                          forM_ (_viPostInstall =<< vi) $ \msg ->
-                            runLogger $ $(logInfo) msg
-                          pure ExitSuccess
-                        VLeft (V (AlreadyInstalled _ v)) -> do
-                          runLogger $ $(logWarn)
-                            [i|Stack ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm stack #{prettyVer v}' first|]
-                          pure ExitSuccess
-                        VLeft e -> do
-                          runLogger $ do
-                            $(logError) $ T.pack $ prettyShow e
-                            $(logError) [i|Also check the logs in #{logsDir}|]
-                          pure $ ExitFailure 4
-
 
           let setGHC' SetOptions{..} =
                 runSetGHC (do
@@ -1444,22 +1373,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                           runLogger $ $(logError) $ T.pack $ prettyShow e
                           pure $ ExitFailure 14
 
-          let setStack' SetOptions{..} =
-                runSetCabal (do
-                    v <- liftE $ fst <$> fromVersion' dls sToolVer Stack
-                    liftE $ setStack (_tvVersion v)
-                    pure v
-                  )
-                  >>= \case
-                        VRight GHCTargetVersion{..} -> do
-                          runLogger
-                            $ $(logInfo)
-                                [i|Stack #{prettyVer _tvVersion} successfully set as default version|]
-                          pure ExitSuccess
-                        VLeft  e -> do
-                          runLogger $ $(logError) $ T.pack $ prettyShow e
-                          pure $ ExitFailure 14
-
           let rmGHC' RmOptions{..} =
                 runRm (do
                     liftE $
@@ -1505,20 +1418,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                           runLogger $ $(logError) $ T.pack $ prettyShow e
                           pure $ ExitFailure 15
 
-          let rmStack' tv =
-                runRm (do
-                    liftE $
-                      rmStackVer tv
-                    pure (getVersionInfo tv Stack dls)
-                  )
-                  >>= \case
-                        VRight vi -> do
-                          forM_ (_viPostRemove =<< vi) $ \msg ->
-                            runLogger $ $(logInfo) msg
-                          pure ExitSuccess
-                        VLeft  e -> do
-                          runLogger $ $(logError) $ T.pack $ prettyShow e
-                          pure $ ExitFailure 15
 
           res <- case optCommand of
 #if defined(BRICK)
@@ -1530,7 +1429,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
             Install (Left (InstallGHC iopts)) -> installGHC iopts
             Install (Left (InstallCabal iopts)) -> installCabal iopts
             Install (Left (InstallHLS iopts)) -> installHLS iopts
-            Install (Left (InstallStack iopts)) -> installStack iopts
             InstallCabalLegacy iopts -> do
               runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|])
               installCabal iopts
@@ -1541,7 +1439,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
             Set (Left (SetGHC sopts)) -> setGHC' sopts
             Set (Left (SetCabal sopts)) -> setCabal' sopts
             Set (Left (SetHLS sopts)) -> setHLS' sopts
-            Set (Left (SetStack sopts)) -> setStack' sopts
 
             List ListOptions {..} ->
               runListGHC (do
@@ -1556,7 +1453,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
             Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
             Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
             Rm (Left (RmHLS rmopts)) -> rmHLS' rmopts
-            Rm (Left (RmStack rmopts)) -> rmStack' rmopts
 
             DInfo ->
               do runDebugInfo $ liftE getDebugInfo
@@ -1758,16 +1654,6 @@ fromVersion' av SetNext tool = do
         . cycle
         . sort
         $ hlses) ?? NoToolVersionSet tool
-    Stack -> do
-      set <- stackSet !? NoToolVersionSet tool
-      stacks <- rights <$> lift getInstalledStacks
-      (fmap (GHCTargetVersion Nothing)
-        . headMay
-        . tail
-        . dropWhile (/= set)
-        . cycle
-        . sort
-        $ stacks) ?? NoToolVersionSet tool
     GHCup -> fail "GHCup cannot be set"
   let vi = getVersionInfo (_tvVersion next) tool av
   pure (next, vi)
@@ -1966,13 +1852,6 @@ checkForUpdates dls pfreq = do
         $ $(logWarn)
             [i|New HLS version available: #{prettyVer l}. To upgrade, run 'ghcup install hls #{prettyVer l}'|]
 
-  forM_ (getLatest dls Stack) $ \(l, _) -> do
-    let mstack_ver = latestInstalled Stack
-    forM mstack_ver $ \stack_ver ->
-      when (l > stack_ver)
-        $ $(logWarn)
-            [i|New Stack version available: #{prettyVer l}. To upgrade, run 'ghcup install stack #{prettyVer l}'|]
-
 
 prettyDebugInfo :: DebugInfo -> String
 prettyDebugInfo DebugInfo {..} = [i|Debug Info

config.yaml

@@ -29,8 +29,6 @@ key-bindings:
     KChar: 'c'
   show-all:
     KChar: 'a'
-  show-all-tools:
-    KChar: 't'
 
 # Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
 # check the 'URLSource' type in the code.

ghcup-0.0.4.yaml

@@ -1835,45 +1835,3 @@ ghcupDownloads:
               dlHash: 4e89b192e2f49637d772e974f2c17b16da067ecd5912575eaa542551de97681b
           Linux_Alpine:
             unknown_versioning: *hls-64
-  Stack:
-    2.5.1:
-      viTags: []
-      viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v251
-      viArch:
-        A_64:
-          Linux_UnknownLinux:
-            unknown_versioning: &stack-251-64
-              dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64.tar.gz
-              dlHash: c83b6c93d6541c0bce2175085a04062020f4160a86116e20f3b343b562f2d1e8
-              dlSubdir:
-                RegexDir: "stack-.*"
-          Darwin:
-            unknown_versioning:
-              dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-osx-x86_64.tar.gz
-              dlHash: f4aedfa8fbe371f77286ee97ec5c3c553842e7ae15b2952a8b8442dccba04bf0
-              dlSubdir:
-                RegexDir: "stack-.*"
-          Linux_Alpine:
-            unknown_versioning: *stack-251-64
-    2.7.1:
-      viTags:
-        - Recommended
-        - Latest
-      viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v271
-      viArch:
-        A_64:
-          Linux_UnknownLinux:
-            unknown_versioning: &stack-64
-              dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-linux-x86_64.tar.gz
-              dlHash: 2bc47749ee4be5eccb52a2d4a6a00b0f3b28b92517742b40c675836d7db2777d
-              dlSubdir:
-                RegexDir: "stack-.*"
-          Darwin:
-            unknown_versioning:
-              dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-osx-x86_64.tar.gz
-              dlHash: 4248c6fbc87e8a2c06f39e867eb5ef28eae0d99470137cb415356c631c0dcbf2
-              dlSubdir:
-                RegexDir: "stack-.*"
-          Linux_Alpine:
-            unknown_versioning: *stack-64
-

ghcup.cabal

@@ -1,6 +1,6 @@
 cabal-version:   3.0
 name:            ghcup
-version:         0.1.14.2
+version:         0.1.14.1
 license:         LGPL-3.0-only
 license-file:    LICENSE
 copyright:       Julian Ospald 2020
@@ -85,6 +85,7 @@ library
 
   build-depends:
     , aeson                 >=1.4        && <1.6
+    , ascii-string          ^>=1.0
     , async                 >=0.8        && <2.3
     , base                  >=4.13       && <5
     , base16-bytestring     >=0.1.1.6    && <1.1

lib/GHCup.hs

@@ -203,6 +203,7 @@ installUnpackedGHC :: ( MonadReader AppState m
                       , MonadThrow m
                       , MonadLogger m
                       , MonadIO m
+                      , MonadMask m
                       )
                    => Path Abs      -- ^ Path to the unpacked GHC bindist (where the configure script resides)
                    -> Path Abs      -- ^ Path to install to
@@ -211,13 +212,13 @@ installUnpackedGHC :: ( MonadReader AppState m
                    -> Excepts '[ProcessError] m ()
 installUnpackedGHC path inst ver PlatformRequest{..} = do
   lift $ $(logInfo) "Installing GHC (this may take a while)"
-  lEM $ execLogged "./configure"
+  lEM $ withConsoleRegions $ execLogged "./configure"
                    False
                    (("--prefix=" <> toFilePath inst) : alpineArgs)
                    [rel|ghc-configure|]
                    (Just path)
                    Nothing
-  lEM $ make ["install"] (Just path)
+  lEM $ withConsoleRegions $ make ["install"] (Just path)
   pure ()
  where
   alpineArgs
@@ -503,115 +504,6 @@ installHLSBin bDls ver pfreq = do
   installHLSBindist dlinfo ver pfreq
 
 
--- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and
--- creates a default @stack -> stack-x.y.z.q@ symlink for
--- the latest installed version.
-installStackBin :: ( MonadMask m
-                   , MonadCatch m
-                   , MonadReader AppState m
-                   , MonadLogger m
-                   , MonadResource m
-                   , MonadIO m
-                   , MonadUnliftIO m
-                   , MonadFail m
-                   )
-                => GHCupDownloads
-                -> Version
-                -> PlatformRequest
-                -> Excepts
-                     '[ AlreadyInstalled
-                      , CopyError
-                      , DigestError
-                      , DownloadFailed
-                      , NoDownload
-                      , NotInstalled
-                      , UnknownArchive
-                      , TarDirDoesNotExist
-#if !defined(TAR)
-                      , ArchiveResult
-#endif
-                      ]
-                     m
-                     ()
-installStackBin bDls ver pfreq = do
-  dlinfo <- lE $ getDownloadInfo Stack ver pfreq bDls
-  installStackBindist dlinfo ver pfreq
-
-
--- | Like 'installStackBin', except takes the 'DownloadInfo' as
--- argument instead of looking it up from 'GHCupDownloads'.
-installStackBindist :: ( MonadMask m
-                       , MonadCatch m
-                       , MonadReader AppState m
-                       , MonadLogger m
-                       , MonadResource m
-                       , MonadIO m
-                       , MonadUnliftIO m
-                       , MonadFail m
-                       )
-                    => DownloadInfo
-                    -> Version
-                    -> PlatformRequest
-                    -> Excepts
-                         '[ AlreadyInstalled
-                          , CopyError
-                          , DigestError
-                          , DownloadFailed
-                          , NoDownload
-                          , NotInstalled
-                          , UnknownArchive
-                          , TarDirDoesNotExist
-#if !defined(TAR)
-                          , ArchiveResult
-#endif
-                          ]
-                         m
-                         ()
-installStackBindist dlinfo ver PlatformRequest {..} = do
-  lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
-
-  AppState {dirs = Dirs {..}} <- lift ask
-
-  whenM (lift (hlsInstalled ver))
-    (throwE $ AlreadyInstalled Stack ver)
-
-  -- download (or use cached version)
-  dl                           <- liftE $ downloadCached dlinfo Nothing
-
-  -- unpack
-  tmpUnpack                    <- lift withGHCupTmpDir
-  liftE $ unpackToDir tmpUnpack dl
-  void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-
-  -- the subdir of the archive where we do the work
-  workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
-
-  liftE $ installStack' workdir binDir
-
-  -- create symlink if this is the latest version
-  sVers <- lift $ fmap rights getInstalledStacks
-  let lInstStack = headMay . reverse . sort $ sVers
-  when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver
-
- where
-  -- | Install an unpacked stack distribution.
-  installStack' :: (MonadLogger m, MonadCatch m, MonadIO m)
-                => Path Abs      -- ^ Path to the unpacked stack bindist (where the executable resides)
-                -> Path Abs      -- ^ Path to install to
-                -> Excepts '[CopyError] m ()
-  installStack' path inst = do
-    lift $ $(logInfo) "Installing stack"
-    let stackFile = [rel|stack|]
-    liftIO $ createDirRecursive' inst
-    destFileName <- lift $ parseRel (toFilePath stackFile <> "-" <> verToBS ver)
-    let destPath = inst </> destFileName
-    handleIO (throwE . CopyError . show) $ liftIO $ copyFile
-      (path </> stackFile)
-      destPath
-      Overwrite
-    lift $ chmod_755 destPath
-
-
 
 
     ---------------------
@@ -790,35 +682,6 @@ setHLS ver = do
   pure ()
 
 
--- | Set the @~\/.ghcup\/bin\/stack@ symlink.
-setStack :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
-         => Version
-         -> Excepts '[NotInstalled] m ()
-setStack ver = do
-  let verBS = verToBS ver
-  targetFile <- parseRel ("stack-" <> verBS)
-
-  -- symlink destination
-  AppState {dirs = Dirs {..}} <- lift ask
-  liftIO $ createDirRecursive' binDir
-
-  whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
-    $ throwE
-    $ NotInstalled Stack (GHCTargetVersion Nothing ver)
-
-  let stackbin = binDir </> [rel|stack|]
-
-  -- delete old file (may be binary or symlink)
-  lift $ $(logDebug) [i|rm -f #{toFilePath stackbin}|]
-  liftIO $ hideError doesNotExistErrorType $ deleteFile
-    stackbin
-
-  -- create symlink
-  let destL = toFilePath targetFile
-  lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath stackbin}|]
-  liftIO $ createSymlink stackbin destL
-
-  pure ()
 
 
 
@@ -876,17 +739,15 @@ listVersions av lt' criteria pfreq = do
   cabals <- getInstalledCabals' cSet
   hlsSet' <- hlsSet
   hlses <- getInstalledHLSs
-  sSet <- stackSet
-  stacks <- getInstalledStacks
 
-  go lt' cSet cabals hlsSet' hlses sSet stacks
+  go lt' cSet cabals hlsSet' hlses
  where
-  go lt cSet cabals hlsSet' hlses sSet stacks = do
+  go lt cSet cabals hlsSet' hlses = do
     case lt of
       Just t -> do
         -- get versions from GHCupDownloads
         let avTools = availableToolVersions av t
-        lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)
+        lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses)
 
         case t of
           GHC -> do
@@ -898,17 +759,13 @@ listVersions av lt' criteria pfreq = do
           HLS -> do
             slr <- strayHLS avTools
             pure (sort (slr ++ lr))
-          Stack -> do
-            slr <- strayStacks avTools
-            pure (sort (slr ++ lr))
           GHCup -> pure lr
       Nothing -> do
-        ghcvers   <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks
+        ghcvers   <- go (Just GHC) cSet cabals hlsSet' hlses
-        cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks
+        cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses
-        hlsvers   <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks
+        hlsvers   <- go (Just HLS) cSet cabals hlsSet' hlses
-        ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks
+        ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses
-        stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks
+        pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers)
-        pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers)
   strayGHCs :: (MonadCatch m, MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m)
             => Map.Map Version [Tag]
             -> m [ListResult]
@@ -1008,34 +865,6 @@ listVersions av lt' criteria pfreq = do
           [i|Could not parse version of stray directory #{toFilePath e}|]
         pure Nothing
 
-  strayStacks :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
-              => Map.Map Version [Tag]
-              -> m [ListResult]
-  strayStacks avTools = do
-    stacks <- getInstalledStacks
-    fmap catMaybes $ forM stacks $ \case
-      Right ver ->
-        case Map.lookup ver avTools of
-          Just _  -> pure Nothing
-          Nothing -> do
-            lSet    <- fmap (== Just ver) hlsSet
-            pure $ Just $ ListResult
-              { lTool      = Stack
-              , lVer       = ver
-              , lCross     = Nothing
-              , lTag       = []
-              , lInstalled = True
-              , lStray     = isNothing (Map.lookup ver avTools)
-              , lNoBindist = False
-              , fromSrc    = False -- actually, we don't know :>
-              , hlsPowered = False
-              , ..
-              }
-      Left e -> do
-        $(logWarn)
-          [i|Could not parse version of stray directory #{toFilePath e}|]
-        pure Nothing
-
   -- NOTE: this are not cross ones, because no bindists
   toListResult :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
                => Tool
@@ -1043,11 +872,9 @@ listVersions av lt' criteria pfreq = do
                -> [Either (Path Rel) Version]
                -> Maybe Version
                -> [Either (Path Rel) Version]
-               -> Maybe Version
-               -> [Either (Path Rel) Version]
                -> (Version, [Tag])
                -> m ListResult
-  toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = case t of
+  toListResult t cSet cabals hlsSet' hlses (v, tags) = case t of
     GHC -> do
       let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
       let tver = mkTVer v
@@ -1095,19 +922,6 @@ listVersions av lt' criteria pfreq = do
                       , hlsPowered = False
                       , ..
                       }
-    Stack -> do
-      let lNoBindist = isLeft $ getDownloadInfo Stack v pfreq av
-      let lSet = stackSet' == Just v
-      let lInstalled = elem v $ rights stacks
-      pure ListResult { lVer    = v
-                      , lCross  = Nothing
-                      , lTag    = tags
-                      , lTool   = t
-                      , fromSrc = False
-                      , lStray  = False
-                      , hlsPowered = False
-                      , ..
-                      }
 
 
   filter' :: [ListResult] -> [ListResult]
@@ -1225,28 +1039,6 @@ rmHLSVer ver = do
       Nothing        -> pure ()
 
 
--- | Delete a stack version. Will try to fix the @stack@ symlink
--- after removal (e.g. setting it to an older version).
-rmStackVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
-           => Version
-           -> Excepts '[NotInstalled] m ()
-rmStackVer ver = do
-  whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver))
-
-  sSet      <- lift stackSet
-
-  AppState {dirs = Dirs {..}} <- lift ask
-
-  stackFile <- lift $ parseRel ("stack-" <> verToBS ver)
-  liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> stackFile)
-
-  when (Just ver == sSet) $ do
-    sVers <- lift $ fmap rights getInstalledStacks
-    case headMay . reverse . sort $ sVers of
-      Just latestver -> setStack latestver
-      Nothing        -> liftIO $ hideError doesNotExistErrorType $ deleteFile
-        (binDir </> [rel|stack|])
-
 
 
     ------------------
@@ -1339,9 +1131,10 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
         pure (workdir, tmpUnpack, tver)
 
       -- clone from git
-      Right GitBranch{..} -> do
+      Right GitBranch{..} -> withConsoleRegions $ \pState rs -> do
         tmpUnpack <- lift mkGhcupTmpDir
-        let git args = execLogged [s|git|] True ("--no-pager":args) [rel|git|] (Just tmpUnpack) Nothing
+        let git args = execLogged [s|git|] True ("--no-pager":args) [rel|git|] (Just tmpUnpack) Nothing pState rs
+            git_fetch = execLogged [s|sh|] True ["-c", [i|git --no-pager fetch --depth 1 origin #{ref} 2>&1 | cat|]] [rel|git|] (Just tmpUnpack) Nothing pState rs
         tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
           let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
           lift $ $(logInfo) [i|Fetching git repo #{rep} at ref #{ref} (this may take a while)|]
@@ -1351,19 +1144,12 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
                     , "origin"
                     , fromString rep ]
 
-          let fetch_args = 
+          lEM $ git_fetch
-                    [ "fetch"
-                    , "--depth"
-                    , "1"
-                    , "--quiet"
-                    , "origin"
-                    , fromString ref ]
-          lEM $ git fetch_args
 
           lEM $ git [ "checkout", "FETCH_HEAD" ]
           lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
-          lEM $ execLogged "./boot" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing
+          lEM $ execLogged "./boot" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing pState rs
-          lEM $ execLogged "./configure" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing
+          lEM $ execLogged "./configure" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing pState rs
           CapturedProcess {..} <- liftIO $ makeOut
             ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack)
           case _exitCode of
@@ -1438,6 +1224,7 @@ HADDOCK_DOCS = YES|]
                     , MonadLogger m
                     , MonadIO m
                     , MonadFail m
+                    , MonadMask m
                     )
                  => Either (Path Rel) (Path Abs)
                  -> GHCTargetVersion
@@ -1446,7 +1233,7 @@ HADDOCK_DOCS = YES|]
                       '[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
                       m
                       (Path Abs)  -- ^ output path of bindist
-  compileBindist bghc tver workdir = do
+  compileBindist bghc tver workdir = withConsoleRegions $ \pState rs -> do
     lift $ $(logInfo) [i|configuring build|]
     liftE checkBuildConfig
 
@@ -1473,6 +1260,8 @@ HADDOCK_DOCS = YES|]
             [rel|ghc-conf|]
             (Just workdir)
             (Just (("GHC", toFilePath bghcPath) : cEnv))
+            pState
+            rs
        | otherwise -> do
         lEM $ execLogged
           "./configure"
@@ -1487,6 +1276,8 @@ HADDOCK_DOCS = YES|]
           [rel|ghc-conf|]
           (Just workdir)
           (Just cEnv)
+          pState
+          rs
 
     case mbuildConfig of
       Just bc -> liftIOException
@@ -1497,10 +1288,10 @@ HADDOCK_DOCS = YES|]
         liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
 
     lift $ $(logInfo) [i|Building (this may take a while)...|]
-    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
+    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) pState rs
 
     lift $ $(logInfo) [i|Creating bindist...|]
-    lEM $ make ["binary-dist"] (Just workdir)
+    lEM $ make ["binary-dist"] (Just workdir) pState rs
     [tar] <- liftIO $ findFiles
       workdir
       (makeRegexOpts compExtended

lib/GHCup/Types.hs

@@ -3,6 +3,9 @@
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE FlexibleInstances           #-}
+{-# LANGUAGE MultiParamTypeClasses           #-}
+{-# LANGUAGE UndecidableInstances           #-}
 
 {-|
 Module      : GHCup.Types
@@ -29,6 +32,8 @@ import qualified Data.Text.Encoding            as E
 import qualified Data.Text.Encoding.Error      as E
 import qualified GHC.Generics                  as GHC
 import qualified Graphics.Vty                  as Vty
+import Haskus.Utils.Variant.Excepts
+import Control.Monad.Reader
 
 
 
@@ -85,7 +90,6 @@ data Tool = GHC
           | Cabal
           | GHCup
           | HLS
-          | Stack
   deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
 
 
@@ -258,7 +262,6 @@ data UserKeyBindings = UserKeyBindings
   , kSet       :: Maybe Vty.Key
   , kChangelog :: Maybe Vty.Key
   , kShowAll   :: Maybe Vty.Key
-  , kShowAllTools :: Maybe Vty.Key
   }
   deriving (Show, GHC.Generic)
 
@@ -270,8 +273,7 @@ data KeyBindings = KeyBindings
   , bUninstall :: Vty.Key
   , bSet       :: Vty.Key
   , bChangelog :: Vty.Key
-  , bShowAllVersions :: Vty.Key
+  , bShowAll   :: Vty.Key
-  , bShowAllTools :: Vty.Key
   }
   deriving (Show, GHC.Generic)
 
@@ -284,8 +286,7 @@ defaultKeyBindings = KeyBindings
   , bUninstall = Vty.KChar 'u'
   , bSet = Vty.KChar 's'
   , bChangelog = Vty.KChar 'c'
-  , bShowAllVersions = Vty.KChar 'a'
+  , bShowAll = Vty.KChar 'a'
-  , bShowAllTools = Vty.KChar 't'
   }
 
 data AppState = AppState
@@ -422,3 +423,13 @@ instance Pretty Versioning where
 
 instance Pretty Version where
   pPrint = text . T.unpack . prettyVer
+
+
+    -----------------
+    --[ Instances ]--
+    -----------------
+
+instance MonadReader r' m => MonadReader r' (Excepts es m) where
+    ask   = lift ask
+    local = mapExcepts . local
+    reader = lift . reader

lib/GHCup/Utils.hs

@@ -90,6 +90,10 @@ import qualified Data.Text                     as T
 #endif
 import qualified Data.Text.Encoding            as E
 import qualified Text.Megaparsec               as MP
+import System.Console.Regions
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Sq
+import Control.Concurrent
 
 
 
@@ -359,54 +363,6 @@ getInstalledHLSs = do
         Just (Left  _) -> pure $ Left f
         Nothing        -> pure $ Left f
 
--- | Get all installed stacks, by matching on
--- @~\/.ghcup\/bin/stack-<\stackver\>@.
-getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m)
-                   => m [Either (Path Rel) Version]
-getInstalledStacks = do
-  AppState { dirs = Dirs {..} } <- ask
-  bins                          <- liftIO $ handleIO (\_ -> pure []) $ findFiles
-    binDir
-    (makeRegexOpts compExtended
-                   execBlank
-                   ([s|^stack-.*$|] :: ByteString)
-    )
-  forM bins $ \f ->
-    case
-          fmap (version . decUTF8Safe) . B.stripPrefix "stack-" . toFilePath $ f
-      of
-        Just (Right r) -> pure $ Right r
-        Just (Left  _) -> pure $ Left f
-        Nothing        -> pure $ Left f
-
--- Return the currently set stack version, if any.
--- TODO: there's a lot of code duplication here :>
-stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
-stackSet = do
-  AppState {dirs = Dirs {..}} <- ask
-  let stackBin = binDir </> [rel|stack|]
-
-  liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
-    broken <- isBrokenSymlink stackBin
-    if broken
-      then pure Nothing
-      else do
-        link <- readSymbolicLink $ toFilePath stackBin
-        Just <$> linkVersion link
- where
-  linkVersion :: MonadThrow m => ByteString -> m Version
-  linkVersion bs = do
-    t <- throwEither $ E.decodeUtf8' bs
-    throwEither $ MP.parse parser "" t
-   where
-    parser =
-      MP.chunk "stack-" *> version'
-
--- | Whether the given Stack version is installed.
-stackInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
-stackInstalled ver = do
-  vers <- fmap rights getInstalledStacks
-  pure $ elem ver vers
 
 -- | Whether the given HLS version is installed.
 hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
@@ -808,15 +764,17 @@ ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
 
 
 -- | Calls gmake if it exists in PATH, otherwise make.
-make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
+make :: (MonadThrow m, MonadIO m, MonadReader AppState m, MonadMask m)
      => [ByteString]
      -> Maybe (Path Abs)
+     -> MVar Bool
+     -> Seq ConsoleRegion
      -> m (Either ProcessError ())
-make args workdir = do
+make args workdir pState rs = do
   spaths    <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
   has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
   let mymake = if has_gmake then "gmake" else "make"
-  execLogged mymake True args [rel|ghc-make|] workdir Nothing
+  execLogged mymake True args [rel|ghc-make|] workdir Nothing pState rs
 
 makeOut :: [ByteString]
         -> Maybe (Path Abs)
@@ -938,3 +896,27 @@ traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
 -- | Gathering monoidal values
 forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
 forFold = \t -> (`traverseFold` t)
+
+
+withConsoleRegions :: (MonadReader AppState m, MonadIO m, MonadMask m) => (MVar Bool -> Seq ConsoleRegion -> m a) -> m a
+withConsoleRegions = withConsoleRegions' Linear 6
+
+
+withConsoleRegions' :: (MonadReader AppState m, MonadIO m, MonadMask m) => RegionLayout -> Int -> (MVar Bool -> Seq ConsoleRegion -> m a) -> m a
+withConsoleRegions' ly size action = do
+  AppState { settings = Settings {..} } <- ask
+  pState <- liftIO newEmptyMVar
+  if (not verbose)
+  then displayConsoleRegions $
+          bracketIO
+                (fmap Sq.fromList . sequence . replicate size . openConsoleRegion $ ly)
+                (\rs -> uninterruptibleMask_ $ do
+                  ps <- takeMVar pState
+                  when ps (forM_ rs closeConsoleRegion))
+                (action pState)
+  else
+    action pState mempty
+  
+ where
+  bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a
+  bracketIO setup cleanup' = bracket (liftIO setup) (liftIO . cleanup')

lib/GHCup/Utils/File.hs

@@ -136,8 +136,10 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
            -> Path Rel         -- ^ log filename (opened in append mode)
            -> Maybe (Path Abs) -- ^ optionally chdir into this
            -> Maybe [(ByteString, ByteString)] -- ^ optional environment
+           -> MVar Bool
+           -> Seq ConsoleRegion
            -> m (Either ProcessError ())
-execLogged exe spath args lfile chdir env = do
+execLogged exe spath args lfile chdir env pState rs = do
   AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
   logfile       <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
   liftIO $ bracket (openFd (toFilePath logfile) WriteOnly [oAppend] (Just newFilePerms))
@@ -147,7 +149,7 @@ execLogged exe spath args lfile chdir env = do
   action verbose fd = do
     actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
       -- start the thread that logs to stdout
-      pState <- newEmptyMVar
+      void $ tryTakeMVar pState
       done   <- newEmptyMVar
       void
         $ forkIO
@@ -155,7 +157,7 @@ execLogged exe spath args lfile chdir env = do
         $ EX.finally
             (if verbose
               then tee fd stdoutRead
-              else printToRegion fd stdoutRead 6 pState
+              else printToRegion fd stdoutRead 6
             )
             (putMVar done ())
 
@@ -192,24 +194,10 @@ execLogged exe spath args lfile chdir env = do
 
   -- Reads fdIn and logs the output in a continous scrolling area
   -- of 'size' terminal lines. Also writes to a log file.
-  printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO ()
+  printToRegion :: Fd -> Fd -> Int -> IO ()
-  printToRegion fileFd fdIn size pState = do
+  printToRegion fileFd fdIn size = do
-    void $ displayConsoleRegions $ do
+    void $
-      rs <-
+      flip runStateT mempty $ readTilEOF (lineAction rs) fdIn
-        liftIO
-        . fmap Sq.fromList
-        . sequence
-        . replicate size
-        . openConsoleRegion
-        $ Linear
-      flip runStateT mempty
-        $ handle
-            (\(ex :: SomeException) -> do
-              ps <- liftIO $ takeMVar pState
-              when ps (forM_ rs (liftIO . closeConsoleRegion))
-              throw ex
-            )
-        $ readTilEOF (lineAction rs) fdIn
 
    where
     -- action to perform line by line
@@ -218,11 +206,11 @@ execLogged exe spath args lfile chdir env = do
                => Seq ConsoleRegion
                -> ByteString
                -> StateT (Seq ByteString) m ()
-    lineAction rs = \bs' -> do
+    lineAction rs' = \bs' -> do
       void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
       modify (swapRegs bs')
       regs <- get
-      liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
+      liftIO $ forM_ (Sq.zip regs rs') $ \(bs, r) -> setConsoleRegion r $ do
         w <- consoleWidth
         return
           . T.pack

lib/GHCup/Utils/Logger.hs

@@ -84,3 +84,4 @@ initGHCupFileLogging = do
 
     createRegularFile newFilePerms logfile
     pure logfile
+