Fix crash in 'ghcup tui' on windows

* https://github.com/haskell/ghcup-hs/issues/1013
* https://github.com/jtdaugherty/brick/issues/502#issuecomment-1974980299
* 4c395182cb

cabal.ghc8107.project

@@ -13,9 +13,12 @@ constraints: http-io-streams -brotli,
              any.aeson >= 2.0.1.0
 
 if os(mingw32)
+  constraints: vty-windows >=0.2.0.2
+
   if impl(ghc >= 9.4)
     constraints: language-c >= 0.9.3
 
+
 source-repository-package
   type: git
   location: https://github.com/haskell/tar.git

cabal.ghc902.project

@@ -13,9 +13,12 @@ constraints: http-io-streams -brotli,
              any.aeson >= 2.0.1.0
 
 if os(mingw32)
+  constraints: vty-windows >=0.2.0.2
+
   if impl(ghc >= 9.4)
     constraints: language-c >= 0.9.3
 
+
 source-repository-package
   type: git
   location: https://github.com/haskell/tar.git

cabal.ghc928.project

@@ -13,9 +13,12 @@ constraints: http-io-streams -brotli,
              any.aeson >= 2.0.1.0
 
 if os(mingw32)
+  constraints: vty-windows >=0.2.0.2
+
   if impl(ghc >= 9.4)
     constraints: language-c >= 0.9.3
 
+
 source-repository-package
   type: git
   location: https://github.com/haskell/tar.git

cabal.ghc948.project

@@ -13,9 +13,12 @@ constraints: http-io-streams -brotli,
              any.aeson >= 2.0.1.0
 
 if os(mingw32)
+  constraints: vty-windows >=0.2.0.2
+
   if impl(ghc >= 9.4)
     constraints: language-c >= 0.9.3
 
+
 source-repository-package
   type: git
   location: https://github.com/haskell/tar.git

cabal.project

@@ -13,9 +13,12 @@ constraints: http-io-streams -brotli,
              any.aeson >= 2.0.1.0
 
 if os(mingw32)
+  constraints: vty-windows >=0.2.0.2
+
   if impl(ghc >= 9.4)
     constraints: language-c >= 0.9.3
 
+
 source-repository-package
   type: git
   location: https://github.com/haskell/tar.git

cabal.project.release

@@ -18,7 +18,7 @@ elif os(mingw32)
   constraints: zlib +bundled-c-zlib,
                lzma +static,
                text -simdutf,
-               vty-windows >=0.1.0.3
+               vty-windows >=0.2.0.2
   if impl(ghc >= 9.4)
     constraints: language-c >= 0.9.3
 elif os(freebsd)

lib-opt/GHCup/OptParse/Compile.hs

@@ -529,14 +529,9 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
           HLS.SourceDist targetVer -> do
             GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
             let vi = getVersionInfo (mkTVer targetVer) HLS dls
-            forM_ (_viPreInstall =<< vi) $ \msg -> do
-              lift $ logWarn msg
-              lift $ logWarn
-                "...waiting for 5 seconds, you can still abort..."
-              liftIO $ threadDelay 5000000 -- give the user a sec to intervene
             forM_ (_viPreCompile =<< vi) $ \msg -> do
-              lift $ logWarn msg
-              lift $ logWarn
+              lift $ logInfo msg
+              lift $ logInfo
                 "...waiting for 5 seconds, you can still abort..."
               liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
           _ -> pure ()
@@ -583,14 +578,9 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
           GHC.SourceDist targetVer -> do
             GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
             let vi = getVersionInfo (mkTVer targetVer) GHC dls
-            forM_ (_viPreInstall =<< vi) $ \msg -> do
-              lift $ logWarn msg
-              lift $ logWarn
-                "...waiting for 5 seconds, you can still abort..."
-              liftIO $ threadDelay 5000000 -- give the user a sec to intervene
             forM_ (_viPreCompile =<< vi) $ \msg -> do
-              lift $ logWarn msg
-              lift $ logWarn
+              lift $ logInfo msg
+              lift $ logInfo
                 "...waiting for 5 seconds, you can still abort..."
               liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
           _ -> pure ()

lib-opt/GHCup/OptParse/Install.hs

@@ -24,7 +24,6 @@ import           GHCup.Prelude
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.String.QQ
 
-import           Control.Concurrent (threadDelay)
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
 #endif
@@ -328,11 +327,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
     (case instBindist of
        Nothing -> runInstGHC s' $ do
          (v, vi) <- liftE $ fromVersion instVer GHC
-         forM_ (_viPreInstall =<< vi) $ \msg -> do
-           lift $ logWarn msg
-           lift $ logWarn
-             "...waiting for 5 seconds, you can still abort..."
-           liftIO $ threadDelay 5000000 -- give the user a sec to intervene
          liftE $ runBothE' (installGHCBin
                      v
                      (maybe GHCupInternal IsolateDir isolateDir)
@@ -344,11 +338,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
        Just uri -> do
          runInstGHC s'{ settings = settings {noVerify = True}} $ do
            (v, vi) <- liftE $ fromVersion instVer GHC
-           forM_ (_viPreInstall =<< vi) $ \msg -> do
-             lift $ logWarn msg
-             lift $ logWarn
-               "...waiting for 5 seconds, you can still abort..."
-             liftIO $ threadDelay 5000000 -- give the user a sec to intervene
            liftE $ runBothE' (installGHCBindist
                        (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing)
                        v
@@ -410,11 +399,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
     (case instBindist of
        Nothing -> runInstTool s' $ do
          (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
-         forM_ (_viPreInstall =<< vi) $ \msg -> do
-           lift $ logWarn msg
-           lift $ logWarn
-             "...waiting for 5 seconds, you can still abort..."
-           liftIO $ threadDelay 5000000 -- give the user a sec to intervene
          liftE $ runBothE' (installCabalBin
                                     v
                                     (maybe GHCupInternal IsolateDir isolateDir)
@@ -424,11 +408,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
        Just uri -> do
          runInstTool s'{ settings = settings { noVerify = True}} $ do
            (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
-           forM_ (_viPreInstall =<< vi) $ \msg -> do
-             lift $ logWarn msg
-             lift $ logWarn
-               "...waiting for 5 seconds, you can still abort..."
-             liftIO $ threadDelay 5000000 -- give the user a sec to intervene
            liftE $ runBothE' (installCabalBindist
                                       (DownloadInfo uri Nothing "" Nothing Nothing)
                                       v
@@ -469,11 +448,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
      (case instBindist of
        Nothing -> runInstTool s' $ do
          (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-         forM_ (_viPreInstall =<< vi) $ \msg -> do
-           lift $ logWarn msg
-           lift $ logWarn
-             "...waiting for 5 seconds, you can still abort..."
-           liftIO $ threadDelay 5000000 -- give the user a sec to intervene
          liftE $ runBothE' (installHLSBin
                                     v
                                     (maybe GHCupInternal IsolateDir isolateDir)
@@ -483,11 +457,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
        Just uri -> do
          runInstTool s'{ settings = settings { noVerify = True}} $ do
            (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-           forM_ (_viPreInstall =<< vi) $ \msg -> do
-             lift $ logWarn msg
-             lift $ logWarn
-               "...waiting for 5 seconds, you can still abort..."
-             liftIO $ threadDelay 5000000 -- give the user a sec to intervene
            -- TODO: support legacy
            liftE $ runBothE' (installHLSBindist
                                       (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing)
@@ -529,11 +498,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
      (case instBindist of
         Nothing -> runInstTool s' $ do
           (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
-          forM_ (_viPreInstall =<< vi) $ \msg -> do
-            lift $ logWarn msg
-            lift $ logWarn
-              "...waiting for 5 seconds, you can still abort..."
-            liftIO $ threadDelay 5000000 -- give the user a sec to intervene
           liftE $ runBothE' (installStackBin
                                      v
                                      (maybe GHCupInternal IsolateDir isolateDir)
@@ -543,11 +507,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
         Just uri -> do
           runInstTool s'{ settings = settings { noVerify = True}} $ do
             (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
-            forM_ (_viPreInstall =<< vi) $ \msg -> do
-              lift $ logWarn msg
-              lift $ logWarn
-                "...waiting for 5 seconds, you can still abort..."
-              liftIO $ threadDelay 5000000 -- give the user a sec to intervene
             liftE $ runBothE' (installStackBindist
                                        (DownloadInfo uri Nothing "" Nothing Nothing)
                                        v

lib-opt/GHCup/OptParse/Upgrade.hs

@@ -17,7 +17,6 @@ import           GHCup.Types
 import           GHCup.Prelude.File
 import           GHCup.Prelude.Logger
 
-import           Control.Concurrent (threadDelay)
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
 #endif
@@ -136,15 +135,8 @@ upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
     UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
 
   runUpgrade runAppState (do
+    v' <- liftE $ upgradeGHCup target force' fatal
     GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
-    Just (tver, vi) <- pure $ getLatest dls GHCup
-    let latestVer = _tvVersion tver
-    forM_ (_viPreInstall vi) $ \msg -> do
-      lift $ logWarn msg
-      lift $ logWarn
-        "...waiting for 5 seconds, you can still abort..."
-      liftIO $ threadDelay 5000000 -- give the user a sec to intervene
-    v' <- liftE $ upgradeGHCup' target force' fatal latestVer
     pure (v', dls)
     ) >>= \case
       VRight (v', dls) -> do

lib/GHCup.hs

@@ -273,6 +273,7 @@ getDebugInfo = do
     --[ GHCup upgrade etc ]--
     -------------------------
 
+
 -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
 -- if no path is provided.
 upgradeGHCup :: ( MonadMask m
@@ -307,48 +308,11 @@ upgradeGHCup :: ( MonadMask m
                   m
                   Version
 upgradeGHCup mtarget force' fatal = do
-  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
-  let latestVer = _tvVersion $ fst (fromJust (getLatest dls GHCup))
-  upgradeGHCup' mtarget force' fatal latestVer
-
-
--- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
--- if no path is provided.
-upgradeGHCup' :: ( MonadMask m
-                 , MonadReader env m
-                 , HasDirs env
-                 , HasPlatformReq env
-                 , HasGHCupInfo env
-                 , HasSettings env
-                 , MonadCatch m
-                 , HasLog env
-                 , MonadThrow m
-                 , MonadFail m
-                 , MonadResource m
-                 , MonadIO m
-                 , MonadUnliftIO m
-                 )
-              => Maybe FilePath    -- ^ full file destination to write ghcup into
-              -> Bool              -- ^ whether to force update regardless
-                                   --   of currently installed version
-              -> Bool              -- ^ whether to throw an error if ghcup is shadowed
-              -> Version
-              -> Excepts
-                   '[ CopyError
-                    , DigestError
-                    , ContentLengthError
-                    , GPGError
-                    , GPGError
-                    , DownloadFailed
-                    , NoDownload
-                    , NoUpdate
-                    , ToolShadowed
-                    ]
-                   m
-                   Version
-upgradeGHCup' mtarget force' fatal latestVer = do
   Dirs {..} <- lift getDirs
+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+
   lift $ logInfo "Upgrading GHCup..."
+  let latestVer = _tvVersion $ fst (fromJust (getLatest dls GHCup))
   (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""
   when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
   dli   <- liftE $ getDownloadInfo GHCup latestVer

lib/GHCup/Download.hs

@@ -177,7 +177,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
    where
     fromDownloadInfo :: DownloadInfo -> VersionInfo
     fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli))
-                           in VersionInfo [] Nothing Nothing Nothing Nothing aspec Nothing Nothing Nothing Nothing
+                           in VersionInfo [] Nothing Nothing Nothing Nothing aspec Nothing Nothing Nothing
 
     fromStackDownloadInfo :: MonadThrow m => Stack.GHCDownloadInfo -> m DownloadInfo
     fromStackDownloadInfo (Stack.GHCDownloadInfo { gdiDownloadInfo = Stack.DownloadInfo{..} }) = do

lib/GHCup/Types.hs

@@ -149,7 +149,6 @@ data VersionInfo = VersionInfo
   , _viTestDL      :: Maybe DownloadInfo -- ^ test tarball
   , _viArch        :: ArchitectureSpec   -- ^ descend for binary downloads per arch
   -- informative messages
-  , _viPreInstall  :: Maybe Text
   , _viPostInstall :: Maybe Text
   , _viPostRemove  :: Maybe Text
   , _viPreCompile  :: Maybe Text

stack.yaml

@@ -37,7 +37,7 @@ extra-deps:
   - vty-6.2@sha256:3536dc83a3fee17d9a114baf58fe47b6f080c24987266f0cd0b7b4b1fcd9cf19,3520
   - vty-crossplatform-0.4.0.0@sha256:50593f91ad16777d921138475a8d2784d538fd206addd30664c620278d6c8544,3172
   - vty-unix-0.2.0.0@sha256:2af3d0bdae3c4b7b7e567ee374efe32c7439fabdf9096465ce011a6c6736e9ae,2932
-  - vty-windows-0.2.0.1@sha256:6c75230057a708168dbc420975572511ad3ec09956bf73c3b6f4be03324e8b13,2815
+  - vty-windows-0.2.0.2
   - yaml-streamly-0.12.4@sha256:b5250c5dc71d668c43c42ed6f86f956d69125136ea960858527a4b2ff712d3d1,5165
   - github: hasufell/uri-bytestring
     commit: 4fb5ed14b500c192e6e7a97f6b2b1eb478806001