hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Improve verbosity

Browse Source
This commit is contained in:
Julian Ospald 2020-07-13 11:52:34 +02:00
parent 30b4d399b9
commit 1a64527e14
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
7 changed files with 54 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
app/ghcup-gen/Validate.hs
View File

@ -179,7 +179,7 @@ validateTarballs dls = do
where
downloadAll dli = do
let settings = Settings True False Never Curl
let settings = Settings True False Never Curl False
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())

1
app/ghcup/BrickMain.hs
View File

@ -299,6 +299,7 @@ settings' = unsafePerformIO
, noVerify = False
, keepDirs = Never
, downloader = Curl
, verbose = False
}
)

1
app/ghcup/Main.hs
View File

@ -808,6 +808,7 @@ toSettings Options {..} =
noVerify = optNoVerify
keepDirs = optKeepDirs
downloader = optsDownloader
verbose = optVerbose
in Settings { .. }

20
lib/GHCup.hs
View File

@ -133,19 +133,19 @@ installGHCBin bDls ver mpfReq = do
where
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
installGHC' :: (MonadLogger m, MonadIO m)
installGHC' :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m ()
installGHC' path inst = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ liftIO $ execLogged "./configure"
lEM $ execLogged "./configure"
False
["--prefix=" <> toFilePath inst]
[rel|ghc-configure|]
(Just path)
Nothing
lEM $ liftIO $ make ["install"] (Just path)
lEM $ make ["install"] (Just path)
pure ()
@ -672,7 +672,7 @@ BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = NO
Stage1Only = YES|]
compile :: (MonadCatch m, MonadLogger m, MonadIO m)
compile :: (MonadReader Settings m, MonadThrow m, MonadCatch m, MonadLogger m, MonadIO m)
=> Either (Path Rel) (Path Abs)
-> Path Abs
-> Path Abs
@ -700,7 +700,7 @@ Stage1Only = YES|]
Left bver -> do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
(liftIO $ searchPath spaths bver) !? NotFoundInPATH bver
lEM $ liftIO $ execLogged
lEM $ execLogged
"./configure"
False
( ["--prefix=" <> toFilePath ghcdir]
@ -714,7 +714,7 @@ Stage1Only = YES|]
(Just workdir)
(Just (("GHC", toFilePath bghcPath) : cEnv))
| otherwise -> do
lEM $ liftIO $ execLogged
lEM $ execLogged
"./configure"
False
( [ "--prefix=" <> toFilePath ghcdir
@ -739,11 +739,11 @@ Stage1Only = YES|]
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
lift $ $(logInfo) [i|Building (this may take a while)...|]
lEM $ liftIO $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
(Just workdir)
lift $ $(logInfo) [i|Installing...|]
lEM $ liftIO $ make ["install"] (Just workdir)
lEM $ make ["install"] (Just workdir)
markSrcBuilt ghcdir workdir = do
let dest = (ghcdir </> ghcUpSrcBuiltFile)
@ -848,7 +848,7 @@ compileCabal dls tver bghc jobs patchdir = do
pure ()
where
compile :: (MonadThrow m, MonadLogger m, MonadIO m, MonadResource m)
compile :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadResource m)
=> Path Abs
-> Excepts '[ProcessError , PatchFailed] m (Path Abs)
compile workdir = do
@ -881,7 +881,7 @@ compileCabal dls tver bghc jobs patchdir = do
newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv)
lift $ $(logDebug) [i|Environment: #{newEnv}|]
lEM $ liftIO $ execLogged "./bootstrap.sh"
lEM $ execLogged "./bootstrap.sh"
False
(maybe [] (\j -> ["-j", fS (show j)]) jobs)
[rel|cabal-bootstrap|]

1
lib/GHCup/Types.hs
View File

@ -152,6 +152,7 @@ data Settings = Settings
, noVerify :: Bool
, keepDirs :: KeepDirs
, downloader :: Downloader
, verbose :: Bool
}
deriving Show

9
lib/GHCup/Utils.hs
View File

@ -473,10 +473,13 @@ ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
-- | Calls gmake if it exists in PATH, otherwise make.
make :: [ByteString] -> Maybe (Path Abs) -> IO (Either ProcessError ())
make :: (MonadThrow m, MonadIO m, MonadReader Settings m)
=> [ByteString]
-> Maybe (Path Abs)
-> m (Either ProcessError ())
make args workdir = do
spaths <- catMaybes . fmap parseAbs <$> getSearchPath
has_gmake <- isJust <$> searchPath spaths [rel|gmake|]
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

51
lib/GHCup/Utils/File.hs
View File

@ -1,16 +1,19 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils.File where
import GHCup.Utils.Dirs
import GHCup.Utils.Prelude
import GHCup.Types
import Control.Concurrent
import Control.Exception ( evaluate )
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.Foldable
import Data.Functor
@ -101,19 +104,21 @@ executeOut path args chdir = captureOutStreams $ do
SPPB.executeFile (toFilePath path) True args Nothing
execLogged :: ByteString -- ^ thing to execute
execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
=> ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Path Rel -- ^ log filename
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> IO (Either ProcessError ())
-> m (Either ProcessError ())
execLogged exe spath args lfile chdir env = do
ldir <- ghcupLogsDir
Settings{..} <- ask
ldir <- liftIO ghcupLogsDir
logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) closeFd (action verbose)
where
action fd = do
action verbose fd = do
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- start the thread that logs to stdout in a region
done <- newEmptyMVar
@ -122,7 +127,7 @@ execLogged exe spath args lfile chdir env = do
$ EX.handle (\(_ :: StopThread) -> pure ())
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip finally (putMVar done ())
$ printToRegion fd stdoutRead 6
$ (if verbose then tee fd stdoutRead else printToRegion fd stdoutRead 6)
-- fork our subprocess
pid <- SPPB.forkProcess $ do
@ -151,6 +156,17 @@ execLogged exe spath args lfile chdir env = do
closeFd stdoutRead
pure e
tee fileFd fdIn = do
flip finally (readTilEOF lineAction fdIn) -- make sure the last few lines don't get cut off
$ do
hideError eofErrorType $ readTilEOF lineAction fdIn
forever (threadDelay 5000)
where
lineAction bs' = do
void $ SPIB.fdWrite fileFd (bs' <> "\n")
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
-- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file.
printToRegion fileFd fdIn size = do
@ -170,6 +186,7 @@ execLogged exe spath args lfile chdir env = do
where
-- action to perform line by line
-- TODO: do this with vty for efficiency
lineAction ref rs bs' = do
modifyIORef' ref (swapRegs bs')
regs <- readIORef ref
@ -193,18 +210,18 @@ execLogged exe spath args lfile chdir env = do
trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..."
| otherwise = bs
-- read an entire line from the file descriptor (removes the newline char)
readLine fd' = do
bs <- SPIB.fdRead fd' 1
if
| bs == "\n" -> pure ""
| bs == "" -> pure ""
| otherwise -> fmap (bs <>) $ readLine fd'
-- read an entire line from the file descriptor (removes the newline char)
readLine fd' = do
bs <- SPIB.fdRead fd' 1
if
| bs == "\n" -> pure ""
| bs == "" -> pure ""
| otherwise -> fmap (bs <>) $ readLine fd'
readTilEOF action' fd' = do
bs <- readLine fd'
void $ action' bs
readTilEOF action' fd'
readTilEOF action' fd' = do
bs <- readLine fd'
void $ action' bs
readTilEOF action' fd'
-- | Capture the stdout and stderr of the given action, which