diff --git a/Cabal-syntax/Cabal-syntax.cabal b/Cabal-syntax/Cabal-syntax.cabal
index 997b91363ce..64aee5d23a4 100644
--- a/Cabal-syntax/Cabal-syntax.cabal
+++ b/Cabal-syntax/Cabal-syntax.cabal
@@ -140,6 +140,7 @@ library
Distribution.Types.Executable
Distribution.Types.Executable.Lens
Distribution.Types.ExecutableScope
+ Distribution.Types.ExtraSource
Distribution.Types.ExposedModule
Distribution.Types.Flag
Distribution.Types.ForeignLib
diff --git a/Cabal-syntax/src/Distribution/Backpack.hs b/Cabal-syntax/src/Distribution/Backpack.hs
index e70b9ffc692..048abdc0239 100644
--- a/Cabal-syntax/src/Distribution/Backpack.hs
+++ b/Cabal-syntax/src/Distribution/Backpack.hs
@@ -53,6 +53,10 @@ import Distribution.Utils.Base62
import qualified Data.Map as Map
import qualified Data.Set as Set
+import GHC.Stack (HasCallStack)
+
+import Unsafe.Coerce (unsafeCoerce)
+
-----------------------------------------------------------------------
-- OpenUnitId
@@ -147,9 +151,7 @@ mkOpenUnitId uid cid insts =
mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId
mkDefUnitId cid insts =
unsafeMkDefUnitId
- ( mkUnitId
- (unComponentId cid ++ maybe "" ("+" ++) (hashModuleSubst insts))
- )
+ (addSuffixToUnitId (maybe "" ("+" ++) (hashModuleSubst insts)) (unsafeCoerce cid))
-- impose invariant!
@@ -254,7 +256,7 @@ openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems
-- | When typechecking, we don't demand that a freshly instantiated
-- 'IndefFullUnitId' be compiled; instead, we just depend on the
-- installed indefinite unit installed at the 'ComponentId'.
-abstractUnitId :: OpenUnitId -> UnitId
+abstractUnitId :: HasCallStack => OpenUnitId -> UnitId
abstractUnitId (DefiniteUnitId def_uid) = unDefUnitId def_uid
abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid
diff --git a/Cabal-syntax/src/Distribution/Compat/Graph.hs b/Cabal-syntax/src/Distribution/Compat/Graph.hs
index c716563f52a..6fe6bb3bfec 100644
--- a/Cabal-syntax/src/Distribution/Compat/Graph.hs
+++ b/Cabal-syntax/src/Distribution/Compat/Graph.hs
@@ -105,6 +105,8 @@ import qualified Data.Set as Set
import qualified Data.Tree as Tree
import qualified Distribution.Compat.Prelude as Prelude
+import GHC.Stack (HasCallStack)
+
-- | A graph of nodes @a@. The nodes are expected to have instance
-- of class 'IsNode'.
data Graph a = Graph
@@ -377,16 +379,18 @@ fromMap m =
bounds = (0, Map.size m - 1)
-- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph.
-fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a
-fromDistinctList =
+fromDistinctList :: (HasCallStack, IsNode a, Show (Key a)) => [a] -> Graph a
+fromDistinctList xs =
fromMap
. Map.fromListWith (\_ -> duplicateError)
- . map (\n -> n `seq` (nodeKey n, n))
+ . map (\n -> n `seq` (nodeKey n, n)) $ xs
where
duplicateError n =
error $
"Graph.fromDistinctList: duplicate key: "
++ show (nodeKey n)
+ ++ " in "
+ ++ unlines (map (show . nodeKey) xs)
-- Map-like operations
diff --git a/Cabal-syntax/src/Distribution/Compiler.hs b/Cabal-syntax/src/Distribution/Compiler.hs
index 40148776ee1..e79b18e846f 100644
--- a/Cabal-syntax/src/Distribution/Compiler.hs
+++ b/Cabal-syntax/src/Distribution/Compiler.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
@@ -173,7 +174,7 @@ instance (Semigroup a, Monoid a) => Monoid (PerCompilerFlavor a) where
-- ------------------------------------------------------------
data CompilerId = CompilerId CompilerFlavor Version
- deriving (Eq, Generic, Ord, Read, Show)
+ deriving (Eq, Generic, Ord, Read, Show, Data)
instance Binary CompilerId
instance Structured CompilerId
@@ -184,12 +185,18 @@ instance Pretty CompilerId where
| v == nullVersion = pretty f
| otherwise = pretty f <<>> Disp.char '-' <<>> pretty v
+instance Pretty (Maybe CompilerId) where
+ pretty = maybe Disp.empty pretty
+
instance Parsec CompilerId where
parsec = do
flavour <- parsec
version <- (P.char '-' >> parsec) <|> return nullVersion
return (CompilerId flavour version)
+instance Parsec (Maybe CompilerId) where
+ parsec = Just <$> parsec <|> return Nothing
+
lowercase :: String -> String
lowercase = map toLower
@@ -216,10 +223,13 @@ data CompilerInfo = CompilerInfo
, compilerInfoExtensions :: Maybe [Extension]
-- ^ Supported extensions, if known.
}
- deriving (Generic, Show, Read)
+ deriving (Generic, Show, Read, Eq)
instance Binary CompilerInfo
+instance Structured CompilerInfo
+instance NFData CompilerInfo where rnf = genericRnf
+-- | AbiTag logic
data AbiTag
= NoAbiTag
| AbiTag String
@@ -227,6 +237,7 @@ data AbiTag
instance Binary AbiTag
instance Structured AbiTag
+instance NFData AbiTag where rnf = genericRnf
instance Pretty AbiTag where
pretty NoAbiTag = Disp.empty
diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs
index fa815a49a5e..f439f9d2b01 100644
--- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs
+++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs
@@ -23,6 +23,8 @@ import Distribution.FieldGrammar.Newtypes
import Distribution.Fields.Field
import Distribution.Utils.ShortText
+import GHC.Stack (HasCallStack)
+
-- | 'FieldGrammar' is parametrised by
--
-- * @s@ which is a structure we are parsing. We need this to provide prettyprinter
@@ -43,11 +45,11 @@ class
| g -> c
where
-- | Unfocus, zoom out, /blur/ 'FieldGrammar'.
- blurFieldGrammar :: ALens' a b -> g b d -> g a d
+ blurFieldGrammar :: HasCallStack => ALens' a b -> g b d -> g a d
-- | Field which should be defined, exactly once.
uniqueFieldAla
- :: (c b, Newtype a b)
+ :: (c b, Newtype a b, HasCallStack)
=> FieldName
-- ^ field name
-> (a -> b)
@@ -58,7 +60,7 @@ class
-- | Boolean field with a default value.
booleanFieldDef
- :: FieldName
+ :: HasCallStack => FieldName
-- ^ field name
-> ALens' s Bool
-- ^ lens into the field
@@ -68,7 +70,7 @@ class
-- | Optional field.
optionalFieldAla
- :: (c b, Newtype a b)
+ :: (c b, Newtype a b, HasCallStack)
=> FieldName
-- ^ field name
-> (a -> b)
@@ -79,7 +81,7 @@ class
-- | Optional field with default value.
optionalFieldDefAla
- :: (c b, Newtype a b, Eq a)
+ :: (c b, Newtype a b, Eq a, HasCallStack)
=> FieldName
-- ^ field name
-> (a -> b)
@@ -95,7 +97,7 @@ class
--
-- @since 3.0.0.0
freeTextField
- :: FieldName
+ :: HasCallStack => FieldName
-> ALens' s (Maybe String)
-- ^ lens into the field
-> g s (Maybe String)
@@ -105,14 +107,14 @@ class
--
-- @since 3.0.0.0
freeTextFieldDef
- :: FieldName
+ :: HasCallStack => FieldName
-> ALens' s String
-- ^ lens into the field
-> g s String
-- | @since 3.2.0.0
freeTextFieldDefST
- :: FieldName
+ :: HasCallStack => FieldName
-> ALens' s ShortText
-- ^ lens into the field
-> g s ShortText
@@ -123,7 +125,7 @@ class
--
-- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid.
monoidalFieldAla
- :: (c b, Monoid a, Newtype a b)
+ :: (c b, Monoid a, Newtype a b, HasCallStack)
=> FieldName
-- ^ field name
-> (a -> b)
@@ -134,21 +136,21 @@ class
-- | Parser matching all fields with a name starting with a prefix.
prefixedFields
- :: FieldName
+ :: HasCallStack => FieldName
-- ^ field name prefix
-> ALens' s [(String, String)]
-- ^ lens into the field
-> g s [(String, String)]
-- | Known field, which we don't parse, nor pretty print.
- knownField :: FieldName -> g s ()
+ knownField :: HasCallStack => FieldName -> g s ()
-- | Field which is parsed but not pretty printed.
- hiddenField :: g s a -> g s a
+ hiddenField :: HasCallStack => g s a -> g s a
-- | Deprecated since
deprecatedSince
- :: CabalSpecVersion
+ :: HasCallStack => CabalSpecVersion
-- ^ version
-> String
-- ^ deprecation message
@@ -157,7 +159,7 @@ class
-- | Removed in. If we encounter removed field, parsing fails.
removedIn
- :: CabalSpecVersion
+ :: HasCallStack => CabalSpecVersion
-- ^ version
-> String
-- ^ removal message
@@ -166,7 +168,7 @@ class
-- | Annotate field with since spec-version.
availableSince
- :: CabalSpecVersion
+ :: HasCallStack => CabalSpecVersion
-- ^ spec version
-> a
-- ^ default value
@@ -181,7 +183,7 @@ class
--
-- @since 3.4.0.0
availableSinceWarn
- :: CabalSpecVersion
+ :: HasCallStack => CabalSpecVersion
-- ^ spec version
-> g s a
-> g s a
@@ -189,7 +191,7 @@ class
-- | Field which can be defined at most once.
uniqueField
- :: (FieldGrammar c g, c (Identity a))
+ :: (FieldGrammar c g, c (Identity a), HasCallStack)
=> FieldName
-- ^ field name
-> ALens' s a
@@ -199,7 +201,7 @@ uniqueField fn l = uniqueFieldAla fn Identity l
-- | Field which can be defined at most once.
optionalField
- :: (FieldGrammar c g, c (Identity a))
+ :: (FieldGrammar c g, c (Identity a), HasCallStack)
=> FieldName
-- ^ field name
-> ALens' s (Maybe a)
@@ -209,7 +211,7 @@ optionalField fn l = optionalFieldAla fn Identity l
-- | Optional field with default value.
optionalFieldDef
- :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a)
+ :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a, HasCallStack)
=> FieldName
-- ^ field name
-> ALens' s a
@@ -221,7 +223,7 @@ optionalFieldDef fn l x = optionalFieldDefAla fn Identity l x
-- | Field which can be define multiple times, and the results are @mappend@ed.
monoidalField
- :: (FieldGrammar c g, c (Identity a), Monoid a)
+ :: (FieldGrammar c g, c (Identity a), Monoid a, HasCallStack)
=> FieldName
-- ^ field name
-> ALens' s a
@@ -231,7 +233,7 @@ monoidalField fn l = monoidalFieldAla fn Identity l
-- | Default implementation for 'freeTextFieldDefST'.
defaultFreeTextFieldDefST
- :: (Functor (g s), FieldGrammar c g)
+ :: (Functor (g s), FieldGrammar c g, HasCallStack)
=> FieldName
-> ALens' s ShortText
-- ^ lens into the field
diff --git a/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs b/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs
index 2c15d678335..dc2499f7a38 100644
--- a/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs
+++ b/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs
@@ -62,11 +62,15 @@ import qualified Text.PrettyPrint as Disp
import Distribution.Types.InstalledPackageInfo
import Distribution.Types.InstalledPackageInfo.FieldGrammar
-installedComponentId :: InstalledPackageInfo -> ComponentId
+import GHC.Stack (HasCallStack)
+
+import Unsafe.Coerce (unsafeCoerce)
+
+installedComponentId :: HasCallStack => InstalledPackageInfo -> ComponentId
installedComponentId ipi =
- case unComponentId (installedComponentId_ ipi) of
- "" -> mkComponentId (unUnitId (installedUnitId ipi))
- _ -> installedComponentId_ ipi
+ fromMaybe
+ (unsafeCoerce (installedUnitId ipi))
+ (installedComponentId_ ipi)
-- | Get the indefinite unit identity representing this package.
-- This IS NOT guaranteed to give you a substitution; for
@@ -93,7 +97,7 @@ sourceComponentName = CLibName . sourceLibName
-- | Return either errors, or IPI with list of warnings
parseInstalledPackageInfo
- :: ByteString
+ :: HasCallStack => ByteString
-> Either (NonEmpty String) ([String], InstalledPackageInfo)
parseInstalledPackageInfo s = case P.readFields s of
Left err -> Left (show err :| [])
@@ -117,12 +121,12 @@ parseInstalledPackageInfo s = case P.readFields s of
-- | Pretty print 'InstalledPackageInfo'.
--
-- @pkgRoot@ isn't printed, as ghc-pkg prints it manually (as GHC-8.4).
-showInstalledPackageInfo :: InstalledPackageInfo -> String
+showInstalledPackageInfo :: HasCallStack => InstalledPackageInfo -> String
showInstalledPackageInfo ipi =
showFullInstalledPackageInfo ipi{pkgRoot = Nothing}
-- | The variant of 'showInstalledPackageInfo' which outputs @pkgroot@ field too.
-showFullInstalledPackageInfo :: InstalledPackageInfo -> String
+showFullInstalledPackageInfo :: HasCallStack => InstalledPackageInfo -> String
showFullInstalledPackageInfo = P.showFields (const NoComment) . prettyFieldGrammar cabalSpecLatest ipiFieldGrammar
-- |
@@ -130,7 +134,7 @@ showFullInstalledPackageInfo = P.showFields (const NoComment) . prettyFieldGramm
-- >>> let ipi = emptyInstalledPackageInfo { maintainer = fromString "Tester" }
-- >>> fmap ($ ipi) $ showInstalledPackageInfoField "maintainer"
-- Just "maintainer: Tester"
-showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
+showInstalledPackageInfoField :: HasCallStack => String -> Maybe (InstalledPackageInfo -> String)
showInstalledPackageInfoField fn =
fmap (\g -> Disp.render . ppField fn . g) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn)
diff --git a/Cabal-syntax/src/Distribution/PackageDescription.hs b/Cabal-syntax/src/Distribution/PackageDescription.hs
index 47d46673e5f..71078654e68 100644
--- a/Cabal-syntax/src/Distribution/PackageDescription.hs
+++ b/Cabal-syntax/src/Distribution/PackageDescription.hs
@@ -48,6 +48,9 @@ module Distribution.PackageDescription
, module Distribution.Types.HookedBuildInfo
, module Distribution.Types.SetupBuildInfo
+ -- * Extra sources
+ , module Distribution.Types.ExtraSource
+
-- * Flags
, module Distribution.Types.Flag
@@ -95,6 +98,7 @@ import Distribution.Types.ComponentName
import Distribution.Types.CondTree
import Distribution.Types.Condition
import Distribution.Types.ConfVar
+import Distribution.Types.ExtraSource
import Distribution.Types.Dependency
import Distribution.Types.ExeDependency
import Distribution.Types.Executable
diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs
index 49db03ee3c1..27e98ee0a82 100644
--- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs
+++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs
@@ -74,7 +74,7 @@ import Prelude ()
import Distribution.CabalSpecVersion
import Distribution.Compat.Newtype (Newtype, pack', unpack')
-import Distribution.Compiler (CompilerFlavor (..), PerCompilerFlavor (..))
+import Distribution.Compiler (CompilerFlavor (..), PerCompilerFlavor (..), CompilerId)
import Distribution.FieldGrammar
import Distribution.Fields
import Distribution.ModuleName (ModuleName)
@@ -101,6 +101,7 @@ packageDescriptionFieldGrammar
, c (Identity BuildType)
, c (Identity PackageName)
, c (Identity Version)
+ , c (Identity CompilerId)
, forall from to. c (List FSep (RelativePathNT from to) (RelativePath from to))
, forall from to. c (List VCat (RelativePathNT from to) (RelativePath from to))
, c (List FSep TestedWith (CompilerFlavor, VersionRange))
@@ -150,6 +151,7 @@ packageDescriptionFieldGrammar =
PackageIdentifier
<$> uniqueField "name" L.pkgName
<*> uniqueField "version" L.pkgVersion
+ <*> optionalField "compiler" L.pkgCompiler
licenseFilesGrammar =
(++)
@@ -174,6 +176,8 @@ libraryFieldGrammar
, c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
, c (List CommaVCat (Identity Dependency) Dependency)
, c (List CommaVCat (Identity Mixin) Mixin)
+ , c (List VCat (Identity (ExtraSource Pkg)) (ExtraSource Pkg))
+ , c (List VCat (Identity (ExtraSource Build)) (ExtraSource Build))
, c (List CommaVCat (Identity ModuleReexport) ModuleReexport)
, c (List FSep (MQuoted Extension) Extension)
, c (List FSep (MQuoted Language) Language)
@@ -224,6 +228,8 @@ foreignLibFieldGrammar
, c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
, c (List CommaVCat (Identity Dependency) Dependency)
, c (List CommaVCat (Identity Mixin) Mixin)
+ , c (List VCat (Identity (ExtraSource Pkg)) (ExtraSource Pkg))
+ , c (List VCat (Identity (ExtraSource Build)) (ExtraSource Build))
, c (List FSep (Identity ForeignLibOption) ForeignLibOption)
, c (List FSep (MQuoted Extension) Extension)
, c (List FSep (MQuoted Language) Language)
@@ -263,6 +269,8 @@ executableFieldGrammar
, c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
, c (List CommaVCat (Identity Dependency) Dependency)
, c (List CommaVCat (Identity Mixin) Mixin)
+ , c (List VCat (Identity (ExtraSource Pkg)) (ExtraSource Pkg))
+ , c (List VCat (Identity (ExtraSource Build)) (ExtraSource Build))
, c (List FSep (MQuoted Extension) Extension)
, c (List FSep (MQuoted Language) Language)
, c (List FSep Token String)
@@ -339,6 +347,8 @@ testSuiteFieldGrammar
, c (List CommaFSep Token String)
, c (List CommaVCat (Identity Dependency) Dependency)
, c (List CommaVCat (Identity Mixin) Mixin)
+ , c (List VCat (Identity (ExtraSource Pkg)) (ExtraSource Pkg))
+ , c (List VCat (Identity (ExtraSource Build)) (ExtraSource Build))
, c (List FSep (MQuoted Extension) Extension)
, c (List FSep (MQuoted Language) Language)
, c (List FSep Token String)
@@ -483,6 +493,8 @@ benchmarkFieldGrammar
, c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
, c (List CommaVCat (Identity Dependency) Dependency)
, c (List CommaVCat (Identity Mixin) Mixin)
+ , c (List VCat (Identity (ExtraSource Pkg)) (ExtraSource Pkg))
+ , c (List VCat (Identity (ExtraSource Build)) (ExtraSource Build))
, c (List FSep (MQuoted Extension) Extension)
, c (List FSep (MQuoted Language) Language)
, c (List FSep Token String)
@@ -585,6 +597,8 @@ buildInfoFieldGrammar
, c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
, c (List CommaVCat (Identity Dependency) Dependency)
, c (List CommaVCat (Identity Mixin) Mixin)
+ , c (List VCat (Identity (ExtraSource Pkg)) (ExtraSource Pkg))
+ , c (List VCat (Identity (ExtraSource Build)) (ExtraSource Build))
, c (List FSep (MQuoted Extension) Extension)
, c (List FSep (MQuoted Language) Language)
, c (List FSep Token String)
@@ -627,14 +641,16 @@ buildInfoFieldGrammar =
<*> monoidalFieldAla "pkgconfig-depends" (alaList CommaFSep) L.pkgconfigDepends
<*> monoidalFieldAla "frameworks" (alaList' FSep RelativePathNT) L.frameworks
<*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep SymbolicPathNT) L.extraFrameworkDirs
- <*> monoidalFieldAla "asm-sources" (alaList' VCat SymbolicPathNT) L.asmSources
+ <*> monoidalFieldAla "asm-sources" formatExtraSources L.asmSources
^^^ availableSince CabalSpecV3_0 []
- <*> monoidalFieldAla "cmm-sources" (alaList' VCat SymbolicPathNT) L.cmmSources
+ <*> monoidalFieldAla "cmm-sources" formatExtraSources L.cmmSources
^^^ availableSince CabalSpecV3_0 []
- <*> monoidalFieldAla "c-sources" (alaList' VCat SymbolicPathNT) L.cSources
- <*> monoidalFieldAla "cxx-sources" (alaList' VCat SymbolicPathNT) L.cxxSources
+ <*> monoidalFieldAla "autogen-cmm-sources" formatExtraSources L.autogenCmmSources
+ -- FIXME ^^^ availableSince CabalSpecV3_0 []
+ <*> monoidalFieldAla "c-sources" formatExtraSources L.cSources
+ <*> monoidalFieldAla "cxx-sources" formatExtraSources L.cxxSources
^^^ availableSince CabalSpecV2_2 []
- <*> monoidalFieldAla "js-sources" (alaList' VCat SymbolicPathNT) L.jsSources
+ <*> monoidalFieldAla "js-sources" formatExtraSources L.jsSources
<*> hsSourceDirsGrammar
<*> monoidalFieldAla "other-modules" formatOtherModules L.otherModules
<*> monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules
@@ -834,6 +850,9 @@ formatOtherExtensions = alaList' FSep MQuoted
formatOtherModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName
formatOtherModules = alaList' VCat MQuoted
+formatExtraSources :: [ExtraSource pkg] -> List VCat (Identity (ExtraSource pkg)) (ExtraSource pkg)
+formatExtraSources = alaList' VCat Identity
+
-------------------------------------------------------------------------------
-- newtypes
-------------------------------------------------------------------------------
diff --git a/Cabal-syntax/src/Distribution/Parsec.hs b/Cabal-syntax/src/Distribution/Parsec.hs
index d0197616fd6..dcc236b840f 100644
--- a/Cabal-syntax/src/Distribution/Parsec.hs
+++ b/Cabal-syntax/src/Distribution/Parsec.hs
@@ -70,6 +70,8 @@ import qualified Distribution.Compat.DList as DList
import qualified Distribution.Compat.MonadFail as Fail
import qualified Text.Parsec as Parsec
+import GHC.Stack (HasCallStack)
+
-------------------------------------------------------------------------------
-- Class
-------------------------------------------------------------------------------
@@ -78,7 +80,7 @@ import qualified Text.Parsec as Parsec
--
-- For parsing @.cabal@ like file structure, see "Distribution.Fields".
class Parsec a where
- parsec :: CabalParsing m => m a
+ parsec :: (HasCallStack, CabalParsing m) => m a
-- | Parsing class which
--
@@ -94,7 +96,7 @@ class (P.CharParsing m, MonadPlus m, Fail.MonadFail m) => CabalParsing m where
askCabalSpecVersion :: m CabalSpecVersion
-- | 'parsec' /could/ consume trailing spaces, this function /will/ consume.
-lexemeParsec :: (CabalParsing m, Parsec a) => m a
+lexemeParsec :: (HasCallStack, CabalParsing m, Parsec a) => m a
lexemeParsec = parsec <* P.spaces
newtype ParsecParser a = PP
@@ -175,14 +177,14 @@ instance CabalParsing ParsecParser where
askCabalSpecVersion = PP pure
-- | Parse a 'String' with 'lexemeParsec'.
-simpleParsec :: Parsec a => String -> Maybe a
+simpleParsec :: (HasCallStack, Parsec a) => String -> Maybe a
simpleParsec =
either (const Nothing) Just
. runParsecParser lexemeParsec "<simpleParsec>"
. fieldLineStreamFromString
-- | Like 'simpleParsec' but for 'ByteString'
-simpleParsecBS :: Parsec a => ByteString -> Maybe a
+simpleParsecBS :: (HasCallStack, Parsec a) => ByteString -> Maybe a
simpleParsecBS =
either (const Nothing) Just
. runParsecParser lexemeParsec "<simpleParsec>"
@@ -191,7 +193,7 @@ simpleParsecBS =
-- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'.
--
-- @since 3.4.0.0
-simpleParsec' :: Parsec a => CabalSpecVersion -> String -> Maybe a
+simpleParsec' :: (HasCallStack, Parsec a) => CabalSpecVersion -> String -> Maybe a
simpleParsec' spec =
either (const Nothing) Just
. runParsecParser' spec lexemeParsec "<simpleParsec>"
@@ -201,7 +203,7 @@ simpleParsec' spec =
-- Fail if there are any warnings.
--
-- @since 3.4.0.0
-simpleParsecW' :: Parsec a => CabalSpecVersion -> String -> Maybe a
+simpleParsecW' :: (HasCallStack, Parsec a) => CabalSpecVersion -> String -> Maybe a
simpleParsecW' spec =
either (const Nothing) (\(x, ws) -> if null ws then Just x else Nothing)
. runParsecParser' spec ((,) <$> lexemeParsec <*> liftParsec Parsec.getState) "<simpleParsec>"
diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs
index 2d7a5edeae1..1d7340e4de5 100644
--- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs
+++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs
@@ -21,6 +21,7 @@ import Prelude ()
import Distribution.Types.Dependency
import Distribution.Types.ExeDependency
+import Distribution.Types.ExtraSource
import Distribution.Types.LegacyExeDependency
import Distribution.Types.Mixin
import Distribution.Types.PkgconfigDependency
@@ -70,14 +71,19 @@ data BuildInfo = BuildInfo
, frameworks :: [RelativePath Framework File]
-- ^ support frameworks for Mac OS X
, extraFrameworkDirs :: [SymbolicPath Pkg (Dir Framework)]
- -- ^ extra locations to find frameworks.
- , asmSources :: [SymbolicPath Pkg File]
- -- ^ Assembly files.
- , cmmSources :: [SymbolicPath Pkg File]
- -- ^ C-- files.
- , cSources :: [SymbolicPath Pkg File]
- , cxxSources :: [SymbolicPath Pkg File]
- , jsSources :: [SymbolicPath Pkg File]
+ -- ^ extra locations to find frameworks
+ , asmSources :: [ExtraSource Pkg]
+ -- ^ Assembly source files
+ , cmmSources :: [ExtraSource Pkg]
+ -- ^ C-- source files
+ , autogenCmmSources :: [ExtraSource Build]
+ -- ^ C-- generated source files
+ , cSources :: [ExtraSource Pkg]
+ -- ^ C source files
+ , cxxSources :: [ExtraSource Pkg]
+ -- ^ C++ source files
+ , jsSources :: [ExtraSource Pkg]
+ -- ^ JavaScript source file
, hsSourceDirs :: [SymbolicPath Pkg (Dir Source)]
-- ^ where to look for the Haskell module hierarchy
, -- NB: these are symbolic paths are not relative paths,
@@ -168,6 +174,7 @@ instance Monoid BuildInfo where
, extraFrameworkDirs = []
, asmSources = []
, cmmSources = []
+ , autogenCmmSources = []
, cSources = []
, cxxSources = []
, jsSources = []
@@ -221,6 +228,7 @@ instance Semigroup BuildInfo where
, extraFrameworkDirs = combineNub extraFrameworkDirs
, asmSources = combineNub asmSources
, cmmSources = combineNub cmmSources
+ , autogenCmmSources = combineNub autogenCmmSources
, cSources = combineNub cSources
, cxxSources = combineNub cxxSources
, jsSources = combineNub jsSources
diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs
index ac99f3c65a5..2d82a81a0bd 100644
--- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs
@@ -13,6 +13,7 @@ import Prelude ()
import Distribution.Compiler (PerCompilerFlavor)
import Distribution.ModuleName (ModuleName)
import Distribution.Types.BuildInfo (BuildInfo)
+import Distribution.Types.ExtraSource (ExtraSource)
import Distribution.Types.Dependency (Dependency)
import Distribution.Types.ExeDependency (ExeDependency)
import Distribution.Types.LegacyExeDependency (LegacyExeDependency)
@@ -79,23 +80,27 @@ class HasBuildInfo a where
extraFrameworkDirs = buildInfo . extraFrameworkDirs
{-# INLINE extraFrameworkDirs #-}
- asmSources :: Lens' a [SymbolicPath Pkg File]
+ asmSources :: Lens' a [ExtraSource Pkg]
asmSources = buildInfo . asmSources
{-# INLINE asmSources #-}
- cmmSources :: Lens' a [SymbolicPath Pkg File]
+ autogenCmmSources :: Lens' a [ExtraSource Build]
+ autogenCmmSources = buildInfo . autogenCmmSources
+ {-# INLINE autogenCmmSources #-}
+
+ cmmSources :: Lens' a [ExtraSource Pkg]
cmmSources = buildInfo . cmmSources
{-# INLINE cmmSources #-}
- cSources :: Lens' a [SymbolicPath Pkg File]
+ cSources :: Lens' a [ExtraSource Pkg]
cSources = buildInfo . cSources
{-# INLINE cSources #-}
- cxxSources :: Lens' a [SymbolicPath Pkg File]
+ cxxSources :: Lens' a [ExtraSource Pkg]
cxxSources = buildInfo . cxxSources
{-# INLINE cxxSources #-}
- jsSources :: Lens' a [SymbolicPath Pkg File]
+ jsSources :: Lens' a [ExtraSource Pkg]
jsSources = buildInfo . jsSources
{-# INLINE jsSources #-}
@@ -267,7 +272,7 @@ instance HasBuildInfo BuildInfo where
cSources f s = fmap (\x -> s{T.cSources = x}) (f (T.cSources s))
{-# INLINE cSources #-}
- cxxSources f s = fmap (\x -> s{T.cSources = x}) (f (T.cxxSources s))
+ cxxSources f s = fmap (\x -> s{T.cxxSources = x}) (f (T.cxxSources s))
{-# INLINE cxxSources #-}
jsSources f s = fmap (\x -> s{T.jsSources = x}) (f (T.jsSources s))
diff --git a/Cabal-syntax/src/Distribution/Types/ComponentId.hs b/Cabal-syntax/src/Distribution/Types/ComponentId.hs
index fa770448363..fd2467972e9 100644
--- a/Cabal-syntax/src/Distribution/Types/ComponentId.hs
+++ b/Cabal-syntax/src/Distribution/Types/ComponentId.hs
@@ -17,6 +17,7 @@ import Distribution.Pretty
import qualified Distribution.Compat.CharParsing as P
import Text.PrettyPrint (text)
+import GHC.Stack (HasCallStack, prettyCallStack, callStack)
-- | A 'ComponentId' uniquely identifies the transitive source
-- code closure of a component (i.e. libraries, executables).
--
@@ -30,8 +31,21 @@ import Text.PrettyPrint (text)
-- This type is opaque since @Cabal-2.0@
--
-- @since 2.0.0.2
-newtype ComponentId = ComponentId ShortText
- deriving (Generic, Read, Show, Eq, Ord, Data)
+data ComponentId = ComponentId {unitComp :: ShortText, unitId :: ShortText, wasPartial :: Bool }
+ | PartialComponentId ShortText
+ deriving (Generic, Read, Show, Data)
+
+instance Eq ComponentId where
+ (ComponentId c1 s1 _) == (ComponentId c2 s2 _) = c1 == c2 && s1 == s2
+ (PartialComponentId s1) == (PartialComponentId s2) = s1 == s2
+ _ == _ = False
+
+instance Ord ComponentId where
+ compare (ComponentId c1 s1 _) (ComponentId c2 s2 _) = compare (c1, s1) (c2, s2)
+ compare (PartialComponentId s1) (PartialComponentId s2) = compare s1 s2
+ compare (PartialComponentId _) _ = LT
+ compare _ (PartialComponentId _) = GT
+
-- | Construct a 'ComponentId' from a 'String'
--
@@ -41,14 +55,27 @@ newtype ComponentId = ComponentId ShortText
-- 'ComponentId' is valid
--
-- @since 2.0.0.2
-mkComponentId :: String -> ComponentId
-mkComponentId = ComponentId . toShortText
+mkComponentId :: HasCallStack => String -> ComponentId
+mkComponentId s = case (simpleParsec s) of
+ -- Just cid@ComponentId{ unitComp = c, unitId = i } | (fromShortText c) == "ghc-9.8.4", (fromShortText i) == "rts-1.0.3-cec100dd" -> trace ("### ComponentId: `" ++ (fromShortText c) ++ "' `" ++ (fromShortText i) ++ "' is a full one.\n" ++ prettyCallStack callStack) cid
+ Just cid@ComponentId{} -> cid
+ Just cid@PartialComponentId{} -> error $ "mkPartialComponentId: `" ++ s ++ "' is a partial component id, not a full one."
+ _ -> error $ "Unable to parse PartialComponentId: `" ++ s ++ "'."
+
+mkComponentId' :: HasCallStack => String -> String -> Bool -> ComponentId
+-- mkComponentId' c i b | c == "ghc-9.8.4", i == "rts-1.0.3-cec100dd" = trace ("### mkComponentId': `" ++ c ++ "' `" ++ i ++ "' is a full one.\n" ++ prettyCallStack callStack) (ComponentId (toShortText c) (toShortText i) b)
+mkComponentId' c i b = ComponentId (toShortText c) (toShortText i) b
+
+mkPartialComponentId :: HasCallStack => String -> ComponentId
+mkPartialComponentId s = PartialComponentId (toShortText s)
-- | Convert 'ComponentId' to 'String'
--
-- @since 2.0.0.2
-unComponentId :: ComponentId -> String
-unComponentId (ComponentId s) = fromShortText s
+unComponentId :: HasCallStack => ComponentId -> String
+unComponentId (ComponentId c s False) = fromShortText c ++ '_':fromShortText s
+unComponentId (ComponentId c s True) = fromShortText s
+unComponentId (PartialComponentId s) = fromShortText s
-- | 'mkComponentId'
--
@@ -63,8 +90,12 @@ instance Pretty ComponentId where
pretty = text . unComponentId
instance Parsec ComponentId where
- parsec = mkComponentId `fmap` P.munch1 abi_char
+ parsec = P.try (mkComponentId' <$> compid <* P.char '_' <*> P.munch1 abi_char <*> return False)
+ <|> mkPartialComponentId <$> P.munch1 abi_char
where
+ compid = (\f v -> f ++ "-" ++ v) <$> P.munch1 isAlpha <* P.char '-' <*> P.munch1 isVerChar
+ isVerChar :: Char -> Bool
+ isVerChar c = c `elem` '.':['0'..'9']
abi_char c = isAlphaNum c || c `elem` "-_."
instance NFData ComponentId where
diff --git a/Cabal-syntax/src/Distribution/Types/ExtraSource.hs b/Cabal-syntax/src/Distribution/Types/ExtraSource.hs
new file mode 100644
index 00000000000..4b888a0d28e
--- /dev/null
+++ b/Cabal-syntax/src/Distribution/Types/ExtraSource.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Distribution.Types.ExtraSource
+ ( ExtraSource (..)
+ , ExtraSourceClass (..)
+ ) where
+
+import Distribution.Compat.Prelude
+import Prelude ()
+
+import Distribution.Parsec
+import Distribution.Pretty
+import Distribution.Utils.Path (Build, FileOrDir (..), Pkg, RelativePath, SymbolicPath, relativeSymbolicPath, unsafeCoerceSymbolicPath)
+
+import qualified Distribution.Compat.CharParsing as P
+import qualified Text.PrettyPrint as PP
+
+data family ExtraSource pkg
+
+data instance ExtraSource Pkg = ExtraSourcePkg (SymbolicPath Pkg File) [String]
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+
+data instance ExtraSource Build = ExtraSourceBuild (RelativePath Build File) [String]
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+
+class ExtraSourceClass e where
+ extraSourceOpts :: e -> [String]
+ extraSourceFile :: e -> SymbolicPath Pkg 'File
+
+instance ExtraSourceClass (ExtraSource Pkg) where
+ extraSourceOpts (ExtraSourcePkg _ opts) = opts
+ extraSourceFile (ExtraSourcePkg f _) = f
+
+instance ExtraSourceClass (ExtraSource Build) where
+ extraSourceOpts (ExtraSourceBuild _ opts) = opts
+
+ -- FIXME
+ extraSourceFile (ExtraSourceBuild f _) = unsafeCoerceSymbolicPath (relativeSymbolicPath f)
+
+instance Binary (ExtraSource Pkg)
+instance Structured (ExtraSource Pkg)
+instance NFData (ExtraSource Pkg) where rnf = genericRnf
+
+instance Binary (ExtraSource Build)
+instance Structured (ExtraSource Build)
+instance NFData (ExtraSource Build) where rnf = genericRnf
+
+instance Parsec (ExtraSource Pkg) where
+ parsec = do
+ path <- parsec <* P.spaces
+ opts <- P.optional (parensLax (P.sepBy p P.spaces))
+ return (ExtraSourcePkg path (fromMaybe mempty opts))
+ where
+ p :: P.CharParsing p => p String
+ p = some $ P.satisfy (\c -> not (isSpace c) && (c /= ')'))
+
+instance Parsec (ExtraSource Build) where
+ parsec = do
+ path <- parsec <* P.spaces
+ opts <- P.optional (parensLax (P.sepBy p P.spaces))
+ return (ExtraSourceBuild path (fromMaybe mempty opts))
+ where
+ p :: P.CharParsing p => p String
+ p = some $ P.satisfy (\c -> not (isSpace c) && (c /= ')'))
+
+instance Pretty (ExtraSource Pkg) where
+ pretty (ExtraSourcePkg path opts) =
+ pretty path <<>> PP.parens (PP.hsep (map PP.text opts))
+
+instance Pretty (ExtraSource Build) where
+ pretty (ExtraSourceBuild path opts) =
+ pretty path <<>> PP.parens (PP.hsep (map PP.text opts))
+
+parensLax :: P.CharParsing m => m a -> m a
+parensLax p = P.between (P.char '(' *> P.spaces) (P.char ')' *> P.spaces) p
diff --git a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs
index f57457d2e5b..49893ab1462 100644
--- a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs
+++ b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs
@@ -16,11 +16,13 @@ import Prelude ()
import Distribution.Backpack
import Distribution.Compat.Graph (IsNode (..))
+import Distribution.Compiler (CompilerId, buildCompilerId)
import Distribution.License
import Distribution.ModuleName
-import Distribution.Package hiding (installedUnitId)
+import Distribution.Package hiding (installedUnitId, pkgCompiler)
import Distribution.Types.AbiDependency
import Distribution.Types.ExposedModule
+import Distribution.Types.Flag (FlagAssignment)
import Distribution.Types.LibraryName
import Distribution.Types.LibraryVisibility
import Distribution.Types.MungedPackageId
@@ -41,7 +43,7 @@ data InstalledPackageInfo = InstalledPackageInfo
-- exactly the same as PackageDescription
sourcePackageId :: PackageId
, sourceLibName :: LibraryName
- , installedComponentId_ :: ComponentId
+ , installedComponentId_ :: Maybe ComponentId
, libVisibility :: LibraryVisibility
, installedUnitId :: UnitId
, -- INVARIANT: if this package is definite, OpenModule's
@@ -61,7 +63,8 @@ data InstalledPackageInfo = InstalledPackageInfo
, description :: !ShortText
, category :: !ShortText
, -- these parts are required by an installed package only:
- abiHash :: AbiHash
+ unitFlags :: FlagAssignment
+ , abiHash :: AbiHash
, indefinite :: Bool
, exposed :: Bool
, -- INVARIANT: if the package is definite, OpenModule's
@@ -93,6 +96,7 @@ data InstalledPackageInfo = InstalledPackageInfo
, haddockInterfaces :: [FilePath]
, haddockHTMLs :: [FilePath]
, pkgRoot :: Maybe FilePath
+ , pkgCompiler :: Maybe CompilerId
}
deriving (Eq, Generic, Read, Show)
@@ -119,8 +123,8 @@ instance IsNode InstalledPackageInfo where
nodeNeighbors = depends
mungedPackageId :: InstalledPackageInfo -> MungedPackageId
-mungedPackageId ipi =
- MungedPackageId (mungedPackageName ipi) (packageVersion ipi)
+mungedPackageId ipi@InstalledPackageInfo{pkgCompiler = comp} =
+ MungedPackageId (mungedPackageName ipi) (packageVersion ipi) comp
-- | Returns the munged package name, which we write into @name@ for
-- compatibility with old versions of GHC.
@@ -130,9 +134,9 @@ mungedPackageName ipi = MungedPackageName (packageName ipi) (sourceLibName ipi)
emptyInstalledPackageInfo :: InstalledPackageInfo
emptyInstalledPackageInfo =
InstalledPackageInfo
- { sourcePackageId = PackageIdentifier (mkPackageName "") nullVersion
+ { sourcePackageId = PackageIdentifier (mkPackageName "") nullVersion Nothing
, sourceLibName = LMainLibName
- , installedComponentId_ = mkComponentId ""
+ , installedComponentId_ = Nothing
, installedUnitId = mkUnitId ""
, instantiatedWith = []
, compatPackageKey = ""
@@ -146,6 +150,7 @@ emptyInstalledPackageInfo =
, synopsis = ""
, description = ""
, category = ""
+ , unitFlags = mempty
, abiHash = mkAbiHash ""
, indefinite = False
, exposed = False
@@ -174,4 +179,5 @@ emptyInstalledPackageInfo =
, haddockHTMLs = []
, pkgRoot = Nothing
, libVisibility = LibraryVisibilityPrivate
+ , pkgCompiler = Nothing
}
diff --git a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs
index 7578907b590..9853efc287b 100644
--- a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs
+++ b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs
@@ -15,13 +15,15 @@ import Distribution.Backpack
import Distribution.CabalSpecVersion
import Distribution.Compat.Lens (Lens', (&), (.~))
import Distribution.Compat.Newtype
+import Distribution.Compiler (CompilerId(..))
import Distribution.FieldGrammar
import Distribution.FieldGrammar.FieldDescrs
import Distribution.License
import Distribution.ModuleName
-import Distribution.Package
+import Distribution.Package hiding (pkgCompiler)
import Distribution.Parsec
import Distribution.Pretty
+import Distribution.Types.Flag (FlagAssignment)
import Distribution.Types.LibraryName
import Distribution.Types.LibraryVisibility
import Distribution.Types.MungedPackageName
@@ -37,7 +39,9 @@ import qualified Text.PrettyPrint as Disp
import Distribution.Types.InstalledPackageInfo
import qualified Distribution.Types.InstalledPackageInfo.Lens as L
-import qualified Distribution.Types.PackageId.Lens as L
+import qualified Distribution.Types.PackageId.Lens as L hiding (pkgCompiler)
+
+import GHC.Stack (HasCallStack)
-- Note: GHC goes nuts and inlines everything,
-- One can see e.g. in -ddump-simpl-stats:
@@ -58,6 +62,7 @@ ipiFieldGrammar
, Applicative (g InstalledPackageInfo)
, Applicative (g Basic)
, c (Identity AbiHash)
+ , c (Identity FlagAssignment)
, c (Identity LibraryVisibility)
, c (Identity PackageName)
, c (Identity UnitId)
@@ -73,7 +78,8 @@ ipiFieldGrammar
, c ExposedModules
, c InstWith
, c SpecLicenseLenient
- )
+ , c (Identity (Maybe CompilerId))
+ , HasCallStack )
=> g InstalledPackageInfo InstalledPackageInfo
ipiFieldGrammar =
mkInstalledPackageInfo
@@ -84,7 +90,10 @@ ipiFieldGrammar =
-- Very basic fields: name, version, package-name, lib-name and visibility
<@> blurFieldGrammar basic basicFieldGrammar
-- Basic fields
- <@> optionalFieldDef "id" L.installedUnitId (mkUnitId "")
+ -- [note: forced default values]
+ -- Observe optionalFieldDef fn l x = optionalFieldDefAla fn Identity l x
+ -- and optionalFieldDefAla will force x.
+ <@> optionalFieldDef "id" L.installedUnitId (mkUnitId "invalid-invalid")
<@> optionalFieldDefAla "instantiated-with" InstWith L.instantiatedWith []
<@> optionalFieldDefAla "key" CompatPackageKey L.compatPackageKey ""
<@> optionalFieldDefAla "license" SpecLicenseLenient L.license (Left SPDX.NONE)
@@ -98,6 +107,7 @@ ipiFieldGrammar =
<@> freeTextFieldDefST "description" L.description
<@> freeTextFieldDefST "category" L.category
-- Installed fields
+ <@> optionalFieldDef "flags" L.unitFlags mempty
<@> optionalFieldDef "abi" L.abiHash (mkAbiHash "")
<@> booleanFieldDef "indefinite" L.indefinite False
<@> booleanFieldDef "exposed" L.exposed False
@@ -125,14 +135,15 @@ ipiFieldGrammar =
<@> monoidalFieldAla "haddock-interfaces" (alaList' FSep FilePathNT) L.haddockInterfaces
<@> monoidalFieldAla "haddock-html" (alaList' FSep FilePathNT) L.haddockHTMLs
<@> optionalFieldAla "pkgroot" FilePathNT L.pkgRoot
+ <@> optionalFieldDef "compiler" L.pkgCompiler Nothing
where
mkInstalledPackageInfo _ Basic{..} =
InstalledPackageInfo
-- _basicPkgName is not used
-- setMaybePackageId says it can be no-op.
- (PackageIdentifier pn _basicVersion)
+ (PackageIdentifier pn _basicVersion _basicCompilerId)
(combineLibraryName ln _basicLibName)
- (mkComponentId "") -- installedComponentId_, not in use
+ Nothing
_basicLibVisibility
where
MungedPackageName pn ln = _basicName
@@ -253,6 +264,7 @@ data Basic = Basic
, _basicPkgName :: Maybe PackageName
, _basicLibName :: LibraryName
, _basicLibVisibility :: LibraryVisibility
+ , _basicCompilerId :: Maybe CompilerId
}
basic :: Lens' InstalledPackageInfo Basic
@@ -265,14 +277,16 @@ basic f ipi = g <$> f b
(maybePackageName ipi)
(sourceLibName ipi)
(libVisibility ipi)
+ (pkgCompiler ipi)
- g (Basic n v pn ln lv) =
+ g (Basic n v pn ln lv compid) =
ipi
& setMungedPackageName n
& L.sourcePackageId . L.pkgVersion .~ v
& setMaybePackageName pn
& L.sourceLibName .~ ln
& L.libVisibility .~ lv
+ & L.pkgCompiler .~ compid
basicName :: Lens' Basic MungedPackageName
basicName f b = (\x -> b{_basicName = x}) <$> f (_basicName b)
@@ -316,7 +330,7 @@ basicFieldGrammar =
<*> optionalField "lib-name" basicLibName
<*> optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate
where
- mkBasic n v pn ln lv = Basic n v pn ln' lv'
+ mkBasic n v pn ln lv = Basic n v pn ln' lv' Nothing
where
ln' = maybe LMainLibName LSubLibName ln
-- Older GHCs (<8.8) always report installed libraries as private
diff --git a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs
index 47fa1c96f40..9a35a03816e 100644
--- a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs
@@ -7,10 +7,12 @@ import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
+import Distribution.Compiler (CompilerId)
import Distribution.Backpack (OpenModule)
import Distribution.License (License)
import Distribution.ModuleName (ModuleName)
import Distribution.Package (AbiHash, ComponentId, PackageIdentifier, UnitId)
+import Distribution.Types.Flag (FlagAssignment)
import Distribution.Types.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo)
import Distribution.Types.LibraryName (LibraryName)
import Distribution.Types.LibraryVisibility (LibraryVisibility)
@@ -27,7 +29,11 @@ installedUnitId :: Lens' InstalledPackageInfo UnitId
installedUnitId f s = fmap (\x -> s{T.installedUnitId = x}) (f (T.installedUnitId s))
{-# INLINE installedUnitId #-}
-installedComponentId_ :: Lens' InstalledPackageInfo ComponentId
+unitFlags :: Lens' InstalledPackageInfo FlagAssignment
+unitFlags f s = fmap (\x -> s{T.unitFlags = x}) (f (T.unitFlags s))
+{-# INLINE unitFlags #-}
+
+installedComponentId_ :: Lens' InstalledPackageInfo (Maybe ComponentId)
installedComponentId_ f s = fmap (\x -> s{T.installedComponentId_ = x}) (f (T.installedComponentId_ s))
{-# INLINE installedComponentId_ #-}
@@ -194,3 +200,7 @@ pkgRoot f s = fmap (\x -> s{T.pkgRoot = x}) (f (T.pkgRoot s))
libVisibility :: Lens' InstalledPackageInfo LibraryVisibility
libVisibility f s = fmap (\x -> s{T.libVisibility = x}) (f (T.libVisibility s))
{-# INLINE libVisibility #-}
+
+pkgCompiler :: Lens' InstalledPackageInfo (Maybe CompilerId)
+pkgCompiler f s = fmap (\x -> s{T.pkgCompiler = x}) (f (T.pkgCompiler s))
+{-# INLINE pkgCompiler #-}
diff --git a/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs b/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs
index 8e879620478..b0edcd99bf5 100644
--- a/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs
+++ b/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs
@@ -15,6 +15,7 @@ import Distribution.Types.LibraryName
import Distribution.Types.MungedPackageName
import Distribution.Types.PackageId
import Distribution.Version (Version, nullVersion)
+import Distribution.Compiler (CompilerId)
import qualified Text.PrettyPrint as Disp
@@ -27,6 +28,7 @@ data MungedPackageId = MungedPackageId
-- 'MungedPackageName'.
, mungedVersion :: Version
-- ^ The version of this package / component, eg 1.2
+ , mingledCompilerId :: Maybe CompilerId
}
deriving (Generic, Read, Show, Eq, Ord, Data)
@@ -41,8 +43,9 @@ instance Structured MungedPackageId
-- >>> prettyShow $ MungedPackageId (MungedPackageName "servant" (LSubLibName "lackey")) (mkVersion [0,1,2])
-- "z-servant-z-lackey-0.1.2"
instance Pretty MungedPackageId where
- pretty (MungedPackageId n v)
- | v == nullVersion = pretty n -- if no version, don't show version.
+ pretty (MungedPackageId n v c)
+ | v == nullVersion = pretty c <<>> Disp.char '-' <<>> pretty n -- if no version, don't show version.
+ | Just c' <- c = pretty c' <<>> Disp.char '-' <<>> pretty n <<>> Disp.char '-' <<>> pretty v
| otherwise = pretty n <<>> Disp.char '-' <<>> pretty v
-- |
@@ -66,15 +69,15 @@ instance Pretty MungedPackageId where
-- Nothing
instance Parsec MungedPackageId where
parsec = do
- PackageIdentifier pn v <- parsec
- return $ MungedPackageId (decodeCompatPackageName pn) v
+ PackageIdentifier pn v comp <- parsec
+ return $ MungedPackageId (decodeCompatPackageName pn) v comp
instance NFData MungedPackageId where
- rnf (MungedPackageId name version) = rnf name `seq` rnf version
+ rnf (MungedPackageId name version compiler) = rnf name `seq` rnf version `seq` rnf compiler
computeCompatPackageId :: PackageId -> LibraryName -> MungedPackageId
-computeCompatPackageId (PackageIdentifier pn vr) ln =
- MungedPackageId (MungedPackageName pn ln) vr
+computeCompatPackageId (PackageIdentifier pn vr comp) ln =
+ MungedPackageId (MungedPackageName pn ln) vr comp
-- $setup
-- >>> :seti -XOverloadedStrings
diff --git a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs
index 4b00a8ef526..17f72e54c95 100644
--- a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs
+++ b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs
@@ -207,6 +207,7 @@ emptyPackageDescription =
PackageIdentifier
(mkPackageName "")
nullVersion
+ Nothing
, licenseRaw = Right UnspecifiedLicense -- TODO:
, licenseFiles = []
, specVersion = CabalSpecV1_0
diff --git a/Cabal-syntax/src/Distribution/Types/PackageId.hs b/Cabal-syntax/src/Distribution/Types/PackageId.hs
index 9cd88a2f810..bc366716216 100644
--- a/Cabal-syntax/src/Distribution/Types/PackageId.hs
+++ b/Cabal-syntax/src/Distribution/Types/PackageId.hs
@@ -13,6 +13,7 @@ import Distribution.Parsec (Parsec (..), simpleParsec)
import Distribution.Pretty
import Distribution.Types.PackageName
import Distribution.Version (Version, nullVersion)
+import Distribution.Compiler (CompilerId)
import qualified Data.List.NonEmpty as NE
import qualified Distribution.Compat.CharParsing as P
@@ -27,6 +28,8 @@ data PackageIdentifier = PackageIdentifier
-- ^ The name of this package, eg. foo
, pkgVersion :: Version
-- ^ the version of this package, eg 1.2
+ , pkgCompiler :: Maybe CompilerId
+ -- ^ the associated compiler id of the package, eg ghc-9.8.4
}
deriving (Generic, Read, Show, Eq, Ord, Data)
@@ -34,8 +37,11 @@ instance Binary PackageIdentifier
instance Structured PackageIdentifier
instance Pretty PackageIdentifier where
- pretty (PackageIdentifier n v)
- | v == nullVersion = pretty n -- if no version, don't show version.
+ pretty (PackageIdentifier n v c)
+ -- we must never print the compiler, as other tools like hackage-security rely on the Pretty instance
+ -- | Just c' <- c, v == nullVersion = pretty c <<>> Disp.char ':' <<>> pretty n -- if no version, don't show version.
+ -- | Just c' <- c = pretty c' <<>> Disp.char ':' <<>> pretty n <<>> Disp.char '-' <<>> pretty v
+ | v == nullVersion = pretty n
| otherwise = pretty n <<>> Disp.char '-' <<>> pretty v
-- |
@@ -61,15 +67,16 @@ instance Pretty PackageIdentifier where
-- Nothing
instance Parsec PackageIdentifier where
parsec = do
+ -- comp <- Just <$> (parsec <* P.char ':') <|> return Nothing
xs' <- P.sepByNonEmpty component (P.char '-')
(v, xs) <- case simpleParsec (NE.last xs') of
Nothing -> return (nullVersion, toList xs') -- all components are version
Just v -> return (v, NE.init xs')
if not (null xs) && all (\c -> all (/= '.') c && not (all isDigit c)) xs
- then return $ PackageIdentifier (mkPackageName (intercalate "-" xs)) v
+ then return $ PackageIdentifier (mkPackageName (intercalate "-" xs)) v Nothing --comp
else fail "all digits or a dot in a portion of package name"
where
component = P.munch1 (\c -> isAlphaNum c || c == '.')
instance NFData PackageIdentifier where
- rnf (PackageIdentifier name version) = rnf name `seq` rnf version
+ rnf (PackageIdentifier name version compiler) = rnf name `seq` rnf version `seq` rnf compiler
diff --git a/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs b/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs
index 08305234fbd..5a4682c7ed3 100644
--- a/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs
@@ -10,6 +10,7 @@ import Prelude ()
import Distribution.Types.PackageId (PackageIdentifier)
import Distribution.Types.PackageName (PackageName)
import Distribution.Version (Version)
+import Distribution.Compiler (CompilerId)
import qualified Distribution.Types.PackageId as T
@@ -20,3 +21,8 @@ pkgName f s = fmap (\x -> s{T.pkgName = x}) (f (T.pkgName s))
pkgVersion :: Lens' PackageIdentifier Version
pkgVersion f s = fmap (\x -> s{T.pkgVersion = x}) (f (T.pkgVersion s))
{-# INLINE pkgVersion #-}
+
+pkgCompiler :: Lens' PackageIdentifier (Maybe CompilerId)
+pkgCompiler f s = fmap (\x -> s{T.pkgCompiler = x}) (f (T.pkgCompiler s))
+{-# INLINE pkgCompiler #-}
+
diff --git a/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs b/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs
index 013226ca2d5..5c2b8d9b0b1 100644
--- a/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs
+++ b/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs
@@ -53,7 +53,7 @@ instance Pretty PackageVersionConstraint where
-- Just (PackageVersionConstraint (PackageName "foo") (ThisVersion (mkVersion [2,0])))
instance Parsec PackageVersionConstraint where
parsec = do
- PackageIdentifier name ver <- parsec
+ PackageIdentifier name ver comp <- parsec
if ver == nullVersion
then do
P.spaces
@@ -64,7 +64,7 @@ instance Parsec PackageVersionConstraint where
-- | @since 3.4.0.0
thisPackageVersionConstraint :: PackageIdentifier -> PackageVersionConstraint
-thisPackageVersionConstraint (PackageIdentifier pn vr) =
+thisPackageVersionConstraint (PackageIdentifier pn vr comp) =
PackageVersionConstraint pn (thisVersion vr)
-- | @since 3.4.0.0
diff --git a/Cabal-syntax/src/Distribution/Types/UnitId.hs b/Cabal-syntax/src/Distribution/Types/UnitId.hs
index 0b5ca4bdf7b..a5aae2a38bd 100644
--- a/Cabal-syntax/src/Distribution/Types/UnitId.hs
+++ b/Cabal-syntax/src/Distribution/Types/UnitId.hs
@@ -7,14 +7,19 @@ module Distribution.Types.UnitId
( UnitId
, unUnitId
, mkUnitId
+ , isPartialUnitId
+ , addPrefixToUnitId
+ , addSuffixToUnitId
, DefUnitId
, unsafeMkDefUnitId
, unDefUnitId
, newSimpleUnitId
, mkLegacyUnitId
, getHSLibraryName
+ , getAbiTag
) where
+import Distribution.Compiler (AbiTag (..))
import Distribution.Compat.Prelude
import Distribution.Utils.ShortText
import Prelude ()
@@ -27,6 +32,11 @@ import Distribution.Types.PackageId
import Text.PrettyPrint (text)
+import GHC.Stack (HasCallStack, prettyCallStack, callStack)
+import Data.List (isInfixOf)
+
+import Unsafe.Coerce (unsafeCoerce)
+
-- | A unit identifier identifies a (possibly instantiated)
-- package/component that can be installed the installed package
-- database. There are several types of components that can be
@@ -63,11 +73,24 @@ import Text.PrettyPrint (text)
-- representation of a UnitId to pass, e.g., as a @-package-id@
-- flag, use the 'display' function, which will work on all
-- versions of Cabal.
-newtype UnitId = UnitId ShortText
- deriving (Generic, Read, Show, Eq, Ord, Data, NFData)
+data UnitId = UnitId {unitComp :: ShortText, unitId :: ShortText, wasPartial :: Bool }
+ | PartialUnitId ShortText
+ deriving (Generic, Read, Show, Data)
+
+instance Eq UnitId where
+ (UnitId c1 s1 _) == (UnitId c2 s2 _) = c1 == c2 && s1 == s2
+ (PartialUnitId s1) == (PartialUnitId s2) = s1 == s2
+ _ == _ = False
+
+instance Ord UnitId where
+ compare (UnitId c1 s1 _) (UnitId c2 s2 _) = compare (c1, s1) (c2, s2)
+ compare (PartialUnitId s1) (PartialUnitId s2) = compare s1 s2
+ compare (PartialUnitId _) _ = LT
+ compare _ (PartialUnitId _) = GT
instance Binary UnitId
instance Structured UnitId
+instance NFData UnitId
-- | The textual format for 'UnitId' coincides with the format
-- GHC accepts for @-package-id@.
@@ -77,8 +100,12 @@ instance Pretty UnitId where
-- | The textual format for 'UnitId' coincides with the format
-- GHC accepts for @-package-id@.
instance Parsec UnitId where
- parsec = mkUnitId <$> P.munch1 isUnitChar
+ parsec = P.try (mkUnitId' <$> compid <* P.char '_' <*> P.munch1 isUnitChar <*> return False)
+ <|> (mkPartialUnitId <$> P.munch1 isUnitChar)
where
+ compid = (\f v -> f ++ "-" ++ v) <$> P.munch1 isAlpha <* P.char '-' <*> P.munch1 isVerChar
+ isVerChar :: Char -> Bool
+ isVerChar c = c `elem` '.':['0'..'9']
-- https://gitlab.haskell.org/ghc/ghc/issues/17752
isUnitChar '-' = True
isUnitChar '_' = True
@@ -86,13 +113,45 @@ instance Parsec UnitId where
isUnitChar '+' = True
isUnitChar c = isAlphaNum c
+isPartialUnitId :: HasCallStack => UnitId -> Bool
+isPartialUnitId (PartialUnitId _) = True
+isPartialUnitId _ = False
+
+addPrefixToUnitId :: HasCallStack => String -> UnitId -> UnitId
+-- addPrefixToUnitId prefix (PartialUnitId s) | s == toShortText "process-1.6.25.0-inplace" = trace ("### addPrefixToUnitId': `" ++ prefix ++ "' `" ++ (fromShortText s) ++ "'.\n" ++ prettyCallStack callStack) $ UnitId (toShortText prefix) s True
+addPrefixToUnitId prefix (PartialUnitId s) = UnitId (toShortText prefix) s True
+addPrefixToUnitId prefix uid@(UnitId _ _ _) = error $ "addPrefixToUnitId: UnitId " ++ show uid ++ " already has a prefix; can't add: " ++ prefix
+
+addSuffixToUnitId :: HasCallStack => String -> UnitId -> UnitId
+addSuffixToUnitId suffix (UnitId c s fromPartial) = UnitId c (s <> toShortText suffix) fromPartial
+addSuffixToUnitId suffix (PartialUnitId s) = PartialUnitId (s <> toShortText suffix)
+
+
+dropPrefixFromUnitId :: HasCallStack => UnitId -> UnitId
+dropPrefixFromUnitId (PartialUnitId s) = PartialUnitId s
+dropPrefixFromUnitId (UnitId _c s _fromPartial) = PartialUnitId s
+
-- | If you need backwards compatibility, consider using 'display'
-- instead, which is supported by all versions of Cabal.
-unUnitId :: UnitId -> String
-unUnitId (UnitId s) = fromShortText s
-
-mkUnitId :: String -> UnitId
-mkUnitId = UnitId . toShortText
+unUnitId :: HasCallStack => UnitId -> String
+unUnitId (UnitId c s False) = fromShortText c ++ '_':fromShortText s
+unUnitId (UnitId c s True) = fromShortText s
+unUnitId (PartialUnitId s) = fromShortText s
+
+mkUnitId :: HasCallStack => String -> UnitId
+mkUnitId s = case (simpleParsec s) of
+ -- Just uid@UnitId{ unitComp = c, unitId = i } | (fromShortText c) == "ghc-9.8.4", (fromShortText i) == "rts-1.0.3-cec100dd" -> trace ("### mkUnitId: `" ++ (fromShortText c) ++ "' `" ++ (fromShortText i) ++ "' is a full one.\n" ++ prettyCallStack callStack) uid
+ Just uid@UnitId{} -> uid
+ Just uid@PartialUnitId{} -> uid -- error $ "mkUnitId: `" ++ s ++ "' is a partial unit id, not a full one."
+ _ -> error $ "Unable to parse UnitId: `" ++ s ++ "'."
+
+mkUnitId' :: HasCallStack => String -> String -> Bool -> UnitId
+-- mkUnitId' c i b | c == "ghc-9.8.4", i == "rts-1.0.3-cec100dd" = trace ("### mkUnitId': `" ++ c ++ "' `" ++ i ++ "' is a full one.\n" ++ prettyCallStack callStack) (UnitId (toShortText c) (toShortText i) b)
+mkUnitId' c i b = UnitId (toShortText c) (toShortText i) b
+
+mkPartialUnitId :: HasCallStack => String -> UnitId
+-- mkPartialUnitId s | s == "process-1.6.25.0-inplace" = trace ("### mkPartialUnitId: `" ++ s ++ "' is a partial unit id, not a full one.\n" ++ prettyCallStack callStack) (PartialUnitId (toShortText s))
+mkPartialUnitId s = PartialUnitId (toShortText s)
-- | 'mkUnitId'
--
@@ -102,17 +161,17 @@ instance IsString UnitId where
-- | Create a unit identity with no associated hash directly
-- from a 'ComponentId'.
-newSimpleUnitId :: ComponentId -> UnitId
-newSimpleUnitId = mkUnitId . unComponentId
+newSimpleUnitId :: HasCallStack => ComponentId -> UnitId
+newSimpleUnitId = unsafeCoerce
-- | Make an old-style UnitId from a package identifier.
-- Assumed to be for the public library
-mkLegacyUnitId :: PackageId -> UnitId
+mkLegacyUnitId :: HasCallStack => PackageId -> UnitId
mkLegacyUnitId = newSimpleUnitId . mkComponentId . prettyShow
-- | Returns library name prefixed with HS, suitable for filenames
getHSLibraryName :: UnitId -> String
-getHSLibraryName uid = "HS" ++ prettyShow uid
+getHSLibraryName uid = "HS" ++ prettyShow (dropPrefixFromUnitId uid)
-- | A 'UnitId' for a definite package. The 'DefUnitId' invariant says
-- that a 'UnitId' identified this way is definite; i.e., it has no
@@ -131,3 +190,17 @@ instance Parsec DefUnitId where
-- is to ensure that the 'DefUnitId' invariant holds.
unsafeMkDefUnitId :: UnitId -> DefUnitId
unsafeMkDefUnitId = DefUnitId
+
+-- | The ABI tag is the part of the unit id that comes after the
+-- last hyphen. It is used to distinguish between different
+-- versions of the same package that are ABI compatible.
+--
+-- FIXME: ideally this would be part of the proper structure of the
+-- datatype, instead of some heuristic of the string.
+getAbiTag :: HasCallStack => UnitId -> AbiTag
+getAbiTag (UnitId _c s _) = case takeWhile (/= '-') . reverse . fromShortText $ s of
+ [] -> NoAbiTag
+ xs -> AbiTag . reverse $ xs
+getAbiTag (PartialUnitId s) = case takeWhile (/= '-') . reverse . fromShortText $ s of
+ [] -> NoAbiTag
+ xs -> AbiTag . reverse $ xs
\ No newline at end of file
diff --git a/Cabal-syntax/src/Distribution/Utils/Path.hs b/Cabal-syntax/src/Distribution/Utils/Path.hs
index a0f18a1dfdd..3d63703f501 100644
--- a/Cabal-syntax/src/Distribution/Utils/Path.hs
+++ b/Cabal-syntax/src/Distribution/Utils/Path.hs
@@ -460,7 +460,7 @@ data CWD
-- | Abstract directory: package directory (e.g. a directory containing the @.cabal@ file).
--
-- See Note [Symbolic paths] in Distribution.Utils.Path.
-data Pkg
+data Pkg deriving (Data)
-- | Abstract directory: dist directory (e.g. @dist-newstyle@).
--
@@ -490,7 +490,7 @@ data Framework
-- | Abstract directory: build directory.
--
-- See Note [Symbolic paths] in Distribution.Utils.Path.
-data Build
+data Build deriving (Data)
-- | Abstract directory: directory for build artifacts, such as documentation or @.hie@ files.
--
diff --git a/Cabal-tests/tests/NoThunks.hs b/Cabal-tests/tests/NoThunks.hs
index 6a81475dc03..63f6bcae070 100644
--- a/Cabal-tests/tests/NoThunks.hs
+++ b/Cabal-tests/tests/NoThunks.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
#if !(__GLASGOW_HASKELL__ >= 806 && defined(MIN_VERSION_nothunks))
module Main (main) where
main :: IO ()
@@ -24,7 +25,7 @@ import Distribution.ModuleName (ModuleName)
import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
import Distribution.SPDX (License, LicenseExceptionId, LicenseExpression, LicenseId, LicenseRef, SimpleLicenseExpression)
import Distribution.System (Arch, OS)
-import Distribution.Utils.Path (SymbolicPathX)
+import Distribution.Utils.Path (SymbolicPathX, Pkg, Build)
import Distribution.Utils.ShortText (ShortText)
import Distribution.Version (Version, VersionRange)
import Language.Haskell.Extension (Extension, KnownExtension, Language)
@@ -72,6 +73,8 @@ instance NoThunks ConfVar
instance NoThunks Dependency
instance NoThunks Executable
instance NoThunks ExecutableScope
+instance NoThunks (ExtraSource Build)
+instance NoThunks (ExtraSource Pkg)
instance NoThunks FlagName
instance NoThunks ForeignLib
instance NoThunks ForeignLibOption
diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs
index 47a0cc1bd2c..cd0f73aeedd 100644
--- a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs
+++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs
@@ -29,8 +29,8 @@ md5Check proxy md5Int = structureHash proxy @?= md5FromInteger md5Int
md5CheckGenericPackageDescription :: Proxy GenericPackageDescription -> Assertion
md5CheckGenericPackageDescription proxy = md5Check proxy
- 0x09251b46ffc5178a7526d31e794d9c62
+ 0x77f4c09dc9b1c6967b07516ad35e73af
md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion
md5CheckLocalBuildInfo proxy = md5Check proxy
- 0x8fa7b2c8cc611407bfdcb734ecb460a2
+ 0x69dab39bf8b56871b28a2c14d423b18a
diff --git a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs
index cb36fe680db..fd7e4eea3c0 100644
--- a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs
+++ b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs
@@ -1,5 +1,6 @@
{-# OPTIONS_GHC -freduction-depth=0 #-}
{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE FlexibleInstances #-}
module Data.TreeDiff.Instances.Cabal () where
import Data.TreeDiff
@@ -28,7 +29,7 @@ import Distribution.Types.DumpBuildInfo (DumpBuildInfo)
import Distribution.Types.PackageVersionConstraint
import Distribution.Types.UnitId (DefUnitId, UnitId)
import Distribution.Utils.NubList (NubList)
-import Distribution.Utils.Path (SymbolicPathX)
+import Distribution.Utils.Path (SymbolicPathX, Build, Pkg)
import Distribution.Utils.ShortText (ShortText, fromShortText)
import Distribution.Verbosity
import Distribution.Verbosity.Internal
@@ -77,6 +78,8 @@ instance ToExpr ExeDependency
instance ToExpr Executable
instance ToExpr ExecutableScope
instance ToExpr ExposedModule
+instance ToExpr (ExtraSource Build)
+instance ToExpr (ExtraSource Pkg)
instance ToExpr FlagAssignment
instance ToExpr FlagName
instance ToExpr ForeignLib
diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal
index 27f7c958016..dab60621228 100644
--- a/Cabal/Cabal.cabal
+++ b/Cabal/Cabal.cabal
@@ -415,3 +415,17 @@ library
TypeOperators
TypeSynonymInstances
UndecidableInstances
+
+executable cabal-main-simple
+ default-language: Haskell2010
+ main-is: src/main_simple.hs
+ build-depends:
+ base,
+ Cabal
+
+executable cabal-main-configure
+ default-language: Haskell2010
+ main-is: src/main_configure.hs
+ build-depends:
+ base,
+ Cabal
diff --git a/Cabal/src/Distribution/Backpack/Configure.hs b/Cabal/src/Distribution/Backpack/Configure.hs
index d4c00b75c7b..41bf7929bc3 100644
--- a/Cabal/src/Distribution/Backpack/Configure.hs
+++ b/Cabal/src/Distribution/Backpack/Configure.hs
@@ -56,6 +56,8 @@ import qualified Data.Set as Set
import Distribution.Pretty
import Text.PrettyPrint
+import Unsafe.Coerce (unsafeCoerce)
+
------------------------------------------------------------------------------
-- Pipeline
------------------------------------------------------------------------------
@@ -144,7 +146,7 @@ configureComponentLocalBuildInfos
,
( DefiniteUnitId
( unsafeMkDefUnitId
- (mkUnitId (unComponentId (ann_id aid)))
+ (unsafeCoerce (ann_id aid))
)
, emptyModuleShape
)
@@ -303,35 +305,35 @@ toComponentLocalBuildInfos
-- TODO: Move this into a helper function
--
-- TODO: This is probably wrong for Backpack
- let pseudoTopPkg :: InstalledPackageInfo
- pseudoTopPkg =
- emptyInstalledPackageInfo
- { Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr)
- , Installed.sourcePackageId = packageId pkg_descr
- , Installed.depends = map pc_uid externalPkgDeps
- }
- case PackageIndex.dependencyInconsistencies
- . PackageIndex.insert pseudoTopPkg
- $ packageDependsIndex of
- [] -> return ()
- inconsistencies ->
- warnProgress $
- hang
- ( text "This package indirectly depends on multiple versions of the same"
- <+> text "package. This is very likely to cause a compile failure."
- )
- 2
- ( vcat
- [ text "package"
- <+> pretty (packageName user)
- <+> parens (pretty (installedUnitId user))
- <+> text "requires"
- <+> pretty inst
- | (_dep_key, insts) <- inconsistencies
- , (inst, users) <- insts
- , user <- users
- ]
- )
+ -- let pseudoTopPkg :: InstalledPackageInfo
+ -- pseudoTopPkg =
+ -- emptyInstalledPackageInfo
+ -- { Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr)
+ -- , Installed.sourcePackageId = packageId pkg_descr
+ -- , Installed.depends = map pc_uid externalPkgDeps
+ -- }
+ -- case PackageIndex.dependencyInconsistencies
+ -- . PackageIndex.insert pseudoTopPkg
+ -- $ packageDependsIndex of
+ -- [] -> return ()
+ -- inconsistencies ->
+ -- warnProgress $
+ -- hang
+ -- ( text "This package indirectly depends on multiple versions of the same"
+ -- <+> text "package. This is very likely to cause a compile failure."
+ -- )
+ -- 2
+ -- ( vcat
+ -- [ text "package"
+ -- <+> pretty (packageName user)
+ -- <+> parens (pretty (installedUnitId user))
+ -- <+> text "requires"
+ -- <+> pretty inst
+ -- | (_dep_key, insts) <- inconsistencies
+ -- , (inst, users) <- insts
+ -- , user <- users
+ -- ]
+ -- )
let clbis = mkLinkedComponentsLocalBuildInfo comp graph
-- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps)
return (clbis, packageDependsIndex)
diff --git a/Cabal/src/Distribution/Backpack/PreExistingComponent.hs b/Cabal/src/Distribution/Backpack/PreExistingComponent.hs
index 0fba79bcb87..a72fe20f07f 100644
--- a/Cabal/src/Distribution/Backpack/PreExistingComponent.hs
+++ b/Cabal/src/Distribution/Backpack/PreExistingComponent.hs
@@ -71,9 +71,9 @@ instance HasMungedPackageId PreExistingComponent where
mungedId = pc_munged_id
instance Package PreExistingComponent where
- packageId pec = PackageIdentifier (pc_pkgname pec) v
+ packageId pec = PackageIdentifier (pc_pkgname pec) v compid
where
- MungedPackageId _ v = pc_munged_id pec
+ MungedPackageId _ v compid = pc_munged_id pec
instance HasUnitId PreExistingComponent where
installedUnitId = pc_uid
diff --git a/Cabal/src/Distribution/Backpack/ReadyComponent.hs b/Cabal/src/Distribution/Backpack/ReadyComponent.hs
index 7a3523d5eab..b871ebff59f 100644
--- a/Cabal/src/Distribution/Backpack/ReadyComponent.hs
+++ b/Cabal/src/Distribution/Backpack/ReadyComponent.hs
@@ -300,6 +300,7 @@ toReadyComponents pid_map subst0 comps =
MungedPackageId
(MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName)
(mkVersion [0])
+ Nothing
instc =
InstantiatedComponent
{ instc_insts = Map.toList insts
diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs
index 925bc69d6e1..799e677af17 100644
--- a/Cabal/src/Distribution/PackageDescription/Check.hs
+++ b/Cabal/src/Distribution/PackageDescription/Check.hs
@@ -582,7 +582,7 @@ checkSetupBuildInfo (Just (SetupBuildInfo ds _)) = do
checkPVPs (checkDependencyVersionRange hasGTLowerBound) gtlck ds
checkPackageId :: Monad m => PackageIdentifier -> CheckM m ()
-checkPackageId (PackageIdentifier pkgName_ _pkgVersion_) = do
+checkPackageId (PackageIdentifier pkgName_ _pkgVersion_ _compid) = do
checkP
(not . FilePath.Windows.isValid . prettyShow $ pkgName_)
(PackageDistInexcusable $ InvalidNameWin pkgName_)
diff --git a/Cabal/src/Distribution/PackageDescription/Check/Target.hs b/Cabal/src/Distribution/PackageDescription/Check/Target.hs
index 0bf173cb980..c62f7e40756 100644
--- a/Cabal/src/Distribution/PackageDescription/Check/Target.hs
+++ b/Cabal/src/Distribution/PackageDescription/Check/Target.hs
@@ -445,11 +445,11 @@ checkBuildInfoPathsContent bi = do
-- Paths well-formedness check for BuildInfo.
checkBuildInfoPathsWellFormedness :: Monad m => BuildInfo -> CheckM m ()
checkBuildInfoPathsWellFormedness bi = do
- mapM_ (checkPath False "asm-sources" PathKindFile . getSymbolicPath) (asmSources bi)
- mapM_ (checkPath False "cmm-sources" PathKindFile . getSymbolicPath) (cmmSources bi)
- mapM_ (checkPath False "c-sources" PathKindFile . getSymbolicPath) (cSources bi)
- mapM_ (checkPath False "cxx-sources" PathKindFile . getSymbolicPath) (cxxSources bi)
- mapM_ (checkPath False "js-sources" PathKindFile . getSymbolicPath) (jsSources bi)
+ mapM_ (checkPath False "asm-sources" PathKindFile . getSymbolicPath . extraSourceFile) (asmSources bi)
+ mapM_ (checkPath False "cmm-sources" PathKindFile . getSymbolicPath . extraSourceFile) (cmmSources bi)
+ mapM_ (checkPath False "c-sources" PathKindFile . getSymbolicPath . extraSourceFile) (cSources bi)
+ mapM_ (checkPath False "cxx-sources" PathKindFile . getSymbolicPath . extraSourceFile) (cxxSources bi)
+ mapM_ (checkPath False "js-sources" PathKindFile . getSymbolicPath . extraSourceFile) (jsSources bi)
mapM_
(checkPath False "install-includes" PathKindFile . getSymbolicPath)
(installIncludes bi)
@@ -515,8 +515,8 @@ checkBuildInfoFeatures bi sv = do
(PackageBuildWarning CVExtensionsDeprecated)
-- asm-sources, cmm-sources and friends only w/ spec ≥ 1.10
- checkCVSources (map getSymbolicPath $ asmSources bi)
- checkCVSources (map getSymbolicPath $ cmmSources bi)
+ checkCVSources (map (getSymbolicPath . extraSourceFile) $ asmSources bi)
+ checkCVSources (map (getSymbolicPath . extraSourceFile) $ cmmSources bi)
checkCVSources (extraBundledLibs bi)
checkCVSources (extraLibFlavours bi)
diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs
index 0ebd51e48ef..008a270848f 100644
--- a/Cabal/src/Distribution/Simple/Build.hs
+++ b/Cabal/src/Distribution/Simple/Build.hs
@@ -642,35 +642,35 @@ generateCode codeGens nm pdesc bi lbi clbi verbosity = do
addExtraCSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo
addExtraCSources bi extras = bi{cSources = new}
where
- new = ordNub (extras ++ cSources bi)
+ new = ordNub (map (flip ExtraSourcePkg []) extras ++ cSources bi)
-- | Add extra C++ sources generated by preprocessing to build
-- information.
addExtraCxxSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo
addExtraCxxSources bi extras = bi{cxxSources = new}
where
- new = ordNub (extras ++ cxxSources bi)
+ new = ordNub (map (flip ExtraSourcePkg []) extras ++ cxxSources bi)
-- | Add extra C-- sources generated by preprocessing to build
-- information.
addExtraCmmSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo
addExtraCmmSources bi extras = bi{cmmSources = new}
where
- new = ordNub (extras ++ cmmSources bi)
+ new = ordNub (map (flip ExtraSourcePkg []) extras ++ cmmSources bi)
-- | Add extra ASM sources generated by preprocessing to build
-- information.
addExtraAsmSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo
addExtraAsmSources bi extras = bi{asmSources = new}
where
- new = ordNub (extras ++ asmSources bi)
+ new = ordNub (map (flip ExtraSourcePkg []) extras ++ asmSources bi)
-- | Add extra JS sources generated by preprocessing to build
-- information.
addExtraJsSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo
addExtraJsSources bi extras = bi{jsSources = new}
where
- new = ordNub (extras ++ jsSources bi)
+ new = ordNub (map (flip ExtraSourcePkg []) extras ++ jsSources bi)
-- | Add extra HS modules generated by preprocessing to build
-- information.
@@ -716,7 +716,7 @@ replComponent
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers
extras <- preprocessExtras verbosity comp lbi
let libbi = libBuildInfo lib
- lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}}
+ lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ map (flip ExtraSourcePkg []) extras}}
replLib replFlags pkg lbi lib' libClbi
replComponent
replFlags
@@ -733,23 +733,23 @@ replComponent
case comp of
CLib lib -> do
let libbi = libBuildInfo lib
- lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}}
+ lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ map (flip ExtraSourcePkg []) extras}}
replLib replFlags pkg_descr lbi lib' clbi
CFLib flib ->
replFLib replFlags pkg_descr lbi flib clbi
CExe exe -> do
let ebi = buildInfo exe
- exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}}
+ exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ map (flip ExtraSourcePkg []) extras}}
replExe replFlags pkg_descr lbi exe' clbi
CTest test@TestSuite{testInterface = TestSuiteExeV10{}} -> do
let exe = testSuiteExeV10AsExe test
let ebi = buildInfo exe
- exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}}
+ exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ map (flip ExtraSourcePkg []) extras}}
replExe replFlags pkg_descr lbi exe' clbi
CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}} -> do
let exe = benchmarkExeV10asExe bm
let ebi = buildInfo exe
- exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}}
+ exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ map (flip ExtraSourcePkg []) extras}}
replExe replFlags pkg_descr lbi exe' clbi
#if __GLASGOW_HASKELL__ < 811
-- silence pattern-match warnings prior to GHC 9.0
@@ -821,7 +821,7 @@ testSuiteLibV09AsLibAndExe
}
-- This is, like, the one place where we use a CTestName for a library.
-- Should NOT use library name, since that could conflict!
- PackageIdentifier pkg_name pkg_ver = package pkg_descr
+ PackageIdentifier pkg_name pkg_ver _pkg_compid = package pkg_descr
-- Note: we do make internal library from the test!
compat_name = MungedPackageName pkg_name (LSubLibName (testName test))
compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi)
diff --git a/Cabal/src/Distribution/Simple/Build/Macros.hs b/Cabal/src/Distribution/Simple/Build/Macros.hs
index f3c51d71c96..e71d5a4a644 100644
--- a/Cabal/src/Distribution/Simple/Build/Macros.hs
+++ b/Cabal/src/Distribution/Simple/Build/Macros.hs
@@ -67,11 +67,11 @@ generateCabalMacrosHeader pkg_descr lbi clbi =
, Z.zMangleStr = map fixchar
}
where
- getPid (_, MungedPackageId (MungedPackageName pn _) v) =
+ getPid (_, MungedPackageId (MungedPackageName pn _) v compid) =
-- NB: Drop the library name! We're just reporting package versions.
-- This would have to be revisited if you are allowed to depend
-- on different versions of the same package
- PackageIdentifier pn v
+ PackageIdentifier pn v compid
-- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@
-- macros for a list of package ids (usually used with the specific deps of
@@ -91,7 +91,7 @@ generatePackageVersionMacros ver pkgids =
}
mkZPackage :: PackageId -> Z.ZPackage
-mkZPackage (PackageIdentifier name ver) =
+mkZPackage (PackageIdentifier name ver compid) =
Z.ZPackage
{ Z.zpkgName = name
, Z.zpkgVersion = ver
diff --git a/Cabal/src/Distribution/Simple/BuildTarget.hs b/Cabal/src/Distribution/Simple/BuildTarget.hs
index ffa7a609e6b..1d987c7715f 100644
--- a/Cabal/src/Distribution/Simple/BuildTarget.hs
+++ b/Cabal/src/Distribution/Simple/BuildTarget.hs
@@ -497,11 +497,11 @@ pkgComponentInfo pkg =
, cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi
, cinfoModules = componentModules c
, cinfoHsFiles = map getSymbolicPath $ componentHsFiles c
- , cinfoAsmFiles = map getSymbolicPath $ asmSources bi
- , cinfoCmmFiles = map getSymbolicPath $ cmmSources bi
- , cinfoCFiles = map getSymbolicPath $ cSources bi
- , cinfoCxxFiles = map getSymbolicPath $ cxxSources bi
- , cinfoJsFiles = map getSymbolicPath $ jsSources bi
+ , cinfoAsmFiles = map (getSymbolicPath . extraSourceFile) $ asmSources bi
+ , cinfoCmmFiles = map (getSymbolicPath . extraSourceFile) $ cmmSources bi
+ , cinfoCFiles = map (getSymbolicPath . extraSourceFile) $ cSources bi
+ , cinfoCxxFiles = map (getSymbolicPath . extraSourceFile) $ cxxSources bi
+ , cinfoJsFiles = map (getSymbolicPath . extraSourceFile) $ jsSources bi
}
| c <- pkgComponents pkg
, let bi = componentBuildInfo c
diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs
index 7c96efb33fc..1ed13020f82 100644
--- a/Cabal/src/Distribution/Simple/Configure.hs
+++ b/Cabal/src/Distribution/Simple/Configure.hs
@@ -183,6 +183,10 @@ import qualified Data.Maybe as M
import qualified Data.Set as Set
import qualified Distribution.Compat.NonEmptySet as NES
+import GHC.Stack (HasCallStack)
+
+import Unsafe.Coerce (unsafeCoerce)
+
type UseExternalInternalDeps = Bool
-- | The errors that can be thrown when reading the @setup-config@ file.
@@ -335,7 +339,7 @@ writePersistBuildConfig mbWorkDir distPref lbi = do
-- | Identifier of the current Cabal package.
currentCabalId :: PackageIdentifier
-currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion
+currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion Nothing
-- | Identifier of the current compiler package.
currentCompilerId :: PackageIdentifier
@@ -343,6 +347,7 @@ currentCompilerId =
PackageIdentifier
(mkPackageName System.Info.compilerName)
(mkVersion' System.Info.compilerVersion)
+ Nothing
-- | Parse the @setup-config@ file header, returning the package identifiers
-- for Cabal and the compiler.
@@ -936,7 +941,8 @@ configurePackage cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 pac
return (lbc, pbd)
finalizeAndConfigurePackage
- :: ConfigFlags
+ :: HasCallStack
+ => ConfigFlags
-> LBC.LocalBuildConfig
-> GenericPackageDescription
-> Compiler
@@ -991,9 +997,17 @@ finalizeAndConfigurePackage cfg lbc0 g_pkg_descr comp platform enabled = do
, requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo
) <-
either (dieWithException verbosity) return $
- combinedConstraints
+ -- why do we need this? We internally now treat everything as properly
+ -- qualified Component/UnitIds. Thus we need to turn Partial ones into
+ -- fully qualified ones. Otherwise any lookup internally will fail.
+ -- installedPackageSet will already contain properly qualified ones.
+ let updCompId :: GivenComponent -> GivenComponent
+ updCompId (GivenComponent pn ln cid) | isPartialUnitId (unsafeCoerce cid) =
+ GivenComponent pn ln (unsafeCoerce (addPrefixToUnitId (prettyShow (compilerId comp)) (unsafeCoerce cid)))
+ updCompId (GivenComponent pn ln cid) = GivenComponent pn ln cid
+ in combinedConstraints
(configConstraints cfg)
- (configDependencies cfg)
+ (map updCompId (configDependencies cfg))
installedPackageSet
let
@@ -1987,7 +2001,7 @@ selectDependency
-- It's an internal library, and we're not per-component build
do_internal lib
| Set.member lib internalIndex =
- Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid
+ Right $ InternalDependency $ PackageIdentifier dep_pkgname (packageVersion pkgid) (pkgCompiler pkgid)
| otherwise =
Left $ DependencyMissingInternal dep_pkgname lib
@@ -2051,7 +2065,7 @@ reportFailedDependencies verbosity failed =
-- with a warning and treated as empty ones, since technically they do not
-- contain any package.
getInstalledPackages
- :: Verbosity
+ :: HasCallStack => Verbosity
-> Compiler
-> Maybe (SymbolicPath CWD (Dir from))
-> PackageDBStackX (SymbolicPath from (Dir PkgDB))
@@ -2094,7 +2108,7 @@ getInstalledPackages verbosity comp mbWorkDir packageDBs progdb = do
-- on the package database stack in question. However, when sandboxes
-- are involved these sanity checks are not desirable.
getPackageDBContents
- :: Verbosity
+ :: HasCallStack => Verbosity
-> Compiler
-> Maybe (SymbolicPath CWD (Dir Pkg))
-> PackageDB
@@ -2184,7 +2198,8 @@ interpretPackageDbFlags userInstall specificDBs =
-- deps in the end. So we still need to remember which installed packages to
-- pick.
combinedConstraints
- :: [PackageVersionConstraint]
+ :: HasCallStack
+ => [PackageVersionConstraint]
-> [GivenComponent]
-- ^ installed dependencies
-> InstalledPackageIndex
@@ -2219,7 +2234,7 @@ combinedConstraints constraints dependencies installedPackages = do
]
-- The dependencies along with the installed package info, if it exists
- dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId, Maybe InstalledPackageInfo)]
+ dependenciesPkgInfo :: HasCallStack => [(PackageName, ComponentName, ComponentId, Maybe InstalledPackageInfo)]
dependenciesPkgInfo =
[ (pkgname, CLibName lname, cid, mpkg)
| GivenComponent pkgname lname cid <- dependencies
diff --git a/Cabal/src/Distribution/Simple/Errors.hs b/Cabal/src/Distribution/Simple/Errors.hs
index 1ce4f7ca06a..0d9062cbe08 100644
--- a/Cabal/src/Distribution/Simple/Errors.hs
+++ b/Cabal/src/Distribution/Simple/Errors.hs
@@ -60,7 +60,7 @@ data CabalException
| OnlySupportSpecificPackageDb
| FailedToParseOutputDescribe String PackageId
| DumpFailed String String
- | FailedToParseOutputDump String
+ | FailedToParseOutputDump String String
| ListFailed String
| FailedToParseOutputList String
| ProgramNotFound String
@@ -336,7 +336,7 @@ exceptionMessage e = case e of
OnlySupportSpecificPackageDb -> "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now"
FailedToParseOutputDescribe programId pkgId -> "failed to parse output of '" ++ programId ++ " describe " ++ prettyShow pkgId ++ "'"
DumpFailed programId exception -> programId ++ " dump failed: " ++ exception
- FailedToParseOutputDump programId -> "failed to parse output of '" ++ programId ++ " dump'"
+ FailedToParseOutputDump programId err -> "failed to parse output of '" ++ programId ++ " dump': " ++ err
ListFailed programId -> programId ++ " list failed"
FailedToParseOutputList programId -> "failed to parse output of '" ++ programId ++ " list'"
ProgramNotFound progName -> "The program '" ++ progName ++ "' is required but it could not be found"
diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs
index 45fbee0fed1..e865fe436d2 100644
--- a/Cabal/src/Distribution/Simple/GHC.hs
+++ b/Cabal/src/Distribution/Simple/GHC.hs
@@ -150,6 +150,8 @@ import System.Directory
import Distribution.Simple.Setup (BuildingWhat (..))
import Distribution.Simple.Setup.Build
+import GHC.Stack (HasCallStack)
+
-- -----------------------------------------------------------------------------
-- Configuring
@@ -249,7 +251,7 @@ configure verbosity hcPath hcPkgPath conf0 = do
compilerId = CompilerId GHC ghcVersion
compilerAbiTag :: AbiTag
- compilerAbiTag = maybe NoAbiTag AbiTag (Map.lookup "Project Unit Id" ghcInfoMap >>= stripPrefix (prettyShow compilerId <> "-"))
+ compilerAbiTag = fromMaybe NoAbiTag (getAbiTag . fromString <$> Map.lookup "Project Unit Id" ghcInfoMap)
let comp =
Compiler
@@ -400,7 +402,7 @@ getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg
-- | Given a single package DB, return all installed packages.
getPackageDBContents
- :: Verbosity
+ :: HasCallStack => Verbosity
-> Maybe (SymbolicPath CWD (Dir from))
-> PackageDBX (SymbolicPath from (Dir PkgDB))
-> ProgramDb
@@ -411,7 +413,7 @@ getPackageDBContents verbosity mbWorkDir packagedb progdb = do
-- | Given a package DB stack, return all installed packages.
getInstalledPackages
- :: Verbosity
+ :: HasCallStack => Verbosity
-> Compiler
-> Maybe (SymbolicPath CWD (Dir from))
-> PackageDBStackX (SymbolicPath from (Dir PkgDB))
@@ -421,9 +423,22 @@ getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do
checkPackageDbEnvVar verbosity
checkPackageDbStack verbosity comp packagedbs
pkgss <- getInstalledPackages' verbosity mbWorkDir packagedbs progdb
- index <- toPackageIndex verbosity pkgss progdb
+ let pkgss' = [ (packagedb, updDependsUnitIds . updUnitId . setPkgCompiler <$> pkgs)
+ | (packagedb, pkgs) <- pkgss
+ ]
+ index <- toPackageIndex verbosity pkgss' progdb
return $! hackRtsPackage index
where
+ setPkgCompiler pkg = pkg{ InstalledPackageInfo.pkgCompiler = Just (compilerId comp) }
+ updUnitId pkg | isPartialUnitId (installedUnitId pkg) =
+ pkg { InstalledPackageInfo.installedUnitId =
+ addPrefixToUnitId (prettyShow (compilerId comp)) (InstalledPackageInfo.installedUnitId pkg)
+ }
+ updUnitId pkg = pkg
+ updDependsUnitIds pkg =
+ pkg { InstalledPackageInfo.depends =
+ map (\x -> if isPartialUnitId x then addPrefixToUnitId (prettyShow (compilerId comp)) x else x) (InstalledPackageInfo.depends pkg)
+ }
hackRtsPackage index =
case PackageIndex.lookupPackageName index (mkPackageName "rts") of
[(_, [rts])] ->
@@ -535,7 +550,7 @@ removeMingwIncludeDir pkg =
-- | Get the packages from specific PackageDBs, not cumulative.
getInstalledPackages'
- :: Verbosity
+ :: HasCallStack => Verbosity
-> Maybe (SymbolicPath CWD (Dir from))
-> [PackageDBX (SymbolicPath from (Dir PkgDB))]
-> ProgramDb
diff --git a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs
index f2ca9aba02f..800059a9402 100644
--- a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs
+++ b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
@@ -26,6 +28,7 @@ import Distribution.Simple.Program.Types
import Distribution.Simple.Setup.Common (commonSetupTempFileOptions)
import Distribution.System (Arch (JavaScript), Platform (..))
import Distribution.Types.ComponentLocalBuildInfo
+import Distribution.Types.ExtraSource (ExtraSource (..))
import Distribution.Utils.Path
import Distribution.Verbosity (Verbosity)
@@ -51,25 +54,24 @@ buildAllExtraSources =
, buildJsSources
, buildAsmSources
, buildCmmSources
+ , buildAutogenCmmSources
]
-buildCSources
- , buildCxxSources
- , buildJsSources
- , buildAsmSources
- , buildCmmSources
- :: Maybe (SymbolicPath Pkg File)
- -- ^ An optional non-Haskell Main file
- -> ConfiguredProgram
- -- ^ The GHC configured program
- -> SymbolicPath Pkg (Dir Artifacts)
- -- ^ The build directory for this target
- -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)
- -- ^ Needed build ways
- -> PreBuildComponentInputs
- -- ^ The context and component being built in it.
- -> IO (NubListR (SymbolicPath Pkg File))
- -- ^ Returns the list of extra sources that were built
+type ExtraSourceBuilder =
+ Maybe (SymbolicPath Pkg File)
+ -- ^ An optional non-Haskell Main file
+ -> ConfiguredProgram
+ -- ^ The GHC configured program
+ -> SymbolicPath Pkg (Dir Artifacts)
+ -- ^ The build directory for this target
+ -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)
+ -- ^ Needed build ways
+ -> PreBuildComponentInputs
+ -- ^ The context and component being built in it.
+ -> IO (NubListR (SymbolicPath Pkg File))
+ -- ^ Returns the list of extra sources that were built
+
+buildCSources :: ExtraSourceBuilder
buildCSources mbMainFile =
buildExtraSources
"C Sources"
@@ -80,9 +82,11 @@ buildCSources mbMainFile =
CExe{}
| Just main <- mbMainFile
, isC $ getSymbolicPath main ->
- cFiles ++ [main]
+ cFiles ++ [ExtraSourcePkg main mempty]
_otherwise -> cFiles
)
+
+buildCxxSources :: ExtraSourceBuilder
buildCxxSources mbMainFile =
buildExtraSources
"C++ Sources"
@@ -93,9 +97,11 @@ buildCxxSources mbMainFile =
CExe{}
| Just main <- mbMainFile
, isCxx $ getSymbolicPath main ->
- cxxFiles ++ [main]
+ cxxFiles ++ [ExtraSourcePkg main mempty]
_otherwise -> cxxFiles
)
+
+buildJsSources :: ExtraSourceBuilder
buildJsSources _mbMainFile ghcProg buildTargetDir neededWays = do
Platform hostArch _ <- hostPlatform <$> localBuildInfo
let hasJsSupport = hostArch == JavaScript
@@ -114,36 +120,49 @@ buildJsSources _mbMainFile ghcProg buildTargetDir neededWays = do
ghcProg
buildTargetDir
neededWays
+
+buildAsmSources :: ExtraSourceBuilder
buildAsmSources _mbMainFile =
buildExtraSources
"Assembler Sources"
Internal.componentAsmGhcOptions
(asmSources . componentBuildInfo)
+
+buildCmmSources :: ExtraSourceBuilder
buildCmmSources _mbMainFile =
buildExtraSources
"C-- Sources"
Internal.componentCmmGhcOptions
(cmmSources . componentBuildInfo)
+buildAutogenCmmSources :: ExtraSourceBuilder
+buildAutogenCmmSources _mbMainFile=
+ buildExtraSources
+ "C-- Generated Sources"
+ Internal.componentCmmGhcOptions
+ (autogenCmmSources . componentBuildInfo)
+
-- | Create 'PreBuildComponentRules' for a given type of extra build sources
-- which are compiled via a GHC invocation with the given options. Used to
-- define built-in extra sources, such as, C, Cxx, Js, Asm, and Cmm sources.
buildExtraSources
- :: String
+ :: forall from
+ . Internal.SourcePath (ExtraSource from)
+ => String
-- ^ String describing the extra sources being built, for printing.
-> ( Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg (Dir Artifacts)
- -> SymbolicPath Pkg File
+ -> ExtraSource from
-> GhcOptions
)
-- ^ Function to determine the @'GhcOptions'@ for the
-- invocation of GHC when compiling these extra sources (e.g.
-- @'Internal.componentCxxGhcOptions'@,
-- @'Internal.componentCmmGhcOptions'@)
- -> (Component -> [SymbolicPath Pkg File])
+ -> (Component -> [ExtraSource from])
-- ^ View the extra sources of a component, typically from
-- the build info (e.g. @'asmSources'@, @'cSources'@).
-- @'Executable'@ components might additionally add the
@@ -189,8 +208,7 @@ buildExtraSources
platform
mbWorkDir
- buildAction :: SymbolicPath Pkg File -> IO ()
- buildAction sourceFile = do
+ buildAction extraSource = do
let baseSrcOpts =
componentSourceGhcOptions
verbosity
@@ -198,7 +216,7 @@ buildExtraSources
bi
clbi
buildTargetDir
- sourceFile
+ extraSource
vanillaSrcOpts =
-- -fPIC is used in case you are using the repl
-- of a dynamically linked GHC
@@ -228,9 +246,9 @@ buildExtraSources
odir = fromFlag (ghcOptObjDir vanillaSrcOpts)
compileIfNeeded :: GhcOptions -> IO ()
- compileIfNeeded opts = do
- needsRecomp <- checkNeedsRecompilation mbWorkDir sourceFile opts
- when needsRecomp $ runGhcProg opts
+ compileIfNeeded opts' = do
+ needsRecomp <- checkNeedsRecompilation mbWorkDir (Internal.sourcePath lbi extraSource) opts'
+ when needsRecomp $ runGhcProg opts'
createDirectoryIfMissingVerbose verbosity True (i odir)
case targetComponent targetInfo of
@@ -269,4 +287,4 @@ buildExtraSources
else do
info verbosity ("Building " ++ description ++ "...")
traverse_ buildAction sources
- return (toNubListR sources)
+ return (toNubListR (map (Internal.sourcePath lbi) sources))
diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs
index e26e3890ba3..78f293e7656 100644
--- a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs
+++ b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs
@@ -121,6 +121,14 @@ linkOrLoadComponent
PD.ldOptions bi
++ [ "-static"
| withFullyStaticExe lbi
+ -- MacOS can not link fully statically.
+ -- Only kernels can be linked fully statically. Everything
+ -- linking against libSystem must link dynamically. Thus even
+ -- if we link all dependencies statically, we must not pass
+ -- '-optl-static', as that will cause the linker to try and
+ -- fail.
+ , let Platform _hostArch hostOS = hostPlatform lbi
+ in hostOS /= OSX
]
-- Pass extra `ld-options` given
-- through to GHC's linker.
diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs
index 6e27b41bc83..dd046fcbece 100644
--- a/Cabal/src/Distribution/Simple/GHC/Internal.hs
+++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
@@ -47,6 +48,9 @@ module Distribution.Simple.GHC.Internal
, ghcEnvironmentFileName
, renderGhcEnvironmentFile
, renderGhcEnvironmentFileEntry
+
+ -- * Paths
+ , SourcePath (..)
) where
import Distribution.Compat.Prelude
@@ -311,7 +315,6 @@ getExtensions verbosity implInfo ghcProg = do
then lines str
else -- Older GHCs only gave us either Foo or NoFoo,
-- so we have to work out the other one ourselves
-
[ extStr''
| extStr <- lines str
, let extStr' = case extStr of
@@ -331,7 +334,6 @@ getExtensions verbosity implInfo ghcProg = do
-- Since it was not a proper extension, it could
-- not be turned off, hence we omit a
-- DisableExtension entry here.
-
(EnableExtension NondecreasingIndentation, Nothing)
: extensions0
else extensions0
@@ -357,21 +359,23 @@ includePaths lbi bi clbi odir =
| dir <- mapMaybe (symbolicPathRelative_maybe . unsafeCoerceSymbolicPath) $ includeDirs bi
]
-componentCcGhcOptions
- :: Verbosity
- -> LocalBuildInfo
- -> BuildInfo
- -> ComponentLocalBuildInfo
- -> SymbolicPath Pkg (Dir Artifacts)
- -> SymbolicPath Pkg File
- -> GhcOptions
-componentCcGhcOptions verbosity lbi bi clbi odir filename =
+type ExtraSourceGhcOptions pkg =
+ Verbosity
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ComponentLocalBuildInfo
+ -> SymbolicPath Pkg (Dir Artifacts)
+ -> ExtraSource pkg
+ -> GhcOptions
+
+componentCcGhcOptions :: SourcePath (ExtraSource pkg) => ExtraSourceGhcOptions pkg
+componentCcGhcOptions verbosity lbi bi clbi odir extraSource =
mempty
{ -- Respect -v0, but don't crank up verbosity on GHC if
-- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
ghcOptVerbosity = toFlag (min verbosity normal)
, ghcOptMode = toFlag GhcModeCompile
- , ghcOptInputFiles = toNubListR [filename]
+ , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource]
, ghcOptCppIncludePath = includePaths lbi bi clbi odir
, ghcOptHideAllPackages = toFlag True
, ghcOptPackageDBs = withPackageDB lbi
@@ -388,29 +392,23 @@ componentCcGhcOptions verbosity lbi bi clbi odir filename =
MaximalDebugInfo -> ["-g3"]
)
++ ccOptions bi
+ ++ extraSourceOpts extraSource
, ghcOptCcProgram =
maybeToFlag $
programPath
- <$> lookupProgram gccProgram (withPrograms lbi)
+ <$> lookupProgram gccProgram (withPrograms lbi)
, ghcOptObjDir = toFlag odir
, ghcOptExtra = hcOptions GHC bi
}
-componentCxxGhcOptions
- :: Verbosity
- -> LocalBuildInfo
- -> BuildInfo
- -> ComponentLocalBuildInfo
- -> SymbolicPath Pkg (Dir Artifacts)
- -> SymbolicPath Pkg File
- -> GhcOptions
-componentCxxGhcOptions verbosity lbi bi clbi odir filename =
+componentCxxGhcOptions :: SourcePath (ExtraSource pkg) => ExtraSourceGhcOptions pkg
+componentCxxGhcOptions verbosity lbi bi clbi odir extraSource =
mempty
{ -- Respect -v0, but don't crank up verbosity on GHC if
-- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
ghcOptVerbosity = toFlag (min verbosity normal)
, ghcOptMode = toFlag GhcModeCompile
- , ghcOptInputFiles = toNubListR [filename]
+ , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource]
, ghcOptCppIncludePath = includePaths lbi bi clbi odir
, ghcOptHideAllPackages = toFlag True
, ghcOptPackageDBs = withPackageDB lbi
@@ -427,29 +425,23 @@ componentCxxGhcOptions verbosity lbi bi clbi odir filename =
MaximalDebugInfo -> ["-g3"]
)
++ cxxOptions bi
+ ++ extraSourceOpts extraSource
, ghcOptCcProgram =
maybeToFlag $
programPath
- <$> lookupProgram gccProgram (withPrograms lbi)
+ <$> lookupProgram gccProgram (withPrograms lbi)
, ghcOptObjDir = toFlag odir
, ghcOptExtra = hcOptions GHC bi
}
-componentAsmGhcOptions
- :: Verbosity
- -> LocalBuildInfo
- -> BuildInfo
- -> ComponentLocalBuildInfo
- -> SymbolicPath Pkg (Dir Artifacts)
- -> SymbolicPath Pkg File
- -> GhcOptions
-componentAsmGhcOptions verbosity lbi bi clbi odir filename =
+componentAsmGhcOptions :: SourcePath (ExtraSource pkg) => ExtraSourceGhcOptions pkg
+componentAsmGhcOptions verbosity lbi bi clbi odir extraSource =
mempty
{ -- Respect -v0, but don't crank up verbosity on GHC if
-- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
ghcOptVerbosity = toFlag (min verbosity normal)
, ghcOptMode = toFlag GhcModeCompile
- , ghcOptInputFiles = toNubListR [filename]
+ , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource]
, ghcOptCppIncludePath = includePaths lbi bi clbi odir
, ghcOptHideAllPackages = toFlag True
, ghcOptPackageDBs = withPackageDB lbi
@@ -469,21 +461,14 @@ componentAsmGhcOptions verbosity lbi bi clbi odir filename =
, ghcOptObjDir = toFlag odir
}
-componentJsGhcOptions
- :: Verbosity
- -> LocalBuildInfo
- -> BuildInfo
- -> ComponentLocalBuildInfo
- -> SymbolicPath Pkg (Dir Artifacts)
- -> SymbolicPath Pkg File
- -> GhcOptions
-componentJsGhcOptions verbosity lbi bi clbi odir filename =
+componentJsGhcOptions :: SourcePath (ExtraSource pkg) => ExtraSourceGhcOptions pkg
+componentJsGhcOptions verbosity lbi bi clbi odir extraSource =
mempty
{ -- Respect -v0, but don't crank up verbosity on GHC if
-- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
ghcOptVerbosity = toFlag (min verbosity normal)
, ghcOptMode = toFlag GhcModeCompile
- , ghcOptInputFiles = toNubListR [filename]
+ , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource]
, ghcOptCppIncludePath = includePaths lbi bi clbi odir
, ghcOptHideAllPackages = toFlag True
, ghcOptPackageDBs = withPackageDB lbi
@@ -577,21 +562,14 @@ toGhcOptimisation NoOptimisation = mempty -- TODO perhaps override?
toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation
toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation
-componentCmmGhcOptions
- :: Verbosity
- -> LocalBuildInfo
- -> BuildInfo
- -> ComponentLocalBuildInfo
- -> SymbolicPath Pkg (Dir Artifacts)
- -> SymbolicPath Pkg File
- -> GhcOptions
-componentCmmGhcOptions verbosity lbi bi clbi odir filename =
+componentCmmGhcOptions :: SourcePath (ExtraSource pkg) => ExtraSourceGhcOptions pkg
+componentCmmGhcOptions verbosity lbi bi clbi odir extraSource =
mempty
{ -- Respect -v0, but don't crank up verbosity on GHC if
-- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
ghcOptVerbosity = toFlag (min verbosity normal)
, ghcOptMode = toFlag GhcModeCompile
- , ghcOptInputFiles = toNubListR [filename]
+ , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource]
, ghcOptCppIncludePath = includePaths lbi bi clbi odir
, ghcOptCppOptions = cppOptions bi
, ghcOptCppIncludes =
@@ -602,7 +580,7 @@ componentCmmGhcOptions verbosity lbi bi clbi odir filename =
, ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi
, ghcOptOptimisation = toGhcOptimisation (withOptimization lbi)
, ghcOptDebugInfo = toFlag (withDebugInfo lbi)
- , ghcOptExtra = cmmOptions bi
+ , ghcOptExtra = cmmOptions bi ++ extraSourceOpts extraSource
, ghcOptObjDir = toFlag odir
}
@@ -838,3 +816,12 @@ renderGhcEnvironmentFileEntry entry = case entry of
UserPackageDB -> "user-package-db"
SpecificPackageDB dbfile -> "package-db " ++ dbfile
GhcEnvFileClearPackageDbStack -> "clear-package-db"
+
+class ExtraSourceClass e => SourcePath e where
+ sourcePath :: LocalBuildInfo -> e -> SymbolicPath Pkg 'File
+
+instance SourcePath (ExtraSource Pkg) where
+ sourcePath _ (ExtraSourcePkg f _) = f
+
+instance SourcePath (ExtraSource Build) where
+ sourcePath lbi (ExtraSourceBuild f _) = buildDir lbi </> f
diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs
index ca71857828e..967981ee045 100644
--- a/Cabal/src/Distribution/Simple/GHCJS.hs
+++ b/Cabal/src/Distribution/Simple/GHCJS.hs
@@ -60,6 +60,7 @@ import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
import Distribution.Simple.Flag
+import Distribution.Simple.GHC.Build.Utils (isCxx)
import Distribution.Simple.GHC.EnvironmentParser
import Distribution.Simple.GHC.ImplInfo
import qualified Distribution.Simple.GHC.Internal as Internal
@@ -509,8 +510,6 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do
-- See Note [Symbolic paths] in Distribution.Utils.Path
i = interpretSymbolicPathLBI lbi
- u :: SymbolicPathX allowAbs Pkg to -> FilePath
- u = getSymbolicPath
(ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
let runGhcjsProg = runGHC verbosity ghcjsProg comp platform mbWorkDir
@@ -538,7 +537,7 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do
-- modules?
let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi)
jsSrcs = jsSources libBi
- cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cLikeFiles
+ cObjs = map ((`replaceExtensionSymbolicPath` objExtension) . extraSourceFile) cLikeFiles
baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir
linkJsLibOpts =
mempty
@@ -546,9 +545,9 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do
[ "-link-js-lib"
, getHSLibraryName uid
, "-js-lib-outputdir"
- , u libTargetDir
+ , getSymbolicPath libTargetDir
]
- ++ map u jsSrcs
+ ++ foldMap (\e -> getSymbolicPath (extraSourceFile e) : extraSourceOpts e) jsSrcs
}
vanillaOptsNoJsLib =
baseOpts
@@ -702,7 +701,7 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do
info verbosity "Linking..."
let cSharedObjs =
map
- ((`replaceExtensionSymbolicPath` ("dyn_" ++ objExtension)))
+ ((`replaceExtensionSymbolicPath` ("dyn_" ++ objExtension)) . extraSourceFile)
(cSources libBi ++ cxxSources libBi)
compiler_id = compilerId (compiler lbi)
sharedLibFilePath = libTargetDir </> makeRelativePathEx (mkSharedLibName (hostPlatform lbi) compiler_id uid)
@@ -1115,8 +1114,8 @@ decodeMainIsArg arg
--
-- Used to correctly build and link sources.
data BuildSources = BuildSources
- { cSourcesFiles :: [SymbolicPath Pkg File]
- , cxxSourceFiles :: [SymbolicPath Pkg File]
+ { cSourcesFiles :: [ExtraSource Pkg]
+ , cxxSourceFiles :: [ExtraSource Pkg]
, inputSourceFiles :: [SymbolicPath Pkg File]
, inputSourceModules :: [ModuleName]
}
@@ -1162,12 +1161,12 @@ gbuildSources verbosity mbWorkDir pkgId specVer tmpDir bm =
-- have no excuse anymore to keep doing it wrong... ;-)
warn verbosity $
"Enabling workaround for Main module '"
- ++ prettyShow mainModName
- ++ "' listed in 'other-modules' illegally!"
+ ++ prettyShow mainModName
+ ++ "' listed in 'other-modules' illegally!"
return
BuildSources
- { cSourcesFiles = cSources bnfo
+ { cSourcesFiles = cSources bnfo
, cxxSourceFiles = cxxSources bnfo
, inputSourceFiles = [main]
, inputSourceModules = filter (/= mainModName) $ exeModules exe
@@ -1182,11 +1181,11 @@ gbuildSources verbosity mbWorkDir pkgId specVer tmpDir bm =
}
else
let (csf, cxxsf)
- | isCxx (getSymbolicPath main) = (cSources bnfo, main : cxxSources bnfo)
+ | isCxx (getSymbolicPath main) = (cSources bnfo, ExtraSourcePkg main [] : cxxSources bnfo)
-- if main is not a Haskell source
-- and main is not a C++ source
-- then we assume that it is a C source
- | otherwise = (main : cSources bnfo, cxxSources bnfo)
+ | otherwise = (ExtraSourcePkg main [] : cSources bnfo, cxxSources bnfo)
in return
BuildSources
{ cSourcesFiles = csf
@@ -1204,9 +1203,6 @@ gbuildSources verbosity mbWorkDir pkgId specVer tmpDir bm =
, inputSourceModules = foreignLibModules flib
}
- isCxx :: FilePath -> Bool
- isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"]
-
-- | FilePath has a Haskell extension: .hs or .lhs
isHaskell :: FilePath -> Bool
isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"]
@@ -1267,8 +1263,8 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
inputModules = inputSourceModules buildSources
isGhcDynamic = isDynamic comp
dynamicTooSupported = supportsDynamicToo comp
- cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cSrcs
- cxxObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cxxSrcs
+ cObjs = map ((`replaceExtensionSymbolicPath` objExtension) . extraSourceFile) cSrcs
+ cxxObjs = map ((`replaceExtensionSymbolicPath` objExtension) . extraSourceFile) cxxSrcs
needDynamic = gbuildNeedDynamic lbi bm
needProfiling = withProfExe lbi
@@ -1470,7 +1466,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
-- add a warning if this occurs.
odir = fromFlag (ghcOptObjDir opts)
createDirectoryIfMissingVerbose verbosity True (i odir)
- needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts
+ needsRecomp <- checkNeedsRecompilation mbWorkDir (extraSourceFile filename) opts
when needsRecomp $
runGhcProg opts
| filename <- cxxSrcs
@@ -1512,7 +1508,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
| otherwise = vanillaCcOpts
odir = fromFlag (ghcOptObjDir opts)
createDirectoryIfMissingVerbose verbosity True (i odir)
- needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts
+ needsRecomp <- checkNeedsRecompilation mbWorkDir (extraSourceFile filename) opts
when needsRecomp $
runGhcProg opts
| filename <- cSrcs
diff --git a/Cabal/src/Distribution/Simple/PackageIndex.hs b/Cabal/src/Distribution/Simple/PackageIndex.hs
index a7d23962b72..7cb606a0e93 100644
--- a/Cabal/src/Distribution/Simple/PackageIndex.hs
+++ b/Cabal/src/Distribution/Simple/PackageIndex.hs
@@ -169,7 +169,6 @@ instance Semigroup (PackageIndex IPI.InstalledPackageInfo) where
{-# NOINLINE invariant #-}
invariant :: WithCallStack (InstalledPackageIndex -> Bool)
invariant (PackageIndex pids pnames) =
- -- trace (show pids' ++ "\n" ++ show pnames') $
pids' == pnames'
where
pids' = map installedUnitId (Map.elems pids)
@@ -324,6 +323,10 @@ deleteUnitId ipkgid original@(PackageIndex pids pnames) =
. List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined
-- | Removes all packages with this source 'PackageId' from the index.
+--
+-- The Index maps unitids to instances, however we may have multiple unitids
+-- for the same package. Especially if for multiple compilers, as such we need
+-- to ensure we don't delete by name/version, but by name/version/compiler only.
deleteSourcePackageId
:: PackageId
-> InstalledPackageIndex
@@ -334,17 +337,30 @@ deleteSourcePackageId pkgid original@(PackageIndex pids pnames) =
Nothing -> original
Just pvers -> case Map.lookup (packageVersion pkgid) pvers of
Nothing -> original
- Just pkgs ->
- mkPackageIndex
- (foldl' (flip (Map.delete . installedUnitId)) pids pkgs)
- (deletePkgName pnames)
+ Just pkgs -> case [pkg | pkg <- pkgs, IPI.pkgCompiler pkg == pkgCompiler pkgid] of
+ [] -> original
+ pkgs' ->
+ mkPackageIndex
+ (foldl' (flip (Map.delete . installedUnitId)) pids pkgs')
+ (deletePkgName pnames)
+
where
deletePkgName =
Map.update deletePkgVersion (packageName pkgid, LMainLibName)
+ deletePkgVersion :: Map Version [IPI.InstalledPackageInfo] -> Maybe (Map Version [IPI.InstalledPackageInfo])
deletePkgVersion =
(\m -> if Map.null m then Nothing else Just m)
- . Map.delete (packageVersion pkgid)
+ . Map.update deletePkgInstances (packageVersion pkgid)
+
+ deletePkgInstance :: IPI.InstalledPackageInfo -> Maybe IPI.InstalledPackageInfo
+ deletePkgInstance ipi
+ | pkgCompiler pkgid /= pkgCompiler (IPI.sourcePackageId ipi) = Just ipi
+ | otherwise = Nothing
+
+ deletePkgInstances :: [IPI.InstalledPackageInfo] -> Maybe [IPI.InstalledPackageInfo]
+ deletePkgInstances xs = if null xs' then Nothing else Just xs'
+ where xs' = [x | x <- xs, pkgCompiler pkgid /= IPI.pkgCompiler x]
-- | Removes all packages with this (case-sensitive) name from the index.
--
diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs
index c76b38e9923..bc5d0714aa3 100644
--- a/Cabal/src/Distribution/Simple/Program/Db.hs
+++ b/Cabal/src/Distribution/Simple/Program/Db.hs
@@ -67,6 +67,7 @@ module Distribution.Simple.Program.Db
, ConfiguredProgs
, updateUnconfiguredProgs
, updateConfiguredProgs
+ , programDbSignature
) where
import Distribution.Compat.Prelude
@@ -564,3 +565,17 @@ requireProgramVersion verbosity prog range programDb =
join $
either (dieWithException verbosity) return
`fmap` lookupProgramVersion verbosity prog range programDb
+
+-- | Select the bits of a 'ProgramDb' to monitor for value changes.
+-- Use 'programsMonitorFiles' for the files to monitor.
+programDbSignature :: ProgramDb -> [ConfiguredProgram]
+programDbSignature progdb =
+ [ prog
+ { programMonitorFiles = []
+ , programOverrideEnv =
+ filter
+ ((/= "PATH") . fst)
+ (programOverrideEnv prog)
+ }
+ | prog <- configuredPrograms progdb
+ ]
diff --git a/Cabal/src/Distribution/Simple/Program/HcPkg.hs b/Cabal/src/Distribution/Simple/Program/HcPkg.hs
index a494bc63f02..8017850d16e 100644
--- a/Cabal/src/Distribution/Simple/Program/HcPkg.hs
+++ b/Cabal/src/Distribution/Simple/Program/HcPkg.hs
@@ -74,6 +74,7 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.List.NonEmpty as NE
import qualified System.FilePath.Posix as FilePath.Posix
+import GHC.Stack (HasCallStack)
-- | Information about the features and capabilities of an @hc-pkg@
-- program.
@@ -277,7 +278,7 @@ hide hpi verbosity mbWorkDir packagedb pkgid =
-- | Call @hc-pkg@ to get all the details of all the packages in the given
-- package database.
dump
- :: HcPkgInfo
+ :: HasCallStack => HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD (Dir from))
-> PackageDBX (SymbolicPath from (Dir PkgDB))
@@ -292,9 +293,9 @@ dump hpi verbosity mbWorkDir packagedb = do
case parsePackages output of
Left ok -> return ok
- _ -> dieWithException verbosity $ FailedToParseOutputDump (programId (hcPkgProgram hpi))
+ Right e -> dieWithException verbosity $ FailedToParseOutputDump (programId (hcPkgProgram hpi)) (unwords e)
-parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String]
+parsePackages :: HasCallStack => LBS.ByteString -> Either [InstalledPackageInfo] [String]
parsePackages lbs0 =
case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of
Right ok -> Left [setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok]
@@ -380,7 +381,7 @@ mungePackagePaths pkgroot pkginfo =
-- Older installed package info files did not have the installedUnitId
-- field, so if it is missing then we fill it as the source package ID.
-- NB: Internal libraries not supported.
-setUnitId :: InstalledPackageInfo -> InstalledPackageInfo
+setUnitId :: HasCallStack => InstalledPackageInfo -> InstalledPackageInfo
setUnitId
pkginfo@InstalledPackageInfo
{ installedUnitId = uid
@@ -389,7 +390,7 @@ setUnitId
| unUnitId uid == "" =
pkginfo
{ installedUnitId = mkLegacyUnitId pid
- , installedComponentId_ = mkComponentId (prettyShow pid)
+ , installedComponentId_ = Just (mkComponentId (prettyShow pid))
}
setUnitId pkginfo = pkginfo
diff --git a/Cabal/src/Distribution/Simple/Register.hs b/Cabal/src/Distribution/Simple/Register.hs
index 0bd7312cbc4..9a9b313d994 100644
--- a/Cabal/src/Distribution/Simple/Register.hs
+++ b/Cabal/src/Distribution/Simple/Register.hs
@@ -90,6 +90,7 @@ import System.FilePath (isAbsolute)
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
+import GHC.Stack (HasCallStack)
-- -----------------------------------------------------------------------------
-- Registration
@@ -163,7 +164,7 @@ generateOne pkg lib lbi clbi regFlags =
mbWorkDir = flagToMaybe $ setupWorkingDir common
registerAll
- :: PackageDescription
+ :: HasCallStack => PackageDescription
-> LocalBuildInfo
-> RegisterFlags
-> [InstalledPackageInfo]
@@ -496,9 +497,10 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi
IPI.InstalledPackageInfo
{ IPI.sourcePackageId = packageId pkg
, IPI.installedUnitId = componentUnitId clbi
- , IPI.installedComponentId_ = componentComponentId clbi
+ , IPI.installedComponentId_ = Just (componentComponentId clbi)
, IPI.instantiatedWith = expectLibraryComponent (maybeComponentInstantiatedWith clbi)
, IPI.sourceLibName = libName lib
+ , IPI.unitFlags = flagAssignment lbi
, IPI.compatPackageKey = expectLibraryComponent (maybeComponentCompatPackageKey clbi)
, -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license
IPI.license =
@@ -553,6 +555,7 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi
, IPI.haddockHTMLs = [htmldir installDirs | hasModules]
, IPI.pkgRoot = Nothing
, IPI.libVisibility = libVisibility lib
+ , IPI.pkgCompiler = Nothing
}
where
ghc84 = case compilerId $ compiler lbi of
diff --git a/Cabal/src/Distribution/Simple/SrcDist.hs b/Cabal/src/Distribution/Simple/SrcDist.hs
index 67f901bf7fb..4e751ed1bbb 100644
--- a/Cabal/src/Distribution/Simple/SrcDist.hs
+++ b/Cabal/src/Distribution/Simple/SrcDist.hs
@@ -566,11 +566,11 @@ allSourcesBuildInfo verbosity rip mbWorkDir bi pps modules = do
return $
sources
++ catMaybes bootFiles
- ++ cSources bi
- ++ cxxSources bi
- ++ cmmSources bi
- ++ asmSources bi
- ++ jsSources bi
+ ++ map extraSourceFile (cSources bi)
+ ++ map extraSourceFile (cxxSources bi)
+ ++ map extraSourceFile (cmmSources bi)
+ ++ map extraSourceFile (asmSources bi)
+ ++ map extraSourceFile (jsSources bi)
where
nonEmpty' :: b -> ([a] -> b) -> [a] -> b
nonEmpty' x _ [] = x
diff --git a/Cabal/src/Distribution/Types/PackageName/Magic.hs b/Cabal/src/Distribution/Types/PackageName/Magic.hs
index 022a62468b1..908e82bea6f 100644
--- a/Cabal/src/Distribution/Types/PackageName/Magic.hs
+++ b/Cabal/src/Distribution/Types/PackageName/Magic.hs
@@ -21,4 +21,4 @@ fakePackageCabalFileName = "fake-package.cabal"
-- | 'fakePackageName' with 'version0'.
fakePackageId :: PackageId
-fakePackageId = PackageIdentifier fakePackageName version0
+fakePackageId = PackageIdentifier fakePackageName version0 Nothing
diff --git a/Cabal/src/main_configure.hs b/Cabal/src/main_configure.hs
new file mode 100644
index 00000000000..577b8311e90
--- /dev/null
+++ b/Cabal/src/main_configure.hs
@@ -0,0 +1,4 @@
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMainWithHooks autoconfUserHooks
diff --git a/Cabal/src/main_simple.hs b/Cabal/src/main_simple.hs
new file mode 100644
index 00000000000..00bfe1fe441
--- /dev/null
+++ b/Cabal/src/main_simple.hs
@@ -0,0 +1,4 @@
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
diff --git a/cabal-install-solver/cabal-install-solver.cabal b/cabal-install-solver/cabal-install-solver.cabal
index 3f3b84644cf..c1145254b6c 100644
--- a/cabal-install-solver/cabal-install-solver.cabal
+++ b/cabal-install-solver/cabal-install-solver.cabal
@@ -95,6 +95,8 @@ library
Distribution.Solver.Types.SolverId
Distribution.Solver.Types.SolverPackage
Distribution.Solver.Types.SourcePackage
+ Distribution.Solver.Types.Stage
+ Distribution.Solver.Types.Toolchain
Distribution.Solver.Types.Variable
build-depends:
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs
index 9111b2d78d0..73bb9c5b20b 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs
@@ -34,7 +34,7 @@ import Distribution.Solver.Modular.IndexConversion
import Distribution.Solver.Modular.Log
( SolverFailure(..), displayLogMessages )
import Distribution.Solver.Modular.Package
- ( PN )
+ ( PN, showPI, I )
import Distribution.Solver.Modular.RetryLog
import Distribution.Solver.Modular.Solver
( SolverConfig(..), PruneAfterFirstSuccess(..), solve )
@@ -54,17 +54,44 @@ import Distribution.Simple.Setup
import Distribution.Simple.Utils
( ordNubBy )
import Distribution.Verbosity
+import Distribution.Solver.Modular.Configured (CP (..))
+import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps
+import Distribution.Pretty (Pretty (..), prettyShow)
+import Text.PrettyPrint (text, vcat, Doc, nest, ($+$))
+import Distribution.Solver.Types.OptionalStanza (showStanzas, optStanzaSetNull)
+import Distribution.Solver.Types.Toolchain ( Toolchains )
+import Distribution.Types.Flag (nullFlagAssignment)
+showCP :: CP QPN -> Doc
+showCP (CP qpi fa es ds) =
+ text "package:" <+> text (showPI qpi) $+$ nest 2 (
+ vcat
+ [ if nullFlagAssignment fa then mempty else text "flags:" <+> pretty fa
+ , if optStanzaSetNull es then mempty else text "stanzas:" <+> text (showStanzas es)
+ , vcat
+ [ text "component" <+> pretty c $+$
+ nest 2 (text "dependencies" $+$
+ nest 2 (vcat [ text (showPI dep) | dep <- deps]))
+ | (c, deps) <- ComponentDeps.toList ds
+ ]
+ ])
+
-- | Ties the two worlds together: classic cabal-install vs. the modular
-- solver. Performs the necessary translations before and after.
modularResolver :: SolverConfig -> DependencyResolver loc
-modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =
- uncurry postprocess <$> -- convert install plan
- solve' sc cinfo idx pkgConfigDB pprefs gcs pns
- where
+modularResolver sc toolchains biidx iidx sidx pkgConfigDB pprefs pcs pns = do
+ (assignment, revdepmap) <- solve' sc toolchains idx pkgConfigDB pprefs gcs pns
+ let cp = toCPs assignment revdepmap
+ Step (show (vcat (map showCP cp))) $
+ return $ postprocess assignment revdepmap
+ where
+ showIdx :: Index -> String
+ showIdx idx = unlines [prettyShow pn ++ ": " ++ show i
+ | (pn, m) <- M.toList idx
+ , (i, _info) <- M.toList (m :: Map I PInfo)]
-- Indices have to be converted into solver-specific uniform index.
- idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
+ idx = convPIs toolchains gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) biidx iidx sidx
-- Constraints have to be converted into a finite map indexed by PN.
gcs = M.fromListWith (++) (map pair pcs)
where
@@ -74,7 +101,7 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns
-- package qualifiers, which means that linked packages become duplicates
-- and can be removed.
postprocess a rdm = ordNubBy nodeKey $
- map (convCP iidx sidx) (toCPs a rdm)
+ map (convCP toolchains biidx iidx sidx) (toCPs a rdm)
-- Helper function to extract the PN from a constraint.
pcName :: PackageConstraint -> PN
@@ -114,21 +141,21 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns
-- complete, i.e., it shows the whole chain of dependencies from the user
-- targets to the conflicting packages.
solve' :: SolverConfig
- -> CompilerInfo
+ -> Toolchains
-> Index
-> Maybe PkgConfigDb
-> (PN -> PackagePreferences)
-> Map PN [LabeledPackageConstraint]
-> Set PN
-> Progress String String (Assignment, RevDepMap)
-solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
+solve' sc toolchains idx pkgConfigDB pprefs gcs pns =
toProgress $ retry (runSolver printFullLog sc) createErrorMsg
where
runSolver :: Bool -> SolverConfig
-> RetryLog String SolverFailure (Assignment, RevDepMap)
runSolver keepLog sc' =
displayLogMessages keepLog $
- solve sc' cinfo idx pkgConfigDB pprefs gcs pns
+ solve sc' toolchains idx pkgConfigDB pprefs gcs pns
createErrorMsg :: SolverFailure
-> RetryLog String String (Assignment, RevDepMap)
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs
index 5d196f4fd9f..9de9ea16ee2 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs
@@ -50,8 +50,7 @@ data BuildState = BS {
index :: Index, -- ^ information about packages and their dependencies
rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies
open :: [OpenGoal], -- ^ set of still open goals (flag and package goals)
- next :: BuildType, -- ^ kind of node to generate next
- qualifyOptions :: QualifyOptions -- ^ qualification options
+ next :: BuildType -- ^ kind of node to generate next
}
-- | Map of available linking targets.
@@ -105,7 +104,7 @@ scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo ->
scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s
where
-- Qualify all package names
- qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps
+ qfdeps = qualifyDeps qpn fdeps
-- Introduce all package flags
qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs
-- Combine new package and flag goals
@@ -255,7 +254,6 @@ buildTree idx (IndependentGoals ind) igs =
, rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns)
, open = L.map topLevelGoal qpns
, next = Goals
- , qualifyOptions = defaultQualifyOptions idx
}
, linkingState = M.empty
}
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs
index 0e2e8ad5baa..32148c4dce8 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs
@@ -6,8 +6,6 @@ import Data.Maybe
import Prelude hiding (pi)
import Data.Either (partitionEithers)
-import Distribution.Package (UnitId, packageId)
-
import qualified Distribution.Simple.PackageIndex as SI
import Distribution.Solver.Modular.Configured
@@ -21,44 +19,51 @@ import Distribution.Solver.Types.SolverId
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.InstSolverPackage
import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.Toolchain
+import Control.Applicative ((<|>))
-- | Converts from the solver specific result @CP QPN@ into
-- a 'ResolverPackage', which can then be converted into
-- the install plan.
-convCP :: SI.InstalledPackageIndex ->
- CI.PackageIndex (SourcePackage loc) ->
- CP QPN -> ResolverPackage loc
-convCP iidx sidx (CP qpi fa es ds) =
- case convPI qpi of
- Left pi -> PreExisting $
+convCP :: Toolchains
+ -> SI.InstalledPackageIndex -- ^ build
+ -> SI.InstalledPackageIndex -- ^ host
+ -> CI.PackageIndex (SourcePackage loc)
+ -> CP QPN -> ResolverPackage loc
+convCP toolchains biidx iidx sidx (CP qpi fa es ds) =
+ case qpi of
+ -- Installed
+ (PI qpn (I _stage _ (Inst pi))) ->
+ PreExisting $
InstSolverPackage {
- instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi,
+ instSolverQPN = qpn,
+ instSolverPkgIPI = fromMaybe (error "convCP: lookupUnitId failed") $ (SI.lookupUnitId iidx pi) <|> (SI.lookupUnitId biidx pi),
instSolverPkgLibDeps = fmap fst ds',
instSolverPkgExeDeps = fmap snd ds'
}
- Right pi -> Configured $
+ -- "In repo" i.e. a source package
+ (PI qpn@(Q _path pn) (I stage v InRepo)) ->
+ let pi = PackageIdentifier pn v (Just $ compilerIdFor stage toolchains) in
+ Configured $
SolverPackage {
- solverPkgSource = srcpkg,
+ solverPkgQPN = qpn,
+ solverPkgStage = stage,
+ solverPkgSource = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi,
solverPkgFlags = fa,
solverPkgStanzas = es,
solverPkgLibDeps = fmap fst ds',
solverPkgExeDeps = fmap snd ds'
}
- where
- srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi
where
ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -})
- ds' = fmap (partitionEithers . map convConfId) ds
-
-convPI :: PI QPN -> Either UnitId PackageId
-convPI (PI _ (I _ (Inst pi))) = Left pi
-convPI pi = Right (packageId (either id id (convConfId pi)))
+ ds' = fmap (partitionEithers . map (convConfId toolchains)) ds
-convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -}
-convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) =
+convConfId :: Toolchains -> PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -}
+convConfId toolchains (PI (Q (PackagePath _ q) pn) (I stage v loc)) =
case loc of
- Inst pi -> Left (PreExistingId sourceId pi)
- _otherwise
+ Inst pi ->
+ Left (PreExistingId sourceId pi)
+ InRepo
| QualExe _ pn' <- q
-- NB: the dependencies of the executable are also
-- qualified. So the way to tell if this is an executable
@@ -67,6 +72,6 @@ convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) =
-- silly and didn't allow arbitrarily nested build-tools
-- dependencies, so a shallow check works.
, pn == pn' -> Right (PlannedId sourceId)
- | otherwise -> Left (PlannedId sourceId)
+ | otherwise -> Left (PlannedId sourceId)
where
- sourceId = PackageIdentifier pn v
+ sourceId = PackageIdentifier pn v (Just $ compilerIdFor stage toolchains)
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs
index 27debc9c6f0..78ac86c89f2 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs
@@ -1,34 +1,38 @@
{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE RecordWildCards #-}
-module Distribution.Solver.Modular.Dependency (
- -- * Variables
- Var(..)
+
+module Distribution.Solver.Modular.Dependency
+ ( -- * Variables
+ Var (..)
, showVar
, varPN
+
-- * Conflict sets
, ConflictSet
, ConflictMap
, CS.showConflictSet
+
-- * Constrained instances
- , CI(..)
+ , CI (..)
+
-- * Flagged dependencies
, FlaggedDeps
- , FlaggedDep(..)
- , LDep(..)
- , Dep(..)
- , PkgComponent(..)
- , ExposedComponent(..)
- , DependencyReason(..)
+ , FlaggedDep (..)
+ , LDep (..)
+ , Dep (..)
+ , PkgComponent (..)
+ , ExposedComponent (..)
+ , DependencyReason (..)
, showDependencyReason
, flattenFlaggedDeps
- , QualifyOptions(..)
, qualifyDeps
, unqualifyDeps
+
-- * Reverse dependency map
, RevDepMap
+
-- * Goals
- , Goal(..)
- , GoalReason(..)
+ , Goal (..)
+ , GoalReason (..)
, QGoalReason
, goalToVar
, varToConflictSet
@@ -39,21 +43,21 @@ module Distribution.Solver.Modular.Dependency (
, dependencyReasonToConflictSetWithVersionConflict
) where
-import Prelude ()
import qualified Data.Map as M
import qualified Data.Set as S
import Distribution.Solver.Compat.Prelude hiding (pi)
+import Prelude ()
-import Language.Haskell.Extension (Extension(..), Language(..))
+import Language.Haskell.Extension (Extension (..), Language (..))
-import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap)
+import Distribution.Solver.Modular.ConflictSet (ConflictMap, ConflictSet)
+import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Var
import Distribution.Solver.Modular.Version
-import qualified Distribution.Solver.Modular.ConflictSet as CS
-import Distribution.Solver.Types.ComponentDeps (Component(..))
+import Distribution.Solver.Types.ComponentDeps (Component (..))
import Distribution.Solver.Types.PackagePath
import Distribution.Types.LibraryName
import Distribution.Types.PkgconfigVersionRange
@@ -85,14 +89,14 @@ type FlaggedDeps qpn = [FlaggedDep qpn]
-- | Flagged dependencies can either be plain dependency constraints,
-- or flag-dependent dependency trees.
-data FlaggedDep qpn =
- -- | Dependencies which are conditional on a flag choice.
+data FlaggedDep qpn
+ = -- | Dependencies which are conditional on a flag choice.
Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)
- -- | Dependencies which are conditional on whether or not a stanza
+ | -- | Dependencies which are conditional on whether or not a stanza
-- (e.g., a test suite or benchmark) is enabled.
- | Stanza (SN qpn) (TrueFlaggedDeps qpn)
- -- | Dependencies which are always enabled, for the component 'comp'.
- | Simple (LDep qpn) Component
+ Stanza (SN qpn) (TrueFlaggedDeps qpn)
+ | -- | Dependencies which are always enabled, for the component 'comp'.
+ Simple (LDep qpn) Component
-- | Conservatively flatten out flagged dependencies
--
@@ -102,10 +106,10 @@ flattenFlaggedDeps = concatMap aux
where
aux :: FlaggedDep qpn -> [(LDep qpn, Component)]
aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f
- aux (Stanza _ t) = flattenFlaggedDeps t
- aux (Simple d c) = [(d, c)]
+ aux (Stanza _ t) = flattenFlaggedDeps t
+ aux (Simple d c) = [(d, c)]
-type TrueFlaggedDeps qpn = FlaggedDeps qpn
+type TrueFlaggedDeps qpn = FlaggedDeps qpn
type FalseFlaggedDeps qpn = FlaggedDeps qpn
-- | A 'Dep' labeled with the reason it was introduced.
@@ -119,11 +123,16 @@ data LDep qpn = LDep (DependencyReason qpn) (Dep qpn)
-- | A dependency (constraint) associates a package name with a constrained
-- instance. It can also represent other types of dependencies, such as
-- dependencies on language extensions.
-data Dep qpn = Dep (PkgComponent qpn) CI -- ^ dependency on a package component
- | Ext Extension -- ^ dependency on a language extension
- | Lang Language -- ^ dependency on a language version
- | Pkg PkgconfigName PkgconfigVersionRange -- ^ dependency on a pkg-config package
- deriving Functor
+data Dep qpn
+ = -- | dependency on a package component
+ Dep (PkgComponent qpn) CI
+ | -- | dependency on a language extension
+ Ext Extension
+ | -- | dependency on a language version
+ Lang Language
+ | -- | dependency on a pkg-config package
+ Pkg PkgconfigName PkgconfigVersionRange
+ deriving (Functor)
-- | An exposed component within a package. This type is used to represent
-- build-depends and build-tool-depends dependencies.
@@ -132,8 +141,8 @@ data PkgComponent qpn = PkgComponent qpn ExposedComponent
-- | A component that can be depended upon by another package, i.e., a library
-- or an executable.
-data ExposedComponent =
- ExposedLib LibraryName
+data ExposedComponent
+ = ExposedLib LibraryName
| ExposedExe UnqualComponentName
deriving (Eq, Ord, Show)
@@ -147,43 +156,25 @@ data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Sta
-- | Print the reason that a dependency was introduced.
showDependencyReason :: DependencyReason QPN -> String
showDependencyReason (DependencyReason qpn flags stanzas) =
- intercalate " " $
- showQPN qpn
+ intercalate " " $
+ showQPN qpn
: map (uncurry showFlagValue) (M.toList flags)
- ++ map (\s -> showSBool s True) (S.toList stanzas)
-
--- | Options for goal qualification (used in 'qualifyDeps')
---
--- See also 'defaultQualifyOptions'
-data QualifyOptions = QO {
- -- | Do we have a version of base relying on another version of base?
- qoBaseShim :: Bool
-
- -- Should dependencies of the setup script be treated as independent?
- , qoSetupIndependent :: Bool
- }
- deriving Show
+ ++ map (\s -> showSBool s True) (S.toList stanzas)
-- | Apply built-in rules for package qualifiers
--
--- Although the behaviour of 'qualifyDeps' depends on the 'QualifyOptions',
--- it is important that these 'QualifyOptions' are _static_. Qualification
--- does NOT depend on flag assignment; in other words, it behaves the same no
--- matter which choices the solver makes (modulo the global 'QualifyOptions');
--- we rely on this in 'linkDeps' (see comment there).
---
-- NOTE: It's the _dependencies_ of a package that may or may not be independent
-- from the package itself. Package flag choices must of course be consistent.
-qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN
-qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
+qualifyDeps :: QPN -> FlaggedDeps PN -> FlaggedDeps QPN
+qualifyDeps (Q pp@(PackagePath ns q) pn) = go
where
go :: FlaggedDeps PN -> FlaggedDeps QPN
go = map go1
go1 :: FlaggedDep PN -> FlaggedDep QPN
go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f)
- go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t)
- go1 (Simple dep comp) = Simple (goLDep dep comp) comp
+ go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t)
+ go1 (Simple dep comp) = Simple (goLDep dep comp) comp
-- Suppose package B has a setup dependency on package A.
-- This will be recorded as something like
@@ -197,15 +188,14 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp)
goD :: Dep PN -> Component -> Dep QPN
- goD (Ext ext) _ = Ext ext
- goD (Lang lang) _ = Lang lang
- goD (Pkg pkn vr) _ = Pkg pkn vr
+ goD (Ext ext) _ = Ext ext
+ goD (Lang lang) _ = Lang lang
+ goD (Pkg pkn vr) _ = Pkg pkn vr
goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ =
- Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci
- goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp
- | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) ci
- | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci
- | otherwise = Dep (Q (PackagePath ns inheritedQ ) <$> dep) ci
+ Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci
+ goD (Dep dep@(PkgComponent _qpn (ExposedLib _)) ci) comp
+ | comp == ComponentSetup = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci
+ | otherwise = Dep (Q (PackagePath ns inheritedQ) <$> dep) ci
-- If P has a setup dependency on Q, and Q has a regular dependency on R, then
-- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup
@@ -216,18 +206,10 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
-- a detailed discussion.
inheritedQ :: Qualifier
inheritedQ = case q of
- QualSetup _ -> q
- QualExe _ _ -> q
- QualToplevel -> q
- QualBase _ -> QualToplevel
-
- -- Should we qualify this goal with the 'Base' package path?
- qBase :: PN -> Bool
- qBase dep = qoBaseShim && unPackageName dep == "base"
-
- -- Should we qualify this goal with the 'Setup' package path?
- qSetup :: Component -> Bool
- qSetup comp = qoSetupIndependent && comp == ComponentSetup
+ QualSetup _ -> q
+ QualExe _ _ -> q
+ QualToplevel -> q
+ QualBase _ -> QualToplevel
-- | Remove qualifiers from set of dependencies
--
@@ -244,8 +226,8 @@ unqualifyDeps = go
go1 :: FlaggedDep QPN -> FlaggedDep PN
go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f)
- go1 (Stanza sn t) = Stanza (fmap unq sn) (go t)
- go1 (Simple dep comp) = Simple (goLDep dep) comp
+ go1 (Stanza sn t) = Stanza (fmap unq sn) (go t)
+ go1 (Simple dep comp) = Simple (goLDep dep) comp
goLDep :: LDep QPN -> LDep PN
goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep)
@@ -271,8 +253,8 @@ data Goal qpn = Goal (Var qpn) (GoalReason qpn)
deriving (Eq, Show, Functor)
-- | Reason why a goal is being added to a goal set.
-data GoalReason qpn =
- UserGoal -- introduced by a build target
+data GoalReason qpn
+ = UserGoal -- introduced by a build target
| DependencyGoal (DependencyReason qpn) -- introduced by a package
deriving (Eq, Show, Functor)
@@ -288,7 +270,7 @@ varToConflictSet = CS.singleton
-- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal
-- leads to a conflict.
goalReasonToConflictSet :: GoalReason QPN -> ConflictSet
-goalReasonToConflictSet UserGoal = CS.empty
+goalReasonToConflictSet UserGoal = CS.empty
goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr
-- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the
@@ -302,14 +284,14 @@ goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet
goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas))
| M.null flags && S.null stanzas =
CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal
-goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr
+goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr
-- | This function returns the solver variables responsible for the dependency.
-- It drops the values chosen for flag and stanza variables, which are only
-- needed for log messages.
dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet
dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) =
- CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas)
+ CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas)
where
-- Filter out any flags that introduced the dependency with both values.
-- They don't need to be included in the conflict set, because changing the
@@ -327,16 +309,19 @@ dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) =
-- This function currently only specifies the reason for the conflict in the
-- simple case where the 'DependencyReason' does not involve any flags or
-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'.
-dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN
- -> Ver
- -> DependencyReason QPN
- -> ConflictSet
dependencyReasonToConflictSetWithVersionConstraintConflict
- dependency excludedVersion dr@(DependencyReason qpn flags stanzas)
- | M.null flags && S.null stanzas =
- CS.singletonWithConflict (P qpn) $
- CS.VersionConstraintConflict dependency excludedVersion
- | otherwise = dependencyReasonToConflictSet dr
+ :: QPN
+ -> Ver
+ -> DependencyReason QPN
+ -> ConflictSet
+dependencyReasonToConflictSetWithVersionConstraintConflict
+ dependency
+ excludedVersion
+ dr@(DependencyReason qpn flags stanzas)
+ | M.null flags && S.null stanzas =
+ CS.singletonWithConflict (P qpn) $
+ CS.VersionConstraintConflict dependency excludedVersion
+ | otherwise = dependencyReasonToConflictSet dr
-- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the
-- conflict occurred because the conflict set variables introduced a version of
@@ -346,13 +331,16 @@ dependencyReasonToConflictSetWithVersionConstraintConflict
-- This function currently only specifies the reason for the conflict in the
-- simple case where the 'DependencyReason' does not involve any flags or
-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'.
-dependencyReasonToConflictSetWithVersionConflict :: QPN
- -> CS.OrderedVersionRange
- -> DependencyReason QPN
- -> ConflictSet
dependencyReasonToConflictSetWithVersionConflict
- pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas)
- | M.null flags && S.null stanzas =
- CS.singletonWithConflict (P qpn) $
- CS.VersionConflict pkgWithVersionConstraint constraint
- | otherwise = dependencyReasonToConflictSet dr
+ :: QPN
+ -> CS.OrderedVersionRange
+ -> DependencyReason QPN
+ -> ConflictSet
+dependencyReasonToConflictSetWithVersionConflict
+ pkgWithVersionConstraint
+ constraint
+ dr@(DependencyReason qpn flags stanzas)
+ | M.null flags && S.null stanzas =
+ CS.singletonWithConflict (P qpn) $
+ CS.VersionConflict pkgWithVersionConstraint constraint
+ | otherwise = dependencyReasonToConflictSet dr
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs
index 90038a28f5c..8dfa9c88bf3 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs
@@ -268,9 +268,9 @@ exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx
-- Skipping it is an optimization. If false, it returns a new conflict set
-- to be merged with the previous one.
couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet
- couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts =
+ couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I _stage v _) _) conflicts =
let (PInfo deps _ _ _) = idx M.! pn M.! i
- qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps
+ qdeps = qualifyDeps currentQPN deps
couldBeResolved :: CS.Conflict -> Maybe ConflictSet
couldBeResolved CS.OtherConflict = Nothing
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs
index 2f28d12de85..1f84e0ba161 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs
@@ -4,7 +4,6 @@ module Distribution.Solver.Modular.Index
, ComponentInfo(..)
, IsVisible(..)
, IsBuildable(..)
- , defaultQualifyOptions
, mkIndex
) where
@@ -58,17 +57,3 @@ mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi)))
groupMap :: Ord a => [(a, b)] -> Map a [b]
groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs)
-defaultQualifyOptions :: Index -> QualifyOptions
-defaultQualifyOptions idx = QO {
- qoBaseShim = or [ dep == base
- | -- Find all versions of base ..
- Just is <- [M.lookup base idx]
- -- .. which are installed ..
- , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is
- -- .. and flatten all their dependencies ..
- , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps
- ]
- , qoSetupIndependent = True
- }
- where
- base = mkPackageName "base"
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs
index 72d0b8193e3..f91b425f593 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs
@@ -14,6 +14,7 @@ import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.Compiler
import Distribution.Package -- from Cabal
import Distribution.Simple.BuildToolDepends -- from Cabal
+import Distribution.Simple.Compiler (compilerInfo)
import Distribution.Types.ExeDependency -- from Cabal
import Distribution.Types.PkgconfigDependency -- from Cabal
import Distribution.Types.ComponentName -- from Cabal
@@ -23,6 +24,7 @@ import Distribution.Types.MungedPackageName -- from Cabal
import Distribution.PackageDescription -- from Cabal
import Distribution.PackageDescription.Configuration
import qualified Distribution.Simple.PackageIndex as SI
+import Distribution.Simple.Compiler (compilerId)
import Distribution.System
import Distribution.Solver.Types.ComponentDeps
@@ -34,6 +36,7 @@ import Distribution.Solver.Types.PackageConstraint
import qualified Distribution.Solver.Types.PackageIndex as CI
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.Toolchain ( Toolchains(..), Toolchain(..) )
import Distribution.Solver.Modular.Dependency as D
import Distribution.Solver.Modular.Flag as F
@@ -53,21 +56,26 @@ import Distribution.Solver.Modular.Version
-- resolving these situations. However, the right thing to do is to
-- fix the problem there, so for now, shadowing is only activated if
-- explicitly requested.
-convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
+convPIs :: Toolchains -> Map PN [LabeledPackageConstraint]
-> ShadowPkgs -> StrongFlags -> SolveExecutables
- -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc)
+ -> SI.InstalledPackageIndex -- ^ build
+ -> SI.InstalledPackageIndex -- ^ host
+ -> CI.PackageIndex (SourcePackage loc)
-> Index
-convPIs os arch comp constraints sip strfl solveExes iidx sidx =
- mkIndex $
- convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx
+convPIs toolchains constraints sip strfl solveExes biidx iidx sidx =
+ mkIndex $ bipis ++ hipis ++ spis
+ where bipis = convIPI' toolchains sip biidx
+ hipis = convIPI' toolchains sip iidx
+ ipis = bipis ++ hipis
+ spis = convSPI' toolchains constraints strfl solveExes sidx
-- | Convert a Cabal installed package index to the simpler,
-- more uniform index format of the solver.
-convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)]
-convIPI' (ShadowPkgs sip) idx =
+convIPI' :: Toolchains -> ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)]
+convIPI' toolchains (ShadowPkgs sip) idx =
-- apply shadowing whenever there are multiple installed packages with
-- the same version
- [ maybeShadow (convIP idx pkg)
+ [ maybeShadow (convIP toolchains idx pkg)
-- IMPORTANT to get internal libraries. See
-- Note [Index conversion with internal libraries]
| (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx
@@ -80,16 +88,20 @@ convIPI' (ShadowPkgs sip) idx =
shadow x = x
-- | Extract/recover the package ID from an installed package info, and convert it to a solver's I.
-convId :: IPI.InstalledPackageInfo -> (PN, I)
-convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi)
- where MungedPackageId mpn ver = mungedId ipi
+convId :: Toolchains -> IPI.InstalledPackageInfo -> (PN, I)
+convId toolchains ipi = (pn, I stage ver $ Inst $ IPI.installedUnitId ipi)
+ where MungedPackageId mpn ver compid = mungedId ipi
-- HACK. See Note [Index conversion with internal libraries]
pn = encodeCompatPackageName mpn
+ stage = case IPI.pkgCompiler ipi of
+ Just c | c == compilerId (toolchainCompiler (buildToolchain toolchains)) -> Build
+ Just c | c == compilerId (toolchainCompiler (hostToolchain toolchains)) -> Host
+ _ -> error "convId: unhandled compiler"
-- | Convert a single installed package into the solver-specific format.
-convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo)
-convIP idx ipi =
- case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of
+convIP :: Toolchains -> SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo)
+convIP toolchains idx ipi =
+ case traverse (convIPId toolchains (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of
Left u -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u)))
Right fds -> (pn, i, PInfo fds components M.empty Nothing)
where
@@ -101,7 +113,7 @@ convIP idx ipi =
, compIsBuildable = IsBuildable True
}
- (pn, i) = convId ipi
+ (pn, i) = convId toolchains ipi
-- 'sourceLibName' is unreliable, but for now we only really use this for
-- primary libs anyways
@@ -141,11 +153,11 @@ convIP idx ipi =
-- May return Nothing if the package can't be found in the index. That
-- indicates that the original package having this dependency is broken
-- and should be ignored.
-convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN)
-convIPId dr comp idx ipid =
+convIPId :: Toolchains -> DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN)
+convIPId toolchains dr comp idx ipid =
case SI.lookupUnitId idx ipid of
Nothing -> Left ipid
- Just ipi -> let (pn, i) = convId ipi
+ Just ipi -> let (pn, i) = convId toolchains ipi
name = ExposedLib LMainLibName -- TODO: Handle sub-libraries.
in Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp)
-- NB: something we pick up from the
@@ -153,31 +165,34 @@ convIPId dr comp idx ipid =
-- | Convert a cabal-install source package index to the simpler,
-- more uniform index format of the solver.
-convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
+convSPI' :: Toolchains -> Map PN [LabeledPackageConstraint]
-> StrongFlags -> SolveExecutables
-> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]
-convSPI' os arch cinfo constraints strfl solveExes =
- L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages
+convSPI' toolchains constraints strfl solveExes =
+ L.concatMap (convSP toolchains constraints strfl solveExes) . CI.allPackages
-- | Convert a single source package into the solver-specific format.
-convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
- -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)
-convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
- let i = I pv InRepo
- pkgConstraints = fromMaybe [] $ M.lookup pn constraints
- in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd)
+convSP :: Toolchains -> Map PN [LabeledPackageConstraint]
+ -> StrongFlags -> SolveExecutables -> SourcePackage loc -> [(PN, I, PInfo)]
+convSP toolchains constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv _compid) gpd _ _pl) =
+ let pkgConstraints = fromMaybe [] $ M.lookup pn constraints
+ in [(pn, I Host pv InRepo, convGPD (hostToolchain toolchains) pkgConstraints strfl solveExes pn gpd)
+ ,(pn, I Build pv InRepo, convGPD (buildToolchain toolchains) pkgConstraints strfl solveExes pn gpd)
+ ]
-- We do not use 'flattenPackageDescription' or 'finalizePD'
-- from 'Distribution.PackageDescription.Configuration' here, because we
-- want to keep the condition tree, but simplify much of the test.
-- | Convert a generic package description to a solver-specific 'PInfo'.
-convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint]
+convGPD :: Toolchain -> [LabeledPackageConstraint]
-> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription
-> PInfo
-convGPD os arch cinfo constraints strfl solveExes pn
+convGPD toolchain constraints strfl solveExes pn
(GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) =
let
+ cinfo = compilerInfo (toolchainCompiler toolchain)
+ (Platform arch os) = toolchainPlatform toolchain
fds = flagInfo strfl flags
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs
index 15514472c80..ead3e10c6d4 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs
@@ -61,8 +61,6 @@ data ValidateState = VS {
, vsLinks :: Map QPN LinkGroup
, vsFlags :: FAssignment
, vsStanzas :: SAssignment
- , vsQualifyOptions :: QualifyOptions
-
-- Saved qualified dependencies. Every time 'validateLinking' makes a
-- package choice, it qualifies the package's dependencies and saves them in
-- this map. Then the qualified dependencies are available for subsequent
@@ -101,7 +99,7 @@ validateLinking index = (`runReader` initVS) . go
goP qpn@(Q _pp pn) opt@(POption i _) r = do
vs <- ask
let PInfo deps _ _ _ = vsIndex vs ! pn ! i
- qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps
+ qdeps = qualifyDeps qpn deps
newSaved = M.insert qpn qdeps (vsSaved vs)
case execUpdateState (pickPOption qpn opt qdeps) vs of
Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
@@ -129,7 +127,6 @@ validateLinking index = (`runReader` initVS) . go
, vsLinks = M.empty
, vsFlags = M.empty
, vsStanzas = M.empty
- , vsQualifyOptions = defaultQualifyOptions index
, vsSaved = M.empty
}
@@ -275,8 +272,7 @@ linkDeps target = \deps -> do
requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
requalify deps = do
- vs <- get
- return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps)
+ return $ qualifyDeps target (unqualifyDeps deps)
pickFlag :: QFN -> Bool -> UpdateState ()
pickFlag qfn b = do
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs
index ccd0e4d4a70..3d2b3026c92 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE DeriveFunctor #-}
module Distribution.Solver.Modular.Package
( I(..)
+ , Stage(..)
, Loc(..)
, PackageId
, PackageIdentifier(..)
@@ -11,8 +12,6 @@ module Distribution.Solver.Modular.Package
, QPV
, instI
, makeIndependent
- , primaryPP
- , setupPP
, showI
, showPI
, unPN
@@ -26,6 +25,7 @@ import Distribution.Pretty (prettyShow)
import Distribution.Solver.Modular.Version
import Distribution.Solver.Types.PackagePath
+import Distribution.Solver.Types.Stage (Stage (..))
-- | A package name.
type PN = PackageName
@@ -51,14 +51,18 @@ type PId = UnitId
data Loc = Inst PId | InRepo
deriving (Eq, Ord, Show)
+showStage :: Stage -> String
+showStage Build = "[build]"
+showStage Host = "[host ]"
+
-- | Instance. A version number and a location.
-data I = I Ver Loc
+data I = I Stage Ver Loc
deriving (Eq, Ord, Show)
-- | String representation of an instance.
showI :: I -> String
-showI (I v InRepo) = showVer v
-showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid
+showI (I s v InRepo) = showStage s ++ showVer v
+showI (I s v (Inst uid)) = showStage s ++ showVer v ++ "/installed" ++ extractPackageAbiHash uid
where
extractPackageAbiHash xs =
case first reverse $ break (=='-') $ reverse (prettyShow xs) of
@@ -74,31 +78,8 @@ showPI :: PI QPN -> String
showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i
instI :: I -> Bool
-instI (I _ (Inst _)) = True
-instI _ = False
-
--- | Is the package in the primary group of packages. This is used to
--- determine (1) if we should try to establish stanza preferences
--- for this goal, and (2) whether or not a user specified @--constraint@
--- should apply to this dependency (grep 'primaryPP' to see the
--- use sites). In particular this does not include packages pulled in
--- as setup deps.
---
-primaryPP :: PackagePath -> Bool
-primaryPP (PackagePath _ns q) = go q
- where
- go QualToplevel = True
- go (QualBase _) = True
- go (QualSetup _) = False
- go (QualExe _ _) = False
-
--- | Is the package a dependency of a setup script. This is used to
--- establish whether or not certain constraints should apply to this
--- dependency (grep 'setupPP' to see the use sites).
---
-setupPP :: PackagePath -> Bool
-setupPP (PackagePath _ns (QualSetup _)) = True
-setupPP (PackagePath _ns _) = False
+instI (I _ _ (Inst _)) = True
+instI _ = False
-- | Qualify a target package with its own name so that its dependencies are not
-- required to be consistent with other targets.
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs
index 9e0d5fb4d22..e17287324f5 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs
@@ -15,6 +15,7 @@ module Distribution.Solver.Modular.Preference
, onlyConstrained
, sortGoals
, pruneAfterFirstSuccess
+ , pruneHostFromSetup
) where
import Prelude ()
@@ -72,7 +73,7 @@ addWeight :: (PN -> [Ver] -> POption -> Weight) -> EndoTreeTrav d c
addWeight f = addWeights [f]
version :: POption -> Ver
-version (POption (I v _) _) = v
+version (POption (I _ v _) _) = v
-- | Prefer to link packages whenever possible.
preferLinked :: EndoTreeTrav d c
@@ -139,8 +140,8 @@ preferPackagePreferences pcs =
-- Prefer installed packages over non-installed packages.
installed :: POption -> Weight
- installed (POption (I _ (Inst _)) _) = 0
- installed _ = 1
+ installed (POption (I _ _ (Inst _)) _) = 0
+ installed _ = 1
-- | Traversal that tries to establish package stanza enable\/disable
-- preferences. Works by reordering the branches of stanza choices.
@@ -184,7 +185,7 @@ processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint s
else r
where
go :: I -> PackageProperty -> Tree d c
- go (I v _) (PackagePropertyVersion vr)
+ go (I _stage v _) (PackagePropertyVersion vr)
| checkVR vr v = r
| otherwise = Fail c (GlobalConstraintVersion vr src)
go _ PackagePropertyInstalled
@@ -338,15 +339,36 @@ avoidReinstalls p = go
| otherwise = PChoiceF qpn rdm gr cs
where
disableReinstalls =
- let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ]
+ let installed = [ v | (_, POption (I _stage v (Inst _)) _, _) <- W.toList cs ]
in W.mapWithKey (notReinstall installed) cs
- notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs =
+ notReinstall vs (POption (I _stage v InRepo) _) _ | v `elem` vs =
Fail (varToConflictSet (P qpn)) CannotReinstall
notReinstall _ _ x =
x
go x = x
+-- | Ensure that Setup (Build time) dependencies only have Build dependencies
+-- available and that Host dependencies only have Host dependencies available.
+-- We also do not want to use InRepo dependencies for setup/build-depends. This
+-- easily leads to cycles.
+pruneHostFromSetup :: EndoTreeTrav d c
+pruneHostFromSetup = go
+ where
+ -- for Setup(.hs) and build-depends, we want to force Build packages.
+ go (PChoiceF qpn rdm gr cs) | (Q (PackagePath _ (QualSetup _)) _) <- qpn =
+ PChoiceF qpn rdm gr (W.filterKey (not . isHost) cs)
+ -- QualExe are build-depends. Structure is QualExe (comp) (build-depend).
+ go (PChoiceF qpn rdm gr cs) | (Q (PackagePath _ (QualExe _ _)) _) <- qpn =
+ PChoiceF qpn rdm gr (W.filterKey (not . isHost) cs)
+ -- everything else use Host packages.
+ go (PChoiceF qpn rdm gr cs) | (Q (PackagePath _ _) _) <- qpn =
+ PChoiceF qpn rdm gr (W.filterKey isHost cs)
+ go x = x
+
+ isHost :: POption -> Bool
+ isHost (POption (I s _v _l) _) = s == Host
+
-- | Require all packages to be mentioned in a constraint or as a goal.
onlyConstrained :: (PN -> Bool) -> EndoTreeTrav d QGoalReason
onlyConstrained p = go
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs
index b2c89fc1537..d519456143f 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs
@@ -24,6 +24,7 @@ import Distribution.Solver.Types.PackagePreferences
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.Toolchain ( Toolchains(..), Toolchain(..), buildIsHost )
import Distribution.Solver.Types.Variable
import Distribution.Solver.Modular.Assignment
@@ -44,6 +45,9 @@ import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.PSQ as PSQ
import Distribution.Simple.Setup (BooleanFlag(..))
+import Distribution.Simple.Compiler (compilerInfo)
+
+import qualified Distribution.Solver.Modular.WeightedPSQ as W
#ifdef DEBUG_TRACETREE
import qualified Distribution.Solver.Modular.ConflictSet as CS
@@ -89,18 +93,19 @@ newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool
-- before exploration.
--
solve :: SolverConfig -- ^ solver parameters
- -> CompilerInfo
+ -> Toolchains
-> Index -- ^ all available packages as an index
-> Maybe PkgConfigDb -- ^ available pkg-config pkgs
-> (PN -> PackagePreferences) -- ^ preferences
-> M.Map PN [LabeledPackageConstraint] -- ^ global constraints
-> S.Set PN -- ^ global goals
-> RetryLog Message SolverFailure (Assignment, RevDepMap)
-solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
+solve sc toolchains idx pkgConfigDB userPrefs userConstraints userGoals =
explorePhase .
traceTree "cycles.json" id .
detectCycles .
traceTree "heuristics.json" id .
+ -- stageBuildDeps "post-pref: " .
trav (
heuristicsPhase .
preferencesPhase .
@@ -110,6 +115,9 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
validationCata .
traceTree "pruned.json" id .
trav prunePhase .
+ -- stageBuildDeps "post-prune: " .
+ (if buildIsHost toolchains then id else trav P.pruneHostFromSetup) .
+ -- stageBuildDeps "build: " .
traceTree "build.json" id $
buildPhase
where
@@ -137,7 +145,7 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
P.enforceManualFlags userConstraints
validationCata = P.enforceSingleInstanceRestriction .
validateLinking idx .
- validateTree cinfo idx pkgConfigDB
+ validateTree (compilerInfo (toolchainCompiler (hostToolchain toolchains))) idx pkgConfigDB
prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) .
(case onlyConstrained sc of
OnlyConstrainedAll ->
@@ -146,6 +154,32 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
id)
buildPhase = buildTree idx (independentGoals sc) (S.toList userGoals)
+ stageBuildDeps prefix = go
+ where go :: Tree d c -> Tree d c
+ -- For Setup we must use the build compiler, as the host compiler
+ -- may not be able to produce code that runs on the build machine.
+ go (PChoice qpn rdm gr cs) | (Q (PackagePath _ (QualSetup _)) _) <- qpn =
+ (PChoice qpn rdm gr (trace (prefix ++ show qpn ++ '\n':unlines (map (" - " ++) candidates)) (go <$> cs)))
+ where candidates = map show
+ -- . filter (\(I _s _v l) -> l /= InRepo)
+ . map (\(_w, (POption i _), _v) -> i) $ W.toList cs
+ -- Same for build-depends. These show up as QualExe (component) (build-depends).
+ go (PChoice qpn rdm gr cs) | (Q (PackagePath _ (QualExe _ _)) _) <- qpn =
+ (PChoice qpn rdm gr (trace (prefix ++ show qpn ++ '\n':unlines (map (" - " ++) candidates)) (go <$> cs)))
+ where candidates = map show
+ -- . filter (\(I _s _v l) -> l /= InRepo)
+ . map (\(_w, (POption i _), _v) -> i) $ W.toList cs
+ go (PChoice qpn rdm gr cs) =
+ (PChoice qpn rdm gr (go <$> cs))
+ go (FChoice qfn rdm gr t b d cs) =
+ FChoice qfn rdm gr t b d (go <$> cs)
+ go (SChoice qsn rdm gr t cs) =
+ SChoice qsn rdm gr t (go <$> cs)
+ go (GoalChoice rdm cs) =
+ GoalChoice rdm (go <$> cs)
+ go x@(Fail _ _) = x
+ go x@(Done _ _) = x
+
allExplicit = M.keysSet userConstraints `S.union` userGoals
pkgIsExplicit :: PN -> Bool
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs
index 4af149b31cf..e0ad47e32b8 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs
@@ -108,9 +108,7 @@ data ValidateState = VS {
-- Map from package name to the components that are required from that
-- package.
- requiredComponents :: Map QPN ComponentDependencyReasons,
-
- qualifyOptions :: QualifyOptions
+ requiredComponents :: Map QPN ComponentDependencyReasons
}
newtype Validate a = Validate (Reader ValidateState a)
@@ -200,11 +198,10 @@ validate = go
svd <- asks saved -- obtain saved dependencies
aComps <- asks availableComponents
rComps <- asks requiredComponents
- qo <- asks qualifyOptions
-- obtain dependencies and index-dictated exclusions introduced by the choice
let (PInfo deps comps _ mfr) = idx ! pn ! i
-- qualify the deps in the current scope
- let qdeps = qualifyDeps qo qpn deps
+ let qdeps = qualifyDeps qpn deps
-- the new active constraints are given by the instance we have chosen,
-- plus the dependency information we have for that instance
let newactives = extractAllDeps pfa psa qdeps
@@ -452,14 +449,14 @@ merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed
, ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1)
, ConflictingDep vs2 (PkgComponent p comp2) ci ) )
-merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr))
+merge (MergedDepFixed comp1 vs1 i@(I _stage v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr))
| checkVR vr v = Right $ MergedDepFixed comp1 vs1 i
| otherwise =
Left ( createConflictSetForVersionConflict p v vs1 vr vs2
, ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i)
, ConflictingDep vs2 (PkgComponent p comp2) ci ) )
-merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) =
+merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I _stage v _))) =
go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ...
where
go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
@@ -577,5 +574,4 @@ validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS {
, pa = PA M.empty M.empty M.empty
, availableComponents = M.empty
, requiredComponents = M.empty
- , qualifyOptions = defaultQualifyOptions idx
}
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs b/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs
index 94def7be196..747017148d7 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs
@@ -9,6 +9,7 @@ module Distribution.Solver.Modular.WeightedPSQ (
, weights
, isZeroOrOne
, filter
+ , filterKey
, lookup
, mapWithKey
, mapWeightsWithKey
@@ -34,6 +35,10 @@ newtype WeightedPSQ w k v = WeightedPSQ [(w, k, v)]
filter :: (v -> Bool) -> WeightedPSQ k w v -> WeightedPSQ k w v
filter p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_3) xs)
+-- | /O(N)/.
+filterKey :: (k -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v
+filterKey p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_2) xs)
+
-- | /O(1)/. Return @True@ if the @WeightedPSQ@ contains zero or one elements.
isZeroOrOne :: WeightedPSQ w k v -> Bool
isZeroOrOne (WeightedPSQ []) = True
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs
index 139a6d2b33d..3306ac620de 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs
@@ -16,6 +16,7 @@ import Distribution.Solver.Types.SourcePackage
import Distribution.Simple.PackageIndex ( InstalledPackageIndex )
import Distribution.Package ( PackageName )
import Distribution.Compiler ( CompilerInfo )
+import Distribution.Solver.Types.Toolchain ( Toolchains )
import Distribution.System ( Platform )
-- | A dependency resolver is a function that works out an installation plan
@@ -26,9 +27,9 @@ import Distribution.System ( Platform )
-- solving the package dependency problem and we want to make it easy to swap
-- in alternatives.
--
-type DependencyResolver loc = Platform
- -> CompilerInfo
- -> InstalledPackageIndex
+type DependencyResolver loc = Toolchains
+ -> InstalledPackageIndex -- ^ build
+ -> InstalledPackageIndex -- ^ host
-> PackageIndex (SourcePackage loc)
-> Maybe PkgConfigDb
-> (PackageName -> PackagePreferences)
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs
index 871a0dd15a9..868d1d9dfe2 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs
@@ -8,6 +8,7 @@ import Prelude ()
import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) )
import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )
+import Distribution.Solver.Types.PackagePath (QPN)
import Distribution.Solver.Types.SolverId
import Distribution.Types.MungedPackageId
import Distribution.Types.PackageId
@@ -17,6 +18,7 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo)
-- | An 'InstSolverPackage' is a pre-existing installed package
-- specified by the dependency solver.
data InstSolverPackage = InstSolverPackage {
+ instSolverQPN :: QPN,
instSolverPkgIPI :: InstalledPackageInfo,
instSolverPkgLibDeps :: ComponentDeps [SolverId],
instSolverPkgExeDeps :: ComponentDeps [SolverId]
@@ -29,8 +31,8 @@ instance Structured InstSolverPackage
instance Package InstSolverPackage where
packageId i =
-- HACK! See Note [Index conversion with internal libraries]
- let MungedPackageId mpn v = mungedId i
- in PackageIdentifier (encodeCompatPackageName mpn) v
+ let MungedPackageId mpn v compid = mungedId i
+ in PackageIdentifier (encodeCompatPackageName mpn) v compid
instance HasMungedPackageId InstSolverPackage where
mungedId = mungedId . instSolverPkgIPI
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs
index 06c5ae169fa..37c0d7dd1d7 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs
@@ -49,6 +49,9 @@ data ConstraintScope
-- | The package with the specified name when it has a
-- setup qualifier.
| ScopeAnySetupQualifier PackageName
+ -- | The package with the specified name when it is a build-time
+ -- dependency. E.g. a Setup script or a build-depends.
+ | ScopeAnyBuildDepQualifier PackageName
-- | The package with the specified name regardless of
-- qualifier.
| ScopeAnyQualifier PackageName
@@ -65,6 +68,7 @@ scopeToPackageName :: ConstraintScope -> PackageName
scopeToPackageName (ScopeTarget pn) = pn
scopeToPackageName (ScopeQualified _ pn) = pn
scopeToPackageName (ScopeAnySetupQualifier pn) = pn
+scopeToPackageName (ScopeAnyBuildDepQualifier pn) = pn
scopeToPackageName (ScopeAnyQualifier pn) = pn
constraintScopeMatches :: ConstraintScope -> QPN -> Bool
@@ -74,6 +78,12 @@ constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') =
in namespaceMatches ns && q == QualToplevel && pn == pn'
constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') =
q == q' && pn == pn'
+constraintScopeMatches (ScopeAnyBuildDepQualifier pn) (Q pp pn') =
+ let setup (PackagePath _ (QualSetup _)) = True
+ setup _ = False
+ build (PackagePath _ (QualExe _ _)) = True
+ build _ = False
+ in (setup pp || build pp) && pn == pn'
constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') =
let setup (PackagePath _ (QualSetup _)) = True
setup _ = False
@@ -83,6 +93,7 @@ constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn'
instance Pretty ConstraintScope where
pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn
pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn
+ pretty (ScopeAnyBuildDepQualifier pn) = Disp.text "build." <<>> pretty pn
pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn
pretty (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs
index 4fc4df25f97..05727ffe8c9 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveGeneric #-}
module Distribution.Solver.Types.PackagePath
( PackagePath(..)
, Namespace(..)
@@ -18,7 +20,10 @@ import qualified Text.PrettyPrint as Disp
-- | A package path consists of a namespace and a package path inside that
-- namespace.
data PackagePath = PackagePath Namespace Qualifier
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show, Generic)
+
+instance Binary PackagePath
+instance Structured PackagePath
-- | Top-level namespace
--
@@ -30,7 +35,10 @@ data Namespace =
-- | A namespace for a specific build target
| Independent PackageName
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show, Generic)
+
+instance Binary Namespace
+instance Structured Namespace
-- | Pretty-prints a namespace. The result is either empty or
-- ends in a period, so it can be prepended onto a qualifier.
@@ -68,7 +76,10 @@ data Qualifier =
-- tracked only @pn2@, that would require us to pick only one
-- version of an executable over the entire install plan.)
| QualExe PackageName PackageName
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show, Generic)
+
+instance Binary Qualifier
+instance Structured Qualifier
-- | Pretty-prints a qualifier. The result is either empty or
-- ends in a period, so it can be prepended onto a package name.
@@ -87,11 +98,14 @@ dispQualifier (QualBase pn) = pretty pn <<>> Disp.text "."
-- | A qualified entity. Pairs a package path with the entity.
data Qualified a = Q PackagePath a
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show, Generic)
-- | Qualified package name.
type QPN = Qualified PackageName
+instance Binary (Qualified PackageName)
+instance Structured (Qualified PackageName)
+
-- | Pretty-prints a qualified package name.
dispQPN :: QPN -> Disp.Doc
dispQPN (Q (PackagePath ns qual) pn) =
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs
index 186f140aefe..956bc5dff6e 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs
@@ -10,8 +10,10 @@ import Distribution.Package ( Package(..) )
import Distribution.PackageDescription ( FlagAssignment )
import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )
import Distribution.Solver.Types.OptionalStanza
+import Distribution.Solver.Types.PackagePath (QPN)
import Distribution.Solver.Types.SolverId
import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.Stage (Stage (..))
-- | A 'SolverPackage' is a package specified by the dependency solver.
-- It will get elaborated into a 'ConfiguredPackage' or even an
@@ -21,6 +23,8 @@ import Distribution.Solver.Types.SourcePackage
-- but for symmetry we have the parameter. (Maybe it can be removed.)
--
data SolverPackage loc = SolverPackage {
+ solverPkgQPN :: QPN,
+ solverPkgStage :: Stage,
solverPkgSource :: SourcePackage loc,
solverPkgFlags :: FlagAssignment,
solverPkgStanzas :: OptionalStanzaSet,
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs b/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs
new file mode 100644
index 00000000000..b2595a33089
--- /dev/null
+++ b/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Distribution.Solver.Types.Stage
+ ( Stage (..)
+ ) where
+
+import Distribution.Compat.Prelude
+import Prelude ()
+
+data Stage
+ = -- | -- The system where the build is running
+ Build
+ | -- | -- The system where the built artifacts will run
+ Host
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Binary Stage
+instance Structured Stage
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs
new file mode 100644
index 00000000000..e965e54bee5
--- /dev/null
+++ b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Distribution.Solver.Types.Toolchain
+ ( Toolchain (..)
+ , Toolchains (..)
+ , toolchainFor
+ , compilerIdFor
+ , mkToolchainsWithHost
+ , buildIsHost
+ ) where
+
+import Distribution.Compat.Prelude
+import Prelude ()
+
+import Distribution.Simple.Compiler
+import Distribution.Simple.Program.Db
+import Distribution.Solver.Types.Stage (Stage (..))
+import Distribution.System
+
+---------------------------
+-- Toolchain
+--
+
+data Toolchain = Toolchain
+ { toolchainPlatform :: Platform
+ , toolchainCompiler :: Compiler
+ , toolchainProgramDb :: ProgramDb
+ }
+ deriving (Show, Generic, Typeable)
+
+-- TODO: review this
+instance Eq Toolchain where
+ lhs == rhs =
+ (((==) `on` toolchainPlatform) lhs rhs)
+ && (((==) `on` toolchainCompiler) lhs rhs)
+ && ((((==)) `on` (configuredPrograms . toolchainProgramDb)) lhs rhs)
+
+instance Binary Toolchain
+instance Structured Toolchain
+
+data Toolchains = Toolchains
+ { buildToolchain :: Toolchain
+ , hostToolchain :: Toolchain
+ }
+ deriving (Eq, Show, Generic, Typeable)
+
+toolchainFor :: Stage -> Toolchains -> Toolchain
+toolchainFor Build = buildToolchain
+toolchainFor Host = hostToolchain
+
+compilerIdFor :: Stage -> Toolchains -> CompilerId
+compilerIdFor stage = compilerId . toolchainCompiler . toolchainFor stage
+
+instance Binary Toolchains
+instance Structured Toolchains
+
+mkToolchainsWithHost :: Platform -> Compiler -> Toolchains
+mkToolchainsWithHost platform compiler =
+ Toolchains
+ { buildToolchain = Toolchain platform compiler (error "build program db missing")
+ , hostToolchain = Toolchain platform compiler (error "host program db missing")
+ }
+
+buildIsHost :: Toolchains -> Bool
+buildIsHost Toolchains {buildToolchain, hostToolchain} =
+ buildToolchain == hostToolchain
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 5aedb23aeed..c237c9d891e 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -141,6 +141,7 @@ library
Distribution.Client.GlobalFlags
Distribution.Client.Haddock
Distribution.Client.HashValue
+ Distribution.Client.HookAccept
Distribution.Client.HttpUtils
Distribution.Client.IndexUtils
Distribution.Client.IndexUtils.ActiveRepos
diff --git a/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs b/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs
index ce1d1665327..a6febfcca50 100644
--- a/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs
+++ b/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs
@@ -103,7 +103,7 @@ newBuildReport os' arch' comp pkgid flags deps result =
cabalInstallID :: PackageIdentifier
cabalInstallID =
- PackageIdentifier (mkPackageName "cabal-install") cabalInstallVersion
+ PackageIdentifier (mkPackageName "cabal-install") cabalInstallVersion Nothing
-------------------------------------------------------------------------------
-- FieldGrammar
diff --git a/cabal-install/src/Distribution/Client/CmdExec.hs b/cabal-install/src/Distribution/Client/CmdExec.hs
index caa680a3a3a..c0f565738fb 100644
--- a/cabal-install/src/Distribution/Client/CmdExec.hs
+++ b/cabal-install/src/Distribution/Client/CmdExec.hs
@@ -55,7 +55,9 @@ import Distribution.Client.ProjectPlanning
)
import qualified Distribution.Client.ProjectPlanning as Planning
import Distribution.Client.ProjectPlanning.Types
- ( dataDirsEnvironmentForPlan
+ ( Toolchain (..)
+ , Toolchains (..)
+ , dataDirsEnvironmentForPlan
)
import Distribution.Client.Setup
( ConfigFlags (configCommonFlags)
@@ -170,7 +172,7 @@ execAction flags@NixStyleFlags{..} extraArgs globalFlags = do
-- Some dependencies may have executables. Let's put those on the PATH.
let extraPaths = pathAdditions baseCtx buildCtx
- pkgProgs = pkgConfigCompilerProgs (elaboratedShared buildCtx)
+ pkgProgs = toolchainProgramDb $ buildToolchain $ pkgConfigToolchains (elaboratedShared buildCtx)
extraEnvVars =
dataDirsEnvironmentForPlan
(distDirLayout baseCtx)
@@ -185,7 +187,7 @@ execAction flags@NixStyleFlags{..} extraArgs globalFlags = do
-- point at the file.
-- In case ghc is too old to support environment files,
-- we pass the same info as arguments
- let compiler = pkgConfigCompiler $ elaboratedShared buildCtx
+ let compiler = toolchainCompiler $ buildToolchain $ pkgConfigToolchains $ elaboratedShared buildCtx
envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler)
case extraArgs of
[] -> dieWithException verbosity SpecifyAnExecutable
@@ -243,7 +245,7 @@ matchCompilerPath elaboratedShared program =
programPath program
`elem` (programPath <$> configuredCompilers)
where
- configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared
+ configuredCompilers = configuredPrograms $ toolchainProgramDb $ buildToolchain $ pkgConfigToolchains elaboratedShared
-- | Execute an action with a temporary .ghc.environment file reflecting the
-- current environment. The action takes an environment containing the env
diff --git a/cabal-install/src/Distribution/Client/CmdFreeze.hs b/cabal-install/src/Distribution/Client/CmdFreeze.hs
index 29718b5d441..d6dae289354 100644
--- a/cabal-install/src/Distribution/Client/CmdFreeze.hs
+++ b/cabal-install/src/Distribution/Client/CmdFreeze.hs
@@ -142,6 +142,7 @@ freezeAction flags@NixStyleFlags{..} extraArgs globalFlags = do
(_, elaboratedPlan, _, totalIndexState, activeRepos) <-
rebuildInstallPlan
verbosity
+ mempty
distDirLayout
cabalDirLayout
projectConfig
diff --git a/cabal-install/src/Distribution/Client/CmdHaddock.hs b/cabal-install/src/Distribution/Client/CmdHaddock.hs
index 677589e3e35..4b35b1f9f2e 100644
--- a/cabal-install/src/Distribution/Client/CmdHaddock.hs
+++ b/cabal-install/src/Distribution/Client/CmdHaddock.hs
@@ -27,9 +27,6 @@ import Distribution.Client.ProjectConfig.Types
, ProjectConfig (..)
)
import Distribution.Client.ProjectOrchestration
-import Distribution.Client.ProjectPlanning
- ( ElaboratedSharedConfig (..)
- )
import Distribution.Client.Setup
( CommonSetupFlags (..)
, ConfigFlags (..)
@@ -48,13 +45,6 @@ import Distribution.Simple.Command
, usageAlternatives
)
import Distribution.Simple.Flag (Flag (..))
-import Distribution.Simple.Program.Builtin
- ( haddockProgram
- )
-import Distribution.Simple.Program.Db
- ( addKnownProgram
- , reconfigurePrograms
- )
import Distribution.Simple.Setup
( HaddockFlags (..)
, fromFlagOrDefault
@@ -160,6 +150,7 @@ haddockAction relFlags targetStrings globalFlags = do
projCtx{buildSettings = (buildSettings projCtx){buildSettingHaddockOpen = True}}
| otherwise =
projCtx
+
absProjectConfig <- mkConfigAbsolute relProjectConfig
let baseCtx = relBaseCtx{projectConfig = absProjectConfig}
@@ -188,28 +179,32 @@ haddockAction relFlags targetStrings globalFlags = do
TargetActionHaddock
targets
elaboratedPlan
+
return (elaboratedPlan', targets)
printPlan verbosity baseCtx buildCtx
- progs <-
- reconfigurePrograms
- verbosity
- (haddockProgramPaths haddockFlags)
- (haddockProgramArgs haddockFlags)
- -- we need to insert 'haddockProgram' before we reconfigure it,
- -- otherwise 'set
- . addKnownProgram haddockProgram
- . pkgConfigCompilerProgs
- . elaboratedShared
- $ buildCtx
+ -- TODO
+ -- progs <-
+ -- reconfigurePrograms
+ -- verbosity
+ -- (haddockProgramPaths haddockFlags)
+ -- (haddockProgramArgs haddockFlags)
+ -- -- we need to insert 'haddockProgram' before we reconfigure it,
+ -- -- otherwise 'set
+ -- . addKnownProgram haddockProgram
+ -- . pkgConfigCompilerProgs
+ -- . elaboratedShared
+ -- $ buildCtx
+
+ -- TODO
let buildCtx' =
buildCtx
- { elaboratedShared =
- (elaboratedShared buildCtx)
- { pkgConfigCompilerProgs = progs
- }
- }
+ -- { elaboratedShared =
+ -- (elaboratedShared buildCtx)
+ -- { pkgConfigCompilerProgs = progs
+ -- }
+ -- }
buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx'
runProjectPostBuildPhase verbosity baseCtx buildCtx' buildOutcomes
diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs
index 0635a77d68e..680e538513b 100644
--- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs
+++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs
@@ -37,7 +37,9 @@ import Distribution.Client.ProjectPlanning
, TargetAction (..)
)
import Distribution.Client.ProjectPlanning.Types
- ( elabDistDirParams
+ ( Toolchain (..)
+ , Toolchains (..)
+ , elabDistDirParams
)
import Distribution.Client.ScriptUtils
( AcceptNoTargets (..)
@@ -72,14 +74,6 @@ import Distribution.Simple.Haddock (createHaddockIndex)
import Distribution.Simple.InstallDirs
( toPathTemplate
)
-import Distribution.Simple.Program.Builtin
- ( haddockProgram
- )
-import Distribution.Simple.Program.Db
- ( addKnownProgram
- , reconfigurePrograms
- , requireProgramVersion
- )
import Distribution.Simple.Setup
( HaddockFlags (..)
, HaddockProjectFlags (..)
@@ -100,8 +94,6 @@ import Distribution.Types.PackageDescription (PackageDescription (benchmarks, su
import Distribution.Types.PackageId (pkgName)
import Distribution.Types.PackageName (unPackageName)
import Distribution.Types.UnitId (unUnitId)
-import Distribution.Types.Version (mkVersion)
-import Distribution.Types.VersionRange (orLaterVersion)
import Distribution.Verbosity as Verbosity
( normal
)
@@ -166,24 +158,26 @@ haddockProjectAction flags _extraArgs globalFlags = do
pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage]
pkgs = matchingPackages elaboratedPlan
- progs <-
- reconfigurePrograms
- verbosity
- (haddockProjectProgramPaths flags)
- (haddockProjectProgramArgs flags)
- -- we need to insert 'haddockProgram' before we reconfigure it,
- -- otherwise 'set
- . addKnownProgram haddockProgram
- . pkgConfigCompilerProgs
- $ sharedConfig
- let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs}
-
- _ <-
- requireProgramVersion
- verbosity
- haddockProgram
- (orLaterVersion (mkVersion [2, 26, 1]))
- progs
+ -- TODO
+ -- progs <-
+ -- reconfigurePrograms
+ -- verbosity
+ -- (haddockProjectProgramPaths flags)
+ -- (haddockProjectProgramArgs flags)
+ -- -- we need to insert 'haddockProgram' before we reconfigure it,
+ -- -- otherwise 'set
+ -- . addKnownProgram haddockProgram
+ -- . pkgConfigCompilerProgs
+ -- $ sharedConfig
+ -- let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs}
+ let sharedConfig' = sharedConfig
+
+ -- _ <-
+ -- requireProgramVersion
+ -- verbosity
+ -- haddockProgram
+ -- (orLaterVersion (mkVersion [2, 26, 1]))
+ -- progs
--
-- Build project; we need to build dependencies.
@@ -301,7 +295,7 @@ haddockProjectAction flags _extraArgs globalFlags = do
packageDir =
storePackageDirectory
(cabalStoreDirLayout cabalLayout)
- (pkgConfigCompiler sharedConfig')
+ (toolchainCompiler $ buildToolchain $ pkgConfigToolchains sharedConfig')
(elabUnitId package)
-- TODO: use `InstallDirTemplates`
docDir = packageDir </> "share" </> "doc" </> "html"
@@ -344,11 +338,12 @@ haddockProjectAction flags _extraArgs globalFlags = do
]
, haddockProjectUseUnicode = NoFlag
}
+ -- NOTE: this lives in Cabal
createHaddockIndex
verbosity
- (pkgConfigCompilerProgs sharedConfig')
- (pkgConfigCompiler sharedConfig')
- (pkgConfigPlatform sharedConfig')
+ (toolchainProgramDb $ buildToolchain $ pkgConfigToolchains sharedConfig')
+ (toolchainCompiler $ buildToolchain $ pkgConfigToolchains sharedConfig')
+ (toolchainPlatform $ buildToolchain $ pkgConfigToolchains sharedConfig')
Nothing
flags'
where
diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs
index 63cf59169a3..07a72119b75 100644
--- a/cabal-install/src/Distribution/Client/CmdInstall.hs
+++ b/cabal-install/src/Distribution/Client/CmdInstall.hs
@@ -467,7 +467,6 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
fetchAndReadSourcePackages
verbosity
distDirLayout
- (Just compiler)
(projectConfigShared config)
(projectConfigBuildOnly config)
[ProjectPackageRemoteTarball uri | uri <- uris]
diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs
index df16b98e1a2..44b78b0347c 100644
--- a/cabal-install/src/Distribution/Client/CmdListBin.hs
+++ b/cabal-install/src/Distribution/Client/CmdListBin.hs
@@ -205,7 +205,7 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do
_ -> []
plat :: Platform
- plat = pkgConfigPlatform elaboratedSharedConfig
+ plat = toolchainPlatform $ buildToolchain $ pkgConfigToolchains elaboratedSharedConfig
-- here and in PlanOutput,
-- use binDirectoryFor?
diff --git a/cabal-install/src/Distribution/Client/CmdPath.hs b/cabal-install/src/Distribution/Client/CmdPath.hs
index d7587219665..ae70fbaf9ee 100644
--- a/cabal-install/src/Distribution/Client/CmdPath.hs
+++ b/cabal-install/src/Distribution/Client/CmdPath.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
-- |
@@ -40,6 +41,7 @@ import Distribution.Client.ProjectConfig.Types
)
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
+import Distribution.Client.ProjectPlanning.Types (Toolchain (..), Toolchains (..))
import Distribution.Client.RebuildMonad (runRebuild)
import Distribution.Client.ScriptUtils
import Distribution.Client.Setup
@@ -242,10 +244,11 @@ pathAction flags@NixStyleFlags{extraFlags = pathFlags', ..} cliTargetStrings glo
if not $ fromFlagOrDefault False (pathCompiler pathFlags)
then pure Nothing
else do
- (compiler, _, progDb) <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx)
- compilerProg <- requireCompilerProg verbosity compiler
- (configuredCompilerProg, _) <- requireProgram verbosity compilerProg progDb
- pure $ Just $ mkCompilerInfo configuredCompilerProg compiler
+ let projectRoot = distProjectRootDirectory (distDirLayout baseCtx)
+ Toolchains{buildToolchain} <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx)
+ compilerProg <- requireCompilerProg verbosity (toolchainCompiler buildToolchain)
+ (configuredCompilerProg, _) <- requireProgram verbosity compilerProg (toolchainProgramDb buildToolchain)
+ pure $ Just $ mkCompilerInfo configuredCompilerProg (toolchainCompiler buildToolchain)
paths <- for (fromFlagOrDefault [] $ pathDirectories pathFlags) $ \p -> do
t <- getPathLocation baseCtx p
diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs
index a75524bbca6..7570e11aa84 100644
--- a/cabal-install/src/Distribution/Client/CmdRepl.hs
+++ b/cabal-install/src/Distribution/Client/CmdRepl.hs
@@ -55,7 +55,9 @@ import Distribution.Client.ProjectPlanning
, ElaboratedSharedConfig (..)
)
import Distribution.Client.ProjectPlanning.Types
- ( elabOrderExeDependencies
+ ( Toolchain (..)
+ , Toolchains (..)
+ , elabOrderExeDependencies
, showElaboratedInstallPlan
)
import Distribution.Client.ScriptUtils
@@ -344,7 +346,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
-- especially in the no-project case.
withInstallPlan (lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do
-- targets should be non-empty map, but there's no NonEmptyMap yet.
- targets <- validatedTargets (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors
+ targets <- validatedTargets (projectConfigShared (projectConfig ctx)) (toolchainCompiler $ buildToolchain $ pkgConfigToolchains sharedConfig) elaboratedPlan targetSelectors
let
(unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets
@@ -368,7 +370,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
let ProjectBaseContext{..} = baseCtx''
-- Recalculate with updated project.
- targets <- validatedTargets (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors
+ targets <- validatedTargets (projectConfigShared projectConfig) (toolchainCompiler $ buildToolchain $ pkgConfigToolchains elaboratedShared') elaboratedPlan targetSelectors
let
elaboratedPlan' =
@@ -400,7 +402,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
, targetsMap = targets
}
- ElaboratedSharedConfig{pkgConfigCompiler = compiler} = elaboratedShared'
+ ElaboratedSharedConfig{pkgConfigToolchains = Toolchains{hostToolchain = Toolchain{toolchainCompiler = compiler}}} = elaboratedShared'
repl_flags = case originalComponent of
Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci
@@ -441,7 +443,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
-- HACK: Just combine together all env overrides, placing the most common things last
-- ghc program with overridden PATH
- (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx'))
+ (ghcProg, _) <- requireProgram verbosity ghcProgram (toolchainProgramDb $ buildToolchain $ pkgConfigToolchains (elaboratedShared buildCtx'))
let ghcProg' = ghcProg{programOverrideEnv = [("PATH", Just sp)]}
-- Find what the unit files are, and start a repl based on all the response
diff --git a/cabal-install/src/Distribution/Client/CmdTarget.hs b/cabal-install/src/Distribution/Client/CmdTarget.hs
index c2edeeec89c..4c9cc59ec24 100644
--- a/cabal-install/src/Distribution/Client/CmdTarget.hs
+++ b/cabal-install/src/Distribution/Client/CmdTarget.hs
@@ -160,6 +160,7 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do
(_, elaboratedPlan, _, _, _) <-
rebuildInstallPlan
verbosity
+ mempty
distDirLayout
cabalDirLayout
projectConfig
diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs
index 419d7d603ea..71888779578 100644
--- a/cabal-install/src/Distribution/Client/Config.hs
+++ b/cabal-install/src/Distribution/Client/Config.hs
@@ -573,6 +573,10 @@ instance Semigroup SavedConfig where
combineMonoid savedConfigureExFlags configAllowOlder
, configWriteGhcEnvironmentFilesPolicy =
combine configWriteGhcEnvironmentFilesPolicy
+ , configBuildHcFlavor = combine configBuildHcFlavor
+ , configBuildHcPath = combine configBuildHcPath
+ , configBuildHcPkg = combine configBuildHcPkg
+ , configBuildPackageDBs = lastNonEmpty configBuildPackageDBs
}
where
combine = combine' savedConfigureExFlags
diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs
index 048a7db963e..bc3c24f9245 100644
--- a/cabal-install/src/Distribution/Client/Configure.hs
+++ b/cabal-install/src/Distribution/Client/Configure.hs
@@ -67,6 +67,7 @@ import Distribution.Solver.Types.PkgConfigDb
)
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.Toolchain (mkToolchainsWithHost)
import Distribution.Client.SavedFlags (readCommandFlags, writeCommandFlags)
import Distribution.Package
@@ -463,6 +464,7 @@ planLocalPackage
. setSolveExecutables (SolveExecutables False)
. setSolverVerbosity verbosity
$ standardInstallPolicy
+ mempty {- build pkgs -}
installedPkgIndex
-- NB: We pass in an *empty* source package database,
-- because cabal configure assumes that all dependencies
@@ -470,7 +472,7 @@ planLocalPackage
(SourcePackageDb mempty packagePrefs)
[SpecificSourcePackage localPkg]
- return (resolveDependencies platform (compilerInfo comp) pkgConfigDb resolverParams)
+ return (resolveDependencies (mkToolchainsWithHost platform comp) pkgConfigDb resolverParams)
-- | Call an installer for an 'SourcePackage' but override the configure
-- flags with the ones given by the 'ReadyPackage'. In particular the
diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs
index d59bc611c44..878a99ca5e9 100644
--- a/cabal-install/src/Distribution/Client/Dependency.hs
+++ b/cabal-install/src/Distribution/Client/Dependency.hs
@@ -115,6 +115,7 @@ import Distribution.PackageDescription.Configuration
import qualified Distribution.PackageDescription.Configuration as PD
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
+import Distribution.Simple.Compiler (compilerInfo)
import Distribution.Simple.Setup
( asBool
)
@@ -153,6 +154,7 @@ import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SolverId
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.Toolchain
import Distribution.Solver.Types.Variable
import Control.Exception
@@ -164,6 +166,8 @@ import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
+import GHC.Stack (HasCallStack)
+
-- ------------------------------------------------------------
-- * High level planner policy
@@ -179,6 +183,7 @@ data DepResolverParams = DepResolverParams
, depResolverPreferences :: [PackagePreference]
, depResolverPreferenceDefault :: PackagesPreferenceDefault
, depResolverInstalledPkgIndex :: InstalledPackageIndex
+ , depResolverBuildInstalledPkgIndex :: InstalledPackageIndex
, depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage
, depResolverReorderGoals :: ReorderGoals
, depResolverCountConflicts :: CountConflicts
@@ -275,15 +280,17 @@ showPackagePreference (PackageStanzasPreference pn st) =
basicDepResolverParams
:: InstalledPackageIndex
+ -> InstalledPackageIndex
-> PackageIndex.PackageIndex UnresolvedSourcePackage
-> DepResolverParams
-basicDepResolverParams installedPkgIndex sourcePkgIndex =
+basicDepResolverParams buildInstalledPkgIndex installedPkgIndex sourcePkgIndex=
DepResolverParams
{ depResolverTargets = Set.empty
, depResolverConstraints = []
, depResolverPreferences = []
, depResolverPreferenceDefault = PreferLatestForSelected
, depResolverInstalledPkgIndex = installedPkgIndex
+ , depResolverBuildInstalledPkgIndex = buildInstalledPkgIndex
, depResolverSourcePkgIndex = sourcePkgIndex
, depResolverReorderGoals = ReorderGoals False
, depResolverCountConflicts = CountConflicts True
@@ -447,7 +454,16 @@ dontInstallNonReinstallablePackages params =
ConstraintSourceNonReinstallablePackage
| pkgname <- nonReinstallablePackages
]
-
+dontInstallNonReinstallablePackagesForBuild :: DepResolverParams -> DepResolverParams
+dontInstallNonReinstallablePackagesForBuild params =
+ addConstraints extraConstraints params
+ where
+ extraConstraints =
+ [ LabeledPackageConstraint
+ (PackageConstraint (ScopeAnyBuildDepQualifier pkgname) PackagePropertyInstalled)
+ ConstraintSourceNonReinstallablePackage
+ | pkgname <- nonReinstallablePackages
+ ]
-- | The set of non-reinstallable packages includes those which cannot be
-- rebuilt using a GHC installation and Hackage-published source distribution.
-- There are a few reasons why this might be true:
@@ -700,11 +716,13 @@ reinstallTargets params =
-- | A basic solver policy on which all others are built.
basicInstallPolicy
- :: InstalledPackageIndex
+ :: InstalledPackageIndex -- ^ Build
+ -> InstalledPackageIndex -- ^ Host
-> SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
basicInstallPolicy
+ binstalledPkgIndex
installedPkgIndex
(SourcePackageDb sourcePkgIndex sourcePkgPrefs)
pkgSpecifiers =
@@ -721,6 +739,7 @@ basicInstallPolicy
. addSourcePackages
[pkg | SpecificSourcePackage pkg <- pkgSpecifiers]
$ basicDepResolverParams
+ binstalledPkgIndex
installedPkgIndex
sourcePkgIndex
@@ -729,13 +748,15 @@ basicInstallPolicy
--
-- It extends the 'basicInstallPolicy' with a policy on setup deps.
standardInstallPolicy
- :: InstalledPackageIndex
+ :: InstalledPackageIndex -- ^ Build
+ -> InstalledPackageIndex -- ^ Host
-> SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
-standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers =
+standardInstallPolicy binstalledPkgIndex installedPkgIndex sourcePkgDb pkgSpecifiers =
addDefaultSetupDependencies mkDefaultSetupDeps $
basicInstallPolicy
+ binstalledPkgIndex
installedPkgIndex
sourcePkgDb
pkgSpecifiers
@@ -782,14 +803,13 @@ runSolver = modularResolver
-- a 'Progress' structure that can be unfolded to provide progress information,
-- logging messages and the final result or an error.
resolveDependencies
- :: Platform
- -> CompilerInfo
+ :: Toolchains
-> Maybe PkgConfigDb
-> DepResolverParams
-> Progress String String SolverInstallPlan
-resolveDependencies platform comp pkgConfigDB params =
+resolveDependencies toolchains pkgConfigDB params =
Step (showDepResolverParams finalparams) $
- fmap (validateSolverResult platform comp indGoals) $
+ fmap (validateSolverResult toolchains indGoals) $
runSolver
( SolverConfig
reordGoals
@@ -808,8 +828,8 @@ resolveDependencies platform comp pkgConfigDB params =
verbosity
(PruneAfterFirstSuccess False)
)
- platform
- comp
+ toolchains
+ binstalledPkgIndex
installedPkgIndex
sourcePkgIndex
pkgConfigDB
@@ -818,12 +838,13 @@ resolveDependencies platform comp pkgConfigDB params =
targets
where
finalparams@( DepResolverParams
- targets
+ targets -- depResolverTargets
constraints
prefs
defpref
installedPkgIndex
- sourcePkgIndex
+ binstalledPkgIndex
+ sourcePkgIndex -- depResolverSourcePkgIndex
reordGoals
cntConflicts
fineGrained
@@ -841,7 +862,9 @@ resolveDependencies platform comp pkgConfigDB params =
verbosity
) =
if asBool (depResolverAllowBootLibInstalls params)
- then params
+ then if buildIsHost toolchains
+ then params
+ else dontInstallNonReinstallablePackagesForBuild params
else dontInstallNonReinstallablePackages params
preferences :: PackageName -> PackagePreferences
@@ -909,18 +932,18 @@ interpretPackagesPreference selected defaultPref prefs =
-- | Make an install plan from the output of the dep resolver.
-- It checks that the plan is valid, or it's an error in the dep resolver.
validateSolverResult
- :: Platform
- -> CompilerInfo
+ :: HasCallStack => Toolchains
-> IndependentGoals
-> [ResolverPackage UnresolvedPkgLoc]
-> SolverInstallPlan
-validateSolverResult platform comp indepGoals pkgs =
- case planPackagesProblems platform comp pkgs of
+validateSolverResult toolchains indepGoals pkgs =
+ case planPackagesProblems toolchains pkgs of
[] -> case SolverInstallPlan.new indepGoals graph of
Right plan -> plan
Left problems -> error (formatPlanProblems problems)
problems -> error (formatPkgProblems problems)
where
+
graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc)
graph = Graph.fromDistinctList pkgs
@@ -960,14 +983,13 @@ showPlanPackageProblem (DuplicatePackageSolverId pid dups) =
++ " duplicate instances."
planPackagesProblems
- :: Platform
- -> CompilerInfo
+ :: Toolchains
-> [ResolverPackage UnresolvedPkgLoc]
-> [PlanPackageProblem]
-planPackagesProblems platform cinfo pkgs =
+planPackagesProblems toolchains pkgs =
[ InvalidConfiguredPackage pkg packageProblems
| Configured pkg <- pkgs
- , let packageProblems = configuredPackageProblems platform cinfo pkg
+ , let packageProblems = configuredPackageProblems toolchains pkg
, not (null packageProblems)
]
++ [ DuplicatePackageSolverId (Graph.nodeKey aDup) dups
@@ -1016,14 +1038,12 @@ showPackageProblem (InvalidDep dep pkgid) =
-- in the configuration given by the flag assignment, all the package
-- dependencies are satisfied by the specified packages.
configuredPackageProblems
- :: Platform
- -> CompilerInfo
+ :: Toolchains
-> SolverPackage UnresolvedPkgLoc
-> [PackageProblem]
configuredPackageProblems
- platform
- cinfo
- (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') =
+ toolchains
+ (SolverPackage _qpn _stage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') =
[ DuplicateFlag flag
| flag <- PD.findDuplicateFlagAssignments specifiedFlags
]
@@ -1061,7 +1081,7 @@ configuredPackageProblems
(sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO
packageSatisfiesDependency :: PackageIdentifier -> Dependency -> Bool
packageSatisfiesDependency
- (PackageIdentifier name version)
+ (PackageIdentifier name version _compid)
(Dependency name' versionRange _) =
assert (name == name') $
version `withinRange` versionRange
@@ -1096,8 +1116,9 @@ configuredPackageProblems
specifiedFlags
compSpec
(const Satisfied)
- platform
- cinfo
+ -- FIXME: HARDCODED HOST TOOLCHAIN here.
+ (toolchainPlatform (hostToolchain toolchains))
+ (compilerInfo (toolchainCompiler (hostToolchain toolchains)))
[]
(srcpkgDescription pkg) of
Right (resolvedPkg, _) ->
@@ -1144,6 +1165,7 @@ resolveWithoutDependencies
prefs
defpref
installedPkgIndex
+ binstalledPkgIndex
sourcePkgIndex
_reorderGoals
_countConflicts
diff --git a/cabal-install/src/Distribution/Client/Errors.hs b/cabal-install/src/Distribution/Client/Errors.hs
index ff9ad369bef..9d750b1548d 100644
--- a/cabal-install/src/Distribution/Client/Errors.hs
+++ b/cabal-install/src/Distribution/Client/Errors.hs
@@ -186,7 +186,9 @@ data CabalInstallException
| MissingPackageList Repo.RemoteRepo
| CmdPathAcceptsNoTargets
| CmdPathCommandDoesn'tSupportDryRun
- deriving (Show)
+ | HookAcceptUnknown FilePath FilePath String
+ | HookAcceptHashMismatch FilePath FilePath String String
+ deriving (Show, Typeable)
exceptionCodeCabalInstall :: CabalInstallException -> Int
exceptionCodeCabalInstall e = case e of
@@ -338,6 +340,8 @@ exceptionCodeCabalInstall e = case e of
MissingPackageList{} -> 7160
CmdPathAcceptsNoTargets{} -> 7161
CmdPathCommandDoesn'tSupportDryRun -> 7163
+ HookAcceptUnknown{} -> 7164
+ HookAcceptHashMismatch{} -> 7165
exceptionMessageCabalInstall :: CabalInstallException -> String
exceptionMessageCabalInstall e = case e of
@@ -381,7 +385,7 @@ exceptionMessageCabalInstall e = case e of
FindOpenProgramLocationErr err -> err
PkgConfParseFailed perror ->
"Couldn't parse the output of 'setup register --gen-pkg-config':"
- ++ show perror
+ ++ perror
ErrorPackingSdist err -> "Error packing sdist: " ++ err
SdistException pkgIdentifier -> "sdist of " ++ prettyShow pkgIdentifier
SpecifyAnExecutable -> "Please specify an executable to run"
@@ -860,6 +864,36 @@ exceptionMessageCabalInstall e = case e of
"The 'path' command accepts no target arguments."
CmdPathCommandDoesn'tSupportDryRun ->
"The 'path' command doesn't support the flag '--dry-run'."
+ HookAcceptUnknown hsPath fpath hash ->
+ concat
+ [ "The following file does not appear in the hooks-security file.\n"
+ , " hook file : "
+ , fpath
+ , "\n"
+ , " file hash : "
+ , hash
+ , "\n"
+ , "After checking the contents of that file, it should be added to the\n"
+ , "hooks-security file with either AcceptAlways or better yet an AcceptHash.\n"
+ , "The hooks-security file is (probably) located at: "
+ , hsPath
+ ]
+ HookAcceptHashMismatch hsPath fpath expected actual ->
+ concat
+ [ "\nHook file hash mismatch for:\n"
+ , " hook file : "
+ , fpath
+ , "\n"
+ , " expected hash: "
+ , expected
+ , "\n"
+ , " actual hash : "
+ , actual
+ , "\n"
+ , "The hook file should be inspected and if deemed ok, the hooks-security file updated.\n"
+ , "The hooks-security file is (probably) located at: "
+ , hsPath
+ ]
instance Exception (VerboseException CabalInstallException) where
displayException :: VerboseException CabalInstallException -> [Char]
diff --git a/cabal-install/src/Distribution/Client/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs
index 033d3a01e14..e66acf66cc6 100644
--- a/cabal-install/src/Distribution/Client/Fetch.hs
+++ b/cabal-install/src/Distribution/Client/Fetch.hs
@@ -38,6 +38,7 @@ import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, readPkgConfigDb)
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.Toolchain (mkToolchainsWithHost)
import Distribution.Client.Errors
import Distribution.Package
@@ -174,8 +175,7 @@ planPackages
installPlan <-
foldProgress logMsg (dieWithException verbosity . PlanPackages . show) return $
resolveDependencies
- platform
- (compilerInfo comp)
+ (mkToolchainsWithHost platform comp)
pkgConfigDb
resolverParams
@@ -220,7 +220,7 @@ planPackages
-- already installed. Since we want to get the source packages of
-- things we might have installed (but not have the sources for).
. reinstallTargets
- $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
+ $ standardInstallPolicy mempty {-build-} installedPkgIndex sourcePkgDb pkgSpecifiers
includeDependencies = fromFlag (fetchDeps fetchFlags)
logMsg message rest = debug verbosity message >> rest
diff --git a/cabal-install/src/Distribution/Client/FetchUtils.hs b/cabal-install/src/Distribution/Client/FetchUtils.hs
index 62da386573d..6b29dd84bfc 100644
--- a/cabal-install/src/Distribution/Client/FetchUtils.hs
+++ b/cabal-install/src/Distribution/Client/FetchUtils.hs
@@ -60,6 +60,7 @@ import Distribution.Package
( PackageId
, packageName
, packageVersion
+ , pkgCompiler
)
import Distribution.Simple.Utils
( debug
@@ -395,7 +396,7 @@ waitAsyncFetchPackage verbosity downloadMap srcloc =
packageFile :: Repo -> PackageId -> FilePath
packageFile repo pkgid =
packageDir repo pkgid
- </> prettyShow pkgid
+ </> prettyShow pkgid{pkgCompiler = Nothing}
<.> "tar.gz"
-- | Generate the full path to the directory where the local cached copy of
diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs
index a03b45b6a2d..e6a5190260f 100644
--- a/cabal-install/src/Distribution/Client/Freeze.hs
+++ b/cabal-install/src/Distribution/Client/Freeze.hs
@@ -52,6 +52,7 @@ import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PkgConfigDb
import Distribution.Solver.Types.SolverId
+import Distribution.Solver.Types.Toolchain (mkToolchainsWithHost)
import Distribution.Client.Errors
import Distribution.Package
@@ -212,8 +213,7 @@ planPackages
installPlan <-
foldProgress logMsg (dieWithException verbosity . FreezeException) return $
resolveDependencies
- platform
- (compilerInfo comp)
+ (mkToolchainsWithHost platform comp)
pkgConfigDb
resolverParams
@@ -245,7 +245,7 @@ planPackages
in LabeledPackageConstraint pc ConstraintSourceFreeze
| pkgSpecifier <- pkgSpecifiers
]
- $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
+ $ standardInstallPolicy mempty {- build -} installedPkgIndex sourcePkgDb pkgSpecifiers
logMsg message rest = debug verbosity message >> rest
diff --git a/cabal-install/src/Distribution/Client/Get.hs b/cabal-install/src/Distribution/Client/Get.hs
index 39ace2f2652..08029a53b8d 100644
--- a/cabal-install/src/Distribution/Client/Get.hs
+++ b/cabal-install/src/Distribution/Client/Get.hs
@@ -148,7 +148,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
resolverParams :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams
resolverParams sourcePkgDb pkgSpecifiers =
-- TODO: add command-line constraint and preference args for unpack
- standardInstallPolicy mempty sourcePkgDb pkgSpecifiers
+ standardInstallPolicy mempty mempty sourcePkgDb pkgSpecifiers
onlyPkgDescr = fromFlagOrDefault False (getOnlyPkgDescr getFlags)
diff --git a/cabal-install/src/Distribution/Client/HashValue.hs b/cabal-install/src/Distribution/Client/HashValue.hs
index c5698f27f1e..12616e07eaa 100644
--- a/cabal-install/src/Distribution/Client/HashValue.hs
+++ b/cabal-install/src/Distribution/Client/HashValue.hs
@@ -4,6 +4,7 @@
module Distribution.Client.HashValue
( HashValue
, hashValue
+ , hashValueFromHex
, truncateHash
, showHashValue
, readFileHashValue
@@ -51,6 +52,11 @@ instance Structured HashValue
hashValue :: LBS.ByteString -> HashValue
hashValue = HashValue . SHA256.hashlazy
+-- From a base16 encoded Bytestring to a HashValue with `Base16`'s
+-- error passing through.
+hashValueFromHex :: BS.ByteString -> Either String HashValue
+hashValueFromHex bs = HashValue <$> Base16.decode bs
+
showHashValue :: HashValue -> String
showHashValue (HashValue digest) = BS.unpack (Base16.encode digest)
diff --git a/cabal-install/src/Distribution/Client/HookAccept.hs b/cabal-install/src/Distribution/Client/HookAccept.hs
new file mode 100644
index 00000000000..fc7e5ae0460
--- /dev/null
+++ b/cabal-install/src/Distribution/Client/HookAccept.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Distribution.Client.HookAccept
+ ( HookAccept (..)
+ , assertHookHash
+ , loadHookHasheshMap
+ , parseHooks
+ ) where
+
+import Distribution.Client.Compat.Prelude
+
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as BS
+
+import qualified Data.Map.Strict as Map
+
+import Distribution.Client.Config (getConfigFilePath)
+import Distribution.Client.Errors (CabalInstallException (..))
+import Distribution.Client.HashValue (HashValue, hashValueFromHex, readFileHashValue, showHashValue)
+import Distribution.Simple.Setup (Flag (..))
+import Distribution.Simple.Utils (dieWithException)
+import Distribution.Verbosity (normal)
+
+import System.FilePath (takeDirectory, (</>))
+
+data HookAccept
+ = AcceptAlways
+ | AcceptHash HashValue
+ deriving (Eq, Show, Generic)
+
+instance Monoid HookAccept where
+ mempty = AcceptAlways -- Should never be needed.
+ mappend = (<>)
+
+instance Semigroup HookAccept where
+ AcceptAlways <> AcceptAlways = AcceptAlways
+ AcceptAlways <> AcceptHash h = AcceptHash h
+ AcceptHash h <> AcceptAlways = AcceptHash h
+ AcceptHash h <> _ = AcceptHash h
+
+instance Binary HookAccept
+instance Structured HookAccept
+
+assertHookHash :: Map FilePath HookAccept -> FilePath -> IO ()
+assertHookHash m fpath = do
+ actualHash <- readFileHashValue fpath
+ hsPath <- getHooksSecurityFilePath NoFlag
+ case Map.lookup fpath m of
+ Nothing ->
+ dieWithException normal $
+ HookAcceptUnknown hsPath fpath (showHashValue actualHash)
+ Just AcceptAlways -> pure ()
+ Just (AcceptHash expectedHash) ->
+ when (actualHash /= expectedHash) $
+ dieWithException normal $
+ HookAcceptHashMismatch
+ hsPath
+ fpath
+ (showHashValue expectedHash)
+ (showHashValue actualHash)
+
+getHooksSecurityFilePath :: Flag FilePath -> IO FilePath
+getHooksSecurityFilePath configFileFlag = do
+ hfpath <- getConfigFilePath configFileFlag
+ pure $ takeDirectory hfpath </> "hooks-security"
+
+loadHookHasheshMap :: Flag FilePath -> IO (Map FilePath HookAccept)
+loadHookHasheshMap configFileFlag = do
+ hookFilePath <- getHooksSecurityFilePath configFileFlag
+ handleNotExists $ fmap parseHooks (BS.readFile hookFilePath)
+ where
+ handleNotExists :: IO (Map FilePath HookAccept) -> IO (Map FilePath HookAccept)
+ handleNotExists action = catchIO action $ \_ -> return mempty
+
+parseHooks :: ByteString -> Map FilePath HookAccept
+parseHooks = Map.fromList . map parse . cleanUp . BS.lines
+ where
+ cleanUp :: [ByteString] -> [ByteString]
+ cleanUp = filter (not . BS.null) . map rmComments
+
+ rmComments :: ByteString -> ByteString
+ rmComments = fst . BS.breakSubstring "--"
+
+parse :: ByteString -> (FilePath, HookAccept)
+parse bs =
+ case BS.words bs of
+ [fp, "AcceptAlways"] -> (BS.unpack fp, AcceptAlways)
+ [fp, "AcceptHash"] -> buildAcceptHash fp "00"
+ [fp, "AcceptHash", h] -> buildAcceptHash fp h
+ _ -> error $ "Not able to parse:" ++ show bs
+ where
+ buildAcceptHash :: ByteString -> ByteString -> (FilePath, HookAccept)
+ buildAcceptHash fp h =
+ case hashValueFromHex h of
+ Left err -> error $ "Distribution.Client.HookAccept.parse :" ++ err
+ Right hv -> (BS.unpack fp, AcceptHash hv)
diff --git a/cabal-install/src/Distribution/Client/IndexUtils.hs b/cabal-install/src/Distribution/Client/IndexUtils.hs
index 6027f5e53f3..489f8acfdb1 100644
--- a/cabal-install/src/Distribution/Client/IndexUtils.hs
+++ b/cabal-install/src/Distribution/Client/IndexUtils.hs
@@ -156,9 +156,11 @@ import Distribution.Client.Errors
import qualified Hackage.Security.Client as Sec
import qualified Hackage.Security.Util.Some as Sec
+import GHC.Stack (HasCallStack)
+
-- | Reduced-verbosity version of 'Configure.getInstalledPackages'
getInstalledPackages
- :: Verbosity
+ :: HasCallStack => Verbosity
-> Compiler
-> PackageDBStackCWD
-> ProgramDb
@@ -617,7 +619,7 @@ extractPkg verbosity entry blockNo = case Tar.entryContent entry of
[pkgname, vers, _] -> case simpleParsec vers of
Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)
where
- pkgid = PackageIdentifier (mkPackageName pkgname) ver
+ pkgid = PackageIdentifier (mkPackageName pkgname) ver Nothing
parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content)
descr = case parsed of
Just d -> d
@@ -1269,10 +1271,10 @@ hashConsCache cache0 =
go !pns !pvs (CachePackageId pid bno ts : rest) =
CachePackageId pid' bno ts : go pns' pvs' rest
where
- !pid' = PackageIdentifier pn' pv'
+ !pid' = PackageIdentifier pn' pv' compid
(!pn', !pns') = mapIntern pn pns
(!pv', !pvs') = mapIntern pv pvs
- PackageIdentifier pn pv = pid
+ PackageIdentifier pn pv compid = pid
go pns pvs (x : xs) = x : go pns pvs xs
mapIntern :: Ord k => k -> Map.Map k k -> (k, Map.Map k k)
@@ -1395,7 +1397,7 @@ read00IndexCacheEntry = \line ->
(Just pkgname, Just pkgver, Just blockno) ->
Just
( CachePackageId
- (PackageIdentifier pkgname pkgver)
+ (PackageIdentifier pkgname pkgver Nothing)
blockno
NoTimestamp
)
diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs
index 635cd7e1689..6f7d3bdd8a9 100644
--- a/cabal-install/src/Distribution/Client/Install.hs
+++ b/cabal-install/src/Distribution/Client/Install.hs
@@ -141,6 +141,7 @@ import Distribution.Solver.Types.PkgConfigDb
)
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SourcePackage as SourcePackage
+import Distribution.Solver.Types.Toolchain (mkToolchainsWithHost)
import Distribution.Client.ProjectConfig
import Distribution.Client.Utils
@@ -585,8 +586,7 @@ planPackages
pkgConfigDb
pkgSpecifiers =
resolveDependencies
- platform
- (compilerInfo comp)
+ (mkToolchainsWithHost platform comp)
pkgConfigDb
resolverParams
>>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return
@@ -650,6 +650,7 @@ planPackages
-- doesn't understand how to install them
. setSolveExecutables (SolveExecutables False)
$ standardInstallPolicy
+ mempty {- build pkgs -}
installedPkgIndex
sourcePkgDb
pkgSpecifiers
@@ -1101,7 +1102,7 @@ theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId
theSpecifiedPackage pkgSpec =
case pkgSpec of
NamedPackage name [PackagePropertyVersion version] ->
- PackageIdentifier name <$> trivialRange version
+ PackageIdentifier name <$> trivialRange version <*> Nothing
NamedPackage _ _ -> Nothing
SpecificSourcePackage pkg -> Just $ packageId pkg
where
diff --git a/cabal-install/src/Distribution/Client/PackageHash.hs b/cabal-install/src/Distribution/Client/PackageHash.hs
index e8975b0fc57..0be2753dcf5 100644
--- a/cabal-install/src/Distribution/Client/PackageHash.hs
+++ b/cabal-install/src/Distribution/Client/PackageHash.hs
@@ -66,6 +66,8 @@ import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Map as Map
import qualified Data.Set as Set
+import GHC.Stack (HasCallStack)
+
-------------------------------
-- Calculating package hashes
--
@@ -76,7 +78,7 @@ import qualified Data.Set as Set
-- Note that due to path length limitations on Windows, this function uses
-- a different method on Windows that produces shorted package ids.
-- See 'hashedInstalledPackageIdLong' vs 'hashedInstalledPackageIdShort'.
-hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId
+hashedInstalledPackageId :: HasCallStack => PackageHashInputs -> InstalledPackageId
hashedInstalledPackageId
| buildOS == Windows = hashedInstalledPackageIdShort
| buildOS == OSX = hashedInstalledPackageIdVeryShort
@@ -91,11 +93,14 @@ hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId
hashedInstalledPackageIdLong
pkghashinputs@PackageHashInputs{pkgHashPkgId, pkgHashComponent} =
mkComponentId $
- prettyShow pkgHashPkgId -- to be a bit user friendly
+ prettyShow compid
+ ++ "_"
+ ++ prettyShow pkgHashPkgId -- to be a bit user friendly
++ maybe "" displayComponent pkgHashComponent
++ "-"
++ showHashValue (hashPackageHashInputs pkghashinputs)
where
+ PackageIdentifier name version (Just compid) = pkgHashPkgId
displayComponent :: CD.Component -> String
displayComponent CD.ComponentLib = ""
displayComponent (CD.ComponentSubLib s) = "-l-" ++ prettyShow s
@@ -122,10 +127,12 @@ hashedInstalledPackageIdLong
-- Truncating the hash size is disappointing but also technically ok. We
-- rely on the hash primarily for collision avoidance not for any security
-- properties (at least for now).
-hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId
+hashedInstalledPackageIdShort :: HasCallStack => PackageHashInputs -> InstalledPackageId
hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =
mkComponentId $
- intercalate
+ prettyShow compid
+ ++
+ '_':intercalate
"-"
-- max length now 64
[ truncateStr 14 (prettyShow name)
@@ -133,7 +140,7 @@ hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =
, showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs))
]
where
- PackageIdentifier name version = pkgHashPkgId
+ PackageIdentifier name version (Just compid) = pkgHashPkgId
-- Truncate a string, with a visual indication that it is truncated.
truncateStr n s
@@ -147,8 +154,7 @@ hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =
-- @store/<libraryname>/libHS<libraryname>.dylib@
-- where libraryname contains the libraries name, version and abi hash, but in
-- @store/lib/libHS<very short libraryname>.dylib@
--- where the very short library name drops all vowels from the package name,
--- and truncates the hash to 4 bytes.
+-- where the very short library name truncates the hash to 4 bytes.
--
-- We therefore we only need one \@rpath entry to @store/lib@ instead of one
-- \@rpath entry for each library. And the reduced library name saves some
@@ -163,17 +169,19 @@ hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =
-- libraries on macOS, such that the proxy libraries and the linked libraries
-- stay under the load command limit, and the recursive linker is still able
-- to link all of them.
-hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId
+hashedInstalledPackageIdVeryShort :: HasCallStack => PackageHashInputs -> InstalledPackageId
hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =
mkComponentId $
- intercalate
+ prettyShow compid
+ ++
+ '_':intercalate
"-"
- [ filter (not . flip elem "aeiou") (prettyShow name)
+ [ prettyShow name
, prettyShow version
, showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs))
]
where
- PackageIdentifier name version = pkgHashPkgId
+ PackageIdentifier name version (Just compid) = pkgHashPkgId
-- | All the information that contributes to a package's hash, and thus its
-- 'InstalledPackageId'.
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
index 7bf6de869a5..c339d790880 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
@@ -220,7 +220,7 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
else return (BuildStatusUnpack tarball)
where
srcdir :: FilePath
- srcdir = distUnpackedSrcDirectory (packageId pkg)
+ srcdir = distUnpackedSrcDirectory ((packageId pkg){pkgCompiler = Nothing})
dryRunLocalPkg
:: ElaboratedConfiguredPackage
@@ -343,8 +343,7 @@ rebuildTargets
storeDirLayout
installPlan
sharedPackageConfig@ElaboratedSharedConfig
- { pkgConfigCompiler = compiler
- , pkgConfigCompilerProgs = progdb
+ { pkgConfigToolchains = Toolchains{hostToolchain = Toolchain{toolchainCompiler = compiler, toolchainProgramDb = progdb}}
}
pkgsBuildStatus
buildSettings@BuildTimeSettings
@@ -714,7 +713,7 @@ withTarballLocalDirectory
let tmpdir = distTempDirectory
builddir = relativeSymbolicPath $ makeRelativePathEx "dist"
in withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do
- let srcdir = makeSymbolicPath $ unpackdir </> prettyShow pkgid
+ let srcdir = makeSymbolicPath $ unpackdir </> prettyShow (pkgid{pkgCompiler = Nothing})
unpackPackageTarball
verbosity
tarball
@@ -728,7 +727,7 @@ withTarballLocalDirectory
-- inplace there
BuildInplaceOnly{} -> do
let srcrootdir = distUnpackedSrcRootDirectory
- srcdir = distUnpackedSrcDirectory pkgid
+ srcdir = distUnpackedSrcDirectory (pkgid{pkgCompiler = Nothing})
builddir =
makeSymbolicPath $
makeRelative (normalise srcdir) $
@@ -792,7 +791,7 @@ unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =
</> pkgsubdir
</> prettyShow pkgname
<.> "cabal"
- pkgsubdir = prettyShow pkgid
+ pkgsubdir = prettyShow (pkgid{pkgCompiler = Nothing})
pkgname = packageName pkgid
-- | This is a bit of a hacky workaround. A number of packages ship
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
index e19c52157c0..c0bad4bc39f 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
@@ -30,6 +30,7 @@ module Distribution.Client.ProjectBuilding.UnpackedPackage
import Distribution.Client.Compat.Prelude
import Prelude ()
+import Distribution.Client.HookAccept (assertHookHash)
import Distribution.Client.PackageHash (renderPackageHashInputs)
import Distribution.Client.ProjectBuilding.Types
import Distribution.Client.ProjectConfig
@@ -79,7 +80,9 @@ import Distribution.Simple.Command (CommandUI)
import Distribution.Simple.Compiler
( PackageDBStackCWD
, coercePackageDBStack
+ , showCompilerId
)
+import Distribution.Solver.Types.Stage
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.LocalBuildInfo
( ComponentName (..)
@@ -105,7 +108,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS.Char8
import qualified Data.List.NonEmpty as NE
import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, assert, catches, onException)
-import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile)
+import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, removeFile)
import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), (</>))
import System.IO (Handle, IOMode (AppendMode), withFile)
import System.Semaphore (SemaphoreName (..))
@@ -117,6 +120,8 @@ import Distribution.Compat.Directory (listDirectory)
import Distribution.Client.ProjectBuilding.PackageFileMonitor
+import GHC.Stack (HasCallStack)
+
-- | Each unpacked package is processed in the following phases:
--
-- * Configure phase
@@ -177,9 +182,7 @@ buildAndRegisterUnpackedPackage
registerLock
cacheLock
pkgshared@ElaboratedSharedConfig
- { pkgConfigCompiler = compiler
- , pkgConfigCompilerProgs = progdb
- }
+ { pkgConfigToolchains = toolchains }
plan
rpkg@(ReadyPackage pkg)
srcdir
@@ -253,6 +256,10 @@ buildAndRegisterUnpackedPackage
return ()
where
+ (compiler, progdb) = case elabStage pkg of
+ Host -> (toolchainCompiler (hostToolchain toolchains), toolchainProgramDb (hostToolchain toolchains))
+ Build -> (toolchainCompiler (buildToolchain toolchains), toolchainProgramDb (buildToolchain toolchains))
+
uid = installedUnitId rpkg
comp_par_strat = case maybe_semaphore of
@@ -450,7 +457,8 @@ buildInplaceUnpackedPackage
buildSettings@BuildTimeSettings{buildSettingHaddockOpen}
registerLock
cacheLock
- pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = Platform _ os}
+ pkgshared@ElaboratedSharedConfig
+ { pkgConfigToolchains = toolchains }
plan
rpkg@(ReadyPackage pkg)
buildStatus
@@ -595,6 +603,10 @@ buildInplaceUnpackedPackage
, buildResultLogFile = Nothing
}
where
+ Platform _ os = case elabStage pkg of
+ Host -> toolchainPlatform (hostToolchain toolchains)
+ Build -> toolchainPlatform (buildToolchain toolchains)
+
dparams = elabDistDirParams pkgshared pkg
packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams
@@ -656,9 +668,7 @@ buildAndInstallUnpackedPackage
registerLock
cacheLock
pkgshared@ElaboratedSharedConfig
- { pkgConfigCompiler = compiler
- , pkgConfigPlatform = platform
- }
+ { pkgConfigToolchains = toolchains }
plan
rpkg@(ReadyPackage pkg)
srcdir
@@ -697,7 +707,48 @@ buildAndInstallUnpackedPackage
runConfigure
PBBuildPhase{runBuild} -> do
noticeProgress ProgressBuilding
+ hooksDir <- (</> "cabalHooks") <$> getCurrentDirectory
+ -- run preBuildHook. If it returns with 0, we assume the build was
+ -- successful. If not, run the build.
+ preBuildHookFile <- canonicalizePath (hooksDir </> "preBuildHook")
+ hookExists <- doesFileExist preBuildHookFile
+ preCode <-
+ if hookExists
+ then do
+ assertHookHash (pkgConfigHookHashes pkgshared) preBuildHookFile
+ rawSystemExitCode
+ verbosity
+ (Just srcdir)
+ preBuildHookFile
+ [ (unUnitId $ installedUnitId rpkg)
+ , (getSymbolicPath srcdir)
+ , (getSymbolicPath builddir)
+ ]
+ Nothing
+ `catchIO` (\_ -> pure (ExitFailure 10))
+ else pure ExitSuccess
+ -- Regardless of whether the preBuildHook exists or not, or whether it returned an
+ -- error or not, we want to run the build command.
+ -- If the preBuildHook downloads a cached version of the build products, the following
+ -- should be a NOOP.
runBuild
+ -- not sure, if we want to care about a failed postBuildHook?
+ postBuildHookFile <- canonicalizePath (hooksDir </> "postBuildHook")
+ hookExists' <- doesFileExist postBuildHookFile
+ when hookExists' $ do
+ assertHookHash (pkgConfigHookHashes pkgshared) postBuildHookFile
+ void $
+ rawSystemExitCode
+ verbosity
+ (Just srcdir)
+ postBuildHookFile
+ [ (unUnitId $ installedUnitId rpkg)
+ , (getSymbolicPath srcdir)
+ , (getSymbolicPath builddir)
+ , show preCode
+ ]
+ Nothing
+ `catchIO` (\_ -> pure (ExitFailure 10))
PBHaddockPhase{runHaddock} -> do
noticeProgress ProgressHaddock
runHaddock
@@ -712,7 +763,10 @@ buildAndInstallUnpackedPackage
| otherwise = do
assert
( elabRegisterPackageDBStack pkg
- == storePackageDBStack compiler (elabPackageDbs pkg)
+ == storePackageDBStack compiler (case elabStage pkg of
+ Host -> elabPackageDbs pkg
+ Build -> elabBuildPackageDbs pkg
+ )
)
(return ())
_ <-
@@ -764,6 +818,10 @@ buildAndInstallUnpackedPackage
, buildResultLogFile = mlogFile
}
where
+ (compiler, platform) = case elabStage pkg of
+ Host -> (toolchainCompiler (hostToolchain toolchains), toolchainPlatform (hostToolchain toolchains))
+ Build -> (toolchainCompiler (buildToolchain toolchains), toolchainPlatform (buildToolchain toolchains))
+
uid = installedUnitId rpkg
pkgid = packageId rpkg
@@ -774,13 +832,24 @@ buildAndInstallUnpackedPackage
prettyShow pkgid
++ " (all, legacy fallback: "
++ unwords (map whyNotPerComponent $ NE.toList pkgWhyNotPerComponent)
+ ++ ", "
+ ++ dispcompiler (elabStage pkg)
+ -- ++ ", "
+ -- ++ show uid
++ ")"
-- Packages built per component
ElabComponent comp ->
prettyShow pkgid
++ " ("
++ maybe "custom" prettyShow (compComponentName comp)
+ ++ ", "
+ ++ dispcompiler (elabStage pkg)
+ -- ++ ", "
+ -- ++ show uid
++ ")"
+ dispcompiler :: Stage -> String
+ dispcompiler Host = showCompilerId (toolchainCompiler (hostToolchain toolchains))
+ dispcompiler Build = showCompilerId (toolchainCompiler (buildToolchain toolchains))
noticeProgress :: ProgressPhase -> IO ()
noticeProgress phase =
@@ -932,7 +1001,7 @@ hasValidHaddockTargets ElaboratedConfiguredPackage{..}
hasHaddocks = not (null (elabPkgDescription ^. componentModules name))
withTempInstalledPackageInfoFile
- :: Verbosity
+ :: HasCallStack => Verbosity
-> FilePath
-> (FilePath -> IO ())
-> IO InstalledPackageInfo
@@ -946,15 +1015,15 @@ withTempInstalledPackageInfoFile verbosity tempdir action =
readPkgConf "." pkgConfDest
where
- pkgConfParseFailed :: String -> IO a
+ pkgConfParseFailed :: HasCallStack => String -> IO a
pkgConfParseFailed perror =
dieWithException verbosity $ PkgConfParseFailed perror
- readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo
+ readPkgConf :: HasCallStack => FilePath -> FilePath -> IO InstalledPackageInfo
readPkgConf pkgConfDir pkgConfFile = do
pkgConfStr <- BS.readFile (pkgConfDir </> pkgConfFile)
(warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of
- Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors
+ Left perrors -> pkgConfParseFailed $ unlines $ "While parsing:":LBS.Char8.unpack (LBS.Char8.fromStrict pkgConfStr):"encountered:":NE.toList perrors
Right (warns, ipkg) -> return (warns, ipkg)
unless (null warns) $
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs
index b9f2cfed6c6..c211f26abca 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs
@@ -57,6 +57,7 @@ module Distribution.Client.ProjectConfig
, BuildTimeSettings (..)
, resolveBuildTimeSettings
, resolveNumJobsSetting
+ , resolveProgramDb
-- * Checking configuration
, checkBadPerPackageCompilerPaths
@@ -175,6 +176,9 @@ import Distribution.Simple.InstallDirs
)
import Distribution.Simple.Program
( ConfiguredProgram (..)
+ , ProgramDb
+ , defaultProgramDb
+ , userSpecifyPaths
)
import Distribution.Simple.Setup
( Flag (Flag)
@@ -245,6 +249,7 @@ import System.IO
)
import Distribution.Deprecated.ProjectParseUtils (ProjectParseError (..), ProjectParseWarning)
+import Distribution.Simple.Program.Db (prependProgramSearchPath)
import Distribution.Solver.Types.ProjectConfigPath
----------------------------------------
@@ -554,6 +559,12 @@ resolveNumJobsSetting projectConfigUseSemaphore projectConfigNumJobs =
1 -> Serial
n -> NumJobs (Just n)
+resolveProgramDb :: Verbosity -> PackageConfig -> IO ProgramDb
+resolveProgramDb verbosity pkgconf = do
+ let extraPath = fromNubList (packageConfigProgramPathExtra pkgconf)
+ progdb <- prependProgramSearchPath verbosity extraPath [] defaultProgramDb
+ return $ userSpecifyPaths (Map.toList (getMapLast (packageConfigProgramPaths pkgconf))) progdb
+
---------------------------------------------
-- Reading and writing project config files
--
@@ -787,6 +798,8 @@ defaultImplicitProjectConfig =
mempty
{ -- We expect a package in the current directory.
projectPackages = ["./*.cabal"]
+ -- By default we do not assume any special build packages.
+ , projectBuildPackages = []
, projectConfigProvenance = Set.singleton Implicit
}
@@ -1073,11 +1086,20 @@ findProjectPackages
DistDirLayout{distProjectRootDirectory}
ProjectConfig{..} = do
requiredPkgs <- findPackageLocations True projectPackages
+ buildPkgs <- findPackageLocations True projectBuildPackages
optionalPkgs <- findPackageLocations False projectPackagesOptional
let repoPkgs = map ProjectPackageRemoteRepo projectPackagesRepo
namedPkgs = map ProjectPackageNamed projectPackagesNamed
- return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs])
+ -- FIXME: We should _REALLY_ Tag the packages here somehow.
+ -- Right now we just slam together requiredPkgs and buildPkgs, ...
+ -- Maybe we can carry the Build/Host distinction in the
+ -- ProjectPackageLocation. Because we later on really want to make
+ -- sure we consider only buildPkgs for building with the Build
+ -- compiler, and all others with the Host compiler. For now we just
+ -- Assume both for both compilers, but this is not god.
+ -- XXX: FIXME!
+ return (concat [requiredPkgs, buildPkgs, optionalPkgs, repoPkgs, namedPkgs])
where
findPackageLocations :: Bool -> [String] -> Rebuild [ProjectPackageLocation]
findPackageLocations required pkglocstr = do
@@ -1261,7 +1283,6 @@ mplusMaybeT ma mb = do
fetchAndReadSourcePackages
:: Verbosity
-> DistDirLayout
- -> Maybe Compiler
-> ProjectConfigShared
-> ProjectConfigBuildOnly
-> [ProjectPackageLocation]
@@ -1269,7 +1290,6 @@ fetchAndReadSourcePackages
fetchAndReadSourcePackages
verbosity
distDirLayout
- compiler
projectConfigShared
projectConfigBuildOnly
pkgLocations = do
@@ -1306,9 +1326,7 @@ fetchAndReadSourcePackages
syncAndReadSourcePackagesRemoteRepos
verbosity
distDirLayout
- compiler
projectConfigShared
- projectConfigBuildOnly
(fromFlag (projectConfigOfflineMode projectConfigBuildOnly))
[repo | ProjectPackageRemoteRepo repo <- pkgLocations]
@@ -1425,23 +1443,16 @@ fetchAndReadSourcePackageRemoteTarball
syncAndReadSourcePackagesRemoteRepos
:: Verbosity
-> DistDirLayout
- -> Maybe Compiler
-> ProjectConfigShared
- -> ProjectConfigBuildOnly
-> Bool
-> [SourceRepoList]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
syncAndReadSourcePackagesRemoteRepos
verbosity
DistDirLayout{distDownloadSrcDirectory}
- compiler
ProjectConfigShared
{ projectConfigProgPathExtra
}
- ProjectConfigBuildOnly
- { projectConfigUseSemaphore
- , projectConfigNumJobs
- }
offlineMode
repos = do
repos' <-
@@ -1462,14 +1473,15 @@ syncAndReadSourcePackagesRemoteRepos
]
let progPathExtra = fromNubList projectConfigProgPathExtra
+
getConfiguredVCS <- delayInitSharedResources $ \repoType ->
let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs
in configureVCS verbosity progPathExtra vcs
- concat
- <$> rerunConcurrentlyIfChanged
+ x <-
+ rerunConcurrentlyIfChanged
verbosity
- (newJobControlFromParStrat verbosity compiler parStrat (Just maxNumFetchJobs))
+ (newParallelJobControl maxNumFetchJobs)
[ ( monitor
, repoGroup'
, do
@@ -1487,8 +1499,9 @@ syncAndReadSourcePackagesRemoteRepos
[PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
monitor = newFileMonitor (pathStem <.> "cache")
]
+
+ return (concat x)
where
- parStrat = resolveNumJobsSetting projectConfigUseSemaphore projectConfigNumJobs
syncRepoGroupAndReadSourcePackages
:: VCS ConfiguredProgram
-> FilePath
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
index 10858d5601d..bc8268d1506 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
@@ -408,6 +408,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
-- can redefine the parsers directly for the new types.
data LegacyProjectConfig = LegacyProjectConfig
{ legacyPackages :: [String]
+ , legacyBuildPackages :: [String]
, legacyPackagesOptional :: [String]
, legacyPackagesRepo :: [SourceRepoList]
, legacyPackagesNamed :: [PackageVersionConstraint]
@@ -613,6 +614,7 @@ convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig
convertLegacyProjectConfig
LegacyProjectConfig
{ legacyPackages
+ , legacyBuildPackages
, legacyPackagesOptional
, legacyPackagesRepo
, legacyPackagesNamed
@@ -637,6 +639,7 @@ convertLegacyProjectConfig
} =
ProjectConfig
{ projectPackages = legacyPackages
+ , projectBuildPackages = legacyBuildPackages
, projectPackagesOptional = legacyPackagesOptional
, projectPackagesRepo = legacyPackagesRepo
, projectPackagesNamed = legacyPackagesNamed
@@ -704,6 +707,11 @@ convertLegacyAllPackageFlags
convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags projectConfigMultiRepl =
ProjectConfigShared{..}
where
+ projectConfigPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigPackageDBs_
+ projectConfigBuildPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigBuildPackageDBs_
+ projectConfigHookHashes = mempty -- :: Map FilePath HookAccept
+ projectConfigDistDir = fmap getSymbolicPath projectConfigAbsoluteDistDir
+
GlobalFlags
{ globalConfigFile = projectConfigConfigFile
, globalRemoteRepos = projectConfigRemoteRepos
@@ -713,8 +721,6 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags
, globalStoreDir = projectConfigStoreDir
} = globalFlags
- projectConfigPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigPackageDBs_
-
ConfigFlags
{ configCommonFlags = commonFlags
, configHcFlavor = projectConfigHcFlavor
@@ -730,8 +736,6 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags
{ setupDistPref = projectConfigAbsoluteDistDir
} = commonFlags
- projectConfigDistDir = fmap getSymbolicPath projectConfigAbsoluteDistDir
-
ConfigExFlags
{ configCabalVersion = projectConfigCabalVersion
, configExConstraints = projectConfigConstraints
@@ -741,6 +745,10 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags
, configAllowNewer = projectConfigAllowNewer
, configWriteGhcEnvironmentFilesPolicy =
projectConfigWriteGhcEnvironmentFilesPolicy
+ , configBuildHcFlavor = projectConfigBuildHcFlavor
+ , configBuildHcPath = projectConfigBuildHcPath
+ , configBuildHcPkg = projectConfigBuildHcPkg
+ , configBuildPackageDBs = projectConfigBuildPackageDBs_
} = configExFlags
InstallFlags
@@ -931,6 +939,7 @@ convertToLegacyProjectConfig :: ProjectConfig -> LegacyProjectConfig
convertToLegacyProjectConfig
projectConfig@ProjectConfig
{ projectPackages
+ , projectBuildPackages
, projectPackagesOptional
, projectPackagesRepo
, projectPackagesNamed
@@ -940,6 +949,7 @@ convertToLegacyProjectConfig
} =
LegacyProjectConfig
{ legacyPackages = projectPackages
+ , legacyBuildPackages = projectBuildPackages
, legacyPackagesOptional = projectPackagesOptional
, legacyPackagesRepo = projectPackagesRepo
, legacyPackagesNamed = projectPackagesNamed
@@ -1010,7 +1020,7 @@ convertToLegacySharedConfig
}
configExFlags =
- ConfigExFlags
+ mempty
{ configCabalVersion = projectConfigCabalVersion
, configAppend = mempty
, configBackup = mempty
@@ -1311,6 +1321,12 @@ legacyProjectConfigFieldDescrs constraintSrc =
parsePackageLocationTokenQ
legacyPackages
(\v flags -> flags{legacyPackages = v})
+ , newLineListField
+ "build-packages"
+ (Disp.text . renderPackageLocationToken)
+ parsePackageLocationTokenQ
+ legacyBuildPackages
+ (\v flags -> flags{legacyBuildPackages = v})
, newLineListField
"optional-packages"
(Disp.text . renderPackageLocationToken)
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
index 1a2b6ae2fa6..0f82fbcc12f 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
@@ -33,6 +33,7 @@ import Distribution.Client.BuildReports.Types
import Distribution.Client.Dependency.Types
( PreSolver
)
+import Distribution.Client.HookAccept (HookAccept (..))
import Distribution.Client.Targets
( UserConstraint
)
@@ -128,6 +129,11 @@ data ProjectConfig = ProjectConfig
-- ^ Packages in this project, including local dirs, local .cabal files
-- local and remote tarballs. When these are file globs, they must
-- match at least one package.
+ , projectBuildPackages :: [String]
+ -- ^ Packages in this project, including local dirs, local .cabal files
+ -- local and remote tarballs considered only for build-time dependencies
+ -- (build-type: Custom orHooks; build-depends, ...). When these are file
+ -- globs, they must match at least one package.
, projectPackagesOptional :: [String]
-- ^ Like 'projectConfigPackageGlobs' but /optional/ in the sense that
-- file globs are allowed to match nothing. The primary use case for
@@ -191,6 +197,9 @@ data ProjectConfigShared = ProjectConfigShared
, projectConfigHcFlavor :: Flag CompilerFlavor
, projectConfigHcPath :: Flag FilePath
, projectConfigHcPkg :: Flag FilePath
+ , projectConfigBuildHcFlavor :: Flag CompilerFlavor
+ , projectConfigBuildHcPath :: Flag FilePath
+ , projectConfigBuildHcPkg :: Flag FilePath
, projectConfigHaddockIndex :: Flag PathTemplate
, -- Only makes sense for manual mode, not --local mode
-- too much control!
@@ -198,6 +207,7 @@ data ProjectConfigShared = ProjectConfigShared
projectConfigInstallDirs :: InstallDirs (Flag PathTemplate)
, projectConfigPackageDBs :: [Maybe PackageDBCWD]
+ , projectConfigBuildPackageDBs :: [Maybe PackageDBCWD]
, -- configuration used both by the solver and other phases
projectConfigRemoteRepos :: NubList RemoteRepo
-- ^ Available Hackage servers.
@@ -227,6 +237,7 @@ data ProjectConfigShared = ProjectConfigShared
, projectConfigPreferOldest :: Flag PreferOldest
, projectConfigProgPathExtra :: NubList FilePath
, projectConfigMultiRepl :: Flag Bool
+ , projectConfigHookHashes :: Map FilePath HookAccept
-- More things that only make sense for manual mode, not --local mode
-- too much control!
-- projectConfigShadowPkgs :: Flag Bool,
diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs
index a14d43e4b99..6d91783326a 100644
--- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs
+++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs
@@ -176,6 +176,8 @@ import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Client.Errors
+import Distribution.Client.HookAccept (loadHookHasheshMap)
+
import Distribution.Package
import Distribution.Simple.Command (commandShowOptions)
import Distribution.Simple.Compiler
@@ -363,6 +365,8 @@ withInstallPlan
, installedPackages
}
action = do
+ hookHashes <- loadHookHasheshMap (projectConfigConfigFile $ projectConfigShared projectConfig)
+
-- Take the project configuration and make a plan for how to build
-- everything in the project. This is independent of any specific targets
-- the user has asked for.
@@ -370,6 +374,7 @@ withInstallPlan
(elaboratedPlan, _, elaboratedShared, _, _) <-
rebuildInstallPlan
verbosity
+ hookHashes
distDirLayout
cabalDirLayout
projectConfig
@@ -392,6 +397,8 @@ runProjectPreBuildPhase
, installedPackages
}
selectPlanSubset = do
+ hookHashes <- loadHookHasheshMap (projectConfigConfigFile $ projectConfigShared projectConfig)
+
-- Take the project configuration and make a plan for how to build
-- everything in the project. This is independent of any specific targets
-- the user has asked for.
@@ -399,6 +406,7 @@ runProjectPreBuildPhase
(elaboratedPlan, _, elaboratedShared, _, _) <-
rebuildInstallPlan
verbosity
+ hookHashes
distDirLayout
cabalDirLayout
projectConfig
@@ -517,7 +525,7 @@ runProjectPostBuildPhase
AlwaysWriteGhcEnvironmentFiles -> True
NeverWriteGhcEnvironmentFiles -> False
WriteGhcEnvironmentFilesOnlyForGhc844AndNewer ->
- let compiler = pkgConfigCompiler elaboratedShared
+ let compiler = toolchainCompiler $ buildToolchain $ pkgConfigToolchains elaboratedShared
ghcCompatVersion = compilerCompatVersion GHC compiler
in maybe False (>= mkVersion [8, 4, 4]) ghcCompatVersion
@@ -651,7 +659,7 @@ resolveTargets
checkTarget bt@(TargetPackage _ (ordNub -> [pkgid]) mkfilter)
| Just ats <-
fmap (maybe id filterTargetsKind mkfilter) $
- Map.lookup pkgid availableTargetsByPackageId =
+ (Map.lookup pkgid availableTargetsByPackageId) =
fmap (componentTargets WholeComponent) $
selectPackageTargets bt ats
| otherwise =
@@ -677,9 +685,17 @@ resolveTargets
$ concat (Map.elems availableTargetsByPackageId)
checkTarget (TargetComponent pkgid cname subtarget)
| Just ats <-
- Map.lookup
- (pkgid, cname)
- availableTargetsByPackageIdAndComponentName =
+ -- FIXME: this is stupid. We do not know what the target selectors HOST compiler is...
+ -- so we'll assume tere is only a _SINGLE_ match in the map if we ignore the pkgCompiler.
+ -- This lookup is now O(n) instead of O(log n).
+ (case [v | ((k,k'),v) <- Map.toList availableTargetsByPackageIdAndComponentName
+ , k{pkgCompiler = Nothing} == pkgid
+ , k' == cname] of
+ [match] -> Just match)
+ -- (Map.lookup
+ -- (pkgid, cname)
+ -- availableTargetsByPackageIdAndComponentName))
+ =
fmap (componentTargets subtarget) $
selectComponentTargets subtarget ats
| Map.member pkgid availableTargetsByPackageId =
@@ -993,6 +1009,8 @@ printPlan
showPkgAndReason (ReadyPackage elab) =
unwords $
filter (not . null) $
+ -- FIXME: ideally we'd like to display the compiler in there as well.
+ -- we do have access to elabStage, but the toolchain isn't around.
[ " -"
, if verbosity >= deafening
then prettyShow (installedUnitId elab)
@@ -1081,7 +1099,7 @@ printPlan
in -- Not necessary to "escape" it, it's just for user output
unwords . ("" :) $
commandShowOptions
- (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared))
+ (Setup.configureCommand (toolchainProgramDb $ buildToolchain $ pkgConfigToolchains elaboratedShared))
partialConfigureFlags
showBuildStatus :: BuildStatus -> String
@@ -1113,7 +1131,9 @@ printPlan
showBuildProfile =
"Build profile: "
++ unwords
- [ "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared
+ [ "-w " ++ (showCompilerId . toolchainCompiler . hostToolchain . pkgConfigToolchains) elaboratedShared
+ -- FIXME: this should only be shown if hostToolchain /= buildToolchain
+ , "-W " ++ (showCompilerId . toolchainCompiler . buildToolchain . pkgConfigToolchains) elaboratedShared
, "-O"
++ ( case globalOptimization <> localOptimization of -- if local is not set, read global
Setup.Flag NoOptimisation -> "0"
@@ -1126,8 +1146,8 @@ printPlan
writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()
writeBuildReports settings buildContext plan buildOutcomes = do
- let plat@(Platform arch os) = pkgConfigPlatform . elaboratedShared $ buildContext
- comp = pkgConfigCompiler . elaboratedShared $ buildContext
+ let plat@(Platform arch os) = toolchainPlatform . buildToolchain . pkgConfigToolchains . elaboratedShared $ buildContext
+ comp = toolchainCompiler . buildToolchain . pkgConfigToolchains . elaboratedShared $ buildContext
getRepo (RepoTarballPackage r _ _) = Just r
getRepo _ = Nothing
fromPlanPackage (InstallPlan.Configured pkg) (Just result) =
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs
index b6b5dc8dd79..a38a792481e 100644
--- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs
+++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs
@@ -46,9 +46,7 @@ import Distribution.Simple.BuildPaths
)
import Distribution.Simple.Compiler
import Distribution.Simple.GHC
- ( GhcEnvironmentFileEntry (..)
- , GhcImplInfo (supportsPkgEnvFiles)
- , getImplInfo
+ ( GhcEnvironmentFileEntry (GhcEnvFileComment)
, simpleGhcEnvironmentFile
, writeGhcEnvironmentFile
)
@@ -57,9 +55,9 @@ import Distribution.System
import Distribution.Types.Version
( mkVersion
)
-import Distribution.Utils.Path hiding
- ( (<.>)
- , (</>)
+import Distribution.Utils.Path
+ ( getSymbolicPath
+ , makeSymbolicPath
)
import Distribution.Verbosity
@@ -107,7 +105,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
[ "cabal-version" J..= jdisplay cabalInstallVersion
, "cabal-lib-version" J..= jdisplay cabalVersion
, "compiler-id"
- J..= (J.String . showCompilerId . pkgConfigCompiler)
+ J..= (J.String . showCompilerId . toolchainCompiler . hostToolchain . pkgConfigToolchains)
elaboratedSharedConfig
, "os" J..= jdisplay os
, "arch" J..= jdisplay arch
@@ -115,7 +113,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
]
where
plat :: Platform
- plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig
+ plat@(Platform arch os) = toolchainPlatform . hostToolchain . pkgConfigToolchains $ elaboratedSharedConfig
installPlanToJ :: ElaboratedInstallPlan -> [J.Value]
installPlanToJ = map planPackageToJ . InstallPlan.toList
@@ -799,7 +797,7 @@ createPackageEnvironment
elaboratedPlan
elaboratedShared
buildStatus
- | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC =
+ | compilerFlavor (toolchainCompiler $ hostToolchain $ pkgConfigToolchains elaboratedShared) == GHC =
do
envFileM <-
writePlanGhcEnvironment
@@ -829,29 +827,30 @@ writePlanGhcEnvironment
writePlanGhcEnvironment
path
elaboratedInstallPlan
- ElaboratedSharedConfig
- { pkgConfigCompiler = compiler
- , pkgConfigPlatform = platform
- }
- postBuildStatus
- | compilerFlavor compiler == GHC
- , supportsPkgEnvFiles (getImplInfo compiler) =
- -- TODO: check ghcjs compat
- fmap Just $
- writeGhcEnvironmentFile
+ elaboratedSharedConfig
+ postBuildStatus =
+ -- \| compilerFlavor compiler == GHC
+ -- , supportsPkgEnvFiles (getImplInfo compiler) =
+
+ -- TODO: check ghcjs compat
+ fmap Just $
+ writeGhcEnvironmentFile
+ path
+ -- FIXME
+ (toolchainPlatform (hostToolchain (pkgConfigToolchains elaboratedSharedConfig)))
+ -- FIXME
+ (compilerVersion (toolchainCompiler (hostToolchain (pkgConfigToolchains elaboratedSharedConfig))))
+ ( renderGhcEnvironmentFile
path
- platform
- (compilerVersion compiler)
- ( renderGhcEnvironmentFile
- path
- elaboratedInstallPlan
- postBuildStatus
- )
+ elaboratedInstallPlan
+ postBuildStatus
+ )
+
-- TODO: [required eventually] support for writing user-wide package
-- environments, e.g. like a global project, but we would not put the
-- env file in the home dir, rather it lives under ~/.ghc/
-writePlanGhcEnvironment _ _ _ _ = return Nothing
+-- writePlanGhcEnvironment _ _ _ _ = return Nothing
renderGhcEnvironmentFile
:: FilePath
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
index c04bca730d7..8df269624f4 100644
--- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs
+++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
@@ -95,6 +95,9 @@ module Distribution.Client.ProjectPlanning
, binDirectories
, storePackageInstallDirs
, storePackageInstallDirs'
+
+ -- * Re-exports for backward compatibility
+ , programDbSignature
) where
import Distribution.Client.Compat.Prelude
@@ -117,6 +120,7 @@ import Distribution.Client.Dependency
import Distribution.Client.DistDirLayout
import Distribution.Client.FetchUtils
import Distribution.Client.HashValue
+import Distribution.Client.HookAccept (HookAccept)
import Distribution.Client.HttpUtils
import Distribution.Client.JobControl
import Distribution.Client.PackageHash
@@ -163,6 +167,7 @@ import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SolverId
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.Stage
import Distribution.ModuleName
import Distribution.Package
@@ -176,7 +181,7 @@ import Distribution.Simple.LocalBuildInfo
)
import Distribution.Simple.BuildWay
-import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import Distribution.Simple.PackageIndex (InstalledPackageIndex, allPackages)
import Distribution.Simple.Program
import Distribution.Simple.Program.Db
import Distribution.Simple.Program.Find
@@ -193,6 +198,7 @@ import Distribution.Types.GivenComponent
import Distribution.Types.LibraryName
import qualified Distribution.Types.LocalBuildConfig as LBC
import Distribution.Types.PackageVersionConstraint
+import qualified Distribution.Types.PackageId as PI
import Distribution.Types.PkgconfigDependency
import Distribution.Types.UnqualComponentName
@@ -215,8 +221,11 @@ import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.GHCJS as GHCJS
import qualified Distribution.Simple.InstallDirs as InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as Cabal
+import qualified Distribution.Simple.PackageIndex as PI
import qualified Distribution.Simple.Setup as Cabal
import qualified Distribution.Solver.Types.ComponentDeps as CD
+-- import Distribution.Solver.Types.Stage
+import Distribution.Solver.Types.Toolchain
import qualified Distribution.Compat.Graph as Graph
@@ -234,6 +243,9 @@ import Distribution.Solver.Types.ProjectConfigPath
import System.FilePath
import qualified Text.PrettyPrint as Disp
+import GHC.Stack (HasCallStack)
+-- import qualified Distribution.Solver.Types.PackageIndex as XXX
+
-- | Check that an 'ElaboratedConfiguredPackage' actually makes
-- sense under some 'ElaboratedSharedConfig'.
sanityCheckElaboratedConfiguredPackage
@@ -397,14 +409,14 @@ rebuildProjectConfig
let fetchCompiler = do
-- have to create the cache directory before configuring the compiler
liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
- (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig)
- pure (os, arch, compiler)
+ Toolchains{hostToolchain = Toolchain{toolchainCompiler = compiler, toolchainPlatform = Platform arch os}} <- configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig)
+ return (os, arch, compiler)
- (projectConfig, compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton
+ (projectConfig, _compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton
when (projectConfigDistDir (projectConfigShared $ projectConfig) /= NoFlag) $
liftIO $
warn verbosity "The builddir option is not supported in project and config files. It will be ignored."
- localPackages <- phaseReadLocalPackages compiler (projectConfig <> cliConfig)
+ localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig)
return (projectConfig, localPackages)
let configfiles =
@@ -436,11 +448,9 @@ rebuildProjectConfig
-- NOTE: These are all packages mentioned in the project configuration.
-- Whether or not they will be considered local to the project will be decided by `shouldBeLocal`.
phaseReadLocalPackages
- :: Maybe Compiler
- -> ProjectConfig
+ :: ProjectConfig
-> Rebuild [PackageSpecifier UnresolvedSourcePackage]
phaseReadLocalPackages
- compiler
projectConfig@ProjectConfig
{ projectConfigShared
, projectConfigBuildOnly
@@ -455,7 +465,6 @@ rebuildProjectConfig
fetchAndReadSourcePackages
verbosity
distDirLayout
- compiler
projectConfigShared
projectConfigBuildOnly
pkgLocations
@@ -464,7 +473,7 @@ configureCompiler
:: Verbosity
-> DistDirLayout
-> ProjectConfig
- -> Rebuild (Compiler, Platform, ProgramDb)
+ -> Rebuild Toolchains
configureCompiler
verbosity
DistDirLayout
@@ -476,9 +485,12 @@ configureCompiler
{ projectConfigHcFlavor
, projectConfigHcPath
, projectConfigHcPkg
+ , projectConfigBuildHcFlavor
+ , projectConfigBuildHcPath
+ , projectConfigBuildHcPkg
}
, projectConfigLocalPackages =
- PackageConfig
+ projectConfigLocalPackages@PackageConfig
{ packageConfigProgramPaths
, packageConfigProgramPathExtra
}
@@ -499,37 +511,55 @@ configureCompiler
)
$ do
liftIO $ info verbosity "Compiler settings changed, reconfiguring..."
- let extraPath = fromNubList packageConfigProgramPathExtra
- progdb <- liftIO $ prependProgramSearchPath verbosity extraPath [] defaultProgramDb
- let progdb' = userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) progdb
- result@(_, _, progdb'') <-
- liftIO $
- Cabal.configCompilerEx
- hcFlavor
- hcPath
- hcPkg
- progdb'
- verbosity
- -- Note that we added the user-supplied program locations and args
- -- for /all/ programs, not just those for the compiler prog and
- -- compiler-related utils. In principle we don't know which programs
- -- the compiler will configure (and it does vary between compilers).
- -- We do know however that the compiler will only configure the
- -- programs it cares about, and those are the ones we monitor here.
- monitorFiles (programsMonitorFiles progdb'')
-
- -- Note: There is currently a bug here: we are dropping unconfigured
- -- programs from the 'ProgramDb' when we re-use the cache created by
- -- 'rerunIfChanged'.
- --
- -- See Note [Caching the result of configuring the compiler]
+ defdb <- liftIO $ resolveProgramDb verbosity projectConfigLocalPackages
+
+ buildToolchain <- do
+ (compiler, platform, progdb) <-
+ liftIO $
+ Cabal.configCompilerEx
+ buildHcFlavor
+ buildHcPath
+ buildHcPkg
+ defdb
+ verbosity
+
+ -- Note that we added the user-supplied program locations and args
+ -- for /all/ programs, not just those for the compiler prog and
+ -- compiler-related utils. In principle we don't know which programs
+ -- the compiler will configure (and it does vary between compilers).
+ -- We do know however that the compiler will only configure the
+ -- programs it cares about, and those are the ones we monitor here.
+ monitorFiles (programsMonitorFiles progdb)
+ return Toolchain{toolchainCompiler = compiler, toolchainPlatform = platform, toolchainProgramDb = progdb}
+
+ hostToolchain <- do
+ (compiler, platform, progdb) <-
+ liftIO $
+ Cabal.configCompilerEx
+ hcFlavor
+ hcPath
+ hcPkg
+ defdb
+ verbosity
- return result
+ -- Note that we added the user-supplied program locations and args
+ -- for /all/ programs, not just those for the compiler prog and
+ -- compiler-related utils. In principle we don't know which programs
+ -- the compiler will configure (and it does vary between compilers).
+ -- We do know however that the compiler will only configure the
+ -- programs it cares about, and those are the ones we monitor here.
+ monitorFiles (programsMonitorFiles progdb)
+ return Toolchain{toolchainCompiler = compiler, toolchainPlatform = platform, toolchainProgramDb = progdb}
+
+ return Toolchains{buildToolchain, hostToolchain}
where
hcFlavor = flagToMaybe projectConfigHcFlavor
hcPath = flagToMaybe projectConfigHcPath
hcPkg = flagToMaybe projectConfigHcPkg
+ buildHcFlavor = flagToMaybe projectConfigBuildHcFlavor <|> flagToMaybe projectConfigHcFlavor
+ buildHcPath = flagToMaybe projectConfigBuildHcPath <|> flagToMaybe projectConfigHcPath
+ buildHcPkg = flagToMaybe projectConfigBuildHcPkg <|> flagToMaybe projectConfigHcPkg
{- Note [Caching the result of configuring the compiler]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -589,6 +619,7 @@ Binary ProgramDb instance.
--
rebuildInstallPlan
:: Verbosity
+ -> Map FilePath HookAccept
-> DistDirLayout
-> CabalDirLayout
-> ProjectConfig
@@ -604,6 +635,7 @@ rebuildInstallPlan
-- ^ @(improvedPlan, elaboratedPlan, _, _, _)@
rebuildInstallPlan
verbosity
+ hookHashes
distDirLayout@DistDirLayout
{ distProjectRootDirectory
, distProjectCacheFile
@@ -621,7 +653,7 @@ rebuildInstallPlan
fileMonitorImprovedPlan
-- react to changes in the project config,
-- the package .cabal files and the path
- (projectConfigMonitored, localPackages, progsearchpath)
+ (projectConfigMonitored, localPackages, progsearchpath, hookHashes)
$ do
-- And so is the elaborated plan that the improved plan based on
(elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <-
@@ -631,14 +663,16 @@ rebuildInstallPlan
( projectConfigMonitored
, localPackages
, progsearchpath
+ , hookHashes
)
$ do
- compilerEtc <- phaseConfigureCompiler projectConfig
- _ <- phaseConfigurePrograms projectConfig compilerEtc
+ toolchains <- phaseConfigureToolchain projectConfig
+
+ -- _ <- phaseConfigurePrograms projectConfig compilerEtc
(solverPlan, pkgConfigDB, totalIndexState, activeRepos) <-
phaseRunSolver
projectConfig
- compilerEtc
+ toolchains
localPackages
(fromMaybe mempty mbInstalledPackages)
( elaboratedPlan
@@ -646,7 +680,7 @@ rebuildInstallPlan
) <-
phaseElaboratePlan
projectConfig
- compilerEtc
+ toolchains
pkgConfigDB
solverPlan
localPackages
@@ -674,10 +708,11 @@ rebuildInstallPlan
-- This is moderately expensive and doesn't change that often so we cache
-- it independently.
--
- phaseConfigureCompiler
+ phaseConfigureToolchain
:: ProjectConfig
- -> Rebuild (Compiler, Platform, ProgramDb)
- phaseConfigureCompiler = configureCompiler verbosity distDirLayout
+ -> Rebuild Toolchains
+ phaseConfigureToolchain = do
+ configureCompiler verbosity distDirLayout
-- Configuring other programs.
--
@@ -691,19 +726,19 @@ rebuildInstallPlan
-- all local packages, but that all the programs configured so far are the
-- compiler program or related util programs.
--
- phaseConfigurePrograms
- :: ProjectConfig
- -> (Compiler, Platform, ProgramDb)
- -> Rebuild ()
- phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do
- -- Users are allowed to specify program locations independently for
- -- each package (e.g. to use a particular version of a pre-processor
- -- for some packages). However they cannot do this for the compiler
- -- itself as that's just not going to work. So we check for this.
- liftIO $
- checkBadPerPackageCompilerPaths
- (configuredPrograms compilerprogdb)
- (getMapMappend (projectConfigSpecificPackage projectConfig))
+ -- phaseConfigurePrograms
+ -- :: ProjectConfig
+ -- -> (Compiler, Platform, ProgramDb)
+ -- -> Rebuild ()
+ -- phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do
+ -- -- Users are allowed to specify program locations independently for
+ -- -- each package (e.g. to use a particular version of a pre-processor
+ -- -- for some packages). However they cannot do this for the compiler
+ -- -- itself as that's just not going to work. So we check for this.
+ -- liftIO $
+ -- checkBadPerPackageCompilerPaths
+ -- (configuredPrograms compilerprogdb)
+ -- (getMapMappend (projectConfigSpecificPackage projectConfig))
-- TODO: [required eventually] find/configure other programs that the
-- user specifies.
@@ -716,7 +751,7 @@ rebuildInstallPlan
--
phaseRunSolver
:: ProjectConfig
- -> (Compiler, Platform, ProgramDb)
+ -> Toolchains
-> [PackageSpecifier UnresolvedSourcePackage]
-> InstalledPackageIndex
-> Rebuild (SolverInstallPlan, Maybe PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)
@@ -725,34 +760,92 @@ rebuildInstallPlan
{ projectConfigShared
, projectConfigBuildOnly
}
- (compiler, platform, progdb)
- localPackages
+ toolchains
+ localPackages_
installedPackages =
rerunIfChanged
verbosity
fileMonitorSolverPlan
( solverSettings
- , localPackages
+ , localPackages_
, localPackagesEnabledStanzas
- , compiler
- , platform
- , programDbSignature progdb
+ , toolchains
+ , hookHashes
)
$ do
- installedPkgIndex <-
+ -- InstalledPackageIndex
+ -- type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo
+ -- data PackageIndex a = PackageIndex
+ -- { -- The primary index. Each InstalledPackageInfo record is uniquely identified
+ -- -- by its UnitId.
+ -- --
+ -- unitIdIndex :: !(Map UnitId a)
+ -- , -- This auxiliary index maps package names (case-sensitively) to all the
+ -- -- versions and instances of that package. This allows us to find all
+ -- -- versions satisfying a dependency.
+ -- --
+ -- -- It is a three-level index. The first level is the package name,
+ -- -- the second is the package version and the final level is instances
+ -- -- of the same package version. These are unique by UnitId
+ -- -- and are kept in preference order.
+ -- --
+ -- -- FIXME: Clarify what "preference order" means. Check that this invariant is
+ -- -- preserved. See #1463 for discussion.
+ -- packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a]))
+ -- }
+ -- deriving (Eq, Generic, Show, Read)
+ --
+ -- let mapPkgIdx f = PI.fromList . map f . PI.allPackages
+ -- let updateIPI :: IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo
+ -- updateIPI ipi = ipi {
+ -- IPI.sourcePackageId = (IPI.sourcePackageId ipi){ PI.pkgCompiler = IPI.pkgCompiler ipi }
+ -- }
+
+ hinstalledPkgIndex <-
+ -- mapPkgIdx updateIPI <$>
getInstalledPackages
verbosity
- compiler
- progdb
- platform
- corePackageDbs
- (sourcePkgDb, tis, ar) <-
+ (hostToolchain toolchains)
+ (corePackageDbs Host)
+ -- this is an aweful hack, however `getInstalledPackages` is
+ -- terribly invovled everywhere so we'll have to do with this
+ -- for now. FIXME!
+ -- let hinstalledPkgIndex' = PI.fromList $ PI.allPackages hinstalledPkgIndex
+ binstalledPkgIndex <-
+ -- mapPkgIdx updateIPI <$>
+ getInstalledPackages
+ verbosity
+ (buildToolchain toolchains)
+ -- FIXME: HACK
+ -- if host and build compiler are the same, we want to get -package-db in here.
+ (corePackageDbs $ if buildIsHost toolchains then Host else Build)
+
+ -- getSourcePackages
+ -- :: Verbosity
+ -- -> (forall a. (RepoContext -> IO a) -> IO a)
+ -- -> Maybe IndexUtils.TotalIndexState
+ -- -> Maybe IndexUtils.ActiveRepos
+ -- -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)
+
+ -- data SourcePackageDb = SourcePackageDb
+ -- { packageIndex :: PackageIndex UnresolvedSourcePackage
+ -- , packagePreferences :: Map PackageName VersionRange
+ -- }
+
+ -- NOTE: sourcePkgDbs is the stuff that we pull from Hackage
+ -- and similar Indices!
+ (sourcePkgDb_, tis, ar) <-
getSourcePackages
verbosity
withRepoCtx
(solverSettingIndexState solverSettings)
(solverSettingActiveRepos solverSettings)
- pkgConfigDB <- getPkgConfigDb verbosity progdb
+
+ -- FIXME: we are duplicating the index here, bad for memory use :-/
+ let sourcePkgDb = sourcePkgDb_{packageIndex = (addCompilerIdToSrcPkg (compilerIdFor Build toolchains) <$> packageIndex sourcePkgDb_)
+ <> (addCompilerIdToSrcPkg (compilerIdFor Host toolchains) <$> packageIndex sourcePkgDb_) }
+
+ pkgConfigDB <- getPkgConfigDb verbosity (toolchainProgramDb $ buildToolchain toolchains)
-- TODO: [code cleanup] it'd be better if the Compiler contained the
-- ConfiguredPrograms that it needs, rather than relying on the progdb
@@ -761,27 +854,52 @@ rebuildInstallPlan
liftIO $ do
notice verbosity "Resolving dependencies..."
+ -- putStrLn "== installedPackages"
+ -- putStrLn $ unlines $ map (prettyShow . IPI.installedUnitId) $ PI.allPackages installedPackages
+ -- putStrLn "== binstalledPackages"
+ -- putStrLn $ unlines $ map (prettyShow . IPI.installedUnitId) $ PI.allPackages binstalledPkgIndex
+ -- putStrLn "== hinstalledPackages"
+ -- putStrLn $ unlines $ map (prettyShow . IPI.installedUnitId) $ PI.allPackages hinstalledPkgIndex
+ -- putStrLn "== localPackages"
+ -- putStrLn $ unlines . map (prettyShow . srcpkgPackageId) $ [pkg | SpecificSourcePackage pkg <- localPackages]
+ -- putStrLn $ unlines . take 20 $ map (prettyShow . srcpkgPackageId) (XXX.allPackages (packageIndex sourcePkgDb))
planOrError <-
foldProgress logMsg (pure . Left) (pure . Right) $
planPackages
verbosity
- compiler
- platform
+ toolchains
solverSettings
- (installedPackages <> installedPkgIndex)
+ binstalledPkgIndex
+ (installedPackages <> hinstalledPkgIndex)
sourcePkgDb
pkgConfigDB
localPackages
localPackagesEnabledStanzas
case planOrError of
Left msg -> do
- reportPlanningFailure projectConfig compiler platform localPackages
+ reportPlanningFailure projectConfig (hostToolchain toolchains) localPackages
dieWithException verbosity $ PhaseRunSolverErr msg
Right plan -> return (plan, pkgConfigDB, tis, ar)
where
- corePackageDbs :: PackageDBStackCWD
- corePackageDbs =
- Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigShared)
+ -- FIXME: See FIXME in Distribution.Client.ProjectConfig wrt to buildPackages.
+ addCompilerToSourcePkg :: CompilerId -> [PackageSpecifier UnresolvedSourcePackage] -> [PackageSpecifier UnresolvedSourcePackage]
+ addCompilerToSourcePkg compilerId = map (addCompilerId compilerId)
+ addCompilerId :: CompilerId -> PackageSpecifier UnresolvedSourcePackage -> PackageSpecifier UnresolvedSourcePackage
+ addCompilerId compilerId (NamedPackage name props) = NamedPackage name props
+ addCompilerId compilerId (SpecificSourcePackage pkg) = SpecificSourcePackage (addCompilerIdToSrcPkg compilerId pkg)
+ addCompilerIdToSrcPkg :: CompilerId -> SourcePackage UnresolvedPkgLoc -> SourcePackage UnresolvedPkgLoc
+ addCompilerIdToSrcPkg compilerId pkg = pkg{srcpkgPackageId = (srcpkgPackageId pkg){pkgCompiler = Just compilerId}}
+ localPackages = (addCompilerToSourcePkg (compilerIdFor Build toolchains) localPackages_)
+ <> (addCompilerToSourcePkg (compilerIdFor Host toolchains) localPackages_)
+ corePackageDbs :: Stage -> PackageDBStackCWD
+ corePackageDbs stage =
+ Cabal.interpretPackageDbFlags False (packageDBs stage)
+
+ packageDBs Host = projectConfigPackageDBs projectConfigShared
+ packageDBs Build
+ | buildIsHost toolchains, null (projectConfigBuildPackageDBs projectConfigShared) = projectConfigPackageDBs projectConfigShared
+ | otherwise = projectConfigBuildPackageDBs projectConfigShared
+
withRepoCtx :: (RepoContext -> IO a) -> IO a
withRepoCtx =
@@ -791,7 +909,7 @@ rebuildInstallPlan
projectConfigBuildOnly
solverSettings = resolveSolverSettings projectConfig
- logMsg message rest = debugNoWrap verbosity message >> rest
+ logMsg message rest = infoNoWrap verbosity message >> rest
localPackagesEnabledStanzas =
Map.fromList
@@ -830,7 +948,7 @@ rebuildInstallPlan
--
phaseElaboratePlan
:: ProjectConfig
- -> (Compiler, Platform, ProgramDb)
+ -> Toolchains
-> Maybe PkgConfigDb
-> SolverInstallPlan
-> [PackageSpecifier (SourcePackage (PackageLocation loc))]
@@ -846,10 +964,10 @@ rebuildInstallPlan
, projectConfigSpecificPackage
, projectConfigBuildOnly
}
- (compiler, platform, progdb)
+ toolchains
pkgConfigDB
solverPlan
- localPackages = do
+ localPackages_ = do
liftIO $ debug verbosity "Elaborating the install plan..."
sourcePackageHashes <-
@@ -859,15 +977,14 @@ rebuildInstallPlan
(packageLocationsSignature solverPlan)
$ getPackageSourceHashes verbosity withRepoCtx solverPlan
- defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler
+ defaultInstallDirs <- liftIO $ userInstallDirTemplates (toolchainCompiler (hostToolchain toolchains))
let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared)
(elaboratedPlan, elaboratedShared) <-
liftIO . runLogProgress verbosity $
elaborateInstallPlan
verbosity
- platform
- compiler
- progdb
+ hookHashes
+ toolchains
pkgConfigDB
distDirLayout
cabalStoreDirLayout
@@ -888,6 +1005,17 @@ rebuildInstallPlan
liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan instantiatedPlan)
return (instantiatedPlan, elaboratedShared)
where
+ -- FIXME: See FIXME in Distribution.Client.ProjectConfig wrt to buildPackages.
+ addCompilerToSourcePkg :: CompilerId -> [PackageSpecifier (SourcePackage (PackageLocation loc))] -> [PackageSpecifier (SourcePackage (PackageLocation loc))]
+ addCompilerToSourcePkg compilerId = map (addCompilerId compilerId)
+ addCompilerId :: CompilerId -> PackageSpecifier (SourcePackage (PackageLocation loc)) -> PackageSpecifier (SourcePackage (PackageLocation loc))
+ addCompilerId compilerId (NamedPackage name props) = NamedPackage name props
+ addCompilerId compilerId (SpecificSourcePackage pkg) = SpecificSourcePackage (f pkg)
+ where f :: SourcePackage (PackageLocation loc) -> SourcePackage (PackageLocation loc)
+ f pkg = pkg{srcpkgPackageId = (srcpkgPackageId pkg){pkgCompiler = Just compilerId}}
+ localPackages = (addCompilerToSourcePkg (compilerIdFor Build toolchains) localPackages_)
+ <> (addCompilerToSourcePkg (compilerIdFor Host toolchains) localPackages_)
+
withRepoCtx :: (RepoContext -> IO a) -> IO a
withRepoCtx =
projectConfigWithSolverRepoContext
@@ -926,10 +1054,11 @@ rebuildInstallPlan
-> Rebuild ElaboratedInstallPlan
phaseImprovePlan elaboratedPlan elaboratedShared = do
liftIO $ debug verbosity "Improving the install plan..."
- storePkgIdSet <- getStoreEntries cabalStoreDirLayout compiler
+ hstorePkgIdSet <- getStoreEntries cabalStoreDirLayout hcompiler
+ bstorePkgIdSet <- getStoreEntries cabalStoreDirLayout bcompiler
let improvedPlan =
improveInstallPlanWithInstalledPackages
- storePkgIdSet
+ (hstorePkgIdSet `Set.union` bstorePkgIdSet)
elaboratedPlan
liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan improvedPlan)
-- TODO: [nice to have] having checked which packages from the store
@@ -938,12 +1067,13 @@ rebuildInstallPlan
-- matches up as expected, e.g. no dangling deps, files deleted.
return improvedPlan
where
- compiler = pkgConfigCompiler elaboratedShared
+ hcompiler = toolchainCompiler (hostToolchain (pkgConfigToolchains elaboratedShared))
+ bcompiler = toolchainCompiler (buildToolchain (pkgConfigToolchains elaboratedShared))
-- | If a 'PackageSpecifier' refers to a single package, return Just that
-- package.
-reportPlanningFailure :: ProjectConfig -> Compiler -> Platform -> [PackageSpecifier UnresolvedSourcePackage] -> IO ()
-reportPlanningFailure projectConfig comp platform pkgSpecifiers =
+reportPlanningFailure :: ProjectConfig -> Toolchain -> [PackageSpecifier UnresolvedSourcePackage] -> IO ()
+reportPlanningFailure projectConfig Toolchain{toolchainCompiler = comp, toolchainPlatform = platform} pkgSpecifiers =
when reportFailure $
BuildReports.storeLocal
(compilerInfo comp)
@@ -967,7 +1097,7 @@ reportPlanningFailure projectConfig comp platform pkgSpecifiers =
theSpecifiedPackage pkgSpec =
case pkgSpec of
NamedPackage name [PackagePropertyVersion version] ->
- PackageIdentifier name <$> trivialRange version
+ PackageIdentifier name <$> trivialRange version <*> Nothing
NamedPackage _ _ -> Nothing
SpecificSourcePackage pkg -> Just $ packageId pkg
-- \| If a range includes only a single version, return Just that version.
@@ -991,44 +1121,28 @@ programsMonitorFiles progdb =
(programPath prog)
]
--- | Select the bits of a 'ProgramDb' to monitor for value changes.
--- Use 'programsMonitorFiles' for the files to monitor.
-programDbSignature :: ProgramDb -> [ConfiguredProgram]
-programDbSignature progdb =
- [ prog
- { programMonitorFiles = []
- , programOverrideEnv =
- filter
- ((/= "PATH") . fst)
- (programOverrideEnv prog)
- }
- | prog <- configuredPrograms progdb
- ]
-
getInstalledPackages
:: Verbosity
- -> Compiler
- -> ProgramDb
- -> Platform
+ -> Toolchain
-> PackageDBStackCWD
-> Rebuild InstalledPackageIndex
-getInstalledPackages verbosity compiler progdb platform packagedbs = do
+getInstalledPackages verbosity Toolchain{toolchainCompiler, toolchainPlatform, toolchainProgramDb} packagedbs = do
monitorFiles . map monitorFileOrDirectory
=<< liftIO
( IndexUtils.getInstalledPackagesMonitorFiles
verbosity
- compiler
+ toolchainCompiler
Nothing -- use ambient working directory
(coercePackageDBStack packagedbs)
- progdb
- platform
+ toolchainProgramDb
+ toolchainPlatform
)
liftIO $
IndexUtils.getInstalledPackages
verbosity
- compiler
+ toolchainCompiler
packagedbs
- progdb
+ toolchainProgramDb
{-
--TODO: [nice to have] use this but for sanity / consistency checking
@@ -1260,10 +1374,10 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
planPackages
:: Verbosity
- -> Compiler
- -> Platform
+ -> Toolchains
-> SolverSettings
- -> InstalledPackageIndex
+ -> InstalledPackageIndex -- ^ Build Installed Package Index
+ -> InstalledPackageIndex -- ^ Host Installed Package Index
-> SourcePackageDb
-> Maybe PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
@@ -1271,17 +1385,16 @@ planPackages
-> Progress String String SolverInstallPlan
planPackages
verbosity
- comp
- platform
+ toolchains
SolverSettings{..}
+ binstalledPkgIndex
installedPkgIndex
sourcePkgDb
pkgConfigDB
localPackages
pkgStanzasEnable =
resolveDependencies
- platform
- (compilerInfo comp)
+ toolchains
pkgConfigDB
resolverParams
where
@@ -1324,7 +1437,9 @@ planPackages
. removeLowerBounds solverSettingAllowOlder
. removeUpperBounds solverSettingAllowNewer
. addDefaultSetupDependencies
- ( mkDefaultSetupDeps comp platform
+ ( mkDefaultSetupDeps
+ (toolchainCompiler (buildToolchain toolchains))
+ (toolchainPlatform (buildToolchain toolchains))
. PD.packageDescription
. srcpkgDescription
)
@@ -1402,6 +1517,7 @@ planPackages
-- Note: we don't use the standardInstallPolicy here, since that uses
-- its own addDefaultSetupDependencies that is not appropriate for us.
basicInstallPolicy
+ binstalledPkgIndex
installedPkgIndex
sourcePkgDb
localPackages
@@ -1458,8 +1574,9 @@ planPackages
| otherwise = mkVersion [1, 20]
where
isGHC = compFlav `elem` [GHC, GHCJS]
- compFlav = compilerFlavor comp
- compVer = compilerVersion comp
+ -- FIXME: We assume HOST here.
+ compFlav = compilerFlavor (toolchainCompiler (hostToolchain toolchains))
+ compVer = compilerVersion (toolchainCompiler (hostToolchain toolchains))
-- As we can't predict the future, we also place a global upper
-- bound on the lib:Cabal version we know how to interact with:
@@ -1584,10 +1701,9 @@ planPackages
-- In theory should be able to make an elaborated install plan with a policy
-- matching that of the classic @cabal install --user@ or @--global@
elaborateInstallPlan
- :: Verbosity
- -> Platform
- -> Compiler
- -> ProgramDb
+ :: HasCallStack => Verbosity
+ -> Map FilePath HookAccept
+ -> Toolchains
-> Maybe PkgConfigDb
-> DistDirLayout
-> StoreDirLayout
@@ -1602,9 +1718,8 @@ elaborateInstallPlan
-> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig)
elaborateInstallPlan
verbosity
- platform
- compiler
- compilerprogdb
+ hookHashes
+ toolchains
pkgConfigDB
distDirLayout@DistDirLayout{..}
storeDirLayout@StoreDirLayout{storePackageDBStack}
@@ -1621,10 +1736,9 @@ elaborateInstallPlan
where
elaboratedSharedConfig =
ElaboratedSharedConfig
- { pkgConfigPlatform = platform
- , pkgConfigCompiler = compiler
- , pkgConfigCompilerProgs = compilerprogdb
+ { pkgConfigToolchains = toolchains
, pkgConfigReplOptions = mempty
+ , pkgConfigHookHashes = hookHashes
}
preexistingInstantiatedPkgs :: Map UnitId FullUnitId
@@ -1644,7 +1758,7 @@ elaborateInstallPlan
f _ = Nothing
elaboratedInstallPlan
- :: LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage)
+ :: HasCallStack => LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage)
elaboratedInstallPlan =
flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg ->
case planpkg of
@@ -1665,10 +1779,10 @@ elaborateInstallPlan
-- NB: We don't INSTANTIATE packages at this point. That's
-- a post-pass. This makes it simpler to compute dependencies.
elaborateSolverToComponents
- :: (SolverId -> [ElaboratedPlanPackage])
+ :: HasCallStack => (SolverId -> [ElaboratedPlanPackage])
-> SolverPackage UnresolvedPkgLoc
-> LogProgress [ElaboratedConfiguredPackage]
- elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) =
+ elaborateSolverToComponents mapDep spkg@(SolverPackage _qpn _stage _ _ _ deps0 exe_deps0) =
case mkComponentsGraph (elabEnabledSpec elab0) pd of
Right g -> do
let src_comps = componentsGraphToList g
@@ -1685,7 +1799,6 @@ elaborateInstallPlan
let whyNotPerComp = why_not_per_component src_comps
case NE.nonEmpty whyNotPerComp of
Nothing -> do
- elaborationWarnings
return comps
Just notPerCompReasons -> do
checkPerPackageOk comps notPerCompReasons
@@ -1758,7 +1871,7 @@ elaborateInstallPlan
<+> fsep (punctuate comma $ map (text . whyNotPerComponent) $ toList reasons)
-- TODO: Maybe exclude Backpack too
- (elab0, elaborationWarnings) = elaborateSolverToCommon spkg
+ elab0 = elaborateSolverToCommon spkg
pkgid = elabPkgSourceId elab0
pd = elabPkgDescription elab0
@@ -1809,7 +1922,7 @@ elaborateInstallPlan
++ " not implemented yet"
buildComponent
- :: ( ConfiguredComponentMap
+ :: HasCallStack => ( ConfiguredComponentMap
, LinkedComponentMap
, Map ComponentId FilePath
)
@@ -1866,10 +1979,14 @@ elaborateInstallPlan
elab0
{ elabPkgOrComp = ElabComponent $ elab_comp
}
+ elabCompiler = toolchainCompiler (toolchainFor (elabStage elab0) toolchains)
+
cid = case elabBuildStyle elab0 of
BuildInplaceOnly{} ->
mkComponentId $
- prettyShow pkgid
+ prettyShow (compilerId elabCompiler)
+ ++
+ '_':prettyShow pkgid
++ "-inplace"
++ ( case Cabal.componentNameString cname of
Nothing -> ""
@@ -2058,6 +2175,8 @@ elaborateInstallPlan
elaborateSolverToPackage
pkgWhyNotPerComponent
pkg@( SolverPackage
+ _qpn
+ _stage
(SourcePackage pkgid _gpd _srcloc _descOverride)
_flags
_stanzas
@@ -2069,11 +2188,17 @@ elaborateInstallPlan
-- Knot tying: the final elab includes the
-- pkgInstalledId, which is calculated by hashing many
-- of the other fields of the elaboratedPackage.
- elaborationWarnings
return elab
where
- (elab0@ElaboratedConfiguredPackage{..}, elaborationWarnings) =
- elaborateSolverToCommon pkg
+ elab =
+ elab1
+ { elabInstallDirs =
+ computeInstallDirs
+ storeDirLayout
+ defaultInstallDirs
+ elaboratedSharedConfig
+ elab1
+ }
elab1 =
elab0
@@ -2084,23 +2209,21 @@ elaborateInstallPlan
, elabModuleShape = modShape
}
- elab =
- elab1
- { elabInstallDirs =
- computeInstallDirs
- storeDirLayout
- defaultInstallDirs
- elaboratedSharedConfig
- elab1
- }
+ elab0@ElaboratedConfiguredPackage{..} =
+ elaborateSolverToCommon pkg
+
modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of
Nothing -> emptyModuleShape
Just e -> Ty.elabModuleShape e
+ elabCompiler = toolchainCompiler (toolchainFor elabStage toolchains)
+
pkgInstalledId
- | shouldBuildInplaceOnly pkg =
- mkComponentId (prettyShow pkgid ++ "-inplace")
+ | shouldBuildInplaceOnly pkg = mkComponentId $
+ prettyShow (compilerId elabCompiler)
+ ++
+ '_':prettyShow pkgid ++ "-inplace"
| otherwise =
assert (isJust elabPkgSourceHash) $
hashedInstalledPackageId
@@ -2111,7 +2234,7 @@ elaborateInstallPlan
-- Need to filter out internal dependencies, because they don't
-- correspond to anything real anymore.
- isExt confid = confSrcId confid /= pkgid
+ isExt confid = (confSrcId confid){pkgCompiler = Nothing} /= pkgid{pkgCompiler = Nothing}
filterExt = filter isExt
filterExt' :: [(ConfiguredId, a)] -> [(ConfiguredId, a)]
@@ -2158,16 +2281,18 @@ elaborateInstallPlan
elaborateSolverToCommon
:: SolverPackage UnresolvedPkgLoc
- -> (ElaboratedConfiguredPackage, LogProgress ())
+ -> ElaboratedConfiguredPackage
elaborateSolverToCommon
pkg@( SolverPackage
+ _qpn
+ stage
(SourcePackage pkgid gdesc srcloc descOverride)
flags
stanzas
deps0
_exe_deps0
) =
- (elaboratedPackage, wayWarnings pkgid)
+ elaboratedPackage
where
elaboratedPackage = ElaboratedConfiguredPackage{..}
@@ -2182,12 +2307,19 @@ elaborateInstallPlan
elabIsCanonical = True
elabPkgSourceId = pkgid
+
+ -- TODO: temporarily set everything to build on build
+ elabStage = stage
+ elabCompiler = toolchainCompiler (toolchainFor elabStage toolchains)
+ elabPlatform = toolchainPlatform (toolchainFor elabStage toolchains)
+ elabProgramDb = toolchainProgramDb (toolchainFor elabStage toolchains)
+
elabPkgDescription = case PD.finalizePD
flags
elabEnabledSpec
(const Satisfied)
- platform
- (compilerInfo compiler)
+ elabPlatform
+ (compilerInfo elabCompiler)
[]
gdesc of
Right (desc, _) -> desc
@@ -2243,15 +2375,18 @@ elaborateInstallPlan
else cp
elabPkgSourceLocation = srcloc
- elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes
+ elabPkgSourceHash = case Map.lookup pkgid sourcePackageHashes of
+ Just h -> Just h
+ Nothing -> Nothing
elabLocalToProject = isLocalToProject pkg
elabBuildStyle =
if shouldBuildInplaceOnly pkg
then BuildInplaceOnly OnDisk
else BuildAndInstall
elabPackageDbs = projectConfigPackageDBs sharedPackageConfig
- elabBuildPackageDBStack = buildAndRegisterDbs
- elabRegisterPackageDBStack = buildAndRegisterDbs
+ elabBuildPackageDbs = projectConfigBuildPackageDBs sharedPackageConfig
+ elabBuildPackageDBStack = buildAndRegisterDbs stage
+ elabRegisterPackageDBStack = buildAndRegisterDbs stage
elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription
elabSetupScriptCliVersion =
@@ -2260,29 +2395,48 @@ elaborateInstallPlan
elabPkgDescription
libDepGraph
deps0
- elabSetupPackageDBStack = buildAndRegisterDbs
- elabInplaceBuildPackageDBStack = inplacePackageDbs
- elabInplaceRegisterPackageDBStack = inplacePackageDbs
- elabInplaceSetupPackageDBStack = inplacePackageDbs
+ -- This code is ... a bit nuts. We need to parameterise the DB stack
+ -- over the stage. (which is also assigned to elabStage). And now
+ -- we have inplace, core, ... other DBStacks, for the Setup however,
+ -- we _must_ force it to use the Build stage stack. As that's where
+ -- the setup dependencies will be found.
+ elabSetupPackageDBStack = buildAndRegisterDbs Build
+
+ inplacePackageDbs stage = corePackageDbs stage ++ [distPackageDB (compilerId (toolchainCompiler (toolchainFor stage toolchains)))]
+
+ corePackageDbs stage = storePackageDBStack (toolchainCompiler (toolchainFor stage toolchains)) (packageDBs stage)
- buildAndRegisterDbs
- | shouldBuildInplaceOnly pkg = inplacePackageDbs
- | otherwise = corePackageDbs
+ packageDBs Host = projectConfigPackageDBs sharedPackageConfig
+ packageDBs Build
+ | buildIsHost toolchains, null (projectConfigBuildPackageDBs sharedPackageConfig) = projectConfigPackageDBs sharedPackageConfig
+ | otherwise = projectConfigBuildPackageDBs sharedPackageConfig
+
+ elabInplaceBuildPackageDBStack = inplacePackageDbs stage
+ elabInplaceRegisterPackageDBStack = inplacePackageDbs stage
+ elabInplaceSetupPackageDBStack = inplacePackageDbs stage
+
+ buildAndRegisterDbs stage
+ | shouldBuildInplaceOnly pkg = inplacePackageDbs stage
+ | otherwise = corePackageDbs stage
elabPkgDescriptionOverride = descOverride
+ pkgsUseSharedLibrary :: Set PackageId
+ pkgsUseSharedLibrary =
+ packagesWithLibDepsDownwardClosedProperty (needsSharedLib elabCompiler)
+
elabBuildOptions =
LBC.BuildOptions
{ withVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively
- , withSharedLib = canBuildSharedLibs && pkgid `Set.member` pkgsUseSharedLibrary
+ , withSharedLib = canBuildSharedLibs elabCompiler && pkgid `Set.member` pkgsUseSharedLibrary
, withStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib
, withDynExe = perPkgOptionFlag pkgid False packageConfigDynExe
, withFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe
, withGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still
, withProfExe = perPkgOptionFlag pkgid False packageConfigProf
- , withProfLib = canBuildProfilingLibs && pkgid `Set.member` pkgsUseProfilingLibrary
- , withProfLibShared = canBuildProfilingSharedLibs && pkgid `Set.member` pkgsUseProfilingLibraryShared
+ , withProfLib = canBuildProfilingLibs elabCompiler && pkgid `Set.member` pkgsUseProfilingLibrary
+ , withProfLibShared = canBuildProfilingSharedLibs elabCompiler && pkgid `Set.member` pkgsUseProfilingLibraryShared
, exeCoverage = perPkgOptionFlag pkgid False packageConfigCoverage
, libCoverage = perPkgOptionFlag pkgid False packageConfigCoverage
, withOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization
@@ -2315,13 +2469,13 @@ elaborateInstallPlan
elabProgramPaths =
Map.fromList
[ (programId prog, programPath prog)
- | prog <- configuredPrograms compilerprogdb
+ | prog <- configuredPrograms elabProgramDb
]
<> perPkgOptionMapLast pkgid packageConfigProgramPaths
elabProgramArgs =
Map.fromList
[ (programId prog, args)
- | prog <- configuredPrograms compilerprogdb
+ | prog <- configuredPrograms elabProgramDb
, let args = programOverrideArgs $ addHaddockIfDocumentationEnabled prog
, not (null args)
]
@@ -2403,12 +2557,6 @@ elaborateInstallPlan
mempty
perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig)
- inplacePackageDbs =
- corePackageDbs
- ++ [distPackageDB (compilerId compiler)]
-
- corePackageDbs = storePackageDBStack compiler (projectConfigPackageDBs sharedPackageConfig)
-
-- For this local build policy, every package that lives in a local source
-- dir (as opposed to a tarball), or depends on such a package, will be
-- built inplace into a shared dist dir. Tarball packages that depend on
@@ -2419,13 +2567,18 @@ elaborateInstallPlan
(packageId pkg)
pkgsToBuildInplaceOnly
+
+ -- FIXME: This change is stupid, however the previous assumption is
+ -- that ALL pkgsLocalToProject somehow end up in the solverPlan. This
+ -- is not given, as we now have every local package listed twice. Once
+ -- for the Host, and once for the Build. Thus iterating over each individual
+ -- package _does_ work, but is rather idiotic.
pkgsToBuildInplaceOnly :: Set PackageId
pkgsToBuildInplaceOnly =
Set.fromList $
map packageId $
- SolverInstallPlan.reverseDependencyClosure
- solverPlan
- (map PlannedId (Set.toList pkgsLocalToProject))
+ concat [SolverInstallPlan.reverseDependencyClosure solverPlan [PlannedId p]
+ | p <- (Set.toList pkgsLocalToProject)]
isLocalToProject :: Package pkg => pkg -> Bool
isLocalToProject pkg =
@@ -2439,13 +2592,13 @@ elaborateInstallPlan
-- TODO: localPackages is a misnomer, it's all project packages
-- here is where we decide which ones will be local!
- pkgsUseSharedLibrary :: Set PackageId
- pkgsUseSharedLibrary =
- packagesWithLibDepsDownwardClosedProperty needsSharedLib
+ pkgsUseProfilingLibrary :: Set PackageId
+ pkgsUseProfilingLibrary =
+ packagesWithLibDepsDownwardClosedProperty needsProfilingLib
- needsSharedLib pkgid =
+ needsSharedLib compiler pkgid =
fromMaybe
- compilerShouldUseSharedLibByDefault
+ (compilerShouldUseSharedLibByDefault compiler)
-- Case 1: --enable-shared or --disable-shared is passed explicitly, honour that.
( case pkgSharedLib of
Just v -> Just v
@@ -2456,7 +2609,7 @@ elaborateInstallPlan
-- Case 3: If --enable-profiling is passed, then we are going to
-- build profiled dynamic, so no need for shared libraries.
case pkgProf of
- Just True -> if canBuildProfilingSharedLibs then Nothing else Just True
+ Just True -> if canBuildProfilingSharedLibs compiler then Nothing else Just True
_ -> Just True
-- But don't necessarily turn off shared library generation if
-- --disable-executable-dynamic is passed. The shared objects might
@@ -2468,54 +2621,10 @@ elaborateInstallPlan
pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe
pkgProf = perPkgOptionMaybe pkgid packageConfigProf
- -- TODO: [code cleanup] move this into the Cabal lib. It's currently open
- -- coded in Distribution.Simple.Configure, but should be made a proper
- -- function of the Compiler or CompilerInfo.
- compilerShouldUseSharedLibByDefault =
- case compilerFlavor compiler of
- GHC -> GHC.compilerBuildWay compiler == DynWay && canBuildSharedLibs
- GHCJS -> GHCJS.isDynamic compiler
- _ -> False
-
- compilerShouldUseProfilingLibByDefault =
- case compilerFlavor compiler of
- GHC -> GHC.compilerBuildWay compiler == ProfWay && canBuildProfilingLibs
- _ -> False
-
- compilerShouldUseProfilingSharedLibByDefault =
- case compilerFlavor compiler of
- GHC -> GHC.compilerBuildWay compiler == ProfDynWay && canBuildProfilingSharedLibs
- _ -> False
-
- -- Returns False if we definitely can't build shared libs
- canBuildWayLibs predicate = case predicate compiler of
- Just can_build -> can_build
- -- If we don't know for certain, just assume we can
- -- which matches behaviour in previous cabal releases
- Nothing -> True
-
- canBuildSharedLibs = canBuildWayLibs dynamicSupported
- canBuildProfilingLibs = canBuildWayLibs profilingVanillaSupported
- canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported
-
- wayWarnings pkg = do
- when
- (needsProfilingLib pkg && not canBuildProfilingLibs)
- (warnProgress (text "Compiler does not support building p libraries, profiling is disabled"))
- when
- (needsSharedLib pkg && not canBuildSharedLibs)
- (warnProgress (text "Compiler does not support building dyn libraries, dynamic libraries are disabled"))
- when
- (needsProfilingLibShared pkg && not canBuildProfilingSharedLibs)
- (warnProgress (text "Compiler does not support building p_dyn libraries, profiling dynamic libraries are disabled."))
-
- pkgsUseProfilingLibrary :: Set PackageId
- pkgsUseProfilingLibrary =
- packagesWithLibDepsDownwardClosedProperty needsProfilingLib
-
- needsProfilingLib pkg =
- fromFlagOrDefault compilerShouldUseProfilingLibByDefault (profBothFlag <> profLibFlag)
+ needsProfilingLib pkg = fromFlagOrDefault False (profBothFlag <> profLibFlag)
where
+ -- fromFlagOrDefault compilerShouldUseProfilingLibByDefault (profBothFlag <> profLibFlag)
+
pkgid = packageId pkg
profBothFlag = lookupPerPkgOption pkgid packageConfigProf
profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib
@@ -2524,24 +2633,26 @@ elaborateInstallPlan
pkgsUseProfilingLibraryShared =
packagesWithLibDepsDownwardClosedProperty needsProfilingLibShared
+ -- TODO: review this logic
needsProfilingLibShared pkg =
- fromMaybe
- compilerShouldUseProfilingSharedLibByDefault
- -- case 1: If --enable-profiling-shared is passed explicitly, honour that
- ( case profLibSharedFlag of
- Just v -> Just v
- Nothing -> case pkgDynExe of
- Just True ->
- case pkgProf of
- -- case 2: --enable-executable-dynamic + --enable-profiling
- -- turn on shared profiling libraries
- Just True -> if canBuildProfilingSharedLibs then Just True else Nothing
- _ -> Nothing
- -- But don't necessarily turn off shared library generation is
- -- --disable-executable-dynamic is passed. The shared objects might
- -- be needed for something different.
- _ -> Nothing
- )
+ -- fromMaybe
+ -- compilerShouldUseProfilingSharedLibByDefault
+ -- -- case 1: If --enable-profiling-shared is passed explicitly, honour that
+ case profLibSharedFlag of
+ Just v -> v
+ Nothing -> case pkgDynExe of
+ Just True ->
+ case pkgProf of
+ -- case 2: --enable-executable-dynamic + --enable-profiling
+ -- turn on shared profiling libraries
+ -- Just True -> if canBuildProfilingSharedLibs then Just True else Nothing
+ Just True -> True
+ _ -> False
+ -- But don't necessarily turn off shared library generation is
+ -- --disable-executable-dynamic is passed. The shared objects might
+ -- be needed for something different.
+ -- _ -> Nothing
+ _ -> False
where
pkgid = packageId pkg
profLibSharedFlag = perPkgOptionMaybe pkgid packageConfigProfShared
@@ -2571,6 +2682,51 @@ elaborateInstallPlan
-- package config validation/resolution pass.
]
+-- TODO: [code cleanup] move this into the Cabal lib. It's currently open
+-- coded in Distribution.Simple.Configure, but should be made a proper
+-- function of the Compiler or CompilerInfo.
+compilerShouldUseSharedLibByDefault :: Compiler -> Bool
+compilerShouldUseSharedLibByDefault compiler =
+ case compilerFlavor compiler of
+ GHC -> GHC.compilerBuildWay compiler == DynWay && canBuildSharedLibs compiler
+ GHCJS -> GHCJS.isDynamic compiler
+ _ -> False
+
+-- -- TODO: [code cleanup] move this into the Cabal lib.
+-- compilerShouldUseProfilingLibByDefault :: Compiler -> Bool
+-- compilerShouldUseProfilingLibByDefault compiler =
+-- case compilerFlavor compiler of
+-- GHC -> GHC.compilerBuildWay compiler == ProfWay && canBuildProfilingLibs compiler
+-- _ -> False
+
+-- -- TODO: [code cleanup] move this into the Cabal lib.
+-- compilerShouldUseProfilingSharedLibByDefault :: Bool
+-- compilerShouldUseProfilingSharedLibByDefault =
+-- case compilerFlavor compiler of
+-- GHC -> GHC.compilerBuildWay compiler == ProfDynWay && canBuildProfilingSharedLibs compiler
+-- _ -> False
+
+-- Returns False if we definitely can't build shared libs
+-- TODO: [code cleanup] move this into the Cabal lib.
+canBuildWayLibs :: (t -> Maybe Bool) -> t -> Bool
+canBuildWayLibs predicate compiler = case predicate compiler of
+ Just can_build -> can_build
+ -- If we don't know for certain, just assume we can
+ -- which matches behaviour in previous cabal releases
+ Nothing -> True
+
+-- TODO: [code cleanup] move this into the Cabal lib.
+canBuildSharedLibs :: Compiler -> Bool
+canBuildSharedLibs = canBuildWayLibs dynamicSupported
+
+-- TODO: [code cleanup] move this into the Cabal lib.
+canBuildProfilingLibs :: Compiler -> Bool
+canBuildProfilingLibs = canBuildWayLibs profilingVanillaSupported
+
+-- TODO: [code cleanup] move this into the Cabal lib.
+canBuildProfilingSharedLibs :: Compiler -> Bool
+canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported
+
-- TODO: [nice to have] config consistency checking:
-- + profiling libs & exes, exe needs lib, recursive
-- + shared libs & exes, exe needs lib, recursive
@@ -2617,7 +2773,7 @@ matchElabPkg p elab =
-- and 'ComponentName' to the 'ComponentId' that should be used
-- in this case.
mkCCMapping
- :: ElaboratedPlanPackage
+ :: HasCallStack => ElaboratedPlanPackage
-> (PackageName, Map ComponentName (AnnotatedId ComponentId))
mkCCMapping =
InstallPlan.foldPlanPackage
@@ -3847,8 +4003,10 @@ setupHsScriptOptions
-- - if we commit to a Cabal version, the logic in
Nothing
else Just elabSetupScriptCliVersion
- , useCompiler = Just pkgConfigCompiler
- , usePlatform = Just pkgConfigPlatform
+ , -- for Setup.hs, we _always_ want to use the BUILD toolchain.
+ useCompiler = Just (toolchainCompiler $ buildToolchain $ pkgConfigToolchains)
+ , usePlatform = Just (toolchainPlatform $ buildToolchain $ pkgConfigToolchains)
+ , useProgramDb = toolchainProgramDb $ buildToolchain $ pkgConfigToolchains
, usePackageDB = elabSetupPackageDBStack
, usePackageIndex = Nothing
, useDependencies =
@@ -3858,7 +4016,6 @@ setupHsScriptOptions
]
, useDependenciesExclusive = True
, useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps
- , useProgramDb = pkgConfigCompilerProgs
, useDistPref = builddir
, useLoggingHandle = Nothing -- this gets set later
, useWorkingDir = Just srcdir
@@ -3943,9 +4100,9 @@ computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab
( InstallDirs.absoluteInstallDirs
(elabPkgSourceId elab)
(elabUnitId elab)
- (compilerInfo (pkgConfigCompiler elaboratedShared))
+ (compilerInfo (toolchainCompiler $ toolchainFor (elabStage elab) $ pkgConfigToolchains elaboratedShared))
InstallDirs.NoCopyDest
- (pkgConfigPlatform elaboratedShared)
+ (toolchainPlatform $ buildToolchain $ pkgConfigToolchains elaboratedShared)
defaultInstallDirs
)
{ -- absoluteInstallDirs sets these as 'undefined' but we have
@@ -3958,7 +4115,7 @@ computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab
-- use special simplified install dirs
storePackageInstallDirs'
storeDirLayout
- (pkgConfigCompiler elaboratedShared)
+ (toolchainCompiler $ toolchainFor (elabStage elab) $ pkgConfigToolchains elaboratedShared)
(elabUnitId elab)
-- TODO: [code cleanup] perhaps reorder this code
@@ -3979,7 +4136,7 @@ setupHsConfigureFlags
mkSymbolicPath
plan
(ReadyPackage elab@ElaboratedConfiguredPackage{..})
- sharedConfig@ElaboratedSharedConfig{..}
+ sharedConfig@ElaboratedSharedConfig{pkgConfigToolchains = Toolchains{buildToolchain}}
configCommonFlags = do
-- explicitly clear, then our package db stack
-- TODO: [required eventually] have to do this differently for older Cabal versions
@@ -4049,7 +4206,7 @@ setupHsConfigureFlags
["-hide-all-packages"]
elabProgramArgs
configProgramPathExtra = toNubList elabProgramPathExtra
- configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler)
+ configHcFlavor = toFlag (compilerFlavor $ toolchainCompiler buildToolchain)
configHcPath = mempty -- we use configProgramPaths instead
configHcPkg = mempty -- we use configProgramPaths instead
configDumpBuildInfo = toFlag elabDumpBuildInfo
@@ -4107,7 +4264,7 @@ setupHsConfigureFlags
configUserInstall = mempty -- don't rely on defaults
configPrograms_ = mempty -- never use, shouldn't exist
configUseResponseFiles = mempty
- configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler
+ configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported (toolchainCompiler buildToolchain)
configIgnoreBuildTools = mempty
cidToGivenComponent :: ConfiguredId -> GivenComponent
@@ -4282,13 +4439,13 @@ setupHsHaddockFlags
-> Cabal.HaddockFlags
setupHsHaddockFlags
(ElaboratedConfiguredPackage{..})
- (ElaboratedSharedConfig{..})
+ (ElaboratedSharedConfig{pkgConfigToolchains = Toolchains{buildToolchain}})
_buildTimeSettings
common =
Cabal.HaddockFlags
{ haddockCommonFlags = common
, haddockProgramPaths =
- case lookupProgram haddockProgram pkgConfigCompilerProgs of
+ case lookupProgram haddockProgram (toolchainProgramDb buildToolchain) of
Nothing -> mempty
Just prg ->
[
@@ -4368,7 +4525,7 @@ setupHsHaddockArgs elab =
-- not replace installed packages with ghc-pkg.
packageHashInputs
- :: ElaboratedSharedConfig
+ :: HasCallStack => ElaboratedSharedConfig
-> ElaboratedConfiguredPackage
-> PackageHashInputs
packageHashInputs
@@ -4426,11 +4583,11 @@ packageHashConfigInputs
:: ElaboratedSharedConfig
-> ElaboratedConfiguredPackage
-> PackageHashConfigInputs
-packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg =
+packageHashConfigInputs shared@ElaboratedSharedConfig{pkgConfigToolchains = Toolchains{buildToolchain}} pkg =
PackageHashConfigInputs
- { pkgHashCompilerId = compilerId pkgConfigCompiler
- , pkgHashCompilerABI = compilerAbiTag pkgConfigCompiler
- , pkgHashPlatform = pkgConfigPlatform
+ { pkgHashCompilerId = compilerId (toolchainCompiler buildToolchain)
+ , pkgHashCompilerABI = compilerAbiTag (toolchainCompiler buildToolchain)
+ , pkgHashPlatform = toolchainPlatform buildToolchain
, pkgHashFlagAssignment = elabFlagAssignment
, pkgHashConfigureScriptArgs = elabConfigureScriptArgs
, pkgHashVanillaLib = withVanillaLib
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs
index 7ee5cb52f41..a4f22a25f2b 100644
--- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs
+++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs
@@ -58,6 +58,10 @@ module Distribution.Client.ProjectPlanning.Types
, isBenchComponentTarget
, componentOptionalStanza
+ -- * Toolchain
+ , Toolchain (..)
+ , Toolchains (..)
+
-- * Setup script
, SetupScriptStyle (..)
) where
@@ -84,6 +88,7 @@ import Distribution.Client.Types
import Distribution.Backpack
import Distribution.Backpack.ModuleShape
+import Distribution.Client.HookAccept (HookAccept (..))
import Distribution.Compat.Graph (IsNode (..))
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import Distribution.ModuleName (ModuleName)
@@ -107,9 +112,10 @@ import Distribution.Simple.Setup
)
import Distribution.Simple.Utils (ordNub)
import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
+import Distribution.Solver.Types.Stage
+import Distribution.Solver.Types.Toolchain
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.OptionalStanza
-import Distribution.System
import Distribution.Types.ComponentRequestedSpec
import qualified Distribution.Types.LocalBuildConfig as LBC
import Distribution.Types.PackageDescription (PackageDescription (..))
@@ -183,13 +189,12 @@ showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode
-- even platform and compiler could be different if we're building things
-- like a server + client with ghc + ghcjs
data ElaboratedSharedConfig = ElaboratedSharedConfig
- { pkgConfigPlatform :: Platform
- , pkgConfigCompiler :: Compiler -- TODO: [code cleanup] replace with CompilerInfo
- , pkgConfigCompilerProgs :: ProgramDb
+ { pkgConfigToolchains :: Toolchains
-- ^ The programs that the compiler configured (e.g. for GHC, the progs
-- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are
-- used.
, pkgConfigReplOptions :: ReplOptions
+ , pkgConfigHookHashes :: Map FilePath HookAccept
}
deriving (Show, Generic)
@@ -246,7 +251,9 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage
-- to disable. This tells us which ones we build by default, and
-- helps with error messages when the user asks to build something
-- they explicitly disabled.
- --
+
+ , elabStage :: Stage
+
-- TODO: The 'Bool' here should be refined into an ADT with three
-- cases: NotRequested, ExplicitlyRequested and
-- ImplicitlyRequested. A stanza is explicitly requested if
@@ -261,6 +268,7 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage
-- just happen not to have any tests. (But perhaps we should
-- warn if ALL local packages don't have any tests.)
, elabPackageDbs :: [Maybe PackageDBCWD]
+ , elabBuildPackageDbs :: [Maybe PackageDBCWD]
, elabSetupPackageDBStack :: PackageDBStackCWD
, elabBuildPackageDBStack :: PackageDBStackCWD
, elabRegisterPackageDBStack :: PackageDBStackCWD
@@ -342,10 +350,10 @@ normaliseConfiguredPackage
:: ElaboratedSharedConfig
-> ElaboratedConfiguredPackage
-> ElaboratedConfiguredPackage
-normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg =
+normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigToolchains = Toolchains{buildToolchain}} pkg =
pkg{elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg)}
where
- knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs
+ knownProgramDb = addKnownPrograms builtinPrograms (toolchainProgramDb buildToolchain)
pkgDesc :: PackageDescription
pkgDesc = elabPkgDescription pkg
@@ -538,8 +546,8 @@ elabDistDirParams shared elab =
, distParamComponentName = case elabPkgOrComp elab of
ElabComponent comp -> compComponentName comp
ElabPackage _ -> Nothing
- , distParamCompilerId = compilerId (pkgConfigCompiler shared)
- , distParamPlatform = pkgConfigPlatform shared
+ , distParamCompilerId = compilerId $ toolchainCompiler $ hostToolchain $ pkgConfigToolchains shared
+ , distParamPlatform = toolchainPlatform $ hostToolchain $ pkgConfigToolchains shared
, distParamOptimization = LBC.withOptimization $ elabBuildOptions elab
}
diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs
index 440de3c84ad..72950f36e0d 100644
--- a/cabal-install/src/Distribution/Client/ScriptUtils.hs
+++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs
@@ -195,6 +195,7 @@ import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy ()
import qualified Data.Set as S
import Distribution.Client.Errors
+import Distribution.Client.ProjectPlanning.Types (Toolchain (..), Toolchains (..))
import Distribution.Utils.Path
( unsafeMakeSymbolicPath
)
@@ -361,9 +362,9 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo
exists <- doesFileExist script
if exists
then do
- ctx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script)
+ baseCtx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script)
- let projectRoot = distProjectRootDirectory $ distDirLayout ctx
+ let projectRoot = distProjectRootDirectory $ distDirLayout baseCtx
writeFile (projectRoot </> "scriptlocation") =<< canonicalizePath script
scriptContents <- BS.readFile script
@@ -375,14 +376,14 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo
(fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
(flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
- projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents
+ projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout baseCtx) (takeFileName script) scriptContents
- createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx)
- (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx)
+ createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout baseCtx)
+ Toolchains{buildToolchain = Toolchain{toolchainPlatform = platform@(Platform arch os), toolchainCompiler = compiler}} <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout baseCtx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig baseCtx)
(projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compiler)) mempty projectCfgSkeleton
- let ctx' = ctx & lProjectConfig %~ (<> projectCfg)
+ let ctx' = baseCtx & lProjectConfig %~ (<> projectCfg)
build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' compiler platform
exePath = build_dir </> "bin" </> scriptExeFileName script
@@ -588,7 +589,7 @@ fakeProjectSourcePackage projectRoot = sourcePackage
movedExePath :: UnqualComponentName -> DistDirLayout -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> Maybe FilePath
movedExePath selectedComponent distDirLayout elabShared elabConfigured = do
exe <- find ((== selectedComponent) . exeName) . executables $ elabPkgDescription elabConfigured
- let CompilerId flavor _ = (compilerId . pkgConfigCompiler) elabShared
+ let CompilerId flavor _ = (compilerId . toolchainCompiler . buildToolchain . pkgConfigToolchains) elabShared
opts <- lookup flavor (perCompilerFlavorToList . options $ buildInfo exe)
let projectRoot = distProjectRootDirectory distDirLayout
fmap (projectRoot </>) . lookup "-o" $ reverse (zip opts (drop 1 opts))
diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs
index 78fcf7c2e1f..05e94256e64 100644
--- a/cabal-install/src/Distribution/Client/Setup.hs
+++ b/cabal-install/src/Distribution/Client/Setup.hs
@@ -162,7 +162,7 @@ import Distribution.ReadE
)
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import qualified Distribution.Simple.Command as Command
-import Distribution.Simple.Compiler (Compiler, PackageDB, PackageDBStack)
+import Distribution.Simple.Compiler (Compiler, CompilerFlavor (..), PackageDB, PackageDBStack)
import Distribution.Simple.Configure
( computeEffectiveProfiling
, configCompilerAuxEx
@@ -920,6 +920,10 @@ data ConfigExFlags = ConfigExFlags
, configAllowOlder :: Maybe AllowOlder
, configWriteGhcEnvironmentFilesPolicy
:: Flag WriteGhcEnvironmentFilesPolicy
+ , configBuildHcFlavor :: Flag CompilerFlavor
+ , configBuildHcPath :: Flag FilePath
+ , configBuildHcPkg :: Flag FilePath
+ , configBuildPackageDBs :: [Maybe PackageDB]
}
deriving (Eq, Show, Generic)
@@ -1047,6 +1051,44 @@ configureExOptions _showOrParseArgs src =
writeGhcEnvironmentFilesPolicyParser
writeGhcEnvironmentFilesPolicyPrinter
)
+ , option
+ []
+ ["build-compiler"]
+ "build compiler"
+ configBuildHcFlavor
+ (\v flags -> flags{configBuildHcFlavor = v})
+ ( choiceOpt
+ [ (Flag GHC, ("g", ["ghc"]), "compile with GHC")
+ , (Flag GHCJS, ([], ["ghcjs"]), "compile with GHCJS")
+ ]
+ )
+ , option
+ "W"
+ ["with-build-compiler", "with-build-hc"]
+ "give the path to the compiler for the build toolchain"
+ configBuildHcPath
+ (\v flags -> flags{configBuildHcPath = v})
+ (reqArgFlag "PATH")
+ , option
+ ""
+ ["with-build-hc-pkg"]
+ "give the path to the package tool for the build toolchain"
+ configBuildHcPkg
+ (\v flags -> flags{configBuildHcPkg = v})
+ (reqArgFlag "PATH")
+ , option
+ ""
+ ["build-package-db"]
+ ( "Append the given package database to the list of package"
+ ++ " databases used (to satisfy dependencies and register into)."
+ ++ " May be a specific file, 'global' or 'user'. The initial list"
+ ++ " is ['global'], ['global', 'user'], or ['global', $sandbox],"
+ ++ " depending on context. Use 'clear' to reset the list to empty."
+ ++ " See the user guide for details."
+ )
+ configBuildPackageDBs
+ (\v flags -> flags{configBuildPackageDBs = v})
+ (reqArg' "DB" readPackageDbList showPackageDbList)
]
writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy)
diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs
index 78833af6d15..d46045c849a 100644
--- a/cabal-install/src/Distribution/Client/SetupWrapper.hs
+++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs
@@ -1068,11 +1068,14 @@ getExternalSetupMethod verbosity options pkg bt = do
debug verbosity "Setup executable needs to be updated, compiling..."
(compiler, progdb, options'') <- configureCompiler options'
pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options''))
- let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion
+ let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion Nothing
(program, extraOpts) =
case compilerFlavor compiler of
GHCJS -> (ghcjsProgram, ["-build-runner"])
- _ -> (ghcProgram, ["-threaded"])
+ _ -> (ghcProgram, [])
+ -- FIXME: don't enable -threaded unconditionnally: we may
+ -- only have vanilla libraries (but maybe we don't have them
+ -- either?)
cabalDep =
maybe
[]
@@ -1152,5 +1155,5 @@ getExternalSetupMethod verbosity options pkg bt = do
return $ i setupProgFile
isCabalPkgId, isBasePkgId :: PackageIdentifier -> Bool
-isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal"
-isBasePkgId (PackageIdentifier pname _) = pname == mkPackageName "base"
+isCabalPkgId (PackageIdentifier pname _ _compid) = pname == mkPackageName "Cabal"
+isBasePkgId (PackageIdentifier pname _ _compid) = pname == mkPackageName "base"
diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs
index 17dcf6d9398..883f9f38a91 100644
--- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs
+++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs
@@ -218,7 +218,7 @@ showPlanProblem (PackageInconsistency name inconsistencies) =
[ " package "
++ prettyShow pkg
++ " requires "
- ++ prettyShow (PackageIdentifier name ver)
+ ++ prettyShow (PackageIdentifier name ver Nothing)
| (pkg, ver) <- inconsistencies
]
showPlanProblem (PackageStateInvalid pkg pkg') =
@@ -360,6 +360,43 @@ setupRoots =
-- Each element in the result is a package name along with the packages that
-- depend on it and the versions they require. These are guaranteed to be
-- distinct.
+
+-- type SolverPlanIndex = Graph (ResolverPackage UnresolvedPkgLoc)
+-- data ResolverPackage loc = PreExisting InstSolverPackage
+-- | Configured (SolverPackage loc)
+-- data InstSolverPackage = InstSolverPackage {
+-- instSolverQPN :: QPN,
+-- instSolverPkgIPI :: InstalledPackageInfo,
+-- instSolverPkgLibDeps :: ComponentDeps [SolverId],
+-- instSolverPkgExeDeps :: ComponentDeps [SolverId]
+-- }
+-- data SolverPackage loc = SolverPackage {
+-- solverPkgQPN :: QPN,
+-- solverPkgStage :: Stage,
+-- solverPkgSource :: SourcePackage loc,
+-- solverPkgFlags :: FlagAssignment,
+-- solverPkgStanzas :: OptionalStanzaSet,
+-- solverPkgLibDeps :: ComponentDeps [SolverId],
+-- solverPkgExeDeps :: ComponentDeps [SolverId]
+-- }
+-- newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a }
+-- data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId }
+-- | PlannedId { solverSrcId :: PackageId }
+--
+-- flatDeps :: ComponentDeps a -> a
+
+-- instance Package (ResolverPackage loc) where
+-- packageId (PreExisting ipkg) = packageId ipkg
+-- packageId (Configured spkg) = packageId spkg
+
+-- resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId]
+-- resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg
+-- resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg
+
+-- resolverPackageExeDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId]
+-- resolverPackageExeDeps (PreExisting ipkg) = instSolverPkgExeDeps ipkg
+-- resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg
+
dependencyInconsistencies'
:: SolverPlanIndex
-> [(PackageName, [(PackageIdentifier, Version)])]
diff --git a/cabal-install/src/Distribution/Client/SourceFiles.hs b/cabal-install/src/Distribution/Client/SourceFiles.hs
index 1166f333f3c..52b203d18c8 100644
--- a/cabal-install/src/Distribution/Client/SourceFiles.hs
+++ b/cabal-install/src/Distribution/Client/SourceFiles.hs
@@ -28,6 +28,7 @@ import Distribution.Types.BuildInfo
import Distribution.Types.Component
import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec)
import Distribution.Types.Executable
+import Distribution.Types.ExtraSource
import Distribution.Types.ForeignLib
import Distribution.Types.Library
import Distribution.Types.PackageDescription
@@ -176,11 +177,11 @@ needBuildInfo pkg_descr bi modules = do
matchDirFileGlobWithDie normal (\_ _ -> return []) (specVersion pkg_descr) (Just $ makeSymbolicPath root) fpath
traverse_ needIfExists $
concat
- [ map getSymbolicPath $ cSources bi
- , map getSymbolicPath $ cxxSources bi
- , map getSymbolicPath $ jsSources bi
- , map getSymbolicPath $ cmmSources bi
- , map getSymbolicPath $ asmSources bi
+ [ map (getSymbolicPath . extraSourceFile) $ cSources bi
+ , map (getSymbolicPath . extraSourceFile) $ cxxSources bi
+ , map (getSymbolicPath . extraSourceFile) $ jsSources bi
+ , map (getSymbolicPath . extraSourceFile) $ cmmSources bi
+ , map (getSymbolicPath . extraSourceFile) $ asmSources bi
, map getSymbolicPath $ expandedExtraSrcFiles
]
for_ (fmap getSymbolicPath $ installIncludes bi) $ \f ->
diff --git a/cabal-install/src/Distribution/Client/Store.hs b/cabal-install/src/Distribution/Client/Store.hs
index dcf4c78d02c..5b82712b963 100644
--- a/cabal-install/src/Distribution/Client/Store.hs
+++ b/cabal-install/src/Distribution/Client/Store.hs
@@ -26,9 +26,11 @@ import Prelude ()
import Distribution.Client.DistDirLayout
import Distribution.Client.RebuildMonad
-import Distribution.Package (UnitId, mkUnitId)
+import Distribution.Package (UnitId, mkUnitId, addPrefixToUnitId, isPartialUnitId)
import Distribution.Simple.Compiler (Compiler (..))
+import GHC.Stack (HasCallStack)
+
import Distribution.Simple.Utils
( debug
, info
@@ -132,18 +134,20 @@ doesStoreEntryExist StoreDirLayout{storePackageDirectory} compiler unitid =
-- | Return the 'UnitId's of all packages\/components already installed in the
-- store.
-getStoreEntries :: StoreDirLayout -> Compiler -> Rebuild (Set UnitId)
+getStoreEntries :: HasCallStack => StoreDirLayout -> Compiler -> Rebuild (Set UnitId)
getStoreEntries StoreDirLayout{storeDirectory} compiler = do
paths <- getDirectoryContentsMonitored (storeDirectory compiler)
return $! mkEntries paths
where
mkEntries =
- Set.delete (mkUnitId "package.db")
- . Set.delete (mkUnitId "incoming")
- . Set.fromList
- . map mkUnitId
+ Set.fromList
+ . map (\pkg -> case mkUnitId pkg of
+ uid | isPartialUnitId uid -> addPrefixToUnitId (prettyShow (compilerId compiler)) uid
+ | otherwise -> uid)
. filter valid
valid ('.' : _) = False
+ valid "incoming" = False
+ valid "package.db" = False
valid _ = True
-- | The outcome of 'newStoreEntry': either the store entry was newly created
diff --git a/cabal-install/src/Distribution/Client/TargetSelector.hs b/cabal-install/src/Distribution/Client/TargetSelector.hs
index b31655c59c6..d74aff42e3e 100644
--- a/cabal-install/src/Distribution/Client/TargetSelector.hs
+++ b/cabal-install/src/Distribution/Client/TargetSelector.hs
@@ -72,6 +72,7 @@ import Distribution.PackageDescription
, BenchmarkInterface (..)
, BuildInfo (..)
, Executable (..)
+ , ExtraSourceClass (..)
, PackageDescription
, TestSuite (..)
, TestSuiteInterface (..)
@@ -1921,8 +1922,8 @@ collectKnownComponentInfo pkg =
, cinfoSrcDirs = ordNub (map getSymbolicPath (hsSourceDirs bi))
, cinfoModules = ordNub (componentModules c)
, cinfoHsFiles = ordNub (componentHsFiles c)
- , cinfoCFiles = ordNub (map getSymbolicPath $ cSources bi)
- , cinfoJsFiles = ordNub (map getSymbolicPath $ jsSources bi)
+ , cinfoCFiles = ordNub (map (getSymbolicPath . extraSourceFile) $ cSources bi)
+ , cinfoJsFiles = ordNub (map (getSymbolicPath . extraSourceFile) $ jsSources bi)
}
| c <- pkgComponents pkg
, let bi = componentBuildInfo c
diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs
index bfa94b0da80..cef19b4d277 100644
--- a/cabal-install/src/Distribution/Client/Targets.hs
+++ b/cabal-install/src/Distribution/Client/Targets.hs
@@ -618,6 +618,8 @@ data UserConstraintScope
UserQualified UserQualifier PackageName
| -- | Scope that applies to the package when it has a setup qualifier.
UserAnySetupQualifier PackageName
+ | -- | Scope that applies to all build packages only.
+ UserAnyBuildDepQualifier PackageName
| -- | Scope that applies to the package when it has any qualifier.
UserAnyQualifier PackageName
deriving (Eq, Show, Generic)
@@ -634,6 +636,7 @@ fromUserConstraintScope :: UserConstraintScope -> ConstraintScope
fromUserConstraintScope (UserQualified q pn) =
ScopeQualified (fromUserQualifier q) pn
fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn
+fromUserConstraintScope (UserAnyBuildDepQualifier pn) = ScopeAnyBuildDepQualifier pn
fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn
-- | Version of 'PackageConstraint' that the user can specify on
@@ -650,6 +653,7 @@ userConstraintPackageName (UserConstraint scope _) = scopePN scope
where
scopePN (UserQualified _ pn) = pn
scopePN (UserAnyQualifier pn) = pn
+ scopePN (UserAnyBuildDepQualifier pn) = pn
scopePN (UserAnySetupQualifier pn) = pn
userToPackageConstraint :: UserConstraint -> PackageConstraint
@@ -698,6 +702,7 @@ instance Parsec UserConstraint where
withDot :: PackageName -> m UserConstraintScope
withDot pn
| pn == mkPackageName "any" = UserAnyQualifier <$> parsec
+ | pn == mkPackageName "build" = UserAnyBuildDepQualifier <$> parsec
| pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec
| otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn
diff --git a/cabal-install/src/Distribution/Client/Types/AllowNewer.hs b/cabal-install/src/Distribution/Client/Types/AllowNewer.hs
index 0a5700174b8..6a6503aaf4c 100644
--- a/cabal-install/src/Distribution/Client/Types/AllowNewer.hs
+++ b/cabal-install/src/Distribution/Client/Types/AllowNewer.hs
@@ -109,7 +109,7 @@ relaxedDepStarP =
-- continuation after package identifier
relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep
-relaxedDepPkgidP pid@(PackageIdentifier pn v)
+relaxedDepPkgidP pid@(PackageIdentifier pn v _compid)
| pn == mkPackageName "all"
, v == nullVersion =
RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec
diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs
index 2b25a64b6be..c6c33735900 100644
--- a/cabal-install/tests/IntegrationTests2.hs
+++ b/cabal-install/tests/IntegrationTests2.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -70,7 +71,7 @@ import qualified Distribution.Simple.Flag as Flag
import Distribution.Simple.Setup (CommonSetupFlags (..), HaddockFlags (..), HaddockProjectFlags (..), defaultCommonSetupFlags, defaultHaddockFlags, defaultHaddockProjectFlags, toFlag)
import Distribution.System
import Distribution.Text
-import Distribution.Utils.Path (unsafeMakeSymbolicPath)
+import Distribution.Utils.Path (FileOrDir (File), Pkg, SymbolicPath, unsafeMakeSymbolicPath)
import Distribution.Version
import IntegrationTests2.CPP
@@ -658,7 +659,10 @@ testTargetSelectorAmbiguous reportSubCase = do
withCFiles :: Executable -> [FilePath] -> Executable
withCFiles exe files =
- exe{buildInfo = (buildInfo exe){cSources = map unsafeMakeSymbolicPath files}}
+ exe{buildInfo = (buildInfo exe){cSources = map (mkExtraSource . unsafeMakeSymbolicPath) files}}
+
+ mkExtraSource :: SymbolicPath Pkg File -> ExtraSource Pkg
+ mkExtraSource x = ExtraSourcePkg x []
withHsSrcDirs :: Executable -> [FilePath] -> Executable
withHsSrcDirs exe srcDirs =
@@ -1887,10 +1891,10 @@ testSetupScriptStyles config reportSubCase = do
let isOSX (Platform _ OSX) = True
isOSX _ = False
- compilerVer = compilerVersion (pkgConfigCompiler sharedConfig)
+ compilerVer = compilerVersion (toolchainCompiler $ buildToolchain $ pkgConfigToolchains sharedConfig)
-- Skip the Custom tests when the shipped Cabal library is buggy
unless
- ( (isOSX (pkgConfigPlatform sharedConfig) && (compilerVer < mkVersion [7, 10]))
+ ( (isOSX (toolchainPlatform $ buildToolchain $ pkgConfigToolchains sharedConfig) && (compilerVer < mkVersion [7, 10]))
-- 9.10 ships Cabal 3.12.0.0 affected by #9940
|| (mkVersion [9, 10] <= compilerVer && compilerVer < mkVersion [9, 11])
)
@@ -1904,7 +1908,7 @@ testSetupScriptStyles config reportSubCase = do
removeFile (basedir </> testdir1 </> "marker")
-- implicit deps implies 'Cabal < 2' which conflicts w/ GHC 8.2 or later
- when (compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [8, 2]) $ do
+ when (compilerVersion (toolchainCompiler $ buildToolchain $ pkgConfigToolchains sharedConfig) < mkVersion [8, 2]) $ do
reportSubCase (show SetupCustomImplicitDeps)
(plan2, res2) <- executePlan =<< planProject testdir2 config
pkg2 <- expectPackageInstalled plan2 res2 pkgidA
@@ -2193,6 +2197,7 @@ planProject testdir cliConfig = do
(elaboratedPlan, _, elaboratedShared, _, _) <-
rebuildInstallPlan
verbosity
+ mempty
distDirLayout
cabalDirLayout
projectConfig
@@ -2779,7 +2784,7 @@ testHaddockProjectDependencies config = do
(_, _, sharedConfig) <- planProject testdir config
-- `haddock-project` is only supported by `haddock-2.26.1` and above which is
-- shipped with `ghc-9.4`
- when (compilerVersion (pkgConfigCompiler sharedConfig) > mkVersion [9, 4]) $ do
+ when (compilerVersion (toolchainCompiler $ buildToolchain $ pkgConfigToolchains sharedConfig) > mkVersion [9, 4]) $ do
let dir = basedir </> testdir
cleanHaddockProject testdir
withCurrentDirectory dir $ do
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
index bf69b20ee04..a77415fec49 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
@@ -11,6 +11,7 @@
module UnitTests.Distribution.Client.ProjectConfig (tests) where
import Control.Monad
+import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Either (isRight)
import Data.Foldable (for_)
import Data.List (intercalate, isPrefixOf, (\\))
@@ -26,6 +27,8 @@ import System.IO.Unsafe (unsafePerformIO)
import Distribution.Deprecated.ParseUtils
import qualified Distribution.Deprecated.ReadP as Parse
+import Distribution.Client.HashValue (hashValue)
+import Distribution.Client.HookAccept (HookAccept (..))
import Distribution.Compiler
import Distribution.Package
import Distribution.PackageDescription
@@ -610,6 +613,9 @@ instance Arbitrary ProjectConfigShared where
projectConfigHcFlavor <- arbitrary
projectConfigHcPath <- arbitraryFlag arbitraryShortToken
projectConfigHcPkg <- arbitraryFlag arbitraryShortToken
+ projectConfigHostHcFlavor <- arbitrary
+ projectConfigHostHcPath <- arbitraryFlag arbitraryShortToken
+ projectConfigHostHcPkg <- arbitraryFlag arbitraryShortToken
projectConfigHaddockIndex <- arbitrary
projectConfigInstallDirs <- fixInstallDirs <$> arbitrary
projectConfigPackageDBs <- shortListOf 2 arbitrary
@@ -638,6 +644,7 @@ instance Arbitrary ProjectConfigShared where
projectConfigPreferOldest <- arbitrary
projectConfigProgPathExtra <- toNubList <$> listOf arbitraryShortToken
projectConfigMultiRepl <- arbitrary
+ projectConfigHookHashes <- arbitrary
return ProjectConfigShared{..}
where
arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)]
@@ -656,6 +663,9 @@ instance Arbitrary ProjectConfigShared where
<*> shrinker projectConfigHcFlavor
<*> shrinkerAla (fmap NonEmpty) projectConfigHcPath
<*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg
+ <*> shrinker projectConfigHostHcFlavor
+ <*> shrinkerAla (fmap NonEmpty) projectConfigHostHcPath
+ <*> shrinkerAla (fmap NonEmpty) projectConfigHostHcPkg
<*> shrinker projectConfigHaddockIndex
<*> shrinker projectConfigInstallDirs
<*> shrinker projectConfigPackageDBs
@@ -684,6 +694,7 @@ instance Arbitrary ProjectConfigShared where
<*> shrinker projectConfigPreferOldest
<*> shrinker projectConfigProgPathExtra
<*> shrinker projectConfigMultiRepl
+ <*> shrinker projectConfigHookHashes
where
preShrink_Constraints = map fst
postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))
@@ -691,6 +702,9 @@ instance Arbitrary ProjectConfigShared where
projectConfigConstraintSource :: ConstraintSource
projectConfigConstraintSource = ConstraintSourceProjectConfig nullProjectConfigPath
+instance Arbitrary HookAccept where
+ arbitrary = elements [AcceptAlways, AcceptHash (hashValue $ LBS.pack "hash")]
+
instance Arbitrary ProjectConfigProvenance where
arbitrary = elements [Implicit, Explicit (ProjectConfigPath $ "cabal.project" :| [])]
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs
index 179fef5688a..42c38a7bc82 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs
@@ -13,6 +13,8 @@ import Distribution.Solver.Types.Settings
import Distribution.Client.BuildReports.Types
import Distribution.Client.CmdInstall.ClientInstallFlags
import Distribution.Client.Dependency.Types
+import Distribution.Client.HashValue (HashValue)
+import Distribution.Client.HookAccept (HookAccept (..))
import Distribution.Client.IndexUtils.ActiveRepos
import Distribution.Client.IndexUtils.IndexState
import Distribution.Client.IndexUtils.Timestamp
@@ -45,6 +47,8 @@ instance ToExpr ProjectConfigPath
instance ToExpr ConstraintSource
instance ToExpr CountConflicts
instance ToExpr FineGrainedConflicts
+instance ToExpr HashValue
+instance ToExpr HookAccept
instance ToExpr IndependentGoals
instance ToExpr InstallMethod
instance ToExpr InstallOutcome
diff --git a/cabal-testsuite/PackageTests/ExtraSources/cbits/test.c b/cabal-testsuite/PackageTests/ExtraSources/cbits/test.c
new file mode 100644
index 00000000000..e31c5a9b7b5
--- /dev/null
+++ b/cabal-testsuite/PackageTests/ExtraSources/cbits/test.c
@@ -0,0 +1,3 @@
+#ifndef DOIT
+#error "It does not work"
+#endif
diff --git a/cabal-testsuite/PackageTests/ExtraSources/extra-sources.cabal b/cabal-testsuite/PackageTests/ExtraSources/extra-sources.cabal
new file mode 100644
index 00000000000..0d340f5c6bd
--- /dev/null
+++ b/cabal-testsuite/PackageTests/ExtraSources/extra-sources.cabal
@@ -0,0 +1,10 @@
+cabal-version: 3.4
+name: extra-sources
+version: 0
+build-type: Simple
+
+library
+ hs-source-dirs: src
+ build-depends: base
+ exposed-modules: MyLib
+ c-sources: cbits/test.c (-D DOIT=1)
diff --git a/cabal-testsuite/PackageTests/ExtraSources/setup.out b/cabal-testsuite/PackageTests/ExtraSources/setup.out
new file mode 100644
index 00000000000..43a3574bd1b
--- /dev/null
+++ b/cabal-testsuite/PackageTests/ExtraSources/setup.out
@@ -0,0 +1,5 @@
+# Setup configure
+Configuring extra-sources-0...
+# Setup build
+Preprocessing library for extra-sources-0...
+Building library for extra-sources-0...
diff --git a/cabal-testsuite/PackageTests/ExtraSources/setup.test.hs b/cabal-testsuite/PackageTests/ExtraSources/setup.test.hs
new file mode 100644
index 00000000000..9e2abcb188b
--- /dev/null
+++ b/cabal-testsuite/PackageTests/ExtraSources/setup.test.hs
@@ -0,0 +1,5 @@
+import Test.Cabal.Prelude
+
+main = setupTest $ do
+ setup "configure" []
+ setup "build" []
diff --git a/cabal-testsuite/PackageTests/ExtraSources/src/MyLib.hs b/cabal-testsuite/PackageTests/ExtraSources/src/MyLib.hs
new file mode 100644
index 00000000000..bcdf120b02c
--- /dev/null
+++ b/cabal-testsuite/PackageTests/ExtraSources/src/MyLib.hs
@@ -0,0 +1,4 @@
+module MyLib where
+
+someFunc :: IO ()
+someFunc = mempty
diff --git a/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs b/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs
index 6267a0f5684..1667106ac8b 100644
--- a/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs
+++ b/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs
@@ -115,11 +115,6 @@ normalizeOutput nenv =
-- and replace it with:
-- > "-package-id","<PACKAGEDEP>"
--
- -- Otherwise, output can not be properly normalized as on MacOs we remove
- -- vowels from packages to make the names shorter.
- -- E.g. "another-framework-0.8.1.1" -> "nthr-frmwrk-0.8.1.1"
- --
- -- This makes it impossible to have a stable package id, thus remove it completely.
-- Check manually in your test-cases if the package-id needs to be verified.
. resub ("\"-package-id\",\"([^\"]*)\"")
"\"-package-id\",\"<PACKAGEDEP>\""
diff --git a/changelog.d/pr-10799 b/changelog.d/pr-10799
new file mode 100644
index 00000000000..3f37124aebb
--- /dev/null
+++ b/changelog.d/pr-10799
@@ -0,0 +1,15 @@
+synopsis: Add pre and post build hooks
+packages: cabal-install
+prs: #10799
+issues: #9892
+significance: significant
+
+description: {
+
+- Run a program (named "preBuildHook") before doing a package build and another program
+ (named "postBuildHook") after the package is built.
+- These programs are project local and need to be in the `cabalHooks` directory which is
+ in the same directory as the `cabal.project` file.
+- The absence of these programs will be ignored.
+- How to check and run these hooks securely is specified in the documentation.
+}
diff --git a/doc/build-hooks.rst b/doc/build-hooks.rst
new file mode 100644
index 00000000000..82e53693dc4
--- /dev/null
+++ b/doc/build-hooks.rst
@@ -0,0 +1,83 @@
+Build Hooks
+===========
+
+Build hooks are programs that are run before (pre-build hook) and
+after (post-build hook) a package (including package dependencies)
+is built. The hooks are completely generic and can even be absent
+(their absence is ignored). Regardless of the return code of the
+pre-build hook, the normal build is executed. In the case where
+the pre-build hook provides a pre-built version of what the build
+step would provide, the build step is still run, but should be
+little more than a NOOP.
+
+Build hooks are project local rather than global to the user
+because a single user may want to use one set of hooks in one
+project and another set of hooks (or even none at all) for another
+project.
+
+Since the hook files are project local (and hence likely to be committed
+to revision control), a naive implementation of these hooks would be
+a potential security issue. A solution to this potential security
+issue has been implemented and described in the Hook Security section
+below.
+
+
+Possible Use Cases
+------------------
+
+Possible use cases include:
+
+* Fine grained benchmarking of individual package build times.
+* Build product caching.
+
+
+Location of Hook Files
+----------------------
+
+The two hook files are `cabalHooks/preBuildHook` and
+`cabalHooks/postBuildHook` where the `cabalHooks` directory is in
+the same directory as the `cabal.project` file. On UNIX style
+systems, these hooks need to be marked as user executable programs.
+
+
+Hook Parameters Exit Codes
+--------------------------
+
+The pre-build hook is passed three parameters; the unit id (from cabal),
+the source directory and the build directory. The post-build hook is
+passed the same three parameters, plus the exit code of the pre-build
+hook.
+
+The exit codes for the two hooks are ignored by cabal apart from cabal
+capturing the exit code for the pre-build hook and passing it to the
+post-build hook.
+
+
+Hook Security
+-------------
+These hook files are generic executable programs and are stored local to
+the project. To prevent the running of malicious hook files, the
+hook files are only run, it they are mentioned in the `hooks-security`
+file which is located in the users home `.cabal` directory, usually
+either `$HOME/.cabal/` or `$HOME/.config/cabal/`.
+
+The `hooks-security` file should contain one entry per line. Blank lines
+are ignored, as are Haskell style single line comments (starts with "--"
+and goes until the end of the line). Each entry should contain the full
+hook file path, at least one space and either "AcceptAlways" or
+"AcceptHash" followed by at least one space and the hexadecimal encoded
+hash of the file. The `hooks-security` file is read once when `cabal` is
+started and the entries inserted into a `Map`.
+
+When `cabal` detects a "preBuildHook" or "postBuildHook" it looks up
+the full file path in the `Map`. If the path is not found in the `Map`,
+`cabal` will die with an error message suggesting that the hook file
+be manually inspected and if deemed safe, added to the `hooks-security`
+file.
+
+If the hook file path is in the `Map` and it was specified as
+"AcceptAlways" the hook will be run. If the `Map` entry is "AcceptHash"
+with a hash, the hash of the hook file will be calculated and compared
+against the supplied hash. If the hashes match, the hook will be run.
+If there is a hash mismatch, `cabal` will abort with an error message
+about the hash mismatch.
diff --git a/doc/index.rst b/doc/index.rst
index 4bd13c65d7a..a721b77ed63 100644
--- a/doc/index.rst
+++ b/doc/index.rst
@@ -20,6 +20,7 @@ Welcome to the Cabal User Guide
how-to-run-in-windows
how-to-use-backpack
how-to-report-bugs
+ build-hooks
.. toctree::
:caption: Cabal Reference