Commit 31c6109c authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Add GhcPkgMode

parent 92b5c350
{-# 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
......@@ -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
......
......@@ -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 "
......
......@@ -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
......@@ -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
......
......@@ -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
......
......@@ -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 ] ]
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment