Commit 382143aa authored by Edsko de Vries's avatar Edsko de Vries Committed by Edward Z. Yang
Browse files

Add support for foreign libraries.

A stanza for a platform library looks something like

    platform-library test-package
      type:                native-shared

      if os(Windows)
        options: standalone
        mod-def-file: TestPackage.def

      other-modules:       MyPlatformLib.Hello
                           MyPlatformLib.SomeBindings
      build-depends:       base >=4.7 && <4.9
      hs-source-dirs:      src
      c-sources:           csrc/MyPlatformLibWrapper.c
      default-language:    Haskell2010

where native-shared means that we want to build a native shared library
(.so on Linux, .dylib on OSX, .dll on Windows). The parser also
recognizes native-static but this is not currently supported anywhere.
The standalone option means that the we merge all library dependencies
into the dynamic library (i.e., ghc options -shared -static), rather
than make the created dynamic library just record its dependencies (ghc
options -shared -dynamic); it is currently compulsory on Windows and
unsupported anywhere else. The mod-def-file can be used to specify a
module definition file, and is also Windows specific.

There is a bit of refactoring in Build: gbuild is the old buildOrReplExe
and now deals with both executables and platform libraries.
parent c837c057
......@@ -191,6 +191,11 @@ extra-source-files:
tests/PackageTests/DuplicateModuleName/tests/Foo.hs
tests/PackageTests/DuplicateModuleName/tests2/Foo.hs
tests/PackageTests/EmptyLib/empty/empty.cabal
tests/PackageTests/ForeignLibs/UseLib.c
tests/PackageTests/ForeignLibs/csrc/MyForeignLibWrapper.c
tests/PackageTests/ForeignLibs/my-foreign-lib.cabal
tests/PackageTests/ForeignLibs/src/MyForeignLib/Hello.hs
tests/PackageTests/ForeignLibs/src/MyForeignLib/SomeBindings.hsc
tests/PackageTests/GhcPkgGuess/SameDirectory/SameDirectory.cabal
tests/PackageTests/GhcPkgGuess/SameDirectory/ghc
tests/PackageTests/GhcPkgGuess/SameDirectory/ghc-pkg
......@@ -485,6 +490,9 @@ library
Distribution.Types.BuildType
Distribution.Types.Executable
Distribution.Types.Library
Distribution.Types.ForeignLib
Distribution.Types.ForeignLibType
Distribution.Types.ForeignLibOption
Distribution.Types.ModuleReexport
Distribution.Types.ModuleRenaming
Distribution.Types.IncludeRenaming
......@@ -636,6 +644,7 @@ test-suite package-tests
PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check
PackageTests.CaretOperator.Check
PackageTests.DeterministicAr.Check
PackageTests.ForeignLibs.Check
PackageTests.TestStanza.Check
PackageTests.TestSuiteTests.ExeV10.Check
PackageTests.PackageTester
......
......@@ -283,6 +283,16 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs
componentCompatPackageKey = rc_compat_key rc comp,
componentCompatPackageName = rc_compat_name rc
}
CFLib _ ->
FLibComponentLocalBuildInfo {
componentUnitId = this_uid,
componentComponentId = this_cid,
componentLocalName = cname,
componentPackageDeps = cpds,
componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc,
componentInternalDeps = internal_deps,
componentIncludes = includes
}
CExe _ ->
ExeComponentLocalBuildInfo {
componentUnitId = this_uid,
......
......@@ -175,7 +175,8 @@ checkSanity pkg =
, check (all ($ pkg) [ null . executables
, null . testSuites
, null . benchmarks
, null . allLibraries ]) $
, null . allLibraries
, null . foreignLibs ]) $
PackageBuildImpossible
"No executables, libraries, tests, or benchmarks found. Nothing to do."
......
......@@ -48,6 +48,8 @@ import Distribution.Text
import Distribution.Compat.ReadP as ReadP hiding ( char )
import qualified Distribution.Compat.ReadP as ReadP ( char )
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.ForeignLib
import Distribution.Types.Component
import qualified Data.Map as Map
import Data.Tree ( Tree(Node) )
......@@ -277,10 +279,7 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
pdTaggedBuildInfo :: PDTagged -> BuildInfo
pdTaggedBuildInfo (Lib l) = libBuildInfo l
pdTaggedBuildInfo (SubLib _ l) = libBuildInfo l
pdTaggedBuildInfo (Exe _ e) = buildInfo e
pdTaggedBuildInfo (Test _ t) = testBuildInfo t
pdTaggedBuildInfo (Bench _ b) = benchmarkBuildInfo b
pdTaggedBuildInfo (SubComp _ c) = componentBuildInfo c
pdTaggedBuildInfo PDNull = mempty
-- | Transforms a 'CondTree' by putting the input under the "then" branch of a
......@@ -424,10 +423,15 @@ overallDependencies enabled (TargetSet targets) = mconcat depss
-- BLANK. I don't know whose fault this is but I'll use the tag
-- instead. -- ezyang
removeDisabledSections (Lib _) = componentNameRequested enabled CLibName
removeDisabledSections (SubLib t _) = componentNameRequested enabled (CSubLibName t)
removeDisabledSections (Exe t _) = componentNameRequested enabled (CExeName t)
removeDisabledSections (Test t _) = componentNameRequested enabled (CTestName t)
removeDisabledSections (Bench t _) = componentNameRequested enabled (CBenchName t)
removeDisabledSections (SubComp t c)
-- Do NOT use componentName
= componentNameRequested enabled
$ case c of
CLib _ -> CSubLibName t
CFLib _ -> CFLibName t
CExe _ -> CExeName t
CTest _ -> CTestName t
CBench _ -> CBenchName t
removeDisabledSections PDNull = True
-- Apply extra constraints to a dependency map.
......@@ -448,67 +452,30 @@ constrainBy left extra =
-- | Collect up the targets in a TargetSet of tagged targets, storing the
-- dependencies as we go.
flattenTaggedTargets :: TargetSet PDTagged ->
(Maybe Library
, [(String, Library)], [(String, Executable)], [(String, TestSuite)]
, [(String, Benchmark)])
flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], [], []) targets
flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(String, Component)])
flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets
where
untag (_, Lib _) (Just _, _, _, _, _) = userBug "Only one library expected"
untag (deps, Lib l) (Nothing, libs, exes, tests, bms) =
(Just l', libs, exes, tests, bms)
untag (_, Lib _) (Just _, _) = userBug "Only one library expected"
untag (deps, Lib l) (Nothing, comps) =
(Just l', comps)
where
l' = l {
libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }
}
untag (deps, SubLib n l) (mb_lib, libs, exes, tests, bms)
| any ((== n) . fst) libs =
userBug $ "There exist several libs with the same name: '" ++ n ++ "'"
-- NB: libraries live in a different namespace than everything else
-- TODO: no, (new-style) TESTS live in same namespace!!
| otherwise = (mb_lib, (n, l'):libs, exes, tests, bms)
where
l' = l {
libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }
}
untag (deps, Exe n e) (mb_lib, libs, exes, tests, bms)
| any ((== n) . fst) exes =
userBug $ "There exist several exes with the same name: '" ++ n ++ "'"
| any ((== n) . fst) tests =
userBug $ "There exists a test with the same name as an exe: '" ++ n ++ "'"
| any ((== n) . fst) bms =
userBug $ "There exists a benchmark with the same name as an exe: '" ++ n ++ "'"
| otherwise = (mb_lib, libs, (n, e'):exes, tests, bms)
where
e' = e {
buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }
}
untag (deps, Test n t) (mb_lib, libs, exes, tests, bms)
| any ((== n) . fst) tests =
userBug $ "There exist several tests with the same name: '" ++ n ++ "'"
| any ((== n) . fst) exes =
userBug $ "There exists an exe with the same name as the test: '" ++ n ++ "'"
| any ((== n) . fst) bms =
userBug $ "There exists a benchmark with the same name as the test: '" ++ n ++ "'"
| otherwise = (mb_lib, libs, exes, (n, t'):tests, bms)
where
t' = t {
testBuildInfo = (testBuildInfo t)
{ targetBuildDepends = fromDepMap deps }
}
untag (deps, Bench n b) (mb_lib, libs, exes, tests, bms)
| any ((== n) . fst) bms =
userBug $ "There exist several benchmarks with the same name: '" ++ n ++ "'"
| any ((== n) . fst) exes =
userBug $ "There exists an exe with the same name as the benchmark: '" ++ n ++ "'"
| any ((== n) . fst) tests =
userBug $ "There exists a test with the same name as the benchmark: '" ++ n ++ "'"
| otherwise = (mb_lib, libs, exes, tests, (n, b'):bms)
untag (deps, SubComp n c) (mb_lib, comps)
| any ((== n) . fst) comps =
userBug $ "There exist several components with the same name: '" ++ n ++ "'"
| otherwise = (mb_lib, (n, c') : comps)
where
b' = b {
benchmarkBuildInfo = (benchmarkBuildInfo b)
{ targetBuildDepends = fromDepMap deps }
}
updBI bi = bi { targetBuildDepends = fromDepMap deps }
c' = case c of
CLib x -> CLib x { libBuildInfo = updBI (libBuildInfo x) }
CFLib x -> CFLib x { foreignLibBuildInfo = updBI (foreignLibBuildInfo x) }
CExe x -> CExe x { buildInfo = updBI (buildInfo x) }
CTest x -> CTest x { testBuildInfo = updBI (testBuildInfo x) }
CBench x -> CBench x { benchmarkBuildInfo = updBI (benchmarkBuildInfo x) }
untag (_, PDNull) x = x -- actually this should not happen, but let's be liberal
......@@ -516,14 +483,8 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], [], [])
-- Convert GenericPackageDescription to PackageDescription
--
-- ezyang: Arguably, this should be:
-- data PDTagged = PDComp Component
-- | PDNull
data PDTagged = Lib Library
| SubLib String Library
| Exe String Executable
| Test String TestSuite
| Bench String Benchmark
| SubComp String Component
| PDNull
deriving Show
......@@ -535,10 +496,7 @@ instance Semigroup PDTagged where
PDNull <> x = x
x <> PDNull = x
Lib l <> Lib l' = Lib (l <> l')
SubLib n l <> SubLib n' l' | n == n' = SubLib n (l <> l')
Exe n e <> Exe n' e' | n == n' = Exe n (e <> e')
Test n t <> Test n' t' | n == n' = Test n (t <> t')
Bench n b <> Bench n' b' | n == n' = Bench n (b <> b')
SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x')
_ <> _ = cabalBug "Cannot combine incompatible tags"
-- | Create a package description with all configurations resolved.
......@@ -583,11 +541,13 @@ finalizePD ::
-- description along with the flag assignments chosen.
finalizePD userflags enabled satisfyDep
(Platform arch os) impl constraints
(GenericPackageDescription pkg flags mb_lib0 sub_libs0 exes0 tests0 bms0) =
(GenericPackageDescription pkg flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) =
case resolveFlags of
Right ((mb_lib', sub_libs', exes', tests', bms'), targetSet, flagVals) ->
Right ((mb_lib', comps'), targetSet, flagVals) ->
let (sub_libs', flibs', exes', tests', bms') = partitionComponents comps' in
Right ( pkg { library = mb_lib'
, subLibraries = sub_libs'
, foreignLibs = flibs'
, executables = exes'
, testSuites = tests'
, benchmarks = bms'
......@@ -599,21 +559,26 @@ finalizePD userflags enabled satisfyDep
where
-- Combine lib, exes, and tests into one list of @CondTree@s with tagged data
condTrees = maybeToList (fmap (mapTreeData Lib) mb_lib0)
++ map (\(name,tree) -> mapTreeData (SubLib name) tree) sub_libs0
++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0
++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0
++ map (\(name,tree) -> mapTreeData (Bench name) tree) bms0
++ map (\(name,tree) -> mapTreeData (SubComp name . CLib) tree) sub_libs0
++ map (\(name,tree) -> mapTreeData (SubComp name . CFLib) tree) flibs0
++ map (\(name,tree) -> mapTreeData (SubComp name . CExe) tree) exes0
++ map (\(name,tree) -> mapTreeData (SubComp name . CTest) tree) tests0
++ map (\(name,tree) -> mapTreeData (SubComp name . CBench) tree) bms0
resolveFlags =
case resolveWithFlags flagChoices enabled os arch impl constraints condTrees check of
Right (targetSet, fs) ->
let (mb_lib, sub_libs, exes, tests, bms) = flattenTaggedTargets targetSet in
Right ( (fmap (\l -> (libFillInDefaults l) { libName = Nothing }) mb_lib,
map (\(n,l) -> (libFillInDefaults l) { libName = Just n
, libExposed = False }) sub_libs,
map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes,
map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests,
map (\(n,b) -> (benchFillInDefaults b) { benchmarkName = n }) bms),
let (mb_lib, comps) = flattenTaggedTargets targetSet in
Right ( (fmap libFillInDefaults mb_lib,
map (\(n,c) ->
foldComponent
(\l -> CLib (libFillInDefaults l) { libName = Just n
, libExposed = False })
(\l -> CFLib (flibFillInDefaults l) { foreignLibName = n })
(\e -> CExe (exeFillInDefaults e) { exeName = n })
(\t -> CTest (testFillInDefaults t) { testName = n })
(\b -> CBench (benchFillInDefaults b) { benchmarkName = n })
c) comps),
targetSet, fs)
Left missing -> Left missing
......@@ -667,26 +632,37 @@ resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribu
-- default path will be missing from the package description returned by this
-- function.
flattenPackageDescription :: GenericPackageDescription -> PackageDescription
flattenPackageDescription (GenericPackageDescription pkg _ mlib0 sub_libs0 exes0 tests0 bms0) =
pkg { library = mlib
flattenPackageDescription
(GenericPackageDescription pkg _ mlib0 sub_libs0 flibs0 exes0 tests0 bms0) =
pkg { library = mlib
, subLibraries = reverse sub_libs
, executables = reverse exes
, testSuites = reverse tests
, benchmarks = reverse bms
, buildDepends = ldeps ++ reverse sub_ldeps ++ reverse edeps ++ reverse tdeps ++ reverse bdeps
, foreignLibs = reverse flibs
, executables = reverse exes
, testSuites = reverse tests
, benchmarks = reverse bms
, buildDepends = ldeps
++ reverse sub_ldeps
++ reverse pldeps
++ reverse edeps
++ reverse tdeps
++ reverse bdeps
}
where
(mlib, ldeps) = case mlib0 of
Just lib -> let (l,ds) = ignoreConditions lib in
(Just ((libFillInDefaults l) { libName = Nothing }), ds)
Nothing -> (Nothing, [])
(sub_libs, sub_ldeps) = foldr flattenLib ([],[]) sub_libs0
(exes, edeps) = foldr flattenExe ([],[]) exes0
(tests, tdeps) = foldr flattenTst ([],[]) tests0
(bms, bdeps) = foldr flattenBm ([],[]) bms0
(sub_libs, sub_ldeps) = foldr flattenLib ([],[]) sub_libs0
(flibs, pldeps) = foldr flattenFLib ([],[]) flibs0
(exes, edeps) = foldr flattenExe ([],[]) exes0
(tests, tdeps) = foldr flattenTst ([],[]) tests0
(bms, bdeps) = foldr flattenBm ([],[]) bms0
flattenLib (n, t) (es, ds) =
let (e, ds') = ignoreConditions t in
( (libFillInDefaults $ e { libName = Just n, libExposed = False }) : es, ds' ++ ds )
flattenFLib (n, t) (es, ds) =
let (e, ds') = ignoreConditions t in
( (flibFillInDefaults $ e { foreignLibName = n }) : es, ds' ++ ds )
flattenExe (n, t) (es, ds) =
let (e, ds') = ignoreConditions t in
( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds )
......@@ -708,6 +684,10 @@ libFillInDefaults :: Library -> Library
libFillInDefaults lib@(Library { libBuildInfo = bi }) =
lib { libBuildInfo = biFillInDefaults bi }
flibFillInDefaults :: ForeignLib -> ForeignLib
flibFillInDefaults flib@(ForeignLib { foreignLibBuildInfo = bi }) =
flib { foreignLibBuildInfo = biFillInDefaults bi }
exeFillInDefaults :: Executable -> Executable
exeFillInDefaults exe@(Executable { buildInfo = bi }) =
exe { buildInfo = biFillInDefaults bi }
......
......@@ -2,7 +2,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.PackageDescription.Parse
......@@ -37,6 +37,7 @@ module Distribution.PackageDescription.Parse (
pkgDescrFieldDescrs,
libFieldDescrs,
foreignLibFieldDescrs,
executableFieldDescrs,
binfoFieldDescrs,
sourceRepoFieldDescrs,
......@@ -49,6 +50,8 @@ import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.IncludeRenaming
import Distribution.Types.ForeignLib
import Distribution.Types.ForeignLibType
import Distribution.ParseUtils hiding (parseFields)
import Distribution.PackageDescription
import Distribution.PackageDescription.Utils
......@@ -192,6 +195,34 @@ storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) =
bi{ customFieldsBI = customFieldsBI bi ++ [(f,val)]}}
storeXFieldsLib _ _ = Nothing
-- ---------------------------------------------------------------------------
-- Foreign libraries
foreignLibFieldDescrs :: [FieldDescr ForeignLib]
foreignLibFieldDescrs =
[ simpleField "type"
disp parse
foreignLibType (\x flib -> flib { foreignLibType = x })
, listField "options"
disp parse
foreignLibOptions (\x flib -> flib { foreignLibOptions = x })
, listField "mod-def-file"
showFilePath parseFilePathQ
foreignLibModDefFile (\x flib -> flib { foreignLibModDefFile = x })
]
++ map biToFLib binfoFieldDescrs
where biToFLib = liftField foreignLibBuildInfo $ \bi flib ->
flib { foreignLibBuildInfo = bi }
storeXFieldsForeignLib :: UnrecFieldParser ForeignLib
storeXFieldsForeignLib (f@('x':'-':_), val)
l@(ForeignLib { foreignLibBuildInfo = bi }) =
Just $ l { foreignLibBuildInfo = bi {
customFieldsBI = (f,val):customFieldsBI bi
}
}
storeXFieldsForeignLib _ _ = Nothing
-- ---------------------------------------------------------------------------
-- The Executable type
......@@ -750,14 +781,14 @@ parsePackageDescription file = do
-- 'getBody' assumes that the remaining fields only consist of
-- flags, lib and exe sections.
(repos, flags, mcsetup, mlib, sub_libs, exes, tests, bms) <- getBody pkg
(repos, flags, mcsetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg
warnIfRest -- warn if getBody did not parse up to the last field.
-- warn about using old/new syntax with wrong cabal-version:
maybeWarnCabalVersion (not $ oldSyntax fields0) pkg
checkForUndefinedFlags flags mlib sub_libs exes tests
return $ GenericPackageDescription
pkg { sourceRepos = repos, setupBuildInfo = mcsetup }
flags mlib sub_libs exes tests bms
flags mlib sub_libs flibs exes tests bms
where
oldSyntax = all isSimpleField
......@@ -857,15 +888,21 @@ parsePackageDescription file = do
_ -> return (reverse acc)
--
-- body ::= { repo | flag | library | executable | test }+
-- body ::= { repo | flag | library | sub library | foreign library
-- | executable | test | bench }+
--
-- The body consists of an optional sequence of declarations of flags and
-- an arbitrary number of libraries/executables/tests.
-- an arbitrary number of components
--
-- TODO: This method is long due for a rewrite to use a accumulator
-- data type, or perhaps some more general way of balling the
-- components up.
getBody :: PackageDescription
-> PM ([SourceRepo], [Flag]
,Maybe SetupBuildInfo
,(Maybe (CondTree ConfVar [Dependency] Library))
,[(String, CondTree ConfVar [Dependency] Library)]
,[(String, CondTree ConfVar [Dependency] ForeignLib)]
,[(String, CondTree ConfVar [Dependency] Executable)]
,[(String, CondTree ConfVar [Dependency] TestSuite)]
,[(String, CondTree ConfVar [Dependency] Benchmark)])
......@@ -877,8 +914,33 @@ parsePackageDescription file = do
exename <- lift $ runP line_no "executable" parseTokenQ sec_label
flds <- collectFields parseExeFields sec_fields
skipField
(repos, flags, csetup, mlib, sub_libs, exes, tests, bms) <- getBody pkg
return (repos, flags, csetup, mlib, sub_libs, (exename, flds): exes, tests, bms)
(repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg
return (repos, flags, csetup, mlib, sub_libs, flibs, (exename, flds): exes, tests, bms)
| sec_type == "foreign-library" -> do
when (null sec_label) $ lift $ syntaxError line_no
"'foreign-library' needs one argument (the library's name)"
libname <- lift $ runP line_no "foreign-library" parseTokenQ sec_label
flds <- collectFields parseForeignLibFields sec_fields
-- Check that a valid foreign library type has been chosen. A type
-- field may be given inside a conditional block, so we must check
-- for that before complaining that a type field has not been given.
-- The foreign library must always have a valid type, so we need to
-- check both the 'then' and 'else' blocks, though the blocks need
-- not have the same type.
let hasType ts = foreignLibType ts /= foreignLibType mempty
if onAllBranches hasType flds
then do
skipField
(repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg
return (repos, flags, csetup, mlib, sub_libs, (libname, flds):flibs, exes, tests, bms)
else lift $ syntaxError line_no $
"Foreign library \"" ++ libname
++ "\" is missing required field \"type\" or the field "
++ "is not present in all conditional branches. The "
++ "available test types are: "
++ intercalate ", " (map display knownForeignLibTypes)
| sec_type == "test-suite" -> do
when (null sec_label) $ lift $ syntaxError line_no
......@@ -886,40 +948,18 @@ parsePackageDescription file = do
testname <- lift $ runP line_no "test" parseTokenQ sec_label
flds <- collectFields (parseTestFields line_no) sec_fields
-- Check that a valid test suite type has been chosen. A type
-- field may be given inside a conditional block, so we must
-- check for that before complaining that a type field has not
-- been given. The test suite must always have a valid type, so
-- we need to check both the 'then' and 'else' blocks, though
-- the blocks need not have the same type.
let checkTestType ts ct =
let ts' = mappend ts $ condTreeData ct
-- If a conditional has only a 'then' block and no
-- 'else' block, then it cannot have a valid type
-- in every branch, unless the type is specified at
-- a higher level in the tree.
checkComponent (_, _, Nothing) = False
-- If a conditional has a 'then' block and an 'else'
-- block, both must specify a test type, unless the
-- type is specified higher in the tree.
checkComponent (_, t, Just e) =
checkTestType ts' t && checkTestType ts' e
-- Does the current node specify a test type?
hasTestType = testInterface ts'
/= testInterface emptyTestSuite
-- If the current level of the tree specifies a type,
-- then we are done. If not, then one of the conditional
-- branches below the current node must specify a type.
-- Each node may have multiple immediate children; we
-- only one need one to specify a type because the
-- configure step uses 'mappend' to join together the
-- results of flag resolution.
in hasTestType || any checkComponent (condTreeComponents ct)
if checkTestType emptyTestSuite flds
-- Check that a valid test suite type has been chosen. A type field
-- may be given inside a conditional block, so we must check for
-- that before complaining that a type field has not been given. The
-- test suite must always have a valid type, so we need to check
-- both the 'then' and 'else' blocks, though the blocks need not
-- have the same type.
let hasType ts = testInterface ts /= testInterface mempty
if onAllBranches hasType flds
then do
skipField
(repos, flags, csetup, mlib, sub_libs, exes, tests, bms) <- getBody pkg
return (repos, flags, csetup, mlib, sub_libs, exes,
(repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg
return (repos, flags, csetup, mlib, sub_libs, flibs, exes,
(testname, flds) : tests, bms)
else lift $ syntaxError line_no $
"Test suite \"" ++ testname
......@@ -934,40 +974,18 @@ parsePackageDescription file = do
benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label
flds <- collectFields (parseBenchmarkFields line_no) sec_fields
-- Check that a valid benchmark type has been chosen. A type
-- field may be given inside a conditional block, so we must
-- check for that before complaining that a type field has not
-- been given. The benchmark must always have a valid type, so
-- we need to check both the 'then' and 'else' blocks, though
-- the blocks need not have the same type.
let checkBenchmarkType ts ct =
let ts' = mappend ts $ condTreeData ct
-- If a conditional has only a 'then' block and no
-- 'else' block, then it cannot have a valid type
-- in every branch, unless the type is specified at
-- a higher level in the tree.
checkComponent (_, _, Nothing) = False
-- If a conditional has a 'then' block and an 'else'
-- block, both must specify a benchmark type, unless the
-- type is specified higher in the tree.
checkComponent (_, t, Just e) =
checkBenchmarkType ts' t && checkBenchmarkType ts' e
-- Does the current node specify a benchmark type?
hasBenchmarkType = benchmarkInterface ts'
/= benchmarkInterface emptyBenchmark
-- If the current level of the tree specifies a type,
-- then we are done. If not, then one of the conditional
-- branches below the current node must specify a type.
-- Each node may have multiple immediate children; we
-- only one need one to specify a type because the
-- configure step uses 'mappend' to join together the
-- results of flag resolution.
in hasBenchmarkType || any checkComponent (condTreeComponents ct)
if checkBenchmarkType emptyBenchmark flds
-- Check that a valid benchmark type has been chosen. A type field
-- may be given inside a conditional block, so we must check for
-- that before complaining that a type field has not been given. The
-- benchmark must always have a valid type, so we need to check both
-- the 'then' and 'else' blocks, though the blocks need not have the
-- same type.
let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty
if onAllBranches hasType flds
then do
skipField
(repos, flags, csetup, mlib, sub_libs, exes, tests, bms) <- getBody pkg
return (repos, flags, csetup, mlib, sub_libs, exes,
(repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg
return (repos, flags, csetup, mlib, sub_libs, flibs, exes,
tests, (benchname, flds) : bms)
else lift $ syntaxError line_no $
"Benchmark \"" ++ benchname
......@@ -985,14 +1003,14 @@ parsePackageDescription file = do
$ runP line_no "library" parseTokenQ sec_label
flds <- collectFields parseLibFields sec_fields
skipField
(repos, flags, csetup, mlib, sub_libs, exes, tests, bms) <- getBody pkg
(repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg
case mb_libname of
Just libname ->
return (repos, flags, csetup, mlib, (libname, flds) : sub_libs, exes, tests, bms)
return (repos, flags, csetup, mlib, (libname, flds) : sub_libs, flibs, exes, tests, bms)
Nothing -> do
when (isJust mlib) $ lift $ syntaxError line_no
"There can only be one (public) library section in a package description."
return (repos, flags, csetup, Just flds, sub_libs, exes, tests, bms)
return (repos, flags, csetup, Just flds, sub_libs, flibs, exes, tests, bms)