Better logging WIP

See https://github.com/haskell/cabal/issues/7313

CHANGELOG.md

@@ -1,5 +1,11 @@
 # Revision history for ghcup
 
+## 0.1.15 -- ????-??-??
+
+* 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)
+
 ## 0.1.14.1 -- 2021-04-11
 
 * Make internal symlink target parser more lax, fixes [#119](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119)

app/ghcup/Main.hs

@@ -165,9 +165,8 @@ data RmOptions = RmOptions
 
 data CompileCommand = CompileGHC GHCCompileOptions
 
-
 data GHCCompileOptions = GHCCompileOptions
-  { targetVer    :: Version
+  { targetGhc    :: Either Version GitBranch
   , bootstrapGhc :: Either Version (Path Abs)
   , jobs         :: Maybe Int
   , buildConfig  :: Maybe (Path Abs)
@@ -177,14 +176,6 @@ data GHCCompileOptions = GHCCompileOptions
   , setCompile   :: Bool
   }
 
-data CabalCompileOptions = CabalCompileOptions
-  { targetVer    :: Version
-  , bootstrapGhc :: Either Version (Path Abs)
-  , jobs         :: Maybe Int
-  , buildConfig  :: Maybe (Path Abs)
-  , patchDir     :: Maybe (Path Abs)
-  }
-
 data UpgradeOpts = UpgradeInplace
                  | UpgradeAt (Path Abs)
                  | UpgradeGHCupDir
@@ -659,7 +650,10 @@ ENV variables:
   such as: CC, LD, OBJDUMP, NM, AR, RANLIB.
 
 Examples:
+  # compile from known version
   ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2
+  # compile from git commit/reference
+  ghcup compile ghc -j 4 -g master -b 8.2.2
   # specify path to bootstrap ghc
   ghcup compile ghc -j 4 -v 8.4.2 -b /usr/bin/ghc-8.2.2
   # build cross compiler
@@ -668,34 +662,22 @@ Examples:
 
 ghcCompileOpts :: Parser GHCCompileOptions
 ghcCompileOpts =
-  (\CabalCompileOptions {..} crossTarget addConfArgs setCompile -> GHCCompileOptions { .. }
-    )
-    <$> cabalCompileOpts
-    <*> optional
-          (option
-            str
-            (short 'x' <> long "cross-target" <> metavar "CROSS_TARGET" <> help
-              "Build cross-compiler for this platform"
-            )
-          )
-    <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
-    <*> flag
-          False
-          True
-          (long "set" <> help
-            "Set as active version after install"
-          )
-
-cabalCompileOpts :: Parser CabalCompileOptions
-cabalCompileOpts =
-  CabalCompileOptions
-    <$> option
+  GHCCompileOptions
+    <$> ((Left <$> option
           (eitherReader
             (first (const "Not a valid version") . version . T.pack)
           )
           (short 'v' <> long "version" <> metavar "VERSION" <> help
             "The tool version to compile"
           )
+          ) <|>
+          (Right <$> (GitBranch <$> option
+          str
+          (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
+            "The git commit/branch/ref to build from"
+          ) <*>
+          optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"))
+          )))
     <*> option
           (eitherReader
             (\x ->
@@ -742,6 +724,20 @@ cabalCompileOpts =
               "Absolute path to patch directory (applied in order, uses -p1)"
             )
           )
+    <*> optional
+          (option
+            str
+            (short 'x' <> long "cross-target" <> metavar "CROSS_TARGET" <> help
+              "Build cross-compiler for this platform"
+            )
+          )
+    <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
+    <*> flag
+          False
+          True
+          (long "set" <> help
+            "Set as active version after install"
+          )
 
 
 toolVersionParser :: Parser ToolVersion
@@ -1073,7 +1069,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           createDirRecursive' baseDir
 
           -- logger interpreter
-          logfile <- flip runReaderT appstate $ initGHCupFileLogging [rel|ghcup.log|]
+          logfile <- flip runReaderT appstate $ initGHCupFileLogging
           let loggerConfig = LoggerConfig
                 { lcPrintDebug = verbose settings
                 , colorOutter  = B.hPut stderr
@@ -1470,22 +1466,26 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
 
             Compile (CompileGHC GHCCompileOptions {..}) ->
               runCompileGHC (do
-                let vi = getVersionInfo targetVer GHC dls
-                forM_ (_viPreCompile =<< vi) $ \msg -> do
-                  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
-                liftE $ compileGHC dls
-                            (GHCTargetVersion crossTarget targetVer)
+                case targetGhc of
+                  Left targetVer -> do
+                    let vi = getVersionInfo targetVer GHC dls
+                    forM_ (_viPreCompile =<< vi) $ \msg -> do
+                      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
+                  Right _ -> pure ()
+                targetVer <- liftE $ compileGHC dls
+                            (first (GHCTargetVersion crossTarget) targetGhc)
                             bootstrapGhc
                             jobs
                             buildConfig
                             patchDir
                             addConfArgs
                             pfreq
+                let vi = getVersionInfo (_tvVersion targetVer) GHC dls
                 when setCompile $ void $ liftE $
-                  setGHC (GHCTargetVersion crossTarget targetVer) SetGHCOnly
+                  setGHC targetVer SetGHCOnly
                 pure vi
                 )
                 >>= \case

ghcup-0.0.4.yaml

@@ -1761,13 +1761,11 @@ ghcupDownloads:
               dlHash: a1e2db664ec00e42a1e071a4181f6476f6e0bad321f1ddc0cf27831119f4c6d4
         A_32:
           Linux_UnknownLinux:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.4.0.0/cabal-install-3.4.0.0-i386-debian-9.tar.xz
-              dlHash: ef3750644a53f7b1fad141b2ad02d4c7a3b239ec0cbfa7f0528fb02c1dfcebce
+            unknown_versioning: &cabal-3400-32
+              dlUri: https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/3.4.0.0/cabal-install-3.4.0.0-i386-unknown-linux.tar.xz
+              dlHash: cc62a471e9e68a6a9933e54f75bf0cffae67a1d2220df1152ab887c38eb6bc8a
           Linux_Alpine:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/cabal/3.4.0.0/cabal-install-3.4.0.0-i386-alpine-linux-musl.tar.gz
-              dlHash: 95adb65f3a72aa8d9ce83685bc06e1eee5b801f56e204e27e957e8a35abd9cf8
+            unknown_versioning: *cabal-3400-32
         A_ARM64:
           Linux_UnknownLinux:
             unknown_versioning:

lib/GHCup.hs

@@ -59,6 +59,7 @@ import           Data.ByteString                ( ByteString )
 import           Data.Either
 import           Data.List
 import           Data.Maybe
+import           Data.String                    ( fromString )
 import           Data.String.Interpolate
 import           Data.Text                      ( Text )
 import           Data.Time.Clock
@@ -79,6 +80,7 @@ import           System.IO.Error
 import           System.Posix.Env.ByteString    ( getEnvironment, getEnv )
 import           System.Posix.FilePath          ( getSearchPath, takeExtension )
 import           System.Posix.Files.ByteString
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           Text.Regex.Posix
 
 import qualified Crypto.Hash.SHA256            as SHA256
@@ -88,6 +90,9 @@ import qualified Data.ByteString.Lazy          as BL
 import qualified Data.Map.Strict               as Map
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
+import qualified Text.Megaparsec               as MP
+import GHCup.Utils.MegaParsec
+import Control.Concurrent (threadDelay)
 
 
 
@@ -198,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
@@ -206,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
@@ -1075,7 +1081,7 @@ compileGHC :: ( MonadMask m
               , MonadFail m
               )
            => GHCupDownloads
-           -> GHCTargetVersion           -- ^ version to install
+           -> Either GHCTargetVersion GitBranch          -- ^ version to install
            -> Either Version (Path Abs)  -- ^ version to bootstrap with
            -> Maybe Int                  -- ^ jobs
            -> Maybe (Path Abs)           -- ^ build config
@@ -1099,38 +1105,81 @@ compileGHC :: ( MonadMask m
 #endif
                  ]
                 m
-                ()
-compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformRequest{..}
+                GHCTargetVersion
+compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformRequest{..}
   = do
-    lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
+    (workdir, tmpUnpack, tver) <- case targetGhc of
+      -- unpack from version tarball
+      Left tver -> do
+        lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
+
+        -- download source tarball
+        dlInfo <-
+          preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
+            ?? NoDownload
+        dl        <- liftE $ downloadCached dlInfo Nothing
+
+        -- unpack
+        tmpUnpack <- lift mkGhcupTmpDir
+        liftE $ unpackToDir tmpUnpack dl
+        void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
+
+        workdir <- maybe (pure tmpUnpack)
+                         (liftE . intoSubdir tmpUnpack)
+                         (view dlSubdir dlInfo)
+
+        pure (workdir, tmpUnpack, tver)
+
+      -- clone from git
+      Right GitBranch{..} -> withConsoleRegions $ \pState rs -> do
+        tmpUnpack <- lift mkGhcupTmpDir
+        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)|]
+          lEM $ git [ "init" ]
+          lEM $ git [ "remote"
+                    , "add"
+                    , "origin"
+                    , fromString rep ]
+
+          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 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
+            ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe $ _stdOut
+            ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe _stdErr))
+
+        void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
+        lift $ $(logInfo) [i|Git version #{ref} corresponds to GHC version #{prettyVer tver}|]
+
+        pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
 
     alreadyInstalled <- lift $ ghcInstalled tver
     alreadySet <- fmap (== Just tver) $ lift $ ghcSet (_tvTarget tver)
+    when alreadyInstalled $ do
+      lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Will overwrite existing version.|]
+      lift $ $(logWarn)
+        "...waiting for 10 seconds before continuing, you can still abort..."
+      liftIO $ threadDelay 10000000 -- give the user a sec to intervene
 
-    -- download source tarball
-    dlInfo <-
-      preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
-        ?? NoDownload
-    dl        <- liftE $ downloadCached dlInfo Nothing
-
-    -- unpack
-    tmpUnpack <- lift mkGhcupTmpDir
-    liftE $ unpackToDir tmpUnpack dl
-    void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
+    ghcdir         <- lift $ ghcupGHCDir tver
 
     bghc <- case bstrap of
       Right g    -> pure $ Right g
       Left  bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
-    workdir <- maybe (pure tmpUnpack)
-                     (liftE . intoSubdir tmpUnpack)
-                     (view dlSubdir dlInfo)
-    ghcdir         <- lift $ ghcupGHCDir tver
 
     (bindist, bmk) <- liftE $ runBuildAction
       tmpUnpack
       Nothing
       (do
-        b   <- compileBindist bghc ghcdir workdir
+        b <- compileBindist bghc tver workdir
         bmk <- liftIO $ readFileStrict (build_mk workdir)
         pure (b, bmk)
       )
@@ -1139,7 +1188,7 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformReques
       lift $ $(logInfo) [i|Deleting existing installation|]
       liftE $ rmGHCVer tver
     liftE $ installPackedGHC bindist
-                             (view dlSubdir dlInfo)
+                             (Just $ RegexDir "ghc-.*")
                              ghcdir
                              (tver ^. tvVersion)
                              pfreq
@@ -1151,21 +1200,23 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformReques
     -- restore
     when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly
 
+    pure tver
+
  where
-  defaultConf = case _tvTarget tver of
-    Nothing -> [s|
-V=0
-BUILD_MAN = NO
-BUILD_SPHINX_HTML = NO
-BUILD_SPHINX_PDF = NO
-HADDOCK_DOCS = YES|]
-    Just _ -> [s|
+  defaultConf = case targetGhc of
+    Left (GHCTargetVersion (Just _) _) -> [s|
 V=0
 BUILD_MAN = NO
 BUILD_SPHINX_HTML = NO
 BUILD_SPHINX_PDF = NO
 HADDOCK_DOCS = NO
 Stage1Only = YES|]
+    _ -> [s|
+V=0
+BUILD_MAN = NO
+BUILD_SPHINX_HTML = NO
+BUILD_SPHINX_PDF = NO
+HADDOCK_DOCS = YES|]
 
   compileBindist :: ( MonadReader AppState m
                     , MonadThrow m
@@ -1173,15 +1224,16 @@ Stage1Only = YES|]
                     , MonadLogger m
                     , MonadIO m
                     , MonadFail m
+                    , MonadMask m
                     )
                  => Either (Path Rel) (Path Abs)
-                 -> Path Abs
+                 -> GHCTargetVersion
                  -> Path Abs
                  -> Excepts
                       '[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
                       m
                       (Path Abs)  -- ^ output path of bindist
-  compileBindist bghc ghcdir workdir = do
+  compileBindist bghc tver workdir = withConsoleRegions $ \pState rs -> do
     lift $ $(logInfo) [i|configuring build|]
     liftE checkBuildConfig
 
@@ -1191,31 +1243,30 @@ Stage1Only = YES|]
 
     cEnv <- liftIO getEnvironment
 
-    if
-      | _tvVersion tver >= [vver|8.8.0|] -> do
-        bghcPath <- case bghc of
-          Right ghc' -> pure ghc'
-          Left  bver -> do
-            spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
-            liftIO (searchPath spaths bver) !? NotFoundInPATH bver
+    if | _tvVersion tver >= [vver|8.8.0|] -> do
+          bghcPath <- case bghc of
+            Right ghc' -> pure ghc'
+            Left  bver -> do
+              spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
+              liftIO (searchPath spaths bver) !? NotFoundInPATH bver
+          lEM $ execLogged
+            "./configure"
+            False
+            (  maybe mempty
+                      (\x -> ["--target=" <> E.encodeUtf8 x])
+                      (_tvTarget tver)
+            ++ fmap E.encodeUtf8 aargs
+            )
+            [rel|ghc-conf|]
+            (Just workdir)
+            (Just (("GHC", toFilePath bghcPath) : cEnv))
+            pState
+            rs
+       | otherwise -> do
         lEM $ execLogged
           "./configure"
           False
-          (  ["--prefix=" <> toFilePath ghcdir]
-          ++ maybe mempty
-                    (\x -> ["--target=" <> E.encodeUtf8 x])
-                    (_tvTarget tver)
-          ++ fmap E.encodeUtf8 aargs
-          )
-          [rel|ghc-conf|]
-          (Just workdir)
-          (Just (("GHC", toFilePath bghcPath) : cEnv))
-      | otherwise -> do
-        lEM $ execLogged
-          "./configure"
-          False
-          (  [ "--prefix=" <> toFilePath ghcdir
-             , "--with-ghc=" <> either toFilePath toFilePath bghc
+          (  [ "--with-ghc=" <> either toFilePath toFilePath bghc
              ]
           ++ maybe mempty
                    (\x -> ["--target=" <> E.encodeUtf8 x])
@@ -1225,6 +1276,8 @@ Stage1Only = YES|]
           [rel|ghc-conf|]
           (Just workdir)
           (Just cEnv)
+          pState
+          rs
 
     case mbuildConfig of
       Just bc -> liftIOException
@@ -1235,10 +1288,10 @@ Stage1Only = 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
@@ -1283,12 +1336,12 @@ Stage1Only = YES|]
     let lines' = fmap T.strip . T.lines $ decUTF8Safe c
 
    -- for cross, we need Stage1Only
-    case _tvTarget tver of
-      Just _ -> when ("Stage1Only = YES" `notElem` lines') $ throwE
+    case targetGhc of
+      Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
         (InvalidBuildConfig
           [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
         )
-      Nothing -> pure ()
+      _ -> pure ()
 
 
 
@@ -1381,4 +1434,3 @@ postGHCInstall ver@GHCTargetVersion {..} = do
     $ getMajorMinorV _tvVersion
   forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget)
     >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
-

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
 
 
 
@@ -379,6 +384,11 @@ data GHCTargetVersion = GHCTargetVersion
   }
   deriving (Ord, Eq, Show)
 
+data GitBranch = GitBranch
+  { ref  :: String
+  , repo :: Maybe String
+  }
+  deriving (Ord, Eq, Show)
 
 mkTVer :: Version -> GHCTargetVersion
 mkTVer = GHCTargetVersion Nothing
@@ -413,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
 
 
 
@@ -187,7 +191,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
     -----------------------------------
 
 
--- | Whethe the given GHC versin is installed.
+-- | Whether the given GHC versin is installed.
 ghcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
 ghcInstalled ver = do
   ghcdir <- ghcupGHCDir ver
@@ -760,15 +764,26 @@ 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)
+        -> IO CapturedProcess
+makeOut args workdir = do
+  spaths    <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
+  has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
+  let mymake = if has_gmake then [rel|gmake|] else [rel|make|]
+  liftIO $ executeOut mymake args workdir
 
 
 -- | Try to apply patches in order. Fails with 'PatchFailed'
@@ -881,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

@@ -50,7 +50,7 @@ import           System.Posix.Directory.ByteString
 import           System.Posix.FD               as FD
 import           System.Posix.FilePath   hiding ( (</>) )
 import           System.Posix.Files.ByteString
-import           System.Posix.Foreign           ( oExcl )
+import           System.Posix.Foreign           ( oExcl, oAppend )
 import "unix"    System.Posix.IO.ByteString
                                          hiding ( openFd )
 import           System.Posix.Process           ( ProcessStatus(..) )
@@ -133,21 +133,23 @@ execLogged :: (MonadReader AppState 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
+           -> 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 (createFile (toFilePath logfile) newFilePerms)
+  liftIO $ bracket (openFd (toFilePath logfile) WriteOnly [oAppend] (Just newFilePerms))
                    closeFd
                    (action verbose)
  where
   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

lib/GHCup/Utils/Logger.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuasiQuotes      #-}
 
 {-|
 Module      : GHCup.Utils.Logger
@@ -15,6 +16,8 @@ module GHCup.Utils.Logger where
 
 import           GHCup.Types
 import           GHCup.Utils
+import           GHCup.Utils.File
+import           GHCup.Utils.String.QQ
 
 import           Control.Monad
 import           Control.Monad.IO.Class
@@ -25,6 +28,7 @@ import           HPath.IO
 import           Prelude                 hiding ( appendFile )
 import           System.Console.Pretty
 import           System.IO.Error
+import           Text.Regex.Posix
 
 import qualified Data.ByteString               as B
 
@@ -64,12 +68,20 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
     rawOutter outr
 
 
-initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => Path Rel -> m (Path Abs)
-initGHCupFileLogging context = do
+initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => m (Path Abs)
+initGHCupFileLogging = do
   AppState {dirs = Dirs {..}} <- ask
-  let logfile = logsDir </> context
+  let logfile = logsDir </> [rel|ghcup.log|]
   liftIO $ do
     createDirRecursive' logsDir
-    hideError doesNotExistErrorType $ deleteFile logfile
+    logFiles <- findFiles
+      logsDir
+      (makeRegexOpts compExtended
+                     execBlank
+                     ([s|^.*\.log$|] :: B.ByteString)
+      )
+    forM_ logFiles $ hideError doesNotExistErrorType . deleteFile . (logsDir </>)
+
     createRegularFile newFilePerms logfile
     pure logfile
+

lib/GHCup/Utils/MegaParsec.hs

@@ -67,6 +67,15 @@ ghcTargetBinP t =
     <*> (MP.chunk t <* MP.eof)
 
 
+-- | Extracts the version from @ProjectVersion="8.10.5"@.
+ghcProjectVersion :: MP.Parsec Void Text Version
+ghcProjectVersion = do
+  _ <- MP.chunk "ProjectVersion=\""
+  ver <- parseUntil1 $ MP.chunk "\""
+  MP.setInput ver
+  version'
+
+
 -- | Extracts target triple and version from e.g.
 --   * armv7-unknown-linux-gnueabihf-8.8.3
 --   * armv7-unknown-linux-gnueabihf-8.8.3