Better logging WIP

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
@@ -1130,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)|]
@@ -1142,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
@@ -1229,6 +1224,7 @@ HADDOCK_DOCS = YES|]
                     , MonadLogger m
                     , MonadIO m
                     , MonadFail m
+                    , MonadMask m
                     )
                  => Either (Path Rel) (Path Abs)
                  -> GHCTargetVersion
@@ -1237,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
 
@@ -1264,6 +1260,8 @@ HADDOCK_DOCS = YES|]
             [rel|ghc-conf|]
             (Just workdir)
             (Just (("GHC", toFilePath bghcPath) : cEnv))
+            pState
+            rs
        | otherwise -> do
         lEM $ execLogged
           "./configure"
@@ -1278,6 +1276,8 @@ HADDOCK_DOCS = YES|]
           [rel|ghc-conf|]
           (Just workdir)
           (Just cEnv)
+          pState
+          rs
 
     case mbuildConfig of
       Just bc -> liftIOException
@@ -1288,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
 
 
 
@@ -418,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
 
 
 
@@ -760,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)
@@ -890,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
+