Add ArMode to distinguish packing and unpacking of archives
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Sun, 3 Sep 2017 12:31:00 +0000 (13:31 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Sun, 3 Sep 2017 12:31:00 +0000 (13:31 +0100)
src/Builder.hs
src/Hadrian/Builder/Ar.hs
src/Rules/Gmp.hs
src/Rules/Libffi.hs
src/Rules/Library.hs
src/Settings/Builders/GhcCabal.hs
src/Settings/Default.hs

index 75f1628..d70ecab 100644 (file)
@@ -1,7 +1,7 @@
 {-# LANGUAGE InstanceSigs #-}
 module Builder (
     -- * Data types
-    CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..),
+    ArMode (..), CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..),
 
     -- * Builder properties
     builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilder,
@@ -63,7 +63,7 @@ instance NFData   GhcPkgMode
 -- @GhcPkg Stage0@ is the bootstrapping @GhcPkg@.
 -- @GhcPkg Stage1@ is the one built in Stage0.
 data Builder = Alex
-             | Ar Stage -- TODO: Add ArMode = Pack | Unpack
+             | Ar ArMode Stage
              | DeriveConstants
              | Cc CcMode Stage
              | Configure FilePath
@@ -133,31 +133,29 @@ instance H.Builder Builder where
     runBuilderWith builder BuildInfo {..} = do
         path <- builderPath builder
         withResources buildResources $ do
+            verbosity <- getVerbosity
             let input  = fromSingleton msgIn buildInputs
                 msgIn  = "[runBuilderWith] Exactly one input file expected."
                 output = fromSingleton msgOut buildOutputs
                 msgOut = "[runBuilderWith] Exactly one output file expected."
+                -- Suppress stdout depending on the Shake's verbosity setting.
+                echo = EchoStdout (verbosity >= Loud)
+                -- Capture stdout and write it to the output file.
                 captureStdout = do
                     Stdout stdout <- cmd [path] buildArgs
                     writeFileChanged output stdout
-
             case builder of
-                Ar _ -> do
-                    if "//*.a" ?== output
-                    then do
-                        useTempFile <- flag ArSupportsAtFile
-                        if useTempFile then runAr                path buildArgs
-                                       else runArWithoutTempFile path buildArgs
-                    else do
-                        top   <- topDirectory
-                        echo  <- cmdEcho
-                        cmd echo [Cwd output] [path] "x" (top -/- input)
+                Ar Pack _ -> do
+                    useTempFile <- flag ArSupportsAtFile
+                    if useTempFile then runAr                path buildArgs
+                                   else runArWithoutTempFile path buildArgs
+
+                Ar Unpack _ -> cmd echo [Cwd output] [path] buildArgs
 
                 Configure dir -> do
                     -- Inject /bin/bash into `libtool`, instead of /bin/sh,
                     -- otherwise Windows breaks. TODO: Figure out why.
                     bash <- bashPath
-                    echo <- cmdEcho
                     let env = AddEnv "CONFIG_SHELL" bash
                     cmd Shell echo env [Cwd dir] [path] buildOptions buildArgs
 
@@ -169,19 +167,9 @@ instance H.Builder Builder where
                     Stdout stdout <- cmd (Stdin stdin) [path] buildArgs
                     writeFileChanged output stdout
 
-                Make dir -> do
-                    echo <- cmdEcho
-                    cmd Shell echo path ["-C", dir] buildArgs
-
-                _  -> do
-                    echo <- cmdEcho
-                    cmd echo [path] buildArgs
+                Make dir -> cmd Shell echo path ["-C", dir] buildArgs
 
--- | Suppress build output depending on the Shake's verbosity setting.
-cmdEcho :: Action CmdOption
-cmdEcho = do
-    verbosity <- getVerbosity
-    return $ EchoStdout (verbosity >= Loud)
+                _  -> cmd echo [path] buildArgs
 
 -- TODO: Some builders are required only on certain platforms. For example,
 -- Objdump is only required on OpenBSD and AIX, as mentioned in #211. Add
@@ -197,8 +185,8 @@ isOptional = \case
 systemBuilderPath :: Builder -> Action FilePath
 systemBuilderPath builder = case builder of
     Alex            -> fromKey "alex"
-    Ar Stage0       -> fromKey "system-ar"
-    Ar _            -> fromKey "ar"
+    Ar _ Stage0     -> fromKey "system-ar"
+    Ar _ _          -> fromKey "ar"
     Cc  _  Stage0   -> fromKey "system-cc"
     Cc  _  _        -> fromKey "cc"
     -- We can't ask configure for the path to configure!
index a8bf834..ad74653 100644 (file)
 -- and call @ar@ multiple times, e.g. when passing arguments via a temporary
 -- file is not supported (see 'runArWithoutTempFile').
 -----------------------------------------------------------------------------
-module Hadrian.Builder.Ar (args, runAr, runArWithoutTempFile) where
+module Hadrian.Builder.Ar (ArMode (..), args, runAr, runArWithoutTempFile) where
 
 import Control.Monad
 import Development.Shake
+import Development.Shake.Classes
+import GHC.Generics
 import Hadrian.Expression
 import Hadrian.Utilities
 
+-- | We support packing and unpacking archives with @ar@.
+data ArMode = Pack | Unpack deriving (Eq, Generic, Show)
+
+instance Binary   ArMode
+instance Hashable ArMode
+instance NFData   ArMode
+
 -- NOTE: Make sure to appropriately update 'arFlagsCount' when changing 'args'.
 -- | Default command line arguments for invoking the archiving utility @ar@.
-args :: (ShakeValue c, ShakeValue b) => Args c b
-args = mconcat [ arg "q", arg =<< getOutput, getInputs ]
+args :: (ShakeValue c, ShakeValue b) => ArMode -> Args c b
+args Pack   = mconcat [ arg "q", arg =<< getOutput, getInputs ]
+args Unpack = mconcat [ arg "x", arg =<< getInput ]
 
--- This count includes "q" and the output file argumentes in 'args'.
+-- This count includes "q" and the output file argumentes in 'args'. This is
+-- only relevant for the 'Pack' @ar@ mode.
 arFlagsCount :: Int
 arFlagsCount = 2
 
index 5e2a73a..097c640 100644 (file)
@@ -40,7 +40,7 @@ gmpBuildInfoPath = pkgPath integerGmp -/- "integer-gmp.buildinfo"
 
 configureEnvironment :: Action [CmdOption]
 configureEnvironment = sequence [ builderEnvironment "CC" $ Cc CompileC Stage1
-                                , builderEnvironment "AR" (Ar Stage1)
+                                , builderEnvironment "AR" (Ar Unpack Stage1)
                                 , builderEnvironment "NM" Nm ]
 
 gmpRules :: Rules ()
@@ -59,8 +59,9 @@ gmpRules = do
             gmpPath <- gmpBuildPath
             need [gmpPath -/- gmpLibrary]
             createDirectory (gmpPath -/- gmpObjectsDir)
-            build $ target gmpContext (Ar Stage1) [gmpPath -/- gmpLibrary   ]
-                                                  [gmpPath -/- gmpObjectsDir]
+            top <- topDirectory
+            build $ target gmpContext (Ar Unpack Stage1)
+                [top -/- gmpPath -/- gmpLibrary] [gmpPath -/- gmpObjectsDir]
             copyFile (gmpPath -/- "gmp.h") header
             copyFile (gmpPath -/- "gmp.h") (gmpPath -/- gmpLibraryInTreeH)
 
index 9c9637b..ffa8169 100644 (file)
@@ -38,7 +38,7 @@ configureEnvironment = do
     sequence [ builderEnvironment "CC" $ Cc CompileC Stage1
              , builderEnvironment "CXX" $ Cc CompileC Stage1
              , builderEnvironment "LD" Ld
-             , builderEnvironment "AR" (Ar Stage1)
+             , builderEnvironment "AR" (Ar Unpack Stage1)
              , builderEnvironment "NM" Nm
              , builderEnvironment "RANLIB" Ranlib
              , return . AddEnv  "CFLAGS" $ unwords  cFlags ++ " -w"
index f7fec30..e6e5b16 100644 (file)
@@ -57,8 +57,8 @@ buildPackageLibrary context@Context {..} = do
         asuf <- libsuf way
         let isLib0 = ("//*-0" ++ asuf) ?== a
         removeFile a
-        if isLib0 then build $ target context (Ar stage) []   [a] -- TODO: Scan for dlls
-                  else build $ target context (Ar stage) objs [a]
+        if isLib0 then build $ target context (Ar Pack stage) []   [a] -- TODO: Scan for dlls
+                  else build $ target context (Ar Pack stage) objs [a]
 
         synopsis <- traverse pkgSynopsis (pkgCabalFile package)
         unless isLib0 . putSuccess $ renderLibrary
index 475cc65..fc39637 100644 (file)
@@ -27,7 +27,7 @@ ghcCabalBuilderArgs = builder GhcCabal ? do
             , bootPackageConstraints
             , withStaged $ Cc CompileC
             , notStage0 ? with Ld
-            , withStaged Ar
+            , withStaged (Ar Pack)
             , with Alex
             , with Happy
             , verbosity < Chatty ? pure [ "-v0", "--configure-option=--quiet"
@@ -104,7 +104,7 @@ cppArgs = do
 
 withBuilderKey :: Builder -> String
 withBuilderKey b = case b of
-    Ar _       -> "--with-ar="
+    Ar _ _     -> "--with-ar="
     Ld         -> "--with-ld="
     Cc  _ _    -> "--with-gcc="
     Ghc _ _    -> "--with-ghc="
index 3ecf6a9..470a3be 100644 (file)
@@ -139,7 +139,8 @@ defaultSplitObjects = do
 defaultBuilderArgs :: Args
 defaultBuilderArgs = mconcat
     [ alexBuilderArgs
-    , builder Ar ? Hadrian.Builder.Ar.args
+    , builder (Ar Pack  ) ? Hadrian.Builder.Ar.args Pack
+    , builder (Ar Unpack) ? Hadrian.Builder.Ar.args Unpack
     , ccBuilderArgs
     , configureBuilderArgs
     , deriveConstantsBuilderArgs