Add GhcPkgMode
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Sun, 27 Nov 2016 18:11:58 +0000 (18:11 +0000)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Sun, 27 Nov 2016 18:11:58 +0000 (18:11 +0000)
src/Builder.hs
src/GHC.hs
src/Oracles/Path.hs
src/Rules/Register.hs
src/Rules/Test.hs
src/Settings/Builders/GhcCabal.hs
src/Settings/Builders/GhcPkg.hs

index ffcf5e1..b2fbca3 100644 (file)
@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveGeneric, LambdaCase #-}
 module Builder (
-    CcMode (..), GhcMode (..), Builder (..), trackedArgument, isOptional
+    CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..),
+    trackedArgument, isOptional
     ) where
 
 import Data.Char
@@ -18,6 +19,9 @@ data CcMode  = CompileC  | FindCDependencies deriving (Eq, Generic, Show)
 data GhcMode = CompileHs | FindHsDependencies | LinkHs
     deriving (Eq, Generic, Show)
 
+-- | GhcPkg can initialise a package database and register packages in it.
+data GhcPkgMode = Init | Update deriving (Eq, Generic, Show)
+
 -- | A 'Builder' is an external command invoked in a separate process via 'cmd'.
 -- @Ghc Stage0@ is the bootstrapping compiler.
 -- @Ghc StageN@, N > 0, is the one built in stage (N - 1).
@@ -33,7 +37,7 @@ data Builder = Alex
              | Ghc GhcMode Stage
              | GhcCabal
              | GhcCabalHsColour   -- synonym for 'GhcCabal hscolour'
-             | GhcPkg Stage
+             | GhcPkg GhcPkgMode Stage
              | Haddock
              | Happy
              | Hpc
@@ -83,3 +87,7 @@ instance NFData CcMode
 instance Binary GhcMode
 instance Hashable GhcMode
 instance NFData GhcMode
+
+instance Binary GhcPkgMode
+instance Hashable GhcPkgMode
+instance NFData GhcPkgMode
index 4521679..1fff56f 100644 (file)
@@ -104,8 +104,8 @@ builderProvenance = \case
     Ghc _ stage      -> context (pred stage) ghc
     GhcCabal         -> context Stage0 ghcCabal
     GhcCabalHsColour -> builderProvenance $ GhcCabal
-    GhcPkg Stage0    -> Nothing
-    GhcPkg _         -> context Stage0 ghcPkg
+    GhcPkg _ Stage0  -> Nothing
+    GhcPkg _ _       -> context Stage0 ghcPkg
     Haddock          -> context Stage2 haddock
     Hpc              -> context Stage1 hpcBin
     Hsc2Hs           -> context Stage0 hsc2hs
index 1a74915..f27041d 100644 (file)
@@ -23,26 +23,26 @@ getTopDirectory = lift topDirectory
 -- | Determine the location of a system 'Builder'.
 systemBuilderPath :: Builder -> Action FilePath
 systemBuilderPath builder = case builder of
-    Alex          -> fromKey "alex"
-    Ar            -> fromKey "ar"
-    Cc  _  Stage0 -> fromKey "system-cc"
-    Cc  _  _      -> fromKey "cc"
+    Alex            -> fromKey "alex"
+    Ar              -> fromKey "ar"
+    Cc  _  Stage0   -> fromKey "system-cc"
+    Cc  _  _        -> fromKey "cc"
     -- We can't ask configure for the path to configure!
-    Configure _   -> return "bash configure"
-    Ghc _  Stage0 -> fromKey "system-ghc"
-    GhcPkg Stage0 -> fromKey "system-ghc-pkg"
-    Happy         -> fromKey "happy"
-    HsColour      -> fromKey "hscolour"
-    HsCpp         -> fromKey "hs-cpp"
-    Ld            -> fromKey "ld"
-    Make _        -> fromKey "make"
-    Nm            -> fromKey "nm"
-    Objdump       -> fromKey "objdump"
-    Patch         -> fromKey "patch"
-    Perl          -> fromKey "perl"
-    Ranlib        -> fromKey "ranlib"
-    Tar           -> fromKey "tar"
-    _             -> error $ "No system.config entry for " ++ show builder
+    Configure _     -> return "bash configure"
+    Ghc _  Stage0   -> fromKey "system-ghc"
+    GhcPkg Stage0 -> fromKey "system-ghc-pkg"
+    Happy           -> fromKey "happy"
+    HsColour        -> fromKey "hscolour"
+    HsCpp           -> fromKey "hs-cpp"
+    Ld              -> fromKey "ld"
+    Make _          -> fromKey "make"
+    Nm              -> fromKey "nm"
+    Objdump         -> fromKey "objdump"
+    Patch           -> fromKey "patch"
+    Perl            -> fromKey "perl"
+    Ranlib          -> fromKey "ranlib"
+    Tar             -> fromKey "tar"
+    _               -> error $ "No system.config entry for " ++ show builder
   where
     fromKey key = do
         let unpack = fromMaybe . error $ "Cannot find path to builder "
index 19ce0e3..6230680 100644 (file)
@@ -18,10 +18,12 @@ registerPackage rs context@Context {..} = when (stage <= Stage1) $ do
 
     matchVersionedFilePath (dir -/- pkgNameString package) "conf" ?> \conf -> do
         need [confIn]
-        buildWithResources rs $ Target context (GhcPkg stage) [confIn] [conf]
+        buildWithResources rs $
+            Target context (GhcPkg Update stage) [confIn] [conf]
 
     when (package == ghc) $ packageDbStamp stage %> \stamp -> do
         removeDirectory dir
-        buildWithResources rs $ Target (vanillaContext stage ghc) (GhcPkg stage) [] [dir]
+        buildWithResources rs $
+            Target (vanillaContext stage ghc) (GhcPkg Init stage) [] [dir]
         writeFileLines stamp []
         putSuccess $ "| Successfully initialised " ++ dir
index dd991f0..08eca05 100644 (file)
@@ -17,7 +17,7 @@ testRules :: Rules ()
 testRules = do
     "validate" ~> do
         needBuilder $ Ghc CompileHs Stage2
-        needBuilder $ GhcPkg Stage1
+        needBuilder $ GhcPkg Update Stage1
         needBuilder Hpc
         build $ Target (vanillaContext Stage2 compiler) (Make "testsuite/tests") [] []
 
@@ -30,7 +30,7 @@ testRules = do
         windows  <- windowsHost
         top      <- topDirectory
         compiler <- builderPath $ Ghc CompileHs Stage2
-        ghcPkg   <- builderPath $ GhcPkg Stage1
+        ghcPkg   <- builderPath $ GhcPkg Update Stage1
         haddock  <- builderPath Haddock
         threads  <- shakeThreads <$> getShakeOptions
         ghcWithNativeCodeGenInt <- fromEnum <$> ghcWithNativeCodeGen
index 263c82a..1c50729 100644 (file)
@@ -17,7 +17,7 @@ ghcCabalBuilderArgs = builder GhcCabal ? do
             , arg $ top -/- buildPath context
             , dll0Args
             , withStaged $ Ghc CompileHs
-            , withStaged GhcPkg
+            , withStaged (GhcPkg Update)
             , bootPackageDatabaseArgs
             , libraryArgs
             , with HsColour
@@ -89,15 +89,15 @@ cppArgs = arg $ "-I" ++ generatedPath
 
 withBuilderKey :: Builder -> String
 withBuilderKey b = case b of
-    Ar       -> "--with-ar="
-    Ld       -> "--with-ld="
-    Cc  _ _  -> "--with-gcc="
-    Ghc _ _  -> "--with-ghc="
-    Alex     -> "--with-alex="
-    Happy    -> "--with-happy="
-    GhcPkg _ -> "--with-ghc-pkg="
-    HsColour -> "--with-hscolour="
-    _        -> error $ "withBuilderKey: not supported builder " ++ show b
+    Ar         -> "--with-ar="
+    Ld         -> "--with-ld="
+    Cc  _ _    -> "--with-gcc="
+    Ghc _ _    -> "--with-ghc="
+    Alex       -> "--with-alex="
+    Happy      -> "--with-happy="
+    GhcPkg _ -> "--with-ghc-pkg="
+    HsColour   -> "--with-hscolour="
+    _          -> error $ "withBuilderKey: not supported builder " ++ show b
 
 -- Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
 with :: Builder -> Args
index 15d5249..fcde08f 100644 (file)
@@ -3,19 +3,13 @@ module Settings.Builders.GhcPkg (ghcPkgBuilderArgs) where
 import Settings.Builders.Common
 
 ghcPkgBuilderArgs :: Args
-ghcPkgBuilderArgs = builder GhcPkg ? (initArgs <> updateArgs)
-
-initPredicate :: Predicate
-initPredicate = orM $ map (output . packageDbDirectory) [Stage0 ..]
-
-initArgs :: Args
-initArgs = initPredicate ? mconcat [ arg "init", arg =<< getOutput ]
-
-updateArgs :: Args
-updateArgs = notM initPredicate ? do
-    verbosity <- lift $ getVerbosity
-    mconcat [ arg "update"
-            , arg "--force"
-            , verbosity < Chatty ? arg "-v0"
-            , bootPackageDatabaseArgs
-            , arg . pkgInplaceConfig =<< getContext ]
+ghcPkgBuilderArgs = mconcat
+    [ builder (GhcPkg Init) ? mconcat [ arg "init", arg =<< getOutput ]
+
+    , builder (GhcPkg Update) ? do
+        verbosity <- lift $ getVerbosity
+        mconcat [ arg "update"
+                , arg "--force"
+                , verbosity < Chatty ? arg "-v0"
+                , bootPackageDatabaseArgs
+                , arg . pkgInplaceConfig =<< getContext ] ]