Better logging WIP

2021-05-11 14:44:02 +02:00 · 2021-05-11 14:44:02 +02:00 · 8d3d3922f2
commit 8d3d3922f2
parent a7dc03af50
5 changed files with 77 additions and 43 deletions
--- a/lib/GHCup.hs
+++ b/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 = 
-                    [ "fetch"
-                    , "--depth"
-                    , "1"
-                    , "--quiet"
-                    , "origin"
-                    , fromString ref ]
-          lEM $ git fetch_args
+          lEM $ git_fetch

          lEM $ git [ "checkout", "FETCH_HEAD" ]
          lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
-          lEM $ execLogged "./boot" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing
-          lEM $ execLogged "./configure" 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 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
--- a/lib/GHCup/Types.hs
+++ b/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
--- a/lib/GHCup/Utils.hs
+++ b/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')
--- a/lib/GHCup/Utils/File.hs
+++ b/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 fileFd fdIn size pState = do
-    void $ displayConsoleRegions $ do
-      rs <-
-        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
+  printToRegion :: Fd -> Fd -> Int -> IO ()
+  printToRegion fileFd fdIn size = do
+    void $
+      flip runStateT mempty $ 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
--- a/lib/GHCup/Utils/Logger.hs
+++ b/lib/GHCup/Utils/Logger.hs
@ -84,3 +84,4 @@ initGHCupFileLogging = do

    createRegularFile newFilePerms logfile
    pure logfile
+