diff --git a/.gitignore b/.gitignore index 5bded8d550e..36110f1eec2 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ # trivial gitignore file .cabal-sandbox/ cabal.sandbox.config +cabal.project.local cabal-dev/ .hpc/ *.hi diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 2bc052c6cfb..ccae6dc7e36 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -40,6 +40,15 @@ extra-source-files: tests/PackageTests/AllowOlder/benchmarks/Bench.hs tests/PackageTests/AllowOlder/src/Foo.hs tests/PackageTests/AllowOlder/tests/Test.hs + tests/PackageTests/Ambiguity/p/Dupe.hs + tests/PackageTests/Ambiguity/p/p.cabal + tests/PackageTests/Ambiguity/package-import/A.hs + tests/PackageTests/Ambiguity/package-import/package-import.cabal + tests/PackageTests/Ambiguity/q/Dupe.hs + tests/PackageTests/Ambiguity/q/q.cabal + tests/PackageTests/Ambiguity/reexport-test/Main.hs + tests/PackageTests/Ambiguity/reexport-test/reexport-test.cabal + tests/PackageTests/Ambiguity/reexport/reexport.cabal tests/PackageTests/AutogenModules/Package/Dummy.hs tests/PackageTests/AutogenModules/Package/MyBenchModule.hs tests/PackageTests/AutogenModules/Package/MyExeModule.hs @@ -54,6 +63,44 @@ extra-source-files: tests/PackageTests/AutogenModules/SrcDist/MyLibrary.hs tests/PackageTests/AutogenModules/SrcDist/MyTestModule.hs tests/PackageTests/AutogenModules/SrcDist/my.cabal + tests/PackageTests/Backpack/Includes1/A.hs + tests/PackageTests/Backpack/Includes1/B.hs + tests/PackageTests/Backpack/Includes1/Includes1.cabal + tests/PackageTests/Backpack/Includes2/Includes2.cabal + tests/PackageTests/Backpack/Includes2/exe/Main.hs + tests/PackageTests/Backpack/Includes2/exe/exe.cabal + tests/PackageTests/Backpack/Includes2/fail.cabal + tests/PackageTests/Backpack/Includes2/mylib/Mine.hs + tests/PackageTests/Backpack/Includes2/mylib/mylib.cabal + tests/PackageTests/Backpack/Includes2/mysql/Database/MySQL.hs + tests/PackageTests/Backpack/Includes2/mysql/mysql.cabal + tests/PackageTests/Backpack/Includes2/postgresql/Database/PostgreSQL.hs + tests/PackageTests/Backpack/Includes2/postgresql/postgresql.cabal + tests/PackageTests/Backpack/Includes2/src/App.hs + tests/PackageTests/Backpack/Includes2/src/src.cabal + tests/PackageTests/Backpack/Includes3/Includes3.cabal + tests/PackageTests/Backpack/Includes3/exe/Main.hs + tests/PackageTests/Backpack/Includes3/exe/exe.cabal + tests/PackageTests/Backpack/Includes3/indef/Foo.hs + tests/PackageTests/Backpack/Includes3/indef/indef.cabal + tests/PackageTests/Backpack/Includes3/sigs/sigs.cabal + tests/PackageTests/Backpack/Includes4/Includes4.cabal + tests/PackageTests/Backpack/Includes4/Main.hs + tests/PackageTests/Backpack/Includes4/impl/A.hs + tests/PackageTests/Backpack/Includes4/impl/B.hs + tests/PackageTests/Backpack/Includes4/impl/Rec.hs + tests/PackageTests/Backpack/Includes4/indef/C.hs + tests/PackageTests/Backpack/Includes5/A.hs + tests/PackageTests/Backpack/Includes5/B.hs + tests/PackageTests/Backpack/Includes5/Includes5.cabal + tests/PackageTests/Backpack/Includes5/impl/Foobar.hs + tests/PackageTests/Backpack/Includes5/impl/Quxbaz.hs + tests/PackageTests/Backpack/Indef1/Indef1.cabal + tests/PackageTests/Backpack/Indef1/Provide.hs + tests/PackageTests/Backpack/Reexport1/p/P.hs + tests/PackageTests/Backpack/Reexport1/p/p.cabal + tests/PackageTests/Backpack/Reexport1/q/Q.hs + tests/PackageTests/Backpack/Reexport1/q/q.cabal tests/PackageTests/BenchmarkExeV10/Foo.hs tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs tests/PackageTests/BenchmarkExeV10/my.cabal @@ -207,6 +254,13 @@ extra-source-files: tests/PackageTests/PreProcessExtraSources/Foo.hsc tests/PackageTests/PreProcessExtraSources/Main.hs tests/PackageTests/PreProcessExtraSources/my.cabal + tests/PackageTests/ReexportedModules/containers-dupe/Data/Map.hs + tests/PackageTests/ReexportedModules/containers-dupe/containers-dupe.cabal + tests/PackageTests/ReexportedModules/p/Private.hs + tests/PackageTests/ReexportedModules/p/Public.hs + tests/PackageTests/ReexportedModules/p/fail-ambiguous.cabal + tests/PackageTests/ReexportedModules/p/fail-missing.cabal + tests/PackageTests/ReexportedModules/p/fail-other.cabal tests/PackageTests/ReexportedModules/p/p.cabal tests/PackageTests/ReexportedModules/q/A.hs tests/PackageTests/ReexportedModules/q/q.cabal @@ -310,6 +364,16 @@ library -Wnoncanonical-monadfail-instances exposed-modules: + Distribution.Backpack + Distribution.Backpack.Configure + Distribution.Backpack.ComponentsGraph + Distribution.Backpack.ConfiguredComponent + Distribution.Backpack.FullUnitId + Distribution.Backpack.LinkedComponent + Distribution.Backpack.ModSubst + Distribution.Backpack.ModuleShape + Distribution.Utils.LogProgress + Distribution.Utils.MapAccum Distribution.Compat.CreatePipe Distribution.Compat.Environment Distribution.Compat.Exception @@ -395,6 +459,7 @@ library Distribution.Types.Library Distribution.Types.ModuleReexport Distribution.Types.ModuleRenaming + Distribution.Types.IncludeRenaming Distribution.Types.SetupBuildInfo Distribution.Types.TestSuite Distribution.Types.TestSuiteInterface @@ -411,12 +476,21 @@ library Distribution.Types.TargetInfo Distribution.Utils.NubList Distribution.Utils.ShortText + Distribution.Utils.Progress Distribution.Verbosity Distribution.Version Language.Haskell.Extension Distribution.Compat.Binary other-modules: + Distribution.Backpack.PreExistingComponent + Distribution.Backpack.ReadyComponent + Distribution.Backpack.MixLink + Distribution.Backpack.ModuleScope + Distribution.Backpack.UnifyM + Distribution.Backpack.Id + Distribution.Utils.UnionFind + Distribution.Utils.Base62 Distribution.Compat.CopyFile Distribution.Compat.GetShortPathName Distribution.Compat.MonadFail diff --git a/Cabal/Distribution/Backpack.hs b/Cabal/Distribution/Backpack.hs new file mode 100644 index 00000000000..a42b5581128 --- /dev/null +++ b/Cabal/Distribution/Backpack.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | This module defines the core data types for Backpack. For more +-- details, see: +-- +-- + +module Distribution.Backpack ( + -- * OpenUnitId + OpenUnitId(..), + openUnitIdComponentId, + openUnitIdFreeHoles, + mkOpenUnitId, + + -- * DefUnitId + DefUnitId, + unDefUnitId, + mkDefUnitId, + + -- * OpenModule + OpenModule(..), + openModuleFreeHoles, + + -- * OpenModuleSubst + OpenModuleSubst, + dispOpenModuleSubst, + dispOpenModuleSubstEntry, + parseOpenModuleSubst, + parseOpenModuleSubstEntry, + openModuleSubstFreeHoles, + + -- * Conversions to 'UnitId' + abstractUnitId, + hashModuleSubst, +) where + +import Prelude () +import Distribution.Compat.Prelude hiding (mod) +import Distribution.Compat.ReadP +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint (hcat) + +import Distribution.ModuleName +import Distribution.Package +import Distribution.Text +import Distribution.Utils.Base62 + +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + +----------------------------------------------------------------------- +-- OpenUnitId + +-- | An 'OpenUnitId' describes a (possibly partially) instantiated +-- Backpack component, with a description of how the holes are filled +-- in. Unlike 'OpenUnitId', the 'ModuleSubst' is kept in a structured +-- form that allows for substitution (which fills in holes.) This form +-- of unit cannot be installed. It must first be converted to a +-- 'UnitId'. +-- +-- In the absence of Backpack, there are no holes to fill, so any such +-- component always has an empty module substitution; thus we can lossly +-- represent it as an 'OpenUnitId uid'. +-- +-- For a source component using Backpack, however, there is more +-- structure as components may be parametrized over some signatures, and +-- these \"holes\" may be partially or wholly filled. +-- +-- OpenUnitId plays an important role when we are mix-in linking, +-- and is recorded to the installed packaged database for indefinite +-- packages; however, for compiled packages that are fully instantiated, +-- we instantiate 'OpenUnitId' into 'UnitId'. +-- +-- For more details see the Backpack spec +-- +-- + +data OpenUnitId + -- | Identifies a component which may have some unfilled holes; + -- specifying its 'ComponentId' and its 'OpenModuleSubst'. + -- TODO: Invariant that 'OpenModuleSubst' is non-empty? + -- See also the Text instance. + = IndefFullUnitId ComponentId OpenModuleSubst + -- | Identifies a fully instantiated component, which has + -- been compiled and abbreviated as a hash. The embedded 'UnitId' + -- MUST NOT be for an indefinite component; an 'OpenUnitId' + -- is guaranteed not to have any holes. + | DefiniteUnitId DefUnitId + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +-- TODO: cache holes? + +instance Binary OpenUnitId + +instance NFData OpenUnitId where + rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst + rnf (DefiniteUnitId uid) = rnf uid + +instance Text OpenUnitId where + disp (IndefFullUnitId cid insts) + -- TODO: arguably a smart constructor to enforce invariant would be + -- better + | Map.null insts = disp cid + | otherwise = disp cid <<>> Disp.brackets (dispOpenModuleSubst insts) + disp (DefiniteUnitId uid) = disp uid + parse = parseOpenUnitId <++ fmap DefiniteUnitId parse + where + parseOpenUnitId = do + cid <- parse + insts <- Parse.between (Parse.char '[') (Parse.char ']') + parseOpenModuleSubst + return (IndefFullUnitId cid insts) + +-- | Get the 'ComponentId' of an 'OpenUnitId'. +openUnitIdComponentId :: OpenUnitId -> ComponentId +openUnitIdComponentId (IndefFullUnitId cid _) = cid +openUnitIdComponentId (DefiniteUnitId def_uid) = unitIdComponentId (unDefUnitId def_uid) + +-- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'. +openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName +openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts +openUnitIdFreeHoles _ = Set.empty + +-- | Safe constructor from a UnitId. The only way to do this safely +-- is if the instantiation is provided. +mkOpenUnitId :: UnitId -> OpenModuleSubst -> OpenUnitId +mkOpenUnitId uid insts = + if Set.null (openModuleSubstFreeHoles insts) + then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds! + else IndefFullUnitId (unitIdComponentId uid) insts + +----------------------------------------------------------------------- +-- DefUnitId + +-- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation +-- with no holes. +mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId +mkDefUnitId cid insts = + unsafeMkDefUnitId (UnitId cid (hashModuleSubst insts)) -- impose invariant! + +----------------------------------------------------------------------- +-- OpenModule + +-- | Unlike a 'Module', an 'OpenModule' is either an ordinary +-- module from some unit, OR an 'OpenModuleVar', representing a +-- hole that needs to be filled in. Substitutions are over +-- module variables. +data OpenModule + = OpenModule OpenUnitId ModuleName + | OpenModuleVar ModuleName + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +instance Binary OpenModule + +instance NFData OpenModule where + rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name + rnf (OpenModuleVar mod_name) = rnf mod_name + +instance Text OpenModule where + disp (OpenModule uid mod_name) = + hcat [disp uid, Disp.text ":", disp mod_name] + disp (OpenModuleVar mod_name) = + hcat [Disp.char '<', disp mod_name, Disp.char '>'] + parse = parseModuleVar <++ parseOpenModule + where + parseOpenModule = do + uid <- parse + _ <- Parse.char ':' + mod_name <- parse + return (OpenModule uid mod_name) + parseModuleVar = do + _ <- Parse.char '<' + mod_name <- parse + _ <- Parse.char '>' + return (OpenModuleVar mod_name) + +-- | Get the set of holes ('ModuleVar') embedded in a 'Module'. +openModuleFreeHoles :: OpenModule -> Set ModuleName +openModuleFreeHoles (OpenModuleVar mod_name) = Set.singleton mod_name +openModuleFreeHoles (OpenModule uid _n) = openUnitIdFreeHoles uid + +----------------------------------------------------------------------- +-- OpenModuleSubst + +-- | An explicit substitution on modules. +-- +-- NB: These substitutions are NOT idempotent, for example, a +-- valid substitution is (A -> B, B -> A). +type OpenModuleSubst = Map ModuleName OpenModule + +-- | Pretty-print the entries of a module substitution, suitable +-- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@. +dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc +dispOpenModuleSubst subst + = Disp.hcat + . Disp.punctuate Disp.comma + $ map dispOpenModuleSubstEntry (Map.toAscList subst) + +-- | Pretty-print a single entry of a module substitution. +dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Disp.Doc +dispOpenModuleSubstEntry (k, v) = disp k <<>> Disp.char '=' <<>> disp v + +-- | Inverse to 'dispModSubst'. +parseOpenModuleSubst :: ReadP r OpenModuleSubst +parseOpenModuleSubst = fmap Map.fromList + . flip Parse.sepBy (Parse.char ',') + $ parseOpenModuleSubstEntry + +-- | Inverse to 'dispModSubstEntry'. +parseOpenModuleSubstEntry :: ReadP r (ModuleName, OpenModule) +parseOpenModuleSubstEntry = + do k <- parse + _ <- Parse.char '=' + v <- parse + return (k, v) + +-- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'. +-- This is NOT the domain of the substitution. +openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName +openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems insts)) + +----------------------------------------------------------------------- +-- Conversions to UnitId + +-- | 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 (DefiniteUnitId def_uid) = unDefUnitId def_uid +abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid + +-- | Take a module substitution and hash it into a string suitable for +-- 'UnitId'. Note that since this takes 'Module', not 'OpenModule', +-- you are responsible for recursively converting 'OpenModule' +-- into 'Module'. See also "Distribution.Backpack.ReadyComponent". +hashModuleSubst :: Map ModuleName Module -> Maybe String +hashModuleSubst subst + | Map.null subst = Nothing + | otherwise = + Just . hashToBase62 $ + concat [ display mod_name ++ "=" ++ display m ++ "\n" + | (mod_name, m) <- Map.toList subst] diff --git a/Cabal/Distribution/Backpack/ComponentsGraph.hs b/Cabal/Distribution/Backpack/ComponentsGraph.hs new file mode 100644 index 00000000000..c96dd78f9a3 --- /dev/null +++ b/Cabal/Distribution/Backpack/ComponentsGraph.hs @@ -0,0 +1,79 @@ +-- | See + +module Distribution.Backpack.ComponentsGraph ( + ComponentsGraph, + dispComponentsGraph, + toComponentsGraph, + componentCycleMsg +) where + +import Distribution.Package +import Distribution.PackageDescription as PD hiding (Flag) +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Simple.Utils +import Distribution.Compat.Graph (Node(..)) +import qualified Distribution.Compat.Graph as Graph + +import Distribution.Text + ( Text(disp) ) +import Text.PrettyPrint + +------------------------------------------------------------------------------ +-- Components graph +------------------------------------------------------------------------------ + +-- | A components graph is a source level graph tracking the +-- dependencies between components in a package. +type ComponentsGraph = [(Component, [ComponentName])] + +-- | Pretty-print a 'ComponentsGraph'. +dispComponentsGraph :: ComponentsGraph -> Doc +dispComponentsGraph graph = + vcat [ hang (text "component" <+> disp (componentName c)) 4 + (vcat [ text "dependency" <+> disp cdep | cdep <- cdeps ]) + | (c, cdeps) <- graph ] + +-- | Given the package description and a 'PackageDescription' (used +-- to determine if a package name is internal or not), create a graph of +-- dependencies between the components. This is NOT necessarily the +-- build order (although it is in the absence of Backpack.) +toComponentsGraph :: ComponentRequestedSpec + -> PackageDescription + -> Either [ComponentName] ComponentsGraph +toComponentsGraph enabled pkg_descr = + let g = Graph.fromList [ N c (componentName c) (componentDeps c) + | c <- pkgBuildableComponents pkg_descr + , componentEnabled enabled c ] + in case Graph.cycles g of + [] -> Right (map (\(N c _ cs) -> (c, cs)) (Graph.revTopSort g)) + ccycles -> Left [ componentName c | N c _ _ <- concat ccycles ] + where + -- The dependencies for the given component + componentDeps component = + [ CExeName toolname | Dependency pkgname _ + <- buildTools bi + , let toolname = unPackageName pkgname + , toolname `elem` map exeName + (executables pkg_descr) ] + + ++ [ if pkgname == packageName pkg_descr + then CLibName + else CSubLibName toolname + | Dependency pkgname _ + <- targetBuildDepends bi + , pkgname `elem` internalPkgDeps + , let toolname = unPackageName pkgname ] + where + bi = componentBuildInfo component + internalPkgDeps = map (conv . libName) (allLibraries pkg_descr) + conv Nothing = packageName pkg_descr + conv (Just s) = mkPackageName s + +-- | Error message when there is a cycle; takes the SCC of components. +componentCycleMsg :: [ComponentName] -> Doc +componentCycleMsg cnames = + text $ "Components in the package depend on each other in a cyclic way:\n " + ++ intercalate " depends on " + [ "'" ++ showComponentName cname ++ "'" + | cname <- cnames ++ [head cnames] ] diff --git a/Cabal/Distribution/Backpack/Configure.hs b/Cabal/Distribution/Backpack/Configure.hs new file mode 100644 index 00000000000..67f76fcbaf6 --- /dev/null +++ b/Cabal/Distribution/Backpack/Configure.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE NondecreasingIndentation #-} + +-- | See +-- +-- WARNING: The contents of this module are HIGHLY experimental. +-- We may refactor it under you. +module Distribution.Backpack.Configure ( + configureComponentLocalBuildInfos, +) where + +import Prelude () +import Distribution.Compat.Prelude hiding ((<>)) + +import Distribution.Backpack +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.PreExistingComponent +import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.ReadyComponent +import Distribution.Backpack.ComponentsGraph + +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Package +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.InstalledPackageInfo (InstalledPackageInfo + ,emptyInstalledPackageInfo) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.PackageDescription as PD hiding (Flag) +import Distribution.ModuleName +import Distribution.Simple.Setup as Setup +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Verbosity +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph (Graph, IsNode(..)) +import Distribution.Utils.Progress +import Distribution.Utils.LogProgress + +import Data.Either + ( lefts ) +import qualified Data.Set as Set +import qualified Data.Map as Map +import Distribution.Text + ( display ) +import Text.PrettyPrint + +------------------------------------------------------------------------------ +-- Pipeline +------------------------------------------------------------------------------ + +configureComponentLocalBuildInfos + :: Verbosity + -> Bool -- use_external_internal_deps + -> ComponentRequestedSpec + -> Flag String -- configIPID + -> Flag ComponentId -- configCID + -> PackageDescription + -> [PreExistingComponent] + -> FlagAssignment -- configConfigurationsFlags + -> [(ModuleName, Module)] -- configInstantiateWith + -> InstalledPackageIndex + -> Compiler + -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) +configureComponentLocalBuildInfos + verbosity use_external_internal_deps enabled ipid_flag cid_flag pkg_descr + prePkgDeps flagAssignment instantiate_with installedPackageSet comp = do + -- NB: In single component mode, this returns a *single* component. + -- In this graph, the graph is NOT closed. + graph0 <- case toComponentsGraph enabled pkg_descr of + Left ccycle -> failProgress (componentCycleMsg ccycle) + Right comps -> return comps + infoProgress $ hang (text "Source component graph:") 4 + (dispComponentsGraph graph0) + + let conf_pkg_map = Map.fromList + [(pc_pkgname pkg, (pc_cid pkg, pc_pkgid pkg)) + | pkg <- prePkgDeps] + graph1 = toConfiguredComponents use_external_internal_deps + flagAssignment + ipid_flag cid_flag pkg_descr + conf_pkg_map (map fst graph0) + infoProgress $ hang (text "Configured component graph:") 4 + (vcat (map dispConfiguredComponent graph1)) + + let shape_pkg_map = Map.fromList + [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg)) + | pkg <- prePkgDeps] + uid_lookup def_uid + | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid + = FullUnitId (Installed.installedComponentId pkg) + (Map.fromList (Installed.instantiatedWith pkg)) + | otherwise = error ("uid_lookup: " ++ display uid) + where uid = unDefUnitId def_uid + graph2 <- toLinkedComponents verbosity uid_lookup + (package pkg_descr) shape_pkg_map graph1 + + infoProgress $ + hang (text "Linked component graph:") 4 + (vcat (map dispLinkedComponent graph2)) + + let pid_map = Map.fromList $ + [ (pc_cid pkg, pc_pkgid pkg) + | pkg <- prePkgDeps] ++ + [ (Installed.installedComponentId pkg, Installed.sourcePackageId pkg) + | (_, Module uid _) <- instantiate_with + , Just pkg <- [PackageIndex.lookupUnitId + installedPackageSet (unDefUnitId uid)] ] ++ + [ (lc_cid lc, lc_pkgid lc) + | lc <- graph2 ] + subst = Map.fromList instantiate_with + graph3 = toReadyComponents pid_map subst graph2 + graph4 = Graph.revTopSort (Graph.fromList graph3) + + infoProgress $ hang (text "Ready component graph:") 4 + (vcat (map dispReadyComponent graph4)) + + toComponentLocalBuildInfos comp installedPackageSet pkg_descr prePkgDeps graph4 + +------------------------------------------------------------------------------ +-- ComponentLocalBuildInfo +------------------------------------------------------------------------------ + +toComponentLocalBuildInfos + :: Compiler + -> InstalledPackageIndex -- FULL set + -> PackageDescription + -> [PreExistingComponent] -- external package deps + -> [ReadyComponent] + -> LogProgress ([ComponentLocalBuildInfo], + InstalledPackageIndex) -- only relevant packages +toComponentLocalBuildInfos + comp installedPackageSet pkg_descr externalPkgDeps graph = do + -- Check and make sure that every instantiated component exists. + -- We have to do this now, because prior to linking/instantiating + -- we don't actually know what the full set of 'UnitId's we need + -- are. + let -- TODO: This is actually a bit questionable performance-wise, + -- since we will pay for the ALL installed packages even if + -- they are not related to what we are building. This was true + -- in the old configure code. + external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + external_graph = Graph.fromList + . map Left + $ PackageIndex.allPackages installedPackageSet + internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + internal_graph = Graph.fromList + . map Right + $ graph + combined_graph = Graph.unionRight external_graph internal_graph + Just local_graph = Graph.closure combined_graph (map nodeKey graph) + -- The database of transitively reachable installed packages that the + -- external components the package (as a whole) depends on. This will be + -- used in several ways: + -- + -- * We'll use it to do a consistency check so we're not depending + -- on multiple versions of the same package (TODO: someday relax + -- this for private dependencies.) See right below. + -- + -- * We'll pass it on in the LocalBuildInfo, where preprocessors + -- and other things will incorrectly use it to determine what + -- the include paths and everything should be. + -- + packageDependsIndex = PackageIndex.fromList (lefts local_graph) + fullIndex = Graph.fromList local_graph + case Graph.broken fullIndex of + [] -> return () + broken -> + -- TODO: ppr this + failProgress . text $ + "The following packages are broken because other" + ++ " packages they depend on are missing. These broken " + ++ "packages must be rebuilt before they can be used.\n" + -- TODO: Undupe. + ++ unlines [ "installed package " + ++ display (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map display deps) + | (Left pkg, deps) <- broken ] + ++ unlines [ "planned package " + ++ display (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map display deps) + | (Right pkg, deps) <- broken ] + + -- In this section, we'd like to look at the 'packageDependsIndex' + -- and see if we've picked multiple versions of the same + -- installed package (this is bad, because it means you might + -- get an error could not match foo-0.1:Type with foo-0.2:Type). + -- + -- What is pseudoTopPkg for? I have no idea. It was used + -- in the very original commit which introduced checking for + -- inconsistencies 5115bb2be4e13841ea07dc9166b9d9afa5f0d012, + -- and then moved out of PackageIndex and put here later. + -- TODO: Try this code without it... + -- + -- 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 . text $ + "This package indirectly depends on multiple versions of the same " + ++ "package. This is highly likely to cause a compile failure.\n" + ++ unlines [ "package " ++ display pkg ++ " requires " + ++ display (PackageIdentifier name ver) + | (name, uses) <- inconsistencies + , (pkg, ver) <- uses ] + let clbis = mkLinkedComponentsLocalBuildInfo comp graph + -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps) + return (clbis, packageDependsIndex) + +-- Build ComponentLocalBuildInfo for each component we are going +-- to build. +-- +-- This conversion is lossy; we lose some invariants from ReadyComponent +mkLinkedComponentsLocalBuildInfo + :: Compiler + -> [ReadyComponent] + -> [ComponentLocalBuildInfo] +mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs + where + internalUnits = Set.fromList (map rc_uid rcs) + isInternal x = Set.member x internalUnits + go rc = + case rc_component rc of + CLib _ -> + let convModuleExport (modname', (Module uid modname)) + | this_uid == unDefUnitId uid + , modname' == modname + = Installed.ExposedModule modname' Nothing + | otherwise + = Installed.ExposedModule modname' + (Just (OpenModule (DefiniteUnitId uid) modname)) + convOpenModuleExport (modname', modu@(OpenModule uid modname)) + -- TODO: This isn't a good enough test if we have mutual + -- recursion (but maybe we'll get saved by the module name + -- check regardless.) + | openUnitIdComponentId uid == this_cid + , modname' == modname + = Installed.ExposedModule modname' Nothing + | otherwise + = Installed.ExposedModule modname' (Just modu) + convOpenModuleExport (_, OpenModuleVar _) + = error "convOpenModuleExport: top-level modvar" + exports = + -- Loses invariants + case rc_i rc of + Left indefc -> map convOpenModuleExport + $ Map.toList (indefc_provides indefc) + Right instc -> map convModuleExport + $ Map.toList (instc_provides instc) + insts = + case rc_i rc of + Left indefc -> [ (m, OpenModuleVar m) | m <- indefc_requires indefc ] + Right instc -> [ (m, OpenModule (DefiniteUnitId uid') m') + | (m, Module uid' m') <- instc_insts instc ] + in LibComponentLocalBuildInfo { + componentPackageDeps = cpds, + componentUnitId = this_uid, + componentInstantiatedWith = insts, + componentIsIndefinite_ = is_indefinite, + componentLocalName = cname, + componentInternalDeps = internal_deps, + componentExeDeps = map unDefUnitId (rc_internal_build_tools rc), + componentIncludes = includes, + componentExposedModules = exports, + componentIsPublic = rc_public rc, + componentCompatPackageKey = rc_compat_key rc comp, + componentCompatPackageName = rc_compat_name rc + } + CExe _ -> + ExeComponentLocalBuildInfo { + componentUnitId = this_uid, + componentLocalName = cname, + componentPackageDeps = cpds, + componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc, + componentInternalDeps = internal_deps, + componentIncludes = includes + } + CTest _ -> + TestComponentLocalBuildInfo { + componentUnitId = this_uid, + componentLocalName = cname, + componentPackageDeps = cpds, + componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc, + componentInternalDeps = internal_deps, + componentIncludes = includes + } + CBench _ -> + BenchComponentLocalBuildInfo { + componentUnitId = this_uid, + componentLocalName = cname, + componentPackageDeps = cpds, + componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc, + componentInternalDeps = internal_deps, + componentIncludes = includes + } + where + this_uid = rc_uid rc + this_cid = unitIdComponentId this_uid + cname = componentName (rc_component rc) + cpds = rc_depends rc + is_indefinite = + case rc_i rc of + Left _ -> True + Right _ -> False + includes = + case rc_i rc of + Left indefc -> + indefc_includes indefc + Right instc -> + map (\(x,y) -> (DefiniteUnitId x,y)) (instc_includes instc) + internal_deps = + filter isInternal (nodeNeighbors rc) + ++ map unDefUnitId (rc_internal_build_tools rc) + + diff --git a/Cabal/Distribution/Backpack/ConfiguredComponent.hs b/Cabal/Distribution/Backpack/ConfiguredComponent.hs new file mode 100644 index 00000000000..184b8bba249 --- /dev/null +++ b/Cabal/Distribution/Backpack/ConfiguredComponent.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE PatternGuards #-} +-- | See +module Distribution.Backpack.ConfiguredComponent ( + ConfiguredComponent(..), + toConfiguredComponent, + toConfiguredComponents, + dispConfiguredComponent, + + ConfiguredComponentMap, + extendConfiguredComponentMap, + + -- TODO: Should go somewhere else + newPackageDepsBehaviour +) where + +import Prelude () +import Distribution.Compat.Prelude hiding ((<>)) + +import Distribution.Backpack.Id + +import Distribution.Types.IncludeRenaming +import Distribution.Package +import Distribution.PackageDescription as PD hiding (Flag) +import Distribution.Simple.Setup as Setup +import Distribution.Simple.LocalBuildInfo +import Distribution.Version + +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Traversable + ( mapAccumL ) +import Distribution.Text +import Text.PrettyPrint + +-- | A configured component, we know exactly what its 'ComponentId' is, +-- and the 'ComponentId's of the things it depends on. +data ConfiguredComponent + = ConfiguredComponent { + cc_cid :: ComponentId, + -- The package this component came from. + cc_pkgid :: PackageId, + cc_component :: Component, + cc_public :: Bool, + -- ^ Is this the public library component of the package? + -- (THIS is what the hole instantiation applies to.) + -- Note that in one-component configure mode, this is + -- always True, because any component is the "public" one.) + cc_internal_build_tools :: [ComponentId], + -- Not resolved yet; component configuration only looks at ComponentIds. + cc_includes :: [(ComponentId, PackageId, IncludeRenaming)] + } + +cc_name :: ConfiguredComponent -> ComponentName +cc_name = componentName . cc_component + +dispConfiguredComponent :: ConfiguredComponent -> Doc +dispConfiguredComponent cc = + hang (text "component" <+> disp (cc_cid cc)) 4 + (vcat [ hsep $ [ text "include", disp cid, disp incl_rn ] + | (cid, _, incl_rn) <- cc_includes cc + ]) + + +-- | Construct a 'ConfiguredComponent', given that the 'ComponentId' +-- and library/executable dependencies are known. The primary +-- work this does is handling implicit @backpack-include@ fields. +mkConfiguredComponent + :: PackageId + -> ComponentId + -> [(PackageName, (ComponentId, PackageId))] + -> [ComponentId] + -> Component + -> ConfiguredComponent +mkConfiguredComponent this_pid this_cid lib_deps exe_deps component = + ConfiguredComponent { + cc_cid = this_cid, + cc_pkgid = this_pid, + cc_component = component, + cc_public = is_public, + cc_internal_build_tools = exe_deps, + cc_includes = explicit_includes ++ implicit_includes + } + where + bi = componentBuildInfo component + deps = map snd lib_deps + deps_map = Map.fromList lib_deps + + -- Resolve each @backpack-include@ into the actual dependency + -- from @lib_deps@. + explicit_includes + = [ (cid, pid { pkgName = name }, rns) + | (name, rns) <- backpackIncludes bi + , Just (cid, pid) <- [Map.lookup name deps_map] ] + + -- Any @build-depends@ which is not explicitly mentioned in + -- @backpack-include@ is converted into an "implicit" include. + used_explicitly = Set.fromList (map (\(cid,_,_) -> cid) explicit_includes) + implicit_includes + = map (\(cid, pid) -> (cid, pid, defaultIncludeRenaming)) + $ filter (flip Set.notMember used_explicitly . fst) deps + + is_public = componentName component == CLibName + +type ConfiguredComponentMap = + (Map PackageName (ComponentId, PackageId), -- libraries + Map String ComponentId) -- executables + +-- Executable map must be different because an executable can +-- have the same name as a library. Ew. + +-- | Given some ambient environment of package names that +-- are "in scope", looks at the 'BuildInfo' to decide +-- what the packages actually resolve to, and then builds +-- a 'ConfiguredComponent'. +toConfiguredComponent + :: PackageDescription + -> ComponentId + -> Map PackageName (ComponentId, PackageId) -- external + -> ConfiguredComponentMap + -> Component + -> ConfiguredComponent +toConfiguredComponent pkg_descr this_cid + external_lib_map (lib_map, exe_map) component = + mkConfiguredComponent + (package pkg_descr) this_cid + lib_deps exe_deps component + where + bi = componentBuildInfo component + find_it :: PackageName -> VersionRange -> (ComponentId, PackageId) + find_it name reqVer = + fromMaybe (error ("toConfiguredComponent: " ++ display name)) $ + lookup_name lib_map <|> + lookup_name external_lib_map + where + lookup_name m = + case Map.lookup name m of + Just (cid, pkgid) + | packageVersion pkgid `withinRange` reqVer + -> Just (cid, pkgid) + _ -> Nothing + lib_deps + | newPackageDepsBehaviour pkg_descr + = [ (name, find_it name reqVer) + | Dependency name reqVer <- targetBuildDepends bi ] + | otherwise + = Map.toList external_lib_map + exe_deps = [ cid + | Dependency pkgname _ <- buildTools bi + , let name = unPackageName pkgname + , Just cid <- [ Map.lookup name exe_map ] ] + +-- | Also computes the 'ComponentId', and sets cc_public if necessary. +-- This is Cabal-only; cabal-install won't use this. +toConfiguredComponent' + :: Bool -- use_external_internal_deps + -> FlagAssignment + -> PackageDescription + -> Flag String -- configIPID (todo: remove me) + -> Flag ComponentId -- configCID + -> Map PackageName (ComponentId, PackageId) -- external + -> ConfiguredComponentMap + -> Component + -> ConfiguredComponent +toConfiguredComponent' use_external_internal_deps flags + pkg_descr ipid_flag cid_flag + external_lib_map (lib_map, exe_map) component = + let cc = toConfiguredComponent + pkg_descr this_cid + external_lib_map (lib_map, exe_map) component + in if use_external_internal_deps + then cc { cc_public = True } + else cc + where + this_cid = computeComponentId ipid_flag cid_flag (package pkg_descr) + (componentName component) (Just (deps, flags)) + deps = [ cid | (cid, _) <- Map.elems external_lib_map ] + +extendConfiguredComponentMap + :: ConfiguredComponent + -> ConfiguredComponentMap + -> ConfiguredComponentMap +extendConfiguredComponentMap cc (lib_map, exe_map) = + (lib_map', exe_map') + where + lib_map' + = case cc_name cc of + CLibName -> + Map.insert (pkgName (cc_pkgid cc)) + (cc_cid cc, cc_pkgid cc) lib_map + CSubLibName str -> + Map.insert (mkPackageName str) + (cc_cid cc, cc_pkgid cc) lib_map + _ -> lib_map + exe_map' + = case cc_name cc of + CExeName str -> + Map.insert str (cc_cid cc) exe_map + _ -> exe_map + +-- Compute the 'ComponentId's for a graph of 'Component's. The +-- list of internal components must be topologically sorted +-- based on internal package dependencies, so that any internal +-- dependency points to an entry earlier in the list. +toConfiguredComponents + :: Bool -- use_external_internal_deps + -> FlagAssignment + -> Flag String -- configIPID + -> Flag ComponentId -- configCID + -> PackageDescription + -> Map PackageName (ComponentId, PackageId) + -> [Component] + -> [ConfiguredComponent] +toConfiguredComponents + use_external_internal_deps flags ipid_flag cid_flag pkg_descr + external_lib_map comps + = snd (mapAccumL go (Map.empty, Map.empty) comps) + where + go m component = (extendConfiguredComponentMap cc m, cc) + where cc = toConfiguredComponent' + use_external_internal_deps flags pkg_descr ipid_flag cid_flag + external_lib_map m component + + +newPackageDepsBehaviourMinVersion :: Version +newPackageDepsBehaviourMinVersion = mkVersion [1,7,1] + + +-- In older cabal versions, there was only one set of package dependencies for +-- the whole package. In this version, we can have separate dependencies per +-- target, but we only enable this behaviour if the minimum cabal version +-- specified is >= a certain minimum. Otherwise, for compatibility we use the +-- old behaviour. +newPackageDepsBehaviour :: PackageDescription -> Bool +newPackageDepsBehaviour pkg = + specVersion pkg >= newPackageDepsBehaviourMinVersion diff --git a/Cabal/Distribution/Backpack/FullUnitId.hs b/Cabal/Distribution/Backpack/FullUnitId.hs new file mode 100644 index 00000000000..cb5e3bf2364 --- /dev/null +++ b/Cabal/Distribution/Backpack/FullUnitId.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Backpack.FullUnitId ( + FullUnitId(..), + FullDb, + expandOpenUnitId, + expandUnitId +) where + +import Distribution.Backpack +import Distribution.Package +import Distribution.Compat.Prelude + +-- Unlike OpenUnitId, which could direct to a UnitId. +data FullUnitId = FullUnitId ComponentId OpenModuleSubst + deriving (Show, Generic) + +type FullDb = DefUnitId -> FullUnitId + +expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId +expandOpenUnitId _db (IndefFullUnitId cid subst) + = FullUnitId cid subst +expandOpenUnitId db (DefiniteUnitId uid) + = expandUnitId db uid + +expandUnitId :: FullDb -> DefUnitId -> FullUnitId +expandUnitId db uid = db uid diff --git a/Cabal/Distribution/Backpack/Id.hs b/Cabal/Distribution/Backpack/Id.hs new file mode 100644 index 00000000000..523433cf634 --- /dev/null +++ b/Cabal/Distribution/Backpack/Id.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternGuards #-} +-- | See +module Distribution.Backpack.Id( + computeComponentId, + computeCompatPackageKey, + computeCompatPackageName, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Package +import Distribution.PackageDescription as PD hiding (Flag) +import Distribution.Simple.Setup as Setup +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.LocalBuildInfo +import Distribution.Utils.Base62 +import Distribution.Version + +import Distribution.Text + ( display, simpleParse ) + +-- | This method computes a default, "good enough" 'ComponentId' +-- for a package. The intent is that cabal-install (or the user) will +-- specify a more detailed IPID via the @--ipid@ flag if necessary. +computeComponentId + :: Flag String + -> Flag ComponentId + -> PackageIdentifier + -> ComponentName + -- This is used by cabal-install's legacy codepath + -> Maybe ([ComponentId], FlagAssignment) + -> ComponentId +computeComponentId mb_ipid mb_cid pid cname mb_details = + -- show is found to be faster than intercalate and then replacement of + -- special character used in intercalating. We cannot simply hash by + -- doubly concating list, as it just flatten out the nested list, so + -- different sources can produce same hash + let hash_suffix + | Just (dep_ipids, flags) <- mb_details + = "-" ++ hashToBase62 + -- For safety, include the package + version here + -- for GHC 7.10, where just the hash is used as + -- the package key + ( display pid + ++ show dep_ipids + ++ show flags ) + | otherwise = "" + generated_base = display pid ++ hash_suffix + explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env + (toPathTemplate cid0)) + -- Hack to reuse install dirs machinery + -- NB: no real IPID available at this point + where env = packageTemplateEnv pid (mkUnitId "") + actual_base = case mb_ipid of + Flag ipid0 -> explicit_base ipid0 + NoFlag -> generated_base + in case mb_cid of + Flag cid -> cid + NoFlag -> mkComponentId $ actual_base + ++ (case componentNameString cname of + Nothing -> "" + Just s -> "-" ++ s) + +-- | Computes the package name for a library. If this is the public +-- library, it will just be the original package name; otherwise, +-- it will be a munged package name recording the original package +-- name as well as the name of the internal library. +-- +-- A lot of tooling in the Haskell ecosystem assumes that if something +-- is installed to the package database with the package name 'foo', +-- then it actually is an entry for the (only public) library in package +-- 'foo'. With internal packages, this is not necessarily true: +-- a public library as well as arbitrarily many internal libraries may +-- come from the same package. To prevent tools from getting confused +-- in this case, the package name of these internal libraries is munged +-- so that they do not conflict the public library proper. A particular +-- case where this matters is ghc-pkg: if we don't munge the package +-- name, the inplace registration will OVERRIDE a different internal +-- library. +-- +-- We munge into a reserved namespace, "z-", and encode both the +-- component name and the package name of an internal library using the +-- following format: +-- +-- compat-pkg-name ::= "z-" package-name "-z-" library-name +-- +-- where package-name and library-name have "-" ( "z" + ) "-" +-- segments encoded by adding an extra "z". +-- +-- When we have the public library, the compat-pkg-name is just the +-- package-name, no surprises there! +-- +computeCompatPackageName :: PackageName -> ComponentName -> Maybe UnitId -> PackageName +-- First handle the cases where we can just use the original 'PackageName'. +-- This is for the PRIMARY library, and it is non-Backpack, or the +-- indefinite package for us. +computeCompatPackageName pkg_name CLibName Nothing = pkg_name +computeCompatPackageName pkg_name CLibName (Just (UnitId _ Nothing)) + = pkg_name +-- OK, we have to z-encode +computeCompatPackageName pkg_name cname mb_uid + = mkPackageName $ "z-" ++ zdashcode (display pkg_name) + ++ (case componentNameString cname of + Just cname_str -> "-z-" ++ zdashcode cname_str + Nothing -> "") + ++ (case mb_uid of + Just (UnitId _ (Just hash)) + -> "-z-" ++ hash + _ -> "") + +zdashcode :: String -> String +zdashcode s = go s (Nothing :: Maybe Int) [] + where go [] _ r = reverse r + go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r) + go ('-':z) _ r = go z (Just 0) ('-':r) + go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r) + go (c:z) _ r = go z Nothing (c:r) + +-- | In GHC 8.0, the string we pass to GHC to use for symbol +-- names for a package can be an arbitrary, IPID-compatible string. +-- However, prior to GHC 8.0 there are some restrictions on what +-- format this string can be (due to how ghc-pkg parsed the key): +-- +-- 1. In GHC 7.10, the string had either be of the form +-- foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated +-- prefix and ABCD is two base-64 encoded 64-bit integers, +-- or a GHC 7.8 style identifier. +-- +-- 2. In GHC 7.8, the string had to be a valid package identifier +-- like foo-0.1. +-- +-- So, the problem is that Cabal, in general, has a general IPID, +-- but needs to figure out a package key / package ID that the +-- old ghc-pkg will actually accept. But there's an EVERY WORSE +-- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx +-- as if it were a package identifier, which means it will SILENTLY +-- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.) +-- So we must CONNIVE to ensure that we don't pick something that +-- looks like this. +-- +-- So this function attempts to define a mapping into the old formats. +-- +-- The mapping for GHC 7.8 and before: +-- +-- * We use the *compatibility* package name and version. For +-- public libraries this is just the package identifier; for +-- internal libraries, it's something like "z-pkgname-z-libname-0.1". +-- See 'computeCompatPackageName' for more details. +-- +-- The mapping for GHC 7.10: +-- +-- * For CLibName: +-- If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would +-- validly parse as a package key, we pass "ABCDEF". (NB: not +-- all hashes parse this way, because GHC 7.10 mandated that +-- these hashes be two base-62 encoded 64 bit integers), +-- but hashes that Cabal generated using 'computeComponentId' +-- are guaranteed to have this form. +-- +-- If it is not of this form, we rehash the IPID into the +-- correct form and pass that. +-- +-- * For sub-components, we rehash the IPID into the correct format +-- and pass that. +-- +computeCompatPackageKey + :: Compiler + -> PackageName + -> Version + -> UnitId + -> String +computeCompatPackageKey comp pkg_name pkg_version (UnitId cid Nothing) + | not (packageKeySupported comp) = + display pkg_name ++ "-" ++ display pkg_version + | not (unifiedIPIDRequired comp) = + let str = unComponentId cid + mb_verbatim_key + = case simpleParse str :: Maybe PackageId of + -- Something like 'foo-0.1', use it verbatim. + -- (NB: hash tags look like tags, so they are parsed, + -- so the extra equality check tests if a tag was dropped.) + Just pid0 | display pid0 == str -> Just str + _ -> Nothing + mb_truncated_key + = let cand = reverse (takeWhile isAlphaNum (reverse str)) + in if length cand == 22 && all isAlphaNum cand + then Just cand + else Nothing + rehashed_key = hashToBase62 str + in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key) + | otherwise = unComponentId cid +computeCompatPackageKey _comp _pkg_name _pkg_version uid@UnitId{} + = display uid diff --git a/Cabal/Distribution/Backpack/LinkedComponent.hs b/Cabal/Distribution/Backpack/LinkedComponent.hs new file mode 100644 index 00000000000..214da2c2ae3 --- /dev/null +++ b/Cabal/Distribution/Backpack/LinkedComponent.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | See +module Distribution.Backpack.LinkedComponent ( + LinkedComponent(..), + lc_cid, + toLinkedComponent, + toLinkedComponents, + dispLinkedComponent, + LinkedComponentMap, + extendLinkedComponentMap, +) where + +import Prelude () +import Distribution.Compat.Prelude hiding ((<>)) + +import Distribution.Backpack +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.ModSubst +import Distribution.Backpack.ModuleShape +import Distribution.Backpack.ModuleScope +import Distribution.Backpack.UnifyM +import Distribution.Backpack.MixLink +import Distribution.Utils.MapAccum + +import Distribution.Types.ModuleRenaming +import Distribution.Types.IncludeRenaming +import Distribution.Package +import Distribution.PackageDescription as PD hiding (Flag) +import Distribution.ModuleName +import Distribution.Simple.LocalBuildInfo +import Distribution.Verbosity +import Distribution.Utils.Progress +import Distribution.Utils.LogProgress + +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Traversable + ( mapM ) +import Distribution.Text + ( Text(disp) ) +import Text.PrettyPrint + +-- | A linked component, we know how it is instantiated and thus how we are +-- going to build it. +data LinkedComponent + = LinkedComponent { + lc_uid :: OpenUnitId, + lc_pkgid :: PackageId, + lc_insts :: [(ModuleName, OpenModule)], + lc_component :: Component, + lc_shape :: ModuleShape, + -- | Local buildTools dependencies + lc_internal_build_tools :: [OpenUnitId], + lc_public :: Bool, + lc_includes :: [(OpenUnitId, ModuleRenaming)], + -- PackageId here is a bit dodgy, but its just for + -- BC so it shouldn't matter. + lc_depends :: [(OpenUnitId, PackageId)] + } + +lc_cid :: LinkedComponent -> ComponentId +lc_cid = openUnitIdComponentId . lc_uid + +dispLinkedComponent :: LinkedComponent -> Doc +dispLinkedComponent lc = + hang (text "unit" <+> disp (lc_uid lc)) 4 $ + vcat [ text "include" <+> disp uid <+> disp prov_rn + | (uid, prov_rn) <- lc_includes lc ] + -- YARRR $+$ dispModSubst (modShapeProvides (lc_shape lc)) + +instance Package LinkedComponent where + packageId = lc_pkgid + +instance ModSubst LinkedComponent where + modSubst subst lc + = lc { + lc_uid = modSubst subst (lc_uid lc), + lc_insts = modSubst subst (lc_insts lc), + lc_shape = modSubst subst (lc_shape lc), + lc_includes = map (\(uid, rns) -> (modSubst subst uid, rns)) (lc_includes lc), + lc_depends = map (\(uid, pkgid) -> (modSubst subst uid, pkgid)) (lc_depends lc) + } + +{- +instance IsNode LinkedComponent where + type Key LinkedComponent = UnitId + nodeKey = lc_uid + nodeNeighbors n = + if Set.null (openUnitIdFreeHoles (lc_uid n)) + then map fst (lc_depends n) + else ordNub (map (generalizeUnitId . fst) (lc_depends n)) +-} + +-- We can't cache these values because they need to be changed +-- when we substitute over a 'LinkedComponent'. By varying +-- these over 'UnitId', we can support old GHCs. Nice! + +toLinkedComponent + :: Verbosity + -> FullDb + -> PackageId + -> LinkedComponentMap + -> ConfiguredComponent + -> LogProgress LinkedComponent +toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { + cc_cid = this_cid, + cc_pkgid = pkgid, + cc_component = component, + cc_internal_build_tools = btools, + cc_public = is_public, + cc_includes = cid_includes + } = do + let + -- The explicitly specified requirements, provisions and + -- reexports from the Cabal file. These are only non-empty for + -- libraries; everything else is trivial. + (src_reqs :: [ModuleName], + src_provs :: [ModuleName], + src_reexports :: [ModuleReexport]) = + case component of + CLib lib -> (signatures lib, + exposedModules lib, + reexportedModules lib) + _ -> ([], [], []) + + -- Take each included ComponentId and resolve it into an + -- *unlinked* unit identity. We will use unification (relying + -- on the ModuleShape) to resolve these into linked identities. + unlinked_includes :: [((OpenUnitId, ModuleShape), PackageId, IncludeRenaming)] + unlinked_includes = [ (lookupUid cid, pid, rns) + | (cid, pid, rns) <- cid_includes ] + + lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) + lookupUid cid = fromMaybe (error "linkComponent: lookupUid") + (Map.lookup cid pkg_map) + + let orErr (Right x) = return x + orErr (Left err) = failProgress (text err) + + -- OK, actually do unification + -- TODO: the unification monad might return errors, in which + -- case we have to deal. Use monadic bind for now. + (linked_shape0 :: ModuleScope, + linked_deps :: [(OpenUnitId, PackageId)], + linked_includes :: [(OpenUnitId, ModuleRenaming)]) <- orErr $ runUnifyM verbosity db $ do + -- The unification monad is implemented using mutable + -- references. Thus, we must convert our *pure* data + -- structures into mutable ones to perform unification. + -- + let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s) + convertReq req = do + req_u <- convertModule (OpenModuleVar req) + return (Map.empty, Map.singleton req req_u) + -- NB: We DON'T convert locally defined modules, as in the + -- absence of mutual recursion across packages they + -- cannot participate in mix-in linking. + (shapes_u, includes_u) <- fmap unzip (mapM convertInclude unlinked_includes) + src_reqs_u <- mapM convertReq src_reqs + -- Mix-in link everything! mixLink is the real workhorse. + shape_u <- foldM mixLink emptyModuleScopeU (shapes_u ++ src_reqs_u) + -- Read out all the final results by converting back + -- into a pure representation. + let convertIncludeU (uid_u, pid, rns) = do + uid <- convertUnitIdU uid_u + return ((uid, rns), (uid, pid)) + shape <- convertModuleScopeU shape_u + includes_deps <- mapM convertIncludeU includes_u + let (incls, deps) = unzip includes_deps + return (shape, deps, incls) + + -- linked_shape0 is almost complete, but it doesn't contain + -- the actual modules we export ourselves. Add them! + let reqs = modScopeRequires linked_shape0 + -- check that there aren't pre-filled requirements... + insts = [ (req, OpenModuleVar req) + | req <- Set.toList reqs ] + this_uid = IndefFullUnitId this_cid . Map.fromList $ insts + + -- add the local exports to the scope + local_exports = Map.fromListWith (++) $ + [ (mod_name, [ModuleSource (packageName this_pid) + defaultIncludeRenaming + (OpenModule this_uid mod_name)]) + | mod_name <- src_provs ] + -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg + -- won't allow it (since someone could directly synthesize + -- an 'InstalledPackageInfo' that violates abstraction.) + -- Though, maybe it should be relaxed? + linked_shape = linked_shape0 { + modScopeProvides = + Map.unionWith (++) + local_exports + (modScopeProvides linked_shape0) + } + + -- OK, compute the reexports + -- TODO: This code reports the errors for reexports one reexport at + -- a time. Better to collect them all up and report them all at + -- once. + reexports_list <- for src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do + let err :: Doc -> LogProgress a + err s = failProgress + $ hang (text "Problem with module re-export" <> quotes (disp reex) + <+> colon) 2 s + case Map.lookup from (modScopeProvides linked_shape) of + Just cands@(x0:xs0) -> do + -- Make sure there is at least one candidate + (x, xs) <- + case mb_pn of + Just pn -> + case filter ((pn==) . msrc_pkgname) cands of + (x1:xs1) -> return (x1, xs1) + _ -> err (brokenReexportMsg reex) + Nothing -> return (x0, xs0) + -- Test that all the candidates are consistent + case filter (\x' -> msrc_module x /= msrc_module x') xs of + [] -> return () + _ -> err $ ambiguousReexportMsg reex (x:xs) + return (to, msrc_module x) + _ -> + err (brokenReexportMsg reex) + + -- TODO: maybe check this earlier; it's syntactically obvious. + let build_reexports m (k, v) + | Map.member k m = + failProgress $ hsep + [ text "Module name ", disp k, text " is exported multiple times." ] + | otherwise = return (Map.insert k v m) + provs <- foldM build_reexports Map.empty $ + -- TODO: doublecheck we have checked for + -- src_provs duplicates already! + [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++ + reexports_list + + let final_linked_shape = ModuleShape provs (modScopeRequires linked_shape) + + return $ LinkedComponent { + lc_uid = this_uid, + lc_insts = insts, + lc_pkgid = pkgid, + lc_component = component, + lc_public = is_public, + -- These must be executables + lc_internal_build_tools = map (\cid -> IndefFullUnitId cid Map.empty) btools, + lc_shape = final_linked_shape, + lc_includes = linked_includes, + lc_depends = linked_deps + } + +-- Handle mix-in linking for components. In the absence of Backpack, +-- every ComponentId gets converted into a UnitId by way of SimpleUnitId. +toLinkedComponents + :: Verbosity + -> FullDb + -> PackageId + -> LinkedComponentMap + -> [ConfiguredComponent] + -> LogProgress [LinkedComponent] +toLinkedComponents verbosity db this_pid lc_map0 comps + = fmap snd (mapAccumM go lc_map0 comps) + where + go :: Map ComponentId (OpenUnitId, ModuleShape) + -> ConfiguredComponent + -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) + go lc_map cc = do + lc <- toLinkedComponent verbosity db this_pid lc_map cc + return (extendLinkedComponentMap lc lc_map, lc) + +type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) + +extendLinkedComponentMap :: LinkedComponent + -> LinkedComponentMap + -> LinkedComponentMap +extendLinkedComponentMap lc m = + Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m + +brokenReexportMsg :: ModuleReexport -> Doc +brokenReexportMsg (ModuleReexport (Just pn) from _to) = + text "The package" <+> disp pn <+> + text "does not export a module" <+> disp from +brokenReexportMsg (ModuleReexport Nothing from _to) = + text "The module" <+> disp from <+> + text "is not exported by any suitable package." <+> + text "It occurs in neither the 'exposed-modules' of this package," <+> + text "nor any of its 'build-depends' dependencies." + +ambiguousReexportMsg :: ModuleReexport -> [ModuleSource] -> Doc +ambiguousReexportMsg (ModuleReexport mb_pn from _to) ys = + text "The module" <+> disp from <+> + text "is (differently) exported by more than one package" <+> + parens (hsep (punctuate comma [displaySource y | y <- ys])) <+> + text "making the re-export ambiguous." <+> help_msg mb_pn + where + help_msg Nothing = + text "The ambiguity can be resolved by qualifying the" <+> + text "re-export with a package name." <+> + text "The syntax is 'packagename:ModuleName [as NewName]'." + -- Qualifying won't help that much. + help_msg (Just _) = + text "The ambiguity can be resolved by introducing a" <+> + text "backpack-include field to rename one of the module" <+> + text "names differently." + displaySource y + | not (isDefaultIncludeRenaming (msrc_renaming y)) + = disp (msrc_pkgname y) <+> text "with renaming" <+> + disp (includeProvidesRn (msrc_renaming y)) + | otherwise = disp (msrc_pkgname y) diff --git a/Cabal/Distribution/Backpack/MixLink.hs b/Cabal/Distribution/Backpack/MixLink.hs new file mode 100644 index 00000000000..06e6352e48a --- /dev/null +++ b/Cabal/Distribution/Backpack/MixLink.hs @@ -0,0 +1,151 @@ +-- | See +module Distribution.Backpack.MixLink ( + mixLink, +) where + +import Prelude () +import Distribution.Compat.Prelude hiding (mod) + +import Distribution.Backpack +import Distribution.Backpack.UnifyM +import Distribution.Backpack.FullUnitId + +import qualified Distribution.Utils.UnionFind as UnionFind +import Distribution.ModuleName +import Distribution.Text +import Distribution.Types.IncludeRenaming +import Distribution.Package + +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Foldable as F + +----------------------------------------------------------------------- +-- Linking + +-- | Given to scopes of provisions and requirements, link them together. +mixLink :: ModuleScopeU s -> ModuleScopeU s -> UnifyM s (ModuleScopeU s) +mixLink (provs1, reqs1) (provs2, reqs2) = do + F.sequenceA_ (Map.intersectionWithKey linkProvision provs1 reqs2) + F.sequenceA_ (Map.intersectionWithKey linkProvision provs2 reqs1) + -- TODO: would be more efficient to collapse provision lists when we + -- unify them. + return (Map.unionWith (++) provs1 provs2, + -- NB: NOT the difference of the unions. That implies + -- self-unification not allowed. (But maybe requirement prov is disjoint + -- from reqs makes this a moot point?) + Map.union (Map.difference reqs1 provs2) + (Map.difference reqs2 provs1)) + +displaySource :: ModuleSourceU s -> String +displaySource src + | isDefaultIncludeRenaming (usrc_renaming src) + = display (usrc_pkgname src) + | otherwise + = display (usrc_pkgname src) ++ " with renaming " ++ display (usrc_renaming src) + +-- | Link a list of possibly provided modules to a single +-- requirement. This applies a side-condition that all +-- of the provided modules at the same name are *actually* +-- the same module. +linkProvision :: ModuleName -> [ModuleSourceU s] -> ModuleU s + -> UnifyM s [ModuleSourceU s] +linkProvision _ [] _reqs = error "linkProvision" +linkProvision mod_name ret@(prov:provs) req = do + forM_ provs $ \prov' -> do + let msg = "Ambiguous module " ++ display mod_name ++ " " ++ + "when trying to fill requirement. It could refer to " ++ + "a module included from " ++ displaySource prov ++ " " ++ + "or module included from " ++ displaySource prov' ++ ". " ++ + "Ambiguity occurred because " + withContext msg (usrc_module prov) (usrc_module prov') $ + unifyModule (usrc_module prov) (usrc_module prov') + let msg = "Could not fill requirement " ++ display mod_name ++ "because " + withContext msg (usrc_module prov) req $ + unifyModule (usrc_module prov) req + return ret + + + +----------------------------------------------------------------------- +-- The unification algorithm + +-- This is based off of https://gist.github.com/amnn/559551517d020dbb6588 +-- which is a translation from Huet's thesis. + +unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s () +unifyUnitId uid1_u uid2_u + | uid1_u == uid2_u = return () + | otherwise = do + xuid1 <- liftST $ UnionFind.find uid1_u + xuid2 <- liftST $ UnionFind.find uid2_u + case (xuid1, xuid2) of + (UnitIdThunkU u1, UnitIdThunkU u2) + | u1 == u2 -> return () + | otherwise -> + unifyFail $ + "pre-installed unit IDs " ++ display u1 ++ + " and " ++ display u2 ++ " do not match." + (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) + -> unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u + (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) + -> unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u + (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) + -> unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u + +unifyThunkWith :: ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> DefUnitId + -> UnitIdU s + -> UnifyM s () +unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do + db <- fmap unify_db getUnifEnv + let FullUnitId cid2 insts2' = expandUnitId db uid2 + insts2 <- convertModuleSubst insts2' + unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u + +unifyInner :: ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> UnifyM s () +unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u = do + when (cid1 /= cid2) $ + -- TODO: if we had a package identifier, could be an + -- easier to understand error message. + unifyFail $ + "component IDs " ++ + display cid1 ++ " and " ++ display cid2 ++ " do not match." + -- The KEY STEP which makes this a Huet-style unification + -- algorithm. (Also a payoff of using union-find.) + -- We can build infinite unit IDs this way, which is necessary + -- for support mutual recursion. NB: union keeps the SECOND + -- descriptor, so we always arrange for a UnitIdThunkU to live + -- there. + liftST $ UnionFind.union uid1_u uid2_u + F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2 + +-- | Imperatively unify two modules. +unifyModule :: ModuleU s -> ModuleU s -> UnifyM s () +unifyModule mod1_u mod2_u + | mod1_u == mod2_u = return () + | otherwise = do + mod1 <- liftST $ UnionFind.find mod1_u + mod2 <- liftST $ UnionFind.find mod2_u + case (mod1, mod2) of + (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u + (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u + (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do + when (mod_name1 /= mod_name2) $ + unifyFail $ + "module names " ++ + display mod_name1 ++ " and " ++ + display mod_name2 ++ " disagree." + -- NB: this is not actually necessary (because we'll + -- detect loops eventually in 'unifyUnitId'), but it + -- seems harmless enough + liftST $ UnionFind.union mod1_u mod2_u + unifyUnitId uid1 uid2 diff --git a/Cabal/Distribution/Backpack/ModSubst.hs b/Cabal/Distribution/Backpack/ModSubst.hs new file mode 100644 index 00000000000..4f04ad30cdc --- /dev/null +++ b/Cabal/Distribution/Backpack/ModSubst.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} + +-- | A type class 'ModSubst' for objects which can have 'ModuleSubst' +-- applied to them. +-- +-- See also + +module Distribution.Backpack.ModSubst ( + ModSubst(..), +) where + +import Prelude () +import Distribution.Compat.Prelude hiding (mod) + +import Distribution.ModuleName + +import Distribution.Backpack + +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + +-- | Applying module substitutions to semantic objects. +class ModSubst a where + -- In notation, substitution is postfix, which implies + -- putting it on the right hand side, but for partial + -- application it's more convenient to have it on the left + -- hand side. + modSubst :: OpenModuleSubst -> a -> a + +instance ModSubst OpenModule where + modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name + modSubst subst mod@(OpenModuleVar mod_name) + | Just mod' <- Map.lookup mod_name subst = mod' + | otherwise = mod + +instance ModSubst OpenUnitId where + modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts) + modSubst _subst uid = uid + +instance ModSubst (Set ModuleName) where + modSubst subst reqs + = Set.union (Set.difference reqs (Map.keysSet subst)) + (openModuleSubstFreeHoles subst) + +-- Substitutions are functorial. NB: this means that +-- there is an @instance 'ModSubst' 'ModuleSubst'@! +instance ModSubst a => ModSubst (Map k a) where + modSubst subst = fmap (modSubst subst) +instance ModSubst a => ModSubst [a] where + modSubst subst = fmap (modSubst subst) +instance ModSubst a => ModSubst (k, a) where + modSubst subst (x,y) = (x, modSubst subst y) diff --git a/Cabal/Distribution/Backpack/ModuleScope.hs b/Cabal/Distribution/Backpack/ModuleScope.hs new file mode 100644 index 00000000000..f2477a7451c --- /dev/null +++ b/Cabal/Distribution/Backpack/ModuleScope.hs @@ -0,0 +1,86 @@ +-- | See +module Distribution.Backpack.ModuleScope ( + -- * Module scopes + ModuleScope(..), + ModuleProvides, + ModuleSource(..), + emptyModuleScope, +) where + +import Prelude () + +import Distribution.ModuleName +import Distribution.Package +import Distribution.Types.IncludeRenaming + +import Distribution.Backpack +import Distribution.Backpack.ModSubst + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + + +----------------------------------------------------------------------- +-- Module scopes + +-- Why is ModuleProvides so complicated? The basic problem is that +-- we want to support this: +-- +-- package p where +-- include q (A) +-- include r (A) +-- module B where +-- import "q" A +-- import "r" A +-- +-- Specifically, in Cabal today it is NOT an error have two modules in +-- scope with the same identifier. So we need to preserve this for +-- Backpack. The modification is that an ambiguous module name is +-- OK... as long as it is NOT used to fill a requirement! +-- +-- So as a first try, we might try deferring unifying provisions that +-- are being glommed together, and check for equality after the fact. +-- But this doesn't work, because what if a multi-module provision +-- is used to fill a requirement?! So you do the equality test +-- IMMEDIATELY before a requirement fill happens... or never at all. +-- +-- Alternate strategy: go ahead and unify, and then if it is revealed +-- that some requirements got filled "out-of-thin-air", error. + + +-- | A 'ModuleScope' describes the modules and requirements that +-- are in-scope as we are processing a Cabal package. Unlike +-- a 'ModuleShape', there may be multiple modules in scope at +-- the same 'ModuleName'; this is only an error if we attempt +-- to use those modules to fill a requirement. A 'ModuleScope' +-- can influence the 'ModuleShape' via a reexport. +data ModuleScope = ModuleScope { + modScopeProvides :: ModuleProvides, + modScopeRequires :: Set ModuleName + } + +-- | Every 'Module' in scope at a 'ModuleName' is annotated with +-- the 'PackageName' it comes from. +type ModuleProvides = Map ModuleName [ModuleSource] +data ModuleSource = + ModuleSource { + -- We don't have line numbers, but if we did the + -- package name and renaming could be associated + -- with that as well + msrc_pkgname :: PackageName, + msrc_renaming :: IncludeRenaming, + msrc_module :: OpenModule + } + +instance ModSubst ModuleScope where + modSubst subst (ModuleScope provs reqs) + = ModuleScope (modSubst subst provs) (modSubst subst reqs) + +-- | An empty 'ModuleScope'. +emptyModuleScope :: ModuleScope +emptyModuleScope = ModuleScope Map.empty Set.empty + +instance ModSubst ModuleSource where + modSubst subst src = src { msrc_module = modSubst subst (msrc_module src) } diff --git a/Cabal/Distribution/Backpack/ModuleShape.hs b/Cabal/Distribution/Backpack/ModuleShape.hs new file mode 100644 index 00000000000..df98ceb77e4 --- /dev/null +++ b/Cabal/Distribution/Backpack/ModuleShape.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveGeneric #-} +-- | See +module Distribution.Backpack.ModuleShape ( + -- * Module shapes + ModuleShape(..), + emptyModuleShape, + shapeInstalledPackage, +) where + +import Prelude () +import Distribution.Compat.Prelude hiding (mod) + +import Distribution.ModuleName +import Distribution.InstalledPackageInfo as IPI + +import Distribution.Backpack.ModSubst +import Distribution.Backpack + +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + +----------------------------------------------------------------------- +-- Module shapes + +-- | A 'ModuleShape' describes the provisions and requirements of +-- a library. We can extract a 'ModuleShape' from an +-- 'InstalledPackageInfo'. +data ModuleShape = ModuleShape { + modShapeProvides :: OpenModuleSubst, + modShapeRequires :: Set ModuleName + } + deriving (Eq, Show, Generic) + +instance Binary ModuleShape + +instance ModSubst ModuleShape where + modSubst subst (ModuleShape provs reqs) + = ModuleShape (modSubst subst provs) (modSubst subst reqs) + +-- | The default module shape, with no provisions and no requirements. +emptyModuleShape :: ModuleShape +emptyModuleShape = ModuleShape Map.empty Set.empty + +-- Food for thought: suppose we apply the Merkel tree optimization. +-- Imagine this situation: +-- +-- component p +-- signature H +-- module P +-- component h +-- module H +-- component a +-- signature P +-- module A +-- component q(P) +-- include p +-- include h +-- component r +-- include q (P) +-- include p (P) requires (H) +-- include h (H) +-- include a (A) requires (P) +-- +-- Component r should not have any conflicts, since after mix-in linking +-- the two P imports will end up being the same, so we can properly +-- instantiate it. But to know that q's P is p:P instantiated with h:H, +-- we have to be able to expand its unit id. Maybe we can expand it +-- lazily but in some cases it will need to be expanded. +-- +-- FWIW, the way that GHC handles this is by improving unit IDs as +-- soon as it sees an improved one in the package database. This +-- is a bit disgusting. +shapeInstalledPackage :: IPI.InstalledPackageInfo -> ModuleShape +shapeInstalledPackage ipi = ModuleShape (Map.fromList provs) reqs + where + uid = installedOpenUnitId ipi + provs = map shapeExposedModule (IPI.exposedModules ipi) + reqs = requiredSignatures ipi + shapeExposedModule (IPI.ExposedModule mod_name Nothing) + = (mod_name, OpenModule uid mod_name) + shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) + = (mod_name, mod) diff --git a/Cabal/Distribution/Backpack/PreExistingComponent.hs b/Cabal/Distribution/Backpack/PreExistingComponent.hs new file mode 100644 index 00000000000..027dbbcbfcb --- /dev/null +++ b/Cabal/Distribution/Backpack/PreExistingComponent.hs @@ -0,0 +1,52 @@ +-- | See +module Distribution.Backpack.PreExistingComponent ( + PreExistingComponent(..), + pc_cid, + ipiToPreExistingComponent, +) where + +import Prelude () + +import Distribution.Backpack.ModuleShape +import Distribution.Backpack + +import qualified Data.Map as Map +import Distribution.Package +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.InstalledPackageInfo (InstalledPackageInfo) + +-- | Stripped down version of 'LinkedComponent' for things +-- we don't need to know how to build. +data PreExistingComponent + = PreExistingComponent { + -- | The 'PackageName' that, when we see it in 'PackageDescription', + -- we should map this to. This may DISAGREE with 'pc_pkgid' for + -- internal dependencies: e.g., an internal component @lib@ + -- may be munged to @z-pkg-z-lib@, but we still want to use + -- it when we see @lib@ in @build-depends@ + pc_pkgname :: PackageName, + pc_pkgid :: PackageId, + pc_uid :: UnitId, + pc_open_uid :: OpenUnitId, + pc_shape :: ModuleShape + } + +-- | The 'ComponentId' of a 'PreExistingComponent'. +pc_cid :: PreExistingComponent -> ComponentId +pc_cid pc = unitIdComponentId (pc_uid pc) + +-- | Convert an 'InstalledPackageInfo' into a 'PreExistingComponent', +-- which was brought into scope under the 'PackageName' (important for +-- a package qualified reference.) +ipiToPreExistingComponent :: (PackageName, InstalledPackageInfo) -> PreExistingComponent +ipiToPreExistingComponent (pn, ipi) = + PreExistingComponent { + pc_pkgname = pn, + pc_pkgid = Installed.sourcePackageId ipi, + pc_uid = Installed.installedUnitId ipi, + pc_open_uid = + IndefFullUnitId (Installed.installedComponentId ipi) + (Map.fromList (Installed.instantiatedWith ipi)), + pc_shape = shapeInstalledPackage ipi + } + diff --git a/Cabal/Distribution/Backpack/ReadyComponent.hs b/Cabal/Distribution/Backpack/ReadyComponent.hs new file mode 100644 index 00000000000..32b95f4af72 --- /dev/null +++ b/Cabal/Distribution/Backpack/ReadyComponent.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternGuards #-} +-- | See +module Distribution.Backpack.ReadyComponent ( + ReadyComponent(..), + InstantiatedComponent(..), + IndefiniteComponent(..), + rc_compat_name, + rc_compat_key, + dispReadyComponent, + toReadyComponents, +) where + +import Prelude () +import Distribution.Compat.Prelude hiding ((<>)) + +import Distribution.Backpack +import Distribution.Backpack.Id +import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.ModuleShape + +import Distribution.Types.ModuleRenaming +import Distribution.Types.Component +import Distribution.Compat.Graph (IsNode(..)) + +import Distribution.ModuleName +import Distribution.Package +import Distribution.Simple.Utils +import Distribution.Simple.Compiler + +import qualified Control.Applicative as A +import qualified Data.Traversable as T + +import Control.Monad +import Text.PrettyPrint +import qualified Data.Map as Map + +import Distribution.Text + +-- | An instantiated component is simply a linked component which +-- may have a fully instantiated 'UnitId'. When we do mix-in linking, +-- we only do each component in its most general form; instantiation +-- then takes all of the fully instantiated components and recursively +-- discovers what other instantiated components we need to build +-- before we can build them. +-- + +data InstantiatedComponent + = InstantiatedComponent { + instc_insts :: [(ModuleName, Module)], + instc_provides :: Map ModuleName Module, + instc_includes :: [(DefUnitId, ModuleRenaming)] + } + +data IndefiniteComponent + = IndefiniteComponent { + indefc_requires :: [ModuleName], + indefc_provides :: Map ModuleName OpenModule, + indefc_includes :: [(OpenUnitId, ModuleRenaming)] + } + +data ReadyComponent + = ReadyComponent { + rc_uid :: UnitId, + rc_pkgid :: PackageId, + rc_component :: Component, + -- build-tools don't participate in mix-in linking. + -- (but what if they cold?) + rc_internal_build_tools :: [DefUnitId], + rc_public :: Bool, + -- PackageId here is a bit dodgy, but its just for + -- BC so it shouldn't matter. + rc_depends :: [(UnitId, PackageId)], + rc_i :: Either IndefiniteComponent InstantiatedComponent + } + +instance Package ReadyComponent where + packageId = rc_pkgid + +instance HasUnitId ReadyComponent where + installedUnitId = rc_uid + +instance IsNode ReadyComponent where + type Key ReadyComponent = UnitId + nodeKey = rc_uid + nodeNeighbors rc = + (case rc_i rc of + Right _ | UnitId cid (Just _) + <- rc_uid rc -> [newSimpleUnitId cid] + _ -> []) ++ + ordNub (map fst (rc_depends rc)) + +rc_compat_name :: ReadyComponent -> PackageName +rc_compat_name ReadyComponent{ + rc_pkgid = PackageIdentifier pkg_name _, + rc_component = component, + rc_uid = uid + } + = computeCompatPackageName pkg_name (componentName component) (Just uid) + +rc_compat_key :: ReadyComponent -> Compiler -> String +rc_compat_key rc@ReadyComponent { + rc_pkgid = PackageIdentifier _ pkg_ver, + rc_uid = uid + } comp -- TODO: A wart. But the alternative is to store + -- the Compiler in the LinkedComponent + = computeCompatPackageKey comp (rc_compat_name rc) pkg_ver uid + +dispReadyComponent :: ReadyComponent -> Doc +dispReadyComponent rc = + hang (text (case rc_i rc of + Left _ -> "indefinite" + Right _ -> "definite") + <+> disp (nodeKey rc) + {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} ) 4 $ + vcat [ text "depends" <+> disp uid + | uid <- nodeNeighbors rc ] + +-- | The state of 'InstM'; a mapping from 'UnitId's to their +-- ready component, or @Nothing@ if its an external +-- component which we don't know how to build. +type InstS = Map UnitId (Maybe ReadyComponent) + +-- | A state monad for doing instantiations (can't use actual +-- State because that would be an extra dependency.) +newtype InstM a = InstM { runInstM :: InstS -> (a, InstS) } + +instance Functor InstM where + fmap f (InstM m) = InstM $ \s -> let (x, s') = m s + in (f x, s') + +instance A.Applicative InstM where + pure a = InstM $ \s -> (a, s) + InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s + (x', s'') = x s' + in (f' x', s'') + +instance Monad InstM where + return = A.pure + InstM m >>= f = InstM $ \s -> let (x, s') = m s + in runInstM (f x) s' + +-- | Given a list of 'LinkedComponent's, expand the module graph +-- so that we have an instantiated graph containing all of the +-- instantiated components we need to build. +-- +-- Instantiation intuitively follows the following algorithm: +-- +-- instantiate a definite unit id p[S]: +-- recursively instantiate each module M in S +-- recursively instantiate modules exported by this unit +-- recursively instantiate dependencies substituted by S +-- +-- The implementation is a bit more involved to memoize instantiation +-- if we have done it already. +-- +-- We also call 'improveUnitId' during this process, so that fully +-- instantiated components are given 'HashedUnitId'. +-- +toReadyComponents + :: Map ComponentId PackageId + -> Map ModuleName Module -- subst for the public component + -> [LinkedComponent] + -> [ReadyComponent] +toReadyComponents pid_map subst0 comps + = catMaybes (Map.elems ready_map) + where + cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ] + + instantiateUnitId :: ComponentId -> Map ModuleName Module + -> InstM DefUnitId + instantiateUnitId cid insts = InstM $ \s -> + case Map.lookup uid s of + Nothing -> + -- Knot tied + let (r, s') = runInstM (instantiateComponent uid cid insts) + (Map.insert uid r s) + in (def_uid, Map.insert uid r s') + Just _ -> (def_uid, s) + where + -- The mkDefUnitId here indicates that we assume + -- that Cabal handles unit id hash allocation. + -- Good thing about hashing here: map is only on string. + -- Bad thing: have to repeatedly hash. + def_uid = mkDefUnitId cid insts + uid = unDefUnitId def_uid + + instantiateComponent + :: UnitId -> ComponentId -> Map ModuleName Module + -> InstM (Maybe ReadyComponent) + instantiateComponent uid cid insts + | Just lc <- Map.lookup cid cmap = do + deps <- forM (lc_depends lc) $ \(x, y) -> do + x' <- substUnitId insts x + return (x', y) + provides <- T.mapM (substModule insts) (modShapeProvides (lc_shape lc)) + includes <- forM (lc_includes lc) $ \(x, y) -> do + x' <- substUnitId insts x + return (x', y) + build_tools <- mapM (substUnitId insts) (lc_internal_build_tools lc) + let getDep (Module dep_def_uid _) + | let dep_uid = unDefUnitId dep_def_uid + , Just pid <- Map.lookup (unitIdComponentId dep_uid) pid_map + -- Lose DefUnitId invariant for rc_depends + = [(dep_uid, pid)] + getDep _ = [] + instc = InstantiatedComponent { + instc_insts = Map.toList insts, + instc_provides = provides, + instc_includes = includes + } + return $ Just ReadyComponent { + rc_uid = uid, + rc_pkgid = lc_pkgid lc, + rc_component = lc_component lc, + rc_internal_build_tools = build_tools, + rc_public = lc_public lc, + rc_depends = ordNub $ + -- NB: don't put the dep on the indef + -- package here, since we DO NOT want + -- to put it in 'depends' in the IPI + map (\(x,y) -> (unDefUnitId x, y)) deps ++ + concatMap getDep (Map.elems insts), + rc_i = Right instc + } + | otherwise = return Nothing + + substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId + substUnitId _ (DefiniteUnitId uid) = + return uid + substUnitId subst (IndefFullUnitId cid insts) = do + insts' <- substSubst subst insts + instantiateUnitId cid insts' + + -- NB: NOT composition + substSubst :: Map ModuleName Module + -> Map ModuleName OpenModule + -> InstM (Map ModuleName Module) + substSubst subst insts = T.mapM (substModule subst) insts + + substModule :: Map ModuleName Module -> OpenModule -> InstM Module + substModule subst (OpenModuleVar mod_name) + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" + substModule subst (OpenModule uid mod_name) = do + uid' <- substUnitId subst uid + return (Module uid' mod_name) + + indefiniteUnitId :: ComponentId -> InstM UnitId + indefiniteUnitId cid = do + let uid = newSimpleUnitId cid + r <- indefiniteComponent uid cid + InstM $ \s -> (uid, Map.insert uid r s) + + indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent) + indefiniteComponent uid cid + | Just lc <- Map.lookup cid cmap = do + -- TODO: Goofy + build_tools <- mapM (substUnitId Map.empty) (lc_internal_build_tools lc) + let indefc = IndefiniteComponent { + indefc_requires = map fst (lc_insts lc), + indefc_provides = modShapeProvides (lc_shape lc), + indefc_includes = lc_includes lc + } + return $ Just ReadyComponent { + rc_uid = uid, + rc_pkgid = lc_pkgid lc, + rc_component = lc_component lc, + rc_internal_build_tools = build_tools, + rc_public = lc_public lc, + rc_depends = ordNub (map (\(x,y) -> (abstractUnitId x, y)) (lc_depends lc)), + rc_i = Left indefc + } + | otherwise = return Nothing + + ready_map = snd $ runInstM work Map.empty + + work + | not (Map.null subst0) + , [lc] <- filter lc_public (Map.elems cmap) + = do _ <- instantiateUnitId (lc_cid lc) subst0 + return () + | otherwise + = forM_ (Map.elems cmap) $ \lc -> + if null (lc_insts lc) + then instantiateUnitId (lc_cid lc) Map.empty >> return () + else indefiniteUnitId (lc_cid lc) >> return () diff --git a/Cabal/Distribution/Backpack/UnifyM.hs b/Cabal/Distribution/Backpack/UnifyM.hs new file mode 100644 index 00000000000..80723f229f8 --- /dev/null +++ b/Cabal/Distribution/Backpack/UnifyM.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE Rank2Types #-} +-- | See +module Distribution.Backpack.UnifyM ( + -- * Unification monad + UnifyM, + runUnifyM, + unifyFail, + withContext, + liftST, + + UnifEnv(..), + getUnifEnv, + + -- * Modules and unit IDs + ModuleU, + ModuleU'(..), + convertModule, + convertModuleU, + + UnitIdU, + UnitIdU'(..), + convertUnitId, + convertUnitIdU, + + ModuleSubstU, + convertModuleSubstU, + convertModuleSubst, + + ModuleScopeU, + emptyModuleScopeU, + convertModuleScopeU, + + ModuleSourceU(..), + + convertInclude, + convertModuleProvides, + convertModuleProvidesU, + +) where + +import Prelude () +import Distribution.Compat.Prelude hiding (mod) + +import Distribution.Backpack.ModuleShape +import Distribution.Backpack.ModuleScope +import Distribution.Backpack.ModSubst +import Distribution.Backpack.FullUnitId +import Distribution.Backpack + +import qualified Distribution.Utils.UnionFind as UnionFind +import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Text +import Distribution.Types.IncludeRenaming +import Distribution.Verbosity + +import Data.STRef +import Control.Monad.ST +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.Traversable as T + +-- TODO: more detailed trace output on high verbosity would probably +-- be appreciated by users debugging unification errors. Collect +-- some good examples! + +-- | The unification monad, this monad encapsulates imperative +-- unification. +newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Either String a) } + +-- | Run a computation in the unification monad. +runUnifyM :: Verbosity -> FullDb -> (forall s. UnifyM s a) -> Either String a +runUnifyM verbosity db m + = runST $ do i <- newSTRef 0 + hmap <- newSTRef Map.empty + unUnifyM m (UnifEnv i hmap verbosity Nothing db) +-- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'. + +-- | The unification environment. +data UnifEnv s = UnifEnv { + -- | A supply of unique integers to label 'UnitIdU' + -- cells. This is used to determine loops in unit + -- identifiers (which can happen with mutual recursion.) + unify_uniq :: UnifRef s UnitIdUnique, + -- | The set of requirements in scope. When + -- a provision is brought into scope, we unify with + -- the requirement at the same module name to fill it. + -- This mapping grows monotonically. + unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)), + -- | How verbose the error message should be + unify_verbosity :: Verbosity, + -- | The error reporting context + unify_ctx :: Maybe (String, ModuleU s, ModuleU s), + -- | The package index for expanding unit identifiers + unify_db :: FullDb + } + +instance Functor (UnifyM s) where + fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m) + +instance Applicative (UnifyM s) where + pure = UnifyM . pure . pure . pure + UnifyM f <*> UnifyM x = UnifyM $ \r -> do + f' <- f r + case f' of + Left err -> return (Left err) + Right f'' -> do + x' <- x r + case x' of + Left err -> return (Left err) + Right x'' -> return (Right (f'' x'')) + +instance Monad (UnifyM s) where + return = pure + UnifyM m >>= f = UnifyM $ \r -> do + x <- m r + case x of + Left err -> return (Left err) + Right x' -> unUnifyM (f x') r + +-- | Lift a computation from 'ST' monad to 'UnifyM' monad. +-- Internal use only. +liftST :: ST s a -> UnifyM s a +liftST m = UnifyM $ \_ -> fmap Right m + +unifyFail :: String -> UnifyM s a +unifyFail err = do + env <- getUnifEnv + msg <- case unify_ctx env of + Nothing -> return ("Unspecified unification error: " ++ err) + Just (ctx, mod1, mod2) + | unify_verbosity env > normal + -> do mod1' <- convertModuleU mod1 + mod2' <- convertModuleU mod2 + let extra = " (was unifying " ++ display mod1' + ++ " and " ++ display mod2' ++ ")" + return (ctx ++ err ++ extra) + | otherwise + -> return (ctx ++ err ++ " (for more information, pass -v flag)") + UnifyM $ \_ -> return (Left msg) + +-- | A convenient alias for mutable references in the unification monad. +type UnifRef s a = STRef s a + +-- | Imperatively read a 'UnifRef'. +readUnifRef :: UnifRef s a -> UnifyM s a +readUnifRef = liftST . readSTRef + +-- | Imperatively write a 'UnifRef'. +writeUnifRef :: UnifRef s a -> a -> UnifyM s () +writeUnifRef x = liftST . writeSTRef x + +-- | Get the current unification environment. +getUnifEnv :: UnifyM s (UnifEnv s) +getUnifEnv = UnifyM $ \r -> return (Right r) + +-- | Run a unification in some context +withContext :: String -> ModuleU s -> ModuleU s -> UnifyM s a -> UnifyM s a +withContext ctx mod1 mod2 m = + UnifyM $ \r -> unUnifyM m r { unify_ctx = Just (ctx, mod1, mod2) } + +----------------------------------------------------------------------- +-- The "unifiable" variants of the data types +-- +-- In order to properly do unification over infinite trees, we +-- need to union find over 'Module's and 'UnitId's. The pure +-- representation is ill-equipped to do this, so we convert +-- from the pure representation into one which is indirected +-- through union-find. 'ModuleU' handles hole variables; +-- 'UnitIdU' handles mu-binders. + +-- | Contents of a mutable 'ModuleU' reference. +data ModuleU' s + = ModuleU (UnitIdU s) ModuleName + | ModuleVarU ModuleName + +-- | Contents of a mutable 'UnitIdU' reference. +data UnitIdU' s + = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s)) + | UnitIdThunkU DefUnitId + +-- | A mutable version of 'Module' which can be imperatively unified. +type ModuleU s = UnionFind.Point s (ModuleU' s) + +-- | A mutable version of 'UnitId' which can be imperatively unified. +type UnitIdU s = UnionFind.Point s (UnitIdU' s) + +-- | An integer for uniquely labeling 'UnitIdU' nodes. We need +-- these labels in order to efficiently serialize 'UnitIdU's into +-- 'UnitId's (we use the label to check if any parent is the +-- node in question, and if so insert a deBruijn index instead.) +-- These labels must be unique across all 'UnitId's/'Module's which +-- participate in unification! +type UnitIdUnique = Int + + +----------------------------------------------------------------------- +-- Conversion to the unifiable data types + +-- An environment for tracking the mu-bindings in scope. +-- The invariant for a state @(m, i)@ is that [0..i] are +-- keys of @m@; in fact, the @i-k@th entry is the @k@th +-- de Bruijn index (this saves us from having to shift as +-- we enter mu-binders.) +type MuEnv s = (IntMap (UnitIdU s), Int) + +extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s +extendMuEnv (m, i) x = + (IntMap.insert (i + 1) x m, i + 1) + +{- +lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s +lookupMuEnv (m, i) k = + case IntMap.lookup (i - k) m of + -- Technically a user can trigger this by giving us a + -- bad 'UnitId', so handle this better. + Nothing -> error "lookupMuEnv: out of bounds (malformed de Bruijn index)" + Just v -> v +-} + +emptyMuEnv :: MuEnv s +emptyMuEnv = (IntMap.empty, -1) + +-- The workhorse functions. These share an environment: +-- * @UnifRef s UnitIdUnique@ - the unique label supply for 'UnitIdU' nodes +-- * @UnifRef s (Map ModuleName moduleU)@ - the (lazily initialized) +-- environment containing the implicitly universally quantified +-- @hole:A@ binders. +-- * @MuEnv@ - the environment for mu-binders. + +convertUnitId' :: MuEnv s + -> OpenUnitId + -> UnifyM s (UnitIdU s) +-- TODO: this could be more lazy if we know there are no internal +-- references +convertUnitId' _ (DefiniteUnitId uid) = + liftST $ UnionFind.fresh (UnitIdThunkU uid) +convertUnitId' stk (IndefFullUnitId cid insts) = do + fs <- fmap unify_uniq getUnifEnv + x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later + insts_u <- T.forM insts $ convertModule' (extendMuEnv stk x) + u <- readUnifRef fs + writeUnifRef fs (u+1) + y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u) + liftST $ UnionFind.union x y + return y +-- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i) + +convertModule' :: MuEnv s + -> OpenModule -> UnifyM s (ModuleU s) +convertModule' _stk (OpenModuleVar mod_name) = do + hmap <- fmap unify_reqs getUnifEnv + hm <- readUnifRef hmap + case Map.lookup mod_name hm of + Nothing -> do mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name) + writeUnifRef hmap (Map.insert mod_name mod hm) + return mod + Just mod -> return mod +convertModule' stk (OpenModule uid mod_name) = do + uid_u <- convertUnitId' stk uid + liftST $ UnionFind.fresh (ModuleU uid_u mod_name) + +convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s) +convertUnitId = convertUnitId' emptyMuEnv + +convertModule :: OpenModule -> UnifyM s (ModuleU s) +convertModule = convertModule' emptyMuEnv + + + +----------------------------------------------------------------------- +-- Substitutions + +-- | The mutable counterpart of a 'ModuleSubst' (not defined here). +type ModuleSubstU s = Map ModuleName (ModuleU s) + +-- | Conversion of 'ModuleSubst' to 'ModuleSubstU' +convertModuleSubst :: Map ModuleName OpenModule -> UnifyM s (Map ModuleName (ModuleU s)) +convertModuleSubst = T.mapM convertModule + +-- | Conversion of 'ModuleSubstU' to 'ModuleSubst' +convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst +convertModuleSubstU = T.mapM convertModuleU + +----------------------------------------------------------------------- +-- Conversion from the unifiable data types + +-- An environment for tracking candidates for adding a mu-binding. +-- The invariant for a state @(m, i)@, is that if we encounter a node +-- labeled @k@ such that @m[k -> v]@, then we can replace this +-- node with the de Bruijn index @i-v@ referring to an enclosing +-- mu-binder; furthermore, @range(m) = [0..i]@. +type MooEnv = (IntMap Int, Int) + +emptyMooEnv :: MooEnv +emptyMooEnv = (IntMap.empty, -1) + +extendMooEnv :: MooEnv -> UnitIdUnique -> MooEnv +extendMooEnv (m, i) k = (IntMap.insert k (i + 1) m, i + 1) + +lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int +lookupMooEnv (m, i) k = + case IntMap.lookup k m of + Nothing -> Nothing + Just v -> Just (i-v) -- de Bruijn indexize + +-- The workhorse functions + +convertUnitIdU' :: MooEnv -> UnitIdU s -> UnifyM s OpenUnitId +convertUnitIdU' stk uid_u = do + x <- liftST $ UnionFind.find uid_u + case x of + UnitIdThunkU uid -> return (DefiniteUnitId uid) + UnitIdU u cid insts_u -> + case lookupMooEnv stk u of + Just _i -> error "convertUnitIdU': mutual recursion" -- return (UnitIdVar i) + Nothing -> do + insts <- T.forM insts_u $ convertModuleU' (extendMooEnv stk u) + return (IndefFullUnitId cid insts) + +convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule +convertModuleU' stk mod_u = do + mod <- liftST $ UnionFind.find mod_u + case mod of + ModuleVarU mod_name -> return (OpenModuleVar mod_name) + ModuleU uid_u mod_name -> do + uid <- convertUnitIdU' stk uid_u + return (OpenModule uid mod_name) + +-- Helper functions + +convertUnitIdU :: UnitIdU s -> UnifyM s OpenUnitId +convertUnitIdU = convertUnitIdU' emptyMooEnv + +convertModuleU :: ModuleU s -> UnifyM s OpenModule +convertModuleU = convertModuleU' emptyMooEnv + +-- | An empty 'ModuleScopeU'. +emptyModuleScopeU :: ModuleScopeU s +emptyModuleScopeU = (Map.empty, Map.empty) + + +-- | The mutable counterpart of 'ModuleScope'. +type ModuleScopeU s = (ModuleProvidesU s, ModuleSubstU s) +-- | The mutable counterpart of 'ModuleProvides' +type ModuleProvidesU s = Map ModuleName [ModuleSourceU s] +data ModuleSourceU s = + ModuleSourceU { + -- We don't have line numbers, but if we did the + -- package name and renaming could be associated + -- with that as well + usrc_pkgname :: PackageName, + usrc_renaming :: IncludeRenaming, + usrc_module :: ModuleU s + } + +-- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do +-- unification on it. +convertInclude + :: ((OpenUnitId, ModuleShape), PackageId, IncludeRenaming) + -> UnifyM s (ModuleScopeU s, (UnitIdU s, PackageId, ModuleRenaming)) +convertInclude ((uid, ModuleShape provs reqs), pid, incl@(IncludeRenaming prov_rns req_rns)) = do + let pn = packageName pid + + -- Suppose our package has two requirements A and B, and + -- we include it with @requires (A as X)@ + -- There are three closely related things we compute based + -- off of @reqs@ and @reqs_rns@: + -- + -- 1. The requirement renaming (A -> X) + -- 2. The requirement substitution (A -> , B -> ) + + -- Requirement renaming. This is read straight off the syntax: + -- + -- [nothing] ==> [empty] + -- requires (B as Y) ==> B -> Y + -- + -- Requirement renamings are NOT injective: if two requirements + -- are mapped to the same name, the intent is to merge them + -- together. But they are *functions*, so @B as X, B as Y@ is + -- illegal. + let insertDistinct m (k,v) = + if Map.member k m + then error ("Duplicate requirement renaming " ++ display k) + else return (Map.insert k v m) + req_rename <- foldM insertDistinct Map.empty =<< + case req_rns of + DefaultRenaming -> return [] + -- Not valid here, but whatever + HidingRenaming _ -> error "Cannot use hiding in requirement renaming" + ModuleRenaming rns -> return rns + let req_rename_fn k = case Map.lookup k req_rename of + Nothing -> k + Just v -> v + + -- Requirement substitution. + -- + -- A -> X ==> A -> + let req_subst = fmap OpenModuleVar req_rename + + uid_u <- convertUnitId (modSubst req_subst uid) + + -- Requirement mapping. This is just taking the range of the + -- requirement substitution, and making a mapping so that it is + -- convenient to merge things together. It INCLUDES the implicit + -- mappings. + -- + -- A -> X ==> X -> , B -> + reqs_u <- convertModuleSubst . Map.fromList $ + [ (k, OpenModuleVar k) + | k <- map req_rename_fn (Set.toList reqs) + ] + + -- Provision computation is more complex. + -- For example, if we have: + -- + -- include p (A as X) requires (B as Y) + -- where A -> q[B=]:A + -- + -- Then we need: + -- + -- X -> [("p", q[B=]:A)] + -- + -- There are a bunch of clever ways to present the algorithm + -- but here is the simple one: + -- + -- 1. If we have a default renaming, apply req_subst + -- to provs and use that. + -- + -- 2. Otherwise, build a map by successively looking + -- up the referenced modules in the renaming in provs. + -- + -- Importantly, overlapping rename targets get accumulated + -- together. It's not an (immediate) error. + (pre_prov_scope, prov_rns') <- + case prov_rns of + DefaultRenaming -> return (Map.toList provs, prov_rns) + HidingRenaming hides -> + let hides_set = Set.fromList hides + in let r = [ (k,v) + | (k,v) <- Map.toList provs + , k `Set.member` hides_set ] + -- GHC doesn't understand hiding, so expand it out! + in return (r, ModuleRenaming (map ((\x -> (x,x)).fst) r)) + ModuleRenaming rns -> do + r <- sequence + [ case Map.lookup from provs of + Just m -> return (to, m) + Nothing -> error ("Tried to rename non-existent module " ++ display from) + | (from, to) <- rns ] + return (r, prov_rns) + let prov_scope = modSubst req_subst + $ Map.fromListWith (++) + [ (k, [ModuleSource pn incl v]) + | (k, v) <- pre_prov_scope ] + + provs_u <- convertModuleProvides prov_scope + + return ((provs_u, reqs_u), (uid_u, pid, prov_rns')) + +-- | Convert a 'ModuleScopeU' to a 'ModuleScope'. +convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope +convertModuleScopeU (provs_u, reqs_u) = do + provs <- convertModuleProvidesU provs_u + reqs <- convertModuleSubstU reqs_u + -- TODO: Test that the requirements are still free. If they + -- are not, they got unified, and that's dodgy at best. + return (ModuleScope provs (Map.keysSet reqs)) + +-- | Convert a 'ModuleProvides' to a 'ModuleProvidesU' +convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s) +convertModuleProvides = T.mapM $ \ms -> + mapM (\(ModuleSource pn incl m) + -> do m' <- convertModule m + return (ModuleSourceU pn incl m')) ms + +-- | Convert a 'ModuleProvidesU' to a 'ModuleProvides' +convertModuleProvidesU :: ModuleProvidesU s -> UnifyM s ModuleProvides +convertModuleProvidesU = T.mapM $ \ms -> + mapM (\(ModuleSourceU pn incl m) + -> do m' <- convertModuleU m + return (ModuleSource pn incl m')) ms diff --git a/Cabal/Distribution/InstalledPackageInfo.hs b/Cabal/Distribution/InstalledPackageInfo.hs index 86fe5df8feb..672145a6c93 100644 --- a/Cabal/Distribution/InstalledPackageInfo.hs +++ b/Cabal/Distribution/InstalledPackageInfo.hs @@ -31,6 +31,8 @@ module Distribution.InstalledPackageInfo ( InstalledPackageInfo(..), installedComponentId, installedPackageId, + requiredSignatures, + installedOpenUnitId, ExposedModule(..), ParseResult(..), PError(..), PWarning, emptyInstalledPackageInfo, @@ -47,6 +49,7 @@ import Distribution.Compat.Prelude import Distribution.ParseUtils import Distribution.License import Distribution.Package hiding (installedUnitId, installedPackageId) +import Distribution.Backpack import qualified Distribution.Package as Package import Distribution.ModuleName import Distribution.Version @@ -55,6 +58,9 @@ import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.Graph import Text.PrettyPrint as Disp +import qualified Data.Char as Char +import qualified Data.Map as Map +import Data.Set (Set) -- ----------------------------------------------------------------------------- -- The InstalledPackageInfo type @@ -66,6 +72,11 @@ data InstalledPackageInfo -- these parts are exactly the same as PackageDescription sourcePackageId :: PackageId, installedUnitId :: UnitId, + -- INVARIANT: if this package is definite, OpenModule's + -- OpenUnitId directly records UnitId. If it is + -- indefinite, OpenModule is always an OpenModuleVar + -- with the same ModuleName as the key. + instantiatedWith :: [(ModuleName, OpenModule)], compatPackageKey :: String, license :: License, copyright :: String, @@ -79,7 +90,10 @@ data InstalledPackageInfo category :: String, -- these parts are required by an installed package only: abiHash :: AbiHash, + indefinite :: Bool, exposed :: Bool, + -- INVARIANT: if the package is definite, OpenModule's + -- OpenUnitId directly records UnitId. exposedModules :: [ExposedModule], hiddenModules :: [ModuleName], trusted :: Bool, @@ -91,6 +105,8 @@ data InstalledPackageInfo extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi includeDirs :: [FilePath], includes :: [String], + -- INVARIANT: if the package is definite, UnitId is NOT + -- a ComponentId of an indefinite package depends :: [UnitId], ccOptions :: [String], ldOptions :: [String], @@ -102,9 +118,22 @@ data InstalledPackageInfo } deriving (Eq, Generic, Read, Show) +-- | Get the indefinite unit identity representing this package. +-- This IS NOT guaranteed to give you a substitution; for +-- instantiated packages you will get @DefiniteUnitId (installedUnitId ipi)@. +-- For indefinite libraries, however, you will correctly get +-- an @OpenUnitId@ with the appropriate 'OpenModuleSubst'. +installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId +installedOpenUnitId ipi + = mkOpenUnitId (installedUnitId ipi) (Map.fromList (instantiatedWith ipi)) + +-- | Returns the set of module names which need to be filled for +-- an indefinite package, or the empty set if the package is definite. +requiredSignatures :: InstalledPackageInfo -> Set ModuleName +requiredSignatures ipi = openModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi)) + installedComponentId :: InstalledPackageInfo -> ComponentId -installedComponentId ipi = case installedUnitId ipi of - SimpleUnitId cid -> cid +installedComponentId ipi = unitIdComponentId (installedUnitId ipi) {-# DEPRECATED installedPackageId "Use installedUnitId instead" #-} -- | Backwards compatibility with Cabal pre-1.24. @@ -135,6 +164,7 @@ emptyInstalledPackageInfo = InstalledPackageInfo { sourcePackageId = PackageIdentifier (mkPackageName "") nullVersion, installedUnitId = mkUnitId "", + instantiatedWith = [], compatPackageKey = "", license = UnspecifiedLicense, copyright = "", @@ -147,6 +177,7 @@ emptyInstalledPackageInfo description = "", category = "", abiHash = mkAbiHash "", + indefinite = False, exposed = False, exposedModules = [], hiddenModules = [], @@ -175,7 +206,7 @@ emptyInstalledPackageInfo data ExposedModule = ExposedModule { exposedName :: ModuleName, - exposedReexport :: Maybe Module + exposedReexport :: Maybe OpenModule } deriving (Eq, Generic, Read, Show) @@ -195,7 +226,6 @@ instance Text ExposedModule where fmap Just parse return (ExposedModule m reexport) - instance Binary ExposedModule -- To maintain backwards-compatibility, we accept both comma/non-comma @@ -233,6 +263,13 @@ showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) showSimpleInstalledPackageInfoField = showSimpleSingleNamedField fieldsInstalledPackageInfo +dispCompatPackageKey :: String -> Doc +dispCompatPackageKey = text + +parseCompatPackageKey :: Parse.ReadP r String +parseCompatPackageKey = Parse.munch1 uid_char + where uid_char c = Char.isAlphaNum c || c `elem` "-_.=[],:<>+" + -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing @@ -250,9 +287,11 @@ basicFieldDescrs = , simpleField "id" disp parse installedUnitId (\pk pkg -> pkg{installedUnitId=pk}) - -- NB: parse these as component IDs + , simpleField "instantiated-with" + (dispOpenModuleSubst . Map.fromList) (fmap Map.toList parseOpenModuleSubst) + instantiatedWith (\iw pkg -> pkg{instantiatedWith=iw}) , simpleField "key" - (disp . mkComponentId) (fmap unComponentId parse) + dispCompatPackageKey parseCompatPackageKey compatPackageKey (\pk pkg -> pkg{compatPackageKey=pk}) , simpleField "license" disp parseLicenseQ @@ -290,6 +329,8 @@ installedFieldDescrs :: [FieldDescr InstalledPackageInfo] installedFieldDescrs = [ boolField "exposed" exposed (\val pkg -> pkg{exposed=val}) + , boolField "indefinite" + indefinite (\val pkg -> pkg{indefinite=val}) , simpleField "exposed-modules" showExposedModules parseExposedModules exposedModules (\xs pkg -> pkg{exposedModules=xs}) diff --git a/Cabal/Distribution/Package.hs b/Cabal/Distribution/Package.hs index bc37caefb0d..da1710eaa88 100644 --- a/Cabal/Distribution/Package.hs +++ b/Cabal/Distribution/Package.hs @@ -25,9 +25,12 @@ module Distribution.Package ( -- * Package keys/installed package IDs (used for linker symbols) ComponentId, unComponentId, mkComponentId, UnitId(..), + DefUnitId, + unsafeMkDefUnitId, + unDefUnitId, mkUnitId, + newSimpleUnitId, mkLegacyUnitId, - unitIdComponentId, getHSLibraryName, InstalledPackageId, -- backwards compat @@ -145,8 +148,7 @@ instance NFData PackageIdentifier where -- module identities, e.g., when writing out reexported modules in -- the 'InstalledPackageInfo'. data Module = - Module { moduleUnitId :: UnitId, - moduleName :: ModuleName } + Module DefUnitId ModuleName deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary Module @@ -164,8 +166,11 @@ instance NFData Module where rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name -- | A 'ComponentId' uniquely identifies the transitive source --- code closure of a component. For non-Backpack components, it also --- serves as the basis for install paths, symbols, etc. +-- code closure of a component (i.e. libraries, executables). +-- +-- For non-Backpack components, this corresponds one to one with +-- the 'UnitId', which serves as the basis for install paths, +-- linker symbols, etc. -- -- Use 'mkComponentId' and 'unComponentId' to convert from/to a -- 'String'. @@ -209,24 +214,90 @@ instance NFData ComponentId where -- | Returns library name prefixed with HS, suitable for filenames getHSLibraryName :: UnitId -> String -getHSLibraryName (SimpleUnitId cid) = "HS" ++ unComponentId cid +getHSLibraryName uid = "HS" ++ display uid --- | For now, there is no distinction between component IDs --- and unit IDs in Cabal. -newtype UnitId = SimpleUnitId ComponentId - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, Text, NFData) +-- | 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 +-- installed: +-- +-- * A traditional library with no holes, so that 'unitIdHash' +-- is @Nothing@. In the absence of Backpack, 'UnitId' +-- is the same as a 'ComponentId'. +-- +-- * An indefinite, Backpack library with holes. In this case, +-- 'unitIdHash' is still @Nothing@, but in the install, +-- there are only interfaces, no compiled objects. +-- +-- * An instantiated Backpack library with all the holes +-- filled in. 'unitIdHash' is a @Just@ a hash of the +-- instantiating mapping. +-- +-- A unit is a component plus the additional information on how the +-- holes are filled in. Thus there is a one to many relationship: for a +-- particular component there are many different ways of filling in the +-- holes, and each different combination is a unit (and has a separate +-- 'UnitId'). +-- +-- 'UnitId' is distinct from 'OpenUnitId', in that it is always +-- installed, whereas 'OpenUnitId' are intermediate unit identities +-- that arise during mixin linking, and don't necessarily correspond +-- to any actually installed unit. Since the mapping is not actually +-- recorded in a 'UnitId', you can't actually substitute over them +-- (but you can substitute over 'OpenUnitId'). See also +-- "Distribution.Backpack.FullUnitId" for a mechanism for expanding an +-- instantiated 'UnitId' to retrieve its mapping. +-- +data UnitId + = UnitId { + unitIdComponentId :: ComponentId, + unitIdHash :: Maybe String + } + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +instance Binary UnitId + +instance NFData UnitId where + rnf (UnitId cid str) = rnf cid `seq` rnf str + +instance Text UnitId where + disp (UnitId cid Nothing) = disp cid + disp (UnitId cid (Just hash)) = disp cid <<>> text "+" <<>> text hash + parse = parseUnitId <++ parseSimpleUnitId + where + parseUnitId = do cid <- parse + _ <- Parse.char '+' + hash <- Parse.munch1 isAlphaNum + return (UnitId cid (Just hash)) + parseSimpleUnitId = fmap newSimpleUnitId parse + +-- | A 'UnitId' for a definite package. The 'DefUnitId' invariant says +-- that a 'UnitId' identified this way is definite; i.e., it has no +-- unfilled holes. +newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId } + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Text) + +-- | Unsafely create a 'DefUnitId' from a 'UnitId'. Your responsibility +-- is to ensure that the 'DefUnitId' invariant holds. +unsafeMkDefUnitId :: UnitId -> DefUnitId +unsafeMkDefUnitId = DefUnitId + +-- | Create a unit identity with no associated hash directly +-- from a 'ComponentId'. +newSimpleUnitId :: ComponentId -> UnitId +newSimpleUnitId cid = + UnitId { + unitIdComponentId = cid, + unitIdHash = Nothing + } -- | Makes a simple-style UnitId from a string. mkUnitId :: String -> UnitId -mkUnitId = SimpleUnitId . mkComponentId +mkUnitId = newSimpleUnitId . mkComponentId -- | Make an old-style UnitId from a package identifier mkLegacyUnitId :: PackageId -> UnitId -mkLegacyUnitId = mkUnitId . display - --- | Extract 'ComponentId' from 'UnitId'. -unitIdComponentId :: UnitId -> ComponentId -unitIdComponentId (SimpleUnitId cid) = cid +mkLegacyUnitId = newSimpleUnitId . mkComponentId . display -- ------------------------------------------------------------ -- * Package source dependencies diff --git a/Cabal/Distribution/PackageDescription.hs b/Cabal/Distribution/PackageDescription.hs index dc74121b548..7b48e548a45 100644 --- a/Cabal/Distribution/PackageDescription.hs +++ b/Cabal/Distribution/PackageDescription.hs @@ -23,10 +23,9 @@ module Distribution.PackageDescription ( knownBuildTypes, allLibraries, - -- ** Renaming + -- ** Renaming (syntactic) ModuleRenaming(..), defaultRenaming, - lookupRenaming, -- ** Libraries Library(..), @@ -35,8 +34,9 @@ module Distribution.PackageDescription ( withLib, hasPublicLib, hasLibs, - libModules, + explicitLibModules, libModulesAutogen, + libModules, -- ** Executables Executable(..), diff --git a/Cabal/Distribution/PackageDescription/Check.hs b/Cabal/Distribution/PackageDescription/Check.hs index f135dd1d642..686f58db3bc 100644 --- a/Cabal/Distribution/PackageDescription/Check.hs +++ b/Cabal/Distribution/PackageDescription/Check.hs @@ -233,22 +233,23 @@ checkLibrary pkg lib = "Duplicate modules in library: " ++ commaSep (map display moduleDuplicates) - , check (null (libModules lib) && null (reexportedModules lib)) $ + -- TODO: This check is bogus if a required-signature was passed through + , check (null (explicitLibModules lib) && null (reexportedModules lib)) $ PackageDistSuspiciousWarn $ "Library " ++ (case libName lib of Nothing -> "" Just n -> n ) ++ "does not expose any modules" - -- check use of required-signatures/exposed-signatures sections - , checkVersion [1,21] (not (null (requiredSignatures lib))) $ + -- check use of signatures sections + , checkVersion [1,25] (not (null (signatures lib))) $ PackageDistInexcusable $ - "To use the 'required-signatures' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.21'." + "To use the 'signatures' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.25'." -- check that all autogen-modules appear on other-modules or exposed-modules , check - (not $ and $ map (flip elem (libModules lib)) (libModulesAutogen lib)) $ + (not $ and $ map (flip elem (explicitLibModules lib)) (libModulesAutogen lib)) $ PackageBuildImpossible $ "An 'autogen-module' is neither on 'exposed-modules' or " ++ "'other-modules'." @@ -261,7 +262,8 @@ checkLibrary pkg lib = | specVersion pkg >= mkVersion ver = Nothing | otherwise = check cond pc - moduleDuplicates = dups (libModules lib ++ + -- TODO: not sure if this check is always right in Backpack + moduleDuplicates = dups (explicitLibModules lib ++ map moduleReexportName (reexportedModules lib)) checkExecutable :: PackageDescription -> Executable -> [PackageCheck] @@ -1005,13 +1007,10 @@ checkCabalVersion pkg = ++ "at least 'cabal-version: >= 1.21'." -- check use of thinning and renaming - , checkVersion [1,21] (not (null depsUsingThinningRenamingSyntax)) $ + , checkVersion [1,25] usesBackpackIncludes $ PackageDistInexcusable $ - "The package uses " - ++ "thinning and renaming in the 'build-depends' field: " - ++ commaSep (map display depsUsingThinningRenamingSyntax) - ++ ". To use this new syntax, the package needs to specify at least" - ++ "'cabal-version: >= 1.21'." + "To use the 'backpack-includes' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.25'." -- check use of 'extra-framework-dirs' field , checkVersion [1,23] (any (not . null) (buildInfoField extraFrameworkDirs)) $ @@ -1240,13 +1239,7 @@ checkCabalVersion pkg = depsUsingMajorBoundSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg , usesMajorBoundSyntax vr ] - -- TODO: If the user writes build-depends: foo with (), this is - -- indistinguishable from build-depends: foo, so there won't be an - -- error even though there should be - depsUsingThinningRenamingSyntax = - [ name - | bi <- allBuildInfo pkg - , (name, _) <- Map.toList (targetBuildRenaming bi) ] + usesBackpackIncludes = any (not . null . backpackIncludes) (allBuildInfo pkg) testedWithUsingWildcardSyntax = [ Dependency (mkPackageName (display compiler)) vr @@ -1342,7 +1335,7 @@ checkCabalVersion pkg = allModuleNames = (case library pkg of Nothing -> [] - (Just lib) -> libModules lib + (Just lib) -> explicitLibModules lib ) ++ concatMap otherModules (allBuildInfo pkg) diff --git a/Cabal/Distribution/PackageDescription/Configuration.hs b/Cabal/Distribution/PackageDescription/Configuration.hs index 45589b2dd62..eb13d5dea53 100644 --- a/Cabal/Distribution/PackageDescription/Configuration.hs +++ b/Cabal/Distribution/PackageDescription/Configuration.hs @@ -609,7 +609,8 @@ finalizePD userflags enabled satisfyDep Right (targetSet, fs) -> let (mb_lib, sub_libs, exes, tests, bms) = flattenTaggedTargets targetSet in Right ( (fmap (\l -> (libFillInDefaults l) { libName = Nothing }) mb_lib, - map (\(n,l) -> (libFillInDefaults l) { libName = Just n }) sub_libs, + map (\(n,l) -> (libFillInDefaults l) { libName = Just n + , libExposed = False }) sub_libs, map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes, map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests, map (\(n,b) -> (benchFillInDefaults b) { benchmarkName = n }) bms), @@ -685,7 +686,7 @@ flattenPackageDescription (GenericPackageDescription pkg _ mlib0 sub_libs0 exes0 (bms, bdeps) = foldr flattenBm ([],[]) bms0 flattenLib (n, t) (es, ds) = let (e, ds') = ignoreConditions t in - ( (libFillInDefaults $ e { libName = Just n }) : es, ds' ++ ds ) + ( (libFillInDefaults $ e { libName = Just n, libExposed = False }) : es, ds' ++ ds ) flattenExe (n, t) (es, ds) = let (e, ds') = ignoreConditions t in ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds ) diff --git a/Cabal/Distribution/PackageDescription/Parse.hs b/Cabal/Distribution/PackageDescription/Parse.hs index 306468166e6..736a602a85e 100644 --- a/Cabal/Distribution/PackageDescription/Parse.hs +++ b/Cabal/Distribution/PackageDescription/Parse.hs @@ -48,6 +48,7 @@ module Distribution.PackageDescription.Parse ( import Prelude () import Distribution.Compat.Prelude +import Distribution.Types.IncludeRenaming import Distribution.ParseUtils hiding (parseFields) import Distribution.PackageDescription import Distribution.PackageDescription.Utils @@ -67,7 +68,7 @@ import Control.Monad (mapM) import Text.PrettyPrint (vcat, ($$), (<+>), text, render, - comma, fsep, nest, ($+$), punctuate) + comma, fsep, nest, ($+$), punctuate, Doc) -- ----------------------------------------------------------------------------- @@ -177,8 +178,8 @@ libFieldDescrs = , commaListFieldWithSep vcat "reexported-modules" disp parse reexportedModules (\mods lib -> lib{reexportedModules=mods}) - , listFieldWithSep vcat "required-signatures" disp parseModuleNameQ - requiredSignatures (\mods lib -> lib{requiredSignatures=mods}) + , listFieldWithSep vcat "signatures" disp parseModuleNameQ + signatures (\mods lib -> lib{signatures=mods}) , boolField "exposed" libExposed (\val lib -> lib{libExposed=val}) @@ -371,6 +372,16 @@ validateBenchmark line stanza = -- --------------------------------------------------------------------------- -- The BuildInfo type +showBackpackInclude :: (PackageName, IncludeRenaming) -> Doc +showBackpackInclude (pkg_name, incl) = do + disp pkg_name <+> disp incl + +parseBackpackInclude :: ReadP r (PackageName, IncludeRenaming) +parseBackpackInclude = do + pkg_name <- parse + skipSpaces + incl <- parse + return (pkg_name, incl) binfoFieldDescrs :: [FieldDescr BuildInfo] binfoFieldDescrs = @@ -382,6 +393,9 @@ binfoFieldDescrs = , commaListFieldWithSep vcat "build-depends" disp parse targetBuildDepends (\xs binfo -> binfo{targetBuildDepends=xs}) + , commaListFieldWithSep vcat "backpack-includes" + showBackpackInclude parseBackpackInclude + backpackIncludes (\xs binfo -> binfo{backpackIncludes=xs}) , spaceListField "cpp-options" showToken parseTokenQ' cppOptions (\val binfo -> binfo{cppOptions=val}) diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index 9daafd53caf..8fbe360bb67 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -33,6 +33,7 @@ import Distribution.Types.LocalBuildInfo import Distribution.Types.TargetInfo import Distribution.Package +import Distribution.Backpack import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.JHC as JHC @@ -67,10 +68,9 @@ import Distribution.Verbosity import Distribution.Compat.Graph (IsNode(..)) -import qualified Data.Map as Map import qualified Data.Set as Set import Data.List ( intersect ) -import System.FilePath ( (), (<.>) ) +import System.FilePath ( (), (<.>), takeDirectory ) import System.Directory ( getCurrentDirectory ) -- ----------------------------------------------------------------------------- @@ -224,6 +224,7 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr (mkAbiHash "") lib' lbi clbi + debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo) registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.MultiInstance (withPackageDB lbi) installedPkgInfo @@ -416,23 +417,25 @@ testSuiteLibV09AsLibAndExe pkg_descr libName = Nothing, exposedModules = [ m ], reexportedModules = [], - requiredSignatures = [], + signatures = [], libExposed = True, libBuildInfo = bi } -- 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 - compat_name = computeCompatPackageName pkg_name (CTestName (testName test)) + compat_name = computeCompatPackageName pkg_name (CTestName (testName test)) (Just (componentUnitId clbi)) compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi) libClbi = LibComponentLocalBuildInfo { componentPackageDeps = componentPackageDeps clbi , componentInternalDeps = componentInternalDeps clbi + , componentIsIndefinite_ = False , componentExeDeps = componentExeDeps clbi , componentLocalName = CSubLibName (testName test) , componentIsPublic = False , componentIncludes = componentIncludes clbi , componentUnitId = componentUnitId clbi + , componentInstantiatedWith = [] , componentCompatPackageName = compat_name , componentCompatPackageKey = compat_key , componentExposedModules = [IPI.ExposedModule m Nothing] @@ -454,8 +457,7 @@ testSuiteLibV09AsLibAndExe pkg_descr buildInfo = (testBuildInfo test) { hsSourceDirs = [ testDir ], targetBuildDepends = testLibDep - : (targetBuildDepends $ testBuildInfo test), - targetBuildRenaming = Map.empty + : (targetBuildDepends $ testBuildInfo test) } } -- | The stub executable needs a new 'ComponentLocalBuildInfo' @@ -472,7 +474,11 @@ testSuiteLibV09AsLibAndExe pkg_descr componentExeDeps = [], componentLocalName = CExeName (stubName test), componentPackageDeps = deps, - componentIncludes = zip (map fst deps) (repeat defaultRenaming) + -- Assert DefUnitId invariant! + -- Executable can't be indefinite, so dependencies must + -- be definite packages. + componentIncludes = zip (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps) + (repeat defaultRenaming) } testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" @@ -586,5 +592,21 @@ writeAutogenFiles verbosity pkg lbi clbi = do ModuleName.toFilePath (autogenPathsModuleName pkg) <.> "hs" rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi clbi) + --TODO: document what we're doing here, and move it to its own function + case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> + -- Write out empty hsig files for all requirements, so that GHC + -- has a source file to look at it when it needs to typecheck + -- a signature. It's harmless to write these out even when + -- there is a real hsig file written by the user, since + -- include path ordering ensures that the real hsig file + -- will always be picked up before the autogenerated one. + for_ (map fst insts) $ \mod_name -> do + let sigPath = autogenComponentModulesDir lbi clbi + ModuleName.toFilePath mod_name <.> "hsig" + createDirectoryIfMissingVerbose verbosity True (takeDirectory sigPath) + rewriteFile sigPath $ "signature " ++ display mod_name ++ " where" + _ -> return () + let cppHeaderPath = autogenComponentModulesDir lbi clbi cppHeaderName rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi clbi) diff --git a/Cabal/Distribution/Simple/BuildTarget.hs b/Cabal/Distribution/Simple/BuildTarget.hs index 328b3f43334..ee5132508ab 100644 --- a/Cabal/Distribution/Simple/BuildTarget.hs +++ b/Cabal/Distribution/Simple/BuildTarget.hs @@ -479,7 +479,14 @@ componentStringName _ (CTestName name) = name componentStringName _ (CBenchName name) = name componentModules :: Component -> [ModuleName] -componentModules (CLib lib) = libModules lib +-- TODO: Use of 'explicitLibModules' here is a bit wrong: +-- a user could very well ask to build a specific signature +-- that was inherited from other packages. To fix this +-- we have to plumb 'LocalBuildInfo' through this code. +-- Fortunately, this is only used by 'pkgComponentInfo' +-- Please don't export this function unless you plan on fixing +-- this. +componentModules (CLib lib) = explicitLibModules lib componentModules (CExe exe) = exeModules exe componentModules (CTest test) = testModules test componentModules (CBench bench) = benchmarkModules bench diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index cb4e31e8533..c619e2534e0 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -36,7 +36,6 @@ module Distribution.Simple.Configure (configure, tryGetPersistBuildConfig, maybeGetPersistBuildConfig, findDistPref, findDistPrefOrDefault, - mkComponentsGraph, getInternalPackages, computeComponentId, computeCompatPackageKey, @@ -62,25 +61,23 @@ import Prelude () import Distribution.Compat.Prelude import Distribution.Compiler +import Distribution.Types.IncludeRenaming import Distribution.Utils.NubList import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.PreProcess import Distribution.Package import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.InstalledPackageInfo (InstalledPackageInfo - ,emptyInstalledPackageInfo) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.PackageDescription as PD hiding (Flag) import Distribution.Types.PackageDescription as PD -import Distribution.ModuleName import Distribution.PackageDescription.PrettyPrint import Distribution.PackageDescription.Configuration import Distribution.PackageDescription.Check hiding (doesFileExist) import Distribution.Simple.Program import Distribution.Simple.Setup as Setup import Distribution.Simple.BuildTarget -import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo import Distribution.Types.LocalBuildInfo import Distribution.Types.ComponentRequestedSpec @@ -90,8 +87,12 @@ import Distribution.System import Distribution.Version import Distribution.Verbosity import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph (Node(..)) import Distribution.Compat.Stack +import Distribution.Backpack.Configure +import Distribution.Backpack.PreExistingComponent +import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) +import Distribution.Backpack.Id +import Distribution.Utils.LogProgress import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS @@ -103,7 +104,6 @@ import qualified Distribution.Simple.HaskellSuite as HaskellSuite import Control.Exception ( ErrorCall, Exception, evaluate, throw, throwIO, try ) import Distribution.Compat.Binary ( decodeOrFailIO, encode ) -import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BLC8 @@ -111,10 +111,7 @@ import Data.List ( (\\), partition, inits, stripPrefix ) import Data.Either ( partitionEithers ) -import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import Numeric ( showIntAtBase ) import System.Directory ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) import System.FilePath @@ -131,6 +128,8 @@ import Text.PrettyPrint import Distribution.Compat.Environment ( lookupEnv ) import Distribution.Compat.Exception ( catchExit, catchIO ) +type UseExternalInternalDeps = Bool + -- | The errors that can be thrown when reading the @setup-config@ file. data ConfigStateFileError = ConfigStateFileNoHeader -- ^ No header found. @@ -490,9 +489,7 @@ configure (pkg_descr0', pbi) cfg = do (updatePackageDescription pbi pkg_descr) -- The list of 'InstalledPackageInfo' recording the selected - -- dependencies... - -- internalPkgDeps: ...on internal packages - -- externalPkgDeps: ...on external packages + -- dependencies on external packages. -- -- Invariant: For any package name, there is at most one package -- in externalPackageDeps which has that name. @@ -503,8 +500,16 @@ configure (pkg_descr0', pbi) cfg = do -- if *any* component (post-flag resolution) has an unsatisfiable -- dependency, we will fail. This can sometimes be undesirable -- for users, see #1786 (benchmark conflicts with executable), - (internalPkgDeps :: [PackageId], - externalPkgDeps :: [InstalledPackageInfo]) + -- + -- In the presence of Backpack, these package dependencies are + -- NOT complete: they only ever include the INDEFINITE + -- dependencies. After we apply an instantiation, we'll get + -- definite references which constitute extra dependencies. + -- (Why not have cabal-install pass these in explicitly? + -- For one it's deterministic; for two, we need to associate + -- them with renamings which would require a far more complicated + -- input scheme than what we have today.) + externalPkgDeps :: [(PackageName, InstalledPackageInfo)] <- configureDependencies verbosity use_external_internal_deps @@ -513,68 +518,6 @@ configure (pkg_descr0', pbi) cfg = do requiredDepsMap pkg_descr - -- The database of transitively reachable installed packages that the - -- external components the package (as a whole) depends on. This will be - -- used in several ways: - -- - -- * We'll use it to do a consistency check so we're not depending - -- on multiple versions of the same package (TODO: someday relax - -- this for private dependencies.) See right below. - -- - -- * We feed it in when configuring the components to resolve - -- module reexports. (TODO: axe this.) - -- - -- * We'll pass it on in the LocalBuildInfo, where preprocessors - -- and other things will incorrectly use it to determine what - -- the include paths and everything should be. - -- - packageDependsIndex :: InstalledPackageIndex <- - case PackageIndex.dependencyClosure installedPackageSet - (map Installed.installedUnitId externalPkgDeps) of - Left packageDependsIndex -> return packageDependsIndex - Right broken -> - die $ "The following installed packages are broken because other" - ++ " packages they depend on are missing. These broken " - ++ "packages must be rebuilt before they can be used.\n" - ++ unlines [ "package " - ++ display (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map display deps) - | (pkg, deps) <- broken ] - - -- In this section, we'd like to look at the 'packageDependsIndex' - -- and see if we've picked multiple versions of the same - -- installed package (this is bad, because it means you might - -- get an error could not match foo-0.1:Type with foo-0.2:Type). - -- - -- What is pseudoTopPkg for? I have no idea. It was used - -- in the very original commit which introduced checking for - -- inconsistencies 5115bb2be4e13841ea07dc9166b9d9afa5f0d012, - -- and then moved out of PackageIndex and put here later. - -- TODO: Try this code without it... - -- - -- TODO: Move this into a helper function - let pseudoTopPkg :: InstalledPackageInfo - pseudoTopPkg = emptyInstalledPackageInfo { - Installed.installedUnitId = - mkLegacyUnitId (packageId pkg_descr), - Installed.sourcePackageId = packageId pkg_descr, - Installed.depends = - map Installed.installedUnitId externalPkgDeps - } - case PackageIndex.dependencyInconsistencies - . PackageIndex.insert pseudoTopPkg - $ packageDependsIndex of - [] -> return () - inconsistencies -> - warn verbosity $ - "This package indirectly depends on multiple versions of the same " - ++ "package. This is highly likely to cause a compile failure.\n" - ++ unlines [ "package " ++ display pkg ++ " requires " - ++ display (PackageIdentifier name ver) - | (name, uses) <- inconsistencies - , (pkg, ver) <- uses ] - -- Compute installation directory templates, based on user -- configuration. -- @@ -636,14 +579,23 @@ configure (pkg_descr0', pbi) cfg = do -- components (which may build-depends on each other) and form a graph. -- From there, we build a ComponentLocalBuildInfo for each of the -- components, which lets us actually build each component. - buildComponents <- - case mkComponentsGraph enabled pkg_descr internalPackageSet of - Left componentCycle -> reportComponentCycle componentCycle - Right comps -> - mkComponentsLocalBuildInfo cfg use_external_internal_deps comp - packageDependsIndex pkg_descr - internalPkgDeps externalPkgDeps - comps (configConfigurationsFlags cfg) + -- internalPackageSet + -- use_external_internal_deps + (buildComponents :: [ComponentLocalBuildInfo], + packageDependsIndex :: InstalledPackageIndex) <- + let prePkgDeps = map ipiToPreExistingComponent externalPkgDeps + in runLogProgress verbosity $ configureComponentLocalBuildInfos + verbosity + use_external_internal_deps + enabled + (configIPID cfg) + (configCID cfg) + pkg_descr + prePkgDeps + (configConfigurationsFlags cfg) + (configInstantiateWith cfg) + installedPackageSet + comp -- Decide if we're going to compile with split objects. split_objs :: Bool <- @@ -999,9 +951,8 @@ configureFinalizedPackage verbosity cfg enabled checkCompilerProblems :: Compiler -> PackageDescription -> ComponentRequestedSpec -> IO () checkCompilerProblems comp pkg_descr enabled = do unless (renamingPackageFlagsSupported comp || - and [ True - | bi <- enabledBuildInfos pkg_descr enabled - , _ <- Map.elems (targetBuildRenaming bi)]) $ + all (all (isDefaultIncludeRenaming . snd) . backpackIncludes) + (enabledBuildInfos pkg_descr enabled)) $ die $ "Your compiler does not support thinning and renaming on " ++ "package flags. To use this feature you probably must use " ++ "GHC 7.9 or later." @@ -1011,8 +962,6 @@ checkCompilerProblems comp pkg_descr enabled = do die $ "Your compiler does not support module re-exports. To use " ++ "this feature you probably must use GHC 7.9 or later." -type UseExternalInternalDeps = Bool - -- | Select dependencies for the package. configureDependencies :: Verbosity @@ -1021,7 +970,7 @@ configureDependencies -> InstalledPackageIndex -- ^ installed packages -> Map PackageName InstalledPackageInfo -- ^ required deps -> PackageDescription - -> IO ([PackageId], [InstalledPackageInfo]) + -> IO [(PackageName, InstalledPackageInfo)] configureDependencies verbosity use_external_internal_deps internalPackageSet installedPackageSet requiredDepsMap pkg_descr = do let selectDependencies :: [Dependency] -> @@ -1037,8 +986,11 @@ configureDependencies verbosity use_external_internal_deps internalPkgDeps = [ pkgid | InternalDependency _ pkgid <- allPkgDeps ] - externalPkgDeps = [ pkg - | ExternalDependency _ pkg <- allPkgDeps ] + -- NB: we have to SAVE the package name, because this is the only + -- way we can be able to resolve package names in the package + -- description. + externalPkgDeps = [ (pn, pkg) + | ExternalDependency (Dependency pn _) pkg <- allPkgDeps ] when (not (null internalPkgDeps) && not (newPackageDepsBehaviour pkg_descr)) $ @@ -1051,7 +1003,7 @@ configureDependencies verbosity use_external_internal_deps reportFailedDependencies failedDeps reportSelectedDependencies verbosity allPkgDeps - return (internalPkgDeps, externalPkgDeps) + return externalPkgDeps -- | Select and apply coverage settings for the build based on the -- 'ConfigFlags' and 'Compiler'. @@ -1231,15 +1183,17 @@ selectDependency pkgid internalIndex installedIndex requiredDepsMap case is_internal of Just cname -> DependencyMissingInternal dep_pkgname (computeCompatPackageName - (packageName pkgid) cname) + (packageName pkgid) cname Nothing) Nothing -> DependencyNotExists dep_pkgname pkgs -> Right $ ExternalDependency dep $ case last pkgs of (_ver, pkginstances) -> head pkginstances where dep' | Just cname <- is_internal - = Dependency (computeCompatPackageName (packageName pkgid) cname) vr + = Dependency (computeCompatPackageName (packageName pkgid) cname Nothing) vr | otherwise = dep + -- NB: here computeCompatPackageName we want to pick up the INDEFINITE ones + -- which is why we pass 'Nothing' as 'UnitId' reportSelectedDependencies :: Verbosity -> [ResolvedDependency] -> IO () @@ -1345,18 +1299,6 @@ interpretPackageDbFlags userInstall specificDBs = extra _ (Nothing:dbs) = extra [] dbs extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs -newPackageDepsBehaviourMinVersion :: Version -newPackageDepsBehaviourMinVersion = mkVersion [1,7,1] - --- In older cabal versions, there was only one set of package dependencies for --- the whole package. In this version, we can have separate dependencies per --- target, but we only enable this behaviour if the minimum cabal version --- specified is >= a certain minimum. Otherwise, for compatibility we use the --- old behaviour. -newPackageDepsBehaviour :: PackageDescription -> Bool -newPackageDepsBehaviour pkg = - specVersion pkg >= newPackageDepsBehaviourMinVersion - -- We are given both --constraint="foo < 2.0" style constraints and also -- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581". -- @@ -1598,495 +1540,6 @@ configCompilerAux :: ConfigFlags -> IO (Compiler, ProgramDb) configCompilerAux = fmap (\(a,_,b) -> (a,b)) . configCompilerAuxEx --- ----------------------------------------------------------------------------- --- Making the internal component graph - --- | Given the package description and the set of package names which --- are considered internal (the current package name and any internal --- libraries are considered internal), create a graph of dependencies --- between the components. This is NOT necessarily the build order --- (although it is in the absence of Backpack.) -mkComponentsGraph :: ComponentRequestedSpec - -> PackageDescription - -> Map PackageName ComponentName - -> Either [ComponentName] - [(Component, [ComponentName])] -mkComponentsGraph enabled pkg_descr internalPackageSet = - let g = Graph.fromList [ N c (componentName c) (componentDeps c) - | c <- pkgBuildableComponents pkg_descr - , componentEnabled enabled c ] - in case Graph.cycles g of - [] -> Right (map (\(N c _ cs) -> (c, cs)) (Graph.revTopSort g)) - ccycles -> Left [ componentName c | N c _ _ <- concat ccycles ] - where - -- The dependencies for the given component - componentDeps component = - [ CExeName (unPackageName toolpname) - | Dependency toolpname _ <- buildTools bi - , unPackageName toolpname `elem` map exeName (executables pkg_descr) ] - ++ [ cname - | Dependency pkgname _ <- targetBuildDepends bi - , cname <- Maybe.maybeToList (Map.lookup pkgname internalPackageSet) ] - where - bi = componentBuildInfo component - -reportComponentCycle :: [ComponentName] -> IO a -reportComponentCycle cnames = - die $ "Components in the package depend on each other in a cyclic way:\n " - ++ intercalate " depends on " - [ "'" ++ showComponentName cname ++ "'" - | cname <- cnames ++ [head cnames] ] - --- | This method computes a default, "good enough" 'ComponentId' --- for a package. The intent is that cabal-install (or the user) will --- specify a more detailed IPID via the @--ipid@ flag if necessary. -computeComponentId - :: Flag String - -> Flag ComponentId - -> PackageIdentifier - -> ComponentName - -- TODO: careful here! - -> [ComponentId] -- IPIDs of the component dependencies - -> FlagAssignment - -> ComponentId -computeComponentId mb_ipid mb_cid pid cname dep_ipids flagAssignment = - -- show is found to be faster than intercalate and then replacement of - -- special character used in intercalating. We cannot simply hash by - -- doubly concating list, as it just flatten out the nested list, so - -- different sources can produce same hash - let hash = hashToBase62 $ - -- For safety, include the package + version here - -- for GHC 7.10, where just the hash is used as - -- the package key - display pid - ++ show dep_ipids - ++ show flagAssignment - generated_base = display pid ++ "-" ++ hash - explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env - (toPathTemplate cid0)) - -- Hack to reuse install dirs machinery - -- NB: no real IPID available at this point - where env = packageTemplateEnv pid (mkUnitId "") - actual_base = case mb_ipid of - Flag ipid0 -> explicit_base ipid0 - NoFlag -> generated_base - in case mb_cid of - Flag cid -> cid - NoFlag -> mkComponentId $ actual_base - ++ (case componentNameString cname of - Nothing -> "" - Just s -> "-" ++ s) - -hashToBase62 :: String -> String -hashToBase62 s = showFingerprint $ fingerprintString s - where - showIntAtBase62 x = showIntAtBase 62 representBase62 x "" - representBase62 x - | x < 10 = chr (48 + x) - | x < 36 = chr (65 + x - 10) - | x < 62 = chr (97 + x - 36) - | otherwise = '@' - showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b - --- | Computes the package name for a library. If this is the public --- library, it will just be the original package name; otherwise, --- it will be a munged package name recording the original package --- name as well as the name of the internal library. --- --- A lot of tooling in the Haskell ecosystem assumes that if something --- is installed to the package database with the package name 'foo', --- then it actually is an entry for the (only public) library in package --- 'foo'. With internal packages, this is not necessarily true: --- a public library as well as arbitrarily many internal libraries may --- come from the same package. To prevent tools from getting confused --- in this case, the package name of these internal libraries is munged --- so that they do not conflict the public library proper. --- --- We munge into a reserved namespace, "z-", and encode both the --- component name and the package name of an internal library using the --- following format: --- --- compat-pkg-name ::= "z-" package-name "-z-" library-name --- --- where package-name and library-name have "-" ( "z" + ) "-" --- segments encoded by adding an extra "z". --- --- When we have the public library, the compat-pkg-name is just the --- package-name, no surprises there! --- -computeCompatPackageName :: PackageName -> ComponentName -> PackageName -computeCompatPackageName pkg_name cname - | Just cname_str <- componentNameString cname - = let zdashcode s = go s (Nothing :: Maybe Int) [] - where go [] _ r = reverse r - go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r) - go ('-':z) _ r = go z (Just 0) ('-':r) - go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r) - go (c:z) _ r = go z Nothing (c:r) - in mkPackageName $ "z-" ++ zdashcode (display pkg_name) - ++ "-z-" ++ zdashcode cname_str - | otherwise - = pkg_name - --- | In GHC 8.0, the string we pass to GHC to use for symbol --- names for a package can be an arbitrary, IPID-compatible string. --- However, prior to GHC 8.0 there are some restrictions on what --- format this string can be (due to how ghc-pkg parsed the key): --- --- 1. In GHC 7.10, the string had either be of the form --- foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated --- prefix and ABCD is two base-64 encoded 64-bit integers, --- or a GHC 7.8 style identifier. --- --- 2. In GHC 7.8, the string had to be a valid package identifier --- like foo-0.1. --- --- So, the problem is that Cabal, in general, has a general IPID, --- but needs to figure out a package key / package ID that the --- old ghc-pkg will actually accept. But there's an EVERY WORSE --- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx --- as if it were a package identifier, which means it will SILENTLY --- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.) --- So we must CONNIVE to ensure that we don't pick something that --- looks like this. --- --- So this function attempts to define a mapping into the old formats. --- --- The mapping for GHC 7.8 and before: --- --- * We use the *compatibility* package name and version. For --- public libraries this is just the package identifier; for --- internal libraries, it's something like "z-pkgname-z-libname-0.1". --- See 'computeCompatPackageName' for more details. --- --- The mapping for GHC 7.10: --- --- * For CLibName: --- If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would --- validly parse as a package key, we pass "ABCDEF". (NB: not --- all hashes parse this way, because GHC 7.10 mandated that --- these hashes be two base-62 encoded 64 bit integers), --- but hashes that Cabal generated using 'computeComponentId' --- are guaranteed to have this form. --- --- If it is not of this form, we rehash the IPID into the --- correct form and pass that. --- --- * For sub-components, we rehash the IPID into the correct format --- and pass that. --- -computeCompatPackageKey - :: Compiler - -> PackageName - -> Version - -> UnitId - -> String -computeCompatPackageKey comp pkg_name pkg_version (SimpleUnitId cid) - | not (packageKeySupported comp) = - display pkg_name ++ "-" ++ display pkg_version - | not (unifiedIPIDRequired comp) = - let mb_verbatim_key - = case simpleParse str :: Maybe PackageId of - -- Something like 'foo-0.1', use it verbatim. - -- (NB: hash tags look like tags, so they are parsed, - -- so the extra equality check tests if a tag was dropped.) - Just pid0 | display pid0 == str -> Just str - _ -> Nothing - mb_truncated_key - = let cand = reverse (takeWhile isAlphaNum (reverse str)) - in if length cand == 22 && all isAlphaNum cand - then Just cand - else Nothing - rehashed_key = hashToBase62 str - in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key) - | otherwise = str - where - str = unComponentId cid - -mkComponentsLocalBuildInfo :: ConfigFlags - -> UseExternalInternalDeps - -> Compiler - -> InstalledPackageIndex - -> PackageDescription - -> [PackageId] -- internal package deps - -> [InstalledPackageInfo] -- external package deps - -> [(Component, [ComponentName])] - -> FlagAssignment - -> IO [ComponentLocalBuildInfo] -mkComponentsLocalBuildInfo cfg use_external_internal comp installedPackages - pkg_descr internalPkgDeps externalPkgDeps - graph flagAssignment = - foldM go [] graph - where - go z (component, dep_cnames) = do - clbi <- componentLocalBuildInfo z component dep_cnames - return (clbi:z) - - -- The allPkgDeps contains all the package deps for the whole package - -- but we need to select the subset for this specific component. - -- we just take the subset for the package names this component - -- needs. Note, this only works because we cannot yet depend on two - -- versions of the same package. - componentLocalBuildInfo :: [ComponentLocalBuildInfo] - -> Component -> [ComponentName] - -> IO ComponentLocalBuildInfo - componentLocalBuildInfo internalComps component dep_cnames = - -- NB: We want to preserve cdeps because it contains extra - -- information like build-tools ordering - let dep_uids = [ componentUnitId dep_clbi - | cname <- dep_cnames - , dep_clbi <- internalComps - , componentLocalName dep_clbi == cname ] - dep_exes = [ componentUnitId dep_clbi - | cname@(CExeName _) <- dep_cnames - , dep_clbi <- internalComps - , componentLocalName dep_clbi == cname ] - in - -- (putStrLn $ "configuring " ++ display (componentName component)) >> - case component of - CLib lib -> do - let exports = map (\n -> Installed.ExposedModule n Nothing) - (PD.exposedModules lib) - mb_reexports = resolveModuleReexports installedPackages - (packageId pkg_descr) - uid - externalPkgDeps lib - reexports <- case mb_reexports of - Left problems -> reportModuleReexportProblems problems - Right r -> return r - - return LibComponentLocalBuildInfo { - componentPackageDeps = cpds, - componentInternalDeps = dep_uids, - componentExeDeps = dep_exes, - componentUnitId = uid, - componentLocalName = componentName component, - componentIsPublic = libName lib == Nothing, - componentCompatPackageKey = compat_key, - componentCompatPackageName = compat_name, - componentIncludes = includes, - componentExposedModules = exports ++ reexports - } - CExe _ -> - return ExeComponentLocalBuildInfo { - componentUnitId = uid, - componentInternalDeps = dep_uids, - componentExeDeps = dep_exes, - componentLocalName = componentName component, - componentPackageDeps = cpds, - componentIncludes = includes - } - CTest _ -> - return TestComponentLocalBuildInfo { - componentUnitId = uid, - componentInternalDeps = dep_uids, - componentExeDeps = dep_exes, - componentLocalName = componentName component, - componentPackageDeps = cpds, - componentIncludes = includes - } - CBench _ -> - return BenchComponentLocalBuildInfo { - componentUnitId = uid, - componentInternalDeps = dep_uids, - componentExeDeps = dep_exes, - componentLocalName = componentName component, - componentPackageDeps = cpds, - componentIncludes = includes - } - where - - cid = computeComponentId (configIPID cfg) (configCID cfg) - (package pkg_descr) - (componentName component) - (getDeps (componentName component)) - flagAssignment - uid = SimpleUnitId cid - PackageIdentifier pkg_name pkg_ver = package pkg_descr - compat_name = computeCompatPackageName pkg_name (componentName component) - compat_key = computeCompatPackageKey comp compat_name pkg_ver uid - - bi = componentBuildInfo component - - lookupInternalPkg :: PackageId -> UnitId - lookupInternalPkg pkgid = do - let matcher clbi - | CLibName <- componentLocalName clbi - , pkgName pkgid == packageName pkg_descr - = Just (componentUnitId clbi) - | CSubLibName str <- componentLocalName clbi - , str == display (pkgName pkgid) - = Just (componentUnitId clbi) - matcher _ = Nothing - case catMaybes (map matcher internalComps) of - [x] -> x - _ -> error $ "lookupInternalPkg " ++ display pkgid - ++ " " ++ intercalate ", " - (map (display . componentUnitId) internalComps) - - cpds = if newPackageDepsBehaviour pkg_descr - then dedup $ - [ (Installed.installedUnitId pkg, packageId pkg) - | pkg <- selectSubset bi externalPkgDeps ] - ++ [ (lookupInternalPkg pkgid, pkgid) - | pkgid <- selectSubset bi internalPkgDeps ] - else [ (Installed.installedUnitId pkg, packageId pkg) - | pkg <- externalPkgDeps ] - includes = map (\(i,p) -> (i,lookupRenaming p cprns)) cpds - cprns = if newPackageDepsBehaviour pkg_descr - then targetBuildRenaming bi - else Map.empty - - dedup = Map.toList . Map.fromList - - -- TODO: this should include internal deps too - -- NB: This works correctly in per-component mode - getDeps :: ComponentName -> [ComponentId] - getDeps cname = - let externalPkgs - = maybe [] (\lib -> selectSubset (componentBuildInfo lib) - externalPkgDeps) - (lookupComponent pkg_descr cname) - in map Installed.installedComponentId externalPkgs - - selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg] - selectSubset bi pkgs - -- No need to subset for one-component config: deps - -- is precisely what we want - | use_external_internal = pkgs - | otherwise = - [ pkg | pkg <- pkgs, packageName pkg `elem` names bi ] - - names :: BuildInfo -> [PackageName] - names bi = [ name | Dependency name _ <- targetBuildDepends bi ] - --- | Given the author-specified re-export declarations from the .cabal file, --- resolve them to the form that we need for the package database. --- --- An invariant of the package database is that we always link the re-export --- directly to its original defining location (rather than indirectly via a --- chain of re-exporting packages). --- -resolveModuleReexports :: InstalledPackageIndex - -> PackageId - -> UnitId - -> [InstalledPackageInfo] - -> Library - -> Either [(ModuleReexport, String)] -- errors - [Installed.ExposedModule] -- ok -resolveModuleReexports installedPackages srcpkgid key externalPkgDeps lib = - case partitionEithers - (map resolveModuleReexport (PD.reexportedModules lib)) of - ([], ok) -> Right ok - (errs, _) -> Left errs - where - -- A mapping from visible module names to their original defining - -- module name. We also record the package name of the package which - -- *immediately* provided the module (not the original) to handle if the - -- user explicitly says which build-depends they want to reexport from. - visibleModules :: Map ModuleName [(PackageName, Installed.ExposedModule)] - visibleModules = - Map.fromListWith (++) $ - [ (Installed.exposedName exposedModule, [(exportingPackageName, - exposedModule)]) - -- The package index here contains all the indirect deps of the - -- package we're configuring, but we want just the direct deps - | let directDeps = Set.fromList - (map Installed.installedUnitId externalPkgDeps) - , pkg <- PackageIndex.allPackages installedPackages - , Installed.installedUnitId pkg `Set.member` directDeps - , let exportingPackageName = packageName pkg - , exposedModule <- visibleModuleDetails pkg - ] - ++ [ (visibleModuleName, [(exportingPackageName, exposedModule)]) - | visibleModuleName <- PD.exposedModules lib - ++ otherModules (libBuildInfo lib) - , let exportingPackageName = packageName srcpkgid - definingModuleName = visibleModuleName - definingPackageId = key - originalModule = Module definingPackageId - definingModuleName - exposedModule = Installed.ExposedModule visibleModuleName - (Just originalModule) - ] - - -- All the modules exported from this package and their defining name and - -- package (either defined here in this package or re-exported from some - -- other package). Return an ExposedModule because we want to hold onto - -- signature information. - visibleModuleDetails :: InstalledPackageInfo -> [Installed.ExposedModule] - visibleModuleDetails pkg = do - exposedModule <- Installed.exposedModules pkg - case Installed.exposedReexport exposedModule of - -- The first case is the modules actually defined in this package. - -- In this case the reexport will point to this package. - Nothing -> return exposedModule { - Installed.exposedReexport = - Just (Module - (Installed.installedUnitId pkg) - (Installed.exposedName exposedModule)) } - -- On the other hand, a visible module might actually be itself - -- a re-export! In this case, the re-export info for the package - -- doing the re-export will point us to the original defining - -- module name and package, so we can reuse the entry. - Just _ -> return exposedModule - - resolveModuleReexport reexport@ModuleReexport { - moduleReexportOriginalPackage = moriginalPackageName, - moduleReexportOriginalName = originalName, - moduleReexportName = newName - } = - - let filterForSpecificPackage = - case moriginalPackageName of - Nothing -> id - Just originalPackageName -> - filter (\(pkgname, _) -> pkgname == originalPackageName) - - matches = filterForSpecificPackage - (Map.findWithDefault [] originalName visibleModules) - in - case (matches, moriginalPackageName) of - ((_, exposedModule):rest, _) - -- TODO: Refine this check for signatures - | all (\(_, exposedModule') -> - Installed.exposedReexport exposedModule - == Installed.exposedReexport exposedModule') rest - -> Right exposedModule { Installed.exposedName = newName } - - ([], Just originalPackageName) - -> Left $ (,) reexport - $ "The package " ++ display originalPackageName - ++ " does not export a module " ++ display originalName - - ([], Nothing) - -> Left $ (,) reexport - $ "The module " ++ display originalName - ++ " is not exported by any suitable package (this package " - ++ "itself nor any of its 'build-depends' dependencies)." - - (ms, _) - -> Left $ (,) reexport - $ "The module " ++ display originalName ++ " is exported " - ++ "by more than one package (" - ++ intercalate ", " [ display pkgname | (pkgname,_) <- ms ] - ++ ") and so the re-export is ambiguous. The ambiguity can " - ++ "be resolved by qualifying by the package name. The " - ++ "syntax is 'packagename:moduleName [as newname]'." - - -- Note: if in future Cabal allows directly depending on multiple - -- instances of the same package (e.g. backpack) then an additional - -- ambiguity case is possible here: (_, Just originalPackageName) - -- with the module being ambiguous despite being qualified by a - -- package name. Presumably by that time we'll have a mechanism to - -- qualify the instance we're referring to. - -reportModuleReexportProblems :: [(ModuleReexport, String)] -> IO a -reportModuleReexportProblems reexportProblems = - die $ unlines - [ "Problem with the module re-export '" ++ display reexport ++ "': " ++ msg - | (reexport, msg) <- reexportProblems ] - -- ----------------------------------------------------------------------------- -- Testing C lib and header dependencies diff --git a/Cabal/Distribution/Simple/GHC.hs b/Cabal/Distribution/Simple/GHC.hs index 63fa0e85ab9..34da26c7199 100644 --- a/Cabal/Distribution/Simple/GHC.hs +++ b/Cabal/Distribution/Simple/GHC.hs @@ -66,6 +66,7 @@ import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo +import Distribution.Types.ComponentLocalBuildInfo import qualified Distribution.Simple.Hpc as Hpc import Distribution.Simple.BuildPaths import Distribution.Simple.Utils @@ -492,6 +493,7 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do ghcVersion = compilerVersion comp implInfo = getImplInfo comp platform@(Platform _hostArch hostOS) = hostPlatform lbi + has_code = not (componentIsIndefinite clbi) (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) let runGhcProg = runGHC verbosity ghcProg comp platform @@ -528,7 +530,7 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do vanillaOpts = baseOpts `mappend` mempty { ghcOptMode = toFlag GhcModeMake, ghcOptNumJobs = numJobs, - ghcOptInputModules = toNubListR $ libModules lib, + ghcOptInputModules = toNubListR $ allLibModules lib clbi, ghcOptHPCDir = hpcdir Hpc.Vanilla } @@ -580,14 +582,17 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do ghcOptHPCDir = hpcdir Hpc.Dyn } - unless (forRepl || null (libModules lib)) $ + unless (forRepl || null (allLibModules lib clbi)) $ do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts) shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts) useDynToo = dynamicTooSupported && (forceVanillaLib || withVanillaLib lbi) && (forceSharedLib || withSharedLib lbi) && null (hcSharedOptions GHC libBi) - if useDynToo + if not has_code + then vanilla + else + if useDynToo then do runGhcProg vanillaSharedOpts case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of @@ -603,10 +608,10 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do else if isGhcDynamic then do shared; vanilla else do vanilla; shared - whenProfLib (runGhcProg profOpts) + when has_code $ whenProfLib (runGhcProg profOpts) -- build any C sources - unless (null (cSources libBi)) $ do + unless (not has_code || null (cSources libBi)) $ do info verbosity "Building C Sources..." sequence_ [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo @@ -640,12 +645,12 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. - ifReplLib $ do - when (null (libModules lib)) $ warn verbosity "No exposed modules" + when has_code . ifReplLib $ do + when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" ifReplLib (runGhcProg replOpts) -- link: - unless forRepl $ do + when has_code . unless forRepl $ do info verbosity "Linking..." let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) (cSources libBi) @@ -663,28 +668,28 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do [ findFileWithExtension [objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- libModules lib ] + , x <- allLibModules lib clbi ] stubProfObjs <- catMaybes <$> sequenceA [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- libModules lib ] + , x <- allLibModules lib clbi ] stubSharedObjs <- catMaybes <$> sequenceA [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- libModules lib ] + , x <- allLibModules lib clbi ] - hObjs <- Internal.getHaskellObjects implInfo lib lbi + hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi libTargetDir objExtension True hProfObjs <- if withProfLib lbi - then Internal.getHaskellObjects implInfo lib lbi + then Internal.getHaskellObjects implInfo lib lbi clbi libTargetDir ("p_" ++ objExtension) True else return [] hSharedObjs <- if withSharedLib lbi - then Internal.getHaskellObjects implInfo lib lbi + then Internal.getHaskellObjects implInfo lib lbi clbi libTargetDir ("dyn_" ++ objExtension) False else return [] @@ -727,6 +732,14 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do else mempty, ghcOptNoAutoLinkPackages = toFlag True, ghcOptPackageDBs = withPackageDB lbi, + ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo { componentCompatPackageKey = pk } + -> toFlag pk + _ -> mempty, + ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } + -> insts + _ -> [], ghcOptPackages = toNubListR $ Internal.mkGhcOptPackages clbi , ghcOptLinkLibs = toNubListR $ extraLibs libBi, @@ -1145,10 +1158,11 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do whenShared $ copyModuleFiles "dyn_hi" -- copy the built library files over: - whenVanilla $ installOrdinary builtDir targetDir vanillaLibName - whenProf $ installOrdinary builtDir targetDir profileLibName - whenGHCi $ installOrdinary builtDir targetDir ghciLibName - whenShared $ installShared builtDir dynlibTargetDir sharedLibName + whenHasCode $ do + whenVanilla $ installOrdinary builtDir targetDir vanillaLibName + whenProf $ installOrdinary builtDir targetDir profileLibName + whenGHCi $ installOrdinary builtDir targetDir ghciLibName + whenShared $ installShared builtDir dynlibTargetDir sharedLibName where builtDir = componentBuildDir lbi clbi @@ -1169,7 +1183,7 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do installShared = install True copyModuleFiles ext = - findModuleFiles [builtDir] [ext] (libModules lib) + findModuleFiles [builtDir] [ext] (allLibModules lib clbi) >>= installOrdinaryFiles verbosity targetDir compiler_id = compilerId (compiler lbi) @@ -1179,12 +1193,14 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do ghciLibName = Internal.mkGHCiLibName uid sharedLibName = (mkSharedLibName compiler_id) uid - hasLib = not $ null (libModules lib) + hasLib = not $ null (allLibModules lib clbi) && null (cSources (libBuildInfo lib)) + has_code = not (componentIsIndefinite clbi) + whenHasCode = when has_code whenVanilla = when (hasLib && withVanillaLib lbi) - whenProf = when (hasLib && withProfLib lbi) - whenGHCi = when (hasLib && withGHCiLib lbi) - whenShared = when (hasLib && withSharedLib lbi) + whenProf = when (hasLib && withProfLib lbi && has_code) + whenGHCi = when (hasLib && withGHCiLib lbi && has_code) + whenShared = when (hasLib && withSharedLib lbi && has_code) -- ----------------------------------------------------------------------------- -- Registering diff --git a/Cabal/Distribution/Simple/GHC/IPI642.hs b/Cabal/Distribution/Simple/GHC/IPI642.hs index 14f1ad4ea53..c364858c0d9 100644 --- a/Cabal/Distribution/Simple/GHC/IPI642.hs +++ b/Cabal/Distribution/Simple/GHC/IPI642.hs @@ -69,6 +69,7 @@ toCurrent ipi@InstalledPackageInfo{} = in Current.InstalledPackageInfo { Current.sourcePackageId = pid, Current.installedUnitId = Current.mkLegacyUnitId pid, + Current.instantiatedWith = [], Current.compatPackageKey = "", Current.abiHash = Current.mkAbiHash "", -- bogus but old GHCs don't care. Current.license = convertLicense (license ipi), @@ -81,6 +82,7 @@ toCurrent ipi@InstalledPackageInfo{} = Current.synopsis = "", Current.description = description ipi, Current.category = category ipi, + Current.indefinite = False, Current.exposed = exposed ipi, Current.exposedModules = map (mkExposedModule . convertModuleName) (exposedModules ipi), Current.hiddenModules = map convertModuleName (hiddenModules ipi), diff --git a/Cabal/Distribution/Simple/GHC/Internal.hs b/Cabal/Distribution/Simple/GHC/Internal.hs index b5fb8446700..df507e4d3ee 100644 --- a/Cabal/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/Distribution/Simple/GHC/Internal.hs @@ -37,6 +37,8 @@ import Distribution.Compat.Prelude import Distribution.Simple.GHC.ImplInfo import Distribution.Package +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Backpack import Distribution.InstalledPackageInfo import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.PackageDescription as PD hiding (Flag) @@ -287,6 +289,11 @@ componentGhcOptions verbosity lbi bi clbi odir = LibComponentLocalBuildInfo { componentCompatPackageKey = pk } -> toFlag pk _ -> mempty, + ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } + -> insts + _ -> [], + ghcOptNoCode = toFlag $ componentIsIndefinite clbi, ghcOptPackageDBs = withPackageDB lbi, ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, ghcOptSplitObjs = toFlag (splitObjs lbi), @@ -356,12 +363,13 @@ ghcLookupProperty prop comp = -- when using -split-objs, we need to search for object files in the -- Module_split directory for each module. getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo + -> ComponentLocalBuildInfo -> FilePath -> String -> Bool -> NoCallStackIO [FilePath] -getHaskellObjects _implInfo lib lbi pref wanted_obj_ext allow_split_objs +getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs | splitObjs lbi && allow_split_objs = do let splitSuffix = "_" ++ wanted_obj_ext ++ "_split" dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) - | x <- libModules lib ] + | x <- allLibModules lib clbi ] objss <- traverse getDirectoryContents dirs let objs = [ dir obj | (objs',dir) <- zip objss dirs, obj <- objs', @@ -370,10 +378,10 @@ getHaskellObjects _implInfo lib lbi pref wanted_obj_ext allow_split_objs return objs | otherwise = return [ pref ModuleName.toFilePath x <.> wanted_obj_ext - | x <- libModules lib ] + | x <- allLibModules lib clbi ] mkGhcOptPackages :: ComponentLocalBuildInfo - -> [(UnitId, ModuleRenaming)] + -> [(OpenUnitId, ModuleRenaming)] mkGhcOptPackages = componentIncludes substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo diff --git a/Cabal/Distribution/Simple/GHCJS.hs b/Cabal/Distribution/Simple/GHCJS.hs index 7928eb6fa6c..217ee72ef51 100644 --- a/Cabal/Distribution/Simple/GHCJS.hs +++ b/Cabal/Distribution/Simple/GHCJS.hs @@ -317,7 +317,7 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do vanillaOptsNoJsLib = baseOpts `mappend` mempty { ghcOptMode = toFlag GhcModeMake, ghcOptNumJobs = numJobs, - ghcOptInputModules = toNubListR $ libModules lib, + ghcOptInputModules = toNubListR $ allLibModules lib clbi, ghcOptHPCDir = hpcdir Hpc.Vanilla } vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts @@ -363,7 +363,7 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do ghcOptHPCDir = hpcdir Hpc.Dyn } - unless (forRepl || (null (libModules lib) && null jsSrcs && null cObjs)) $ + unless (forRepl || (null (allLibModules lib clbi) && null jsSrcs && null cObjs)) $ do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) useDynToo = dynamicTooSupported && @@ -414,7 +414,7 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do -- TODO: problem here is we need the .c files built first, so we can load them -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. - unless (null (libModules lib)) $ + unless (null (allLibModules lib clbi)) $ ifReplLib (runGhcjsProg replOpts) -- link: @@ -430,16 +430,16 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do sharedLibFilePath = libTargetDir mkSharedLibName compiler_id uid ghciLibFilePath = libTargetDir Internal.mkGHCiLibName uid - hObjs <- Internal.getHaskellObjects implInfo lib lbi + hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi libTargetDir objExtension True hProfObjs <- if (withProfLib lbi) - then Internal.getHaskellObjects implInfo lib lbi + then Internal.getHaskellObjects implInfo lib lbi clbi libTargetDir ("p_" ++ objExtension) True else return [] hSharedObjs <- if (withSharedLib lbi) - then Internal.getHaskellObjects implInfo lib lbi + then Internal.getHaskellObjects implInfo lib lbi clbi libTargetDir ("dyn_" ++ objExtension) False else return [] @@ -726,7 +726,7 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do installSharedNative = install True False copyModuleFiles ext = - findModuleFiles [builtDir] [ext] (libModules lib) + findModuleFiles [builtDir] [ext] (allLibModules lib clbi) >>= installOrdinaryFiles verbosity targetDir compiler_id = compilerId (compiler lbi) @@ -736,7 +736,7 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do ghciLibName = Internal.mkGHCiLibName uid sharedLibName = (mkSharedLibName compiler_id) uid - hasLib = not $ null (libModules lib) + hasLib = not $ null (allLibModules lib clbi) && null (cSources (libBuildInfo lib)) whenVanilla = when (hasLib && withVanillaLib lbi) whenProf = when (hasLib && withProfLib lbi) diff --git a/Cabal/Distribution/Simple/Haddock.hs b/Cabal/Distribution/Simple/Haddock.hs index b11d737e8a0..df0317031f1 100644 --- a/Cabal/Distribution/Simple/Haddock.hs +++ b/Cabal/Distribution/Simple/Haddock.hs @@ -729,10 +729,10 @@ getLibSourceFiles :: LocalBuildInfo getLibSourceFiles lbi lib clbi = getSourceFiles searchpaths modules where bi = libBuildInfo lib - modules = PD.exposedModules lib ++ otherModules bi - searchpaths = autogenComponentModulesDir lbi clbi - : autogenPackageModulesDir lbi - : buildDir lbi : hsSourceDirs bi + modules = allLibModules lib clbi + searchpaths = componentBuildDir lbi clbi : hsSourceDirs bi ++ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi ] getExeSourceFiles :: LocalBuildInfo -> Executable @@ -753,10 +753,10 @@ getSourceFiles :: [FilePath] -> [ModuleName.ModuleName] -> IO [(ModuleName.ModuleName, FilePath)] getSourceFiles dirs modules = flip traverse modules $ \m -> fmap ((,) m) $ - findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m) + findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m) >>= maybe (notFound m) (return . normalise) where - notFound module_ = die $ "can't find source for module " ++ display module_ + notFound module_ = die $ "haddock: can't find source for module " ++ display module_ -- | The directory where we put build results for an executable exeBuildDir :: LocalBuildInfo -> Executable -> FilePath diff --git a/Cabal/Distribution/Simple/HaskellSuite.hs b/Cabal/Distribution/Simple/HaskellSuite.hs index e71a6debfd6..3dd567703a0 100644 --- a/Cabal/Distribution/Simple/HaskellSuite.hs +++ b/Cabal/Distribution/Simple/HaskellSuite.hs @@ -179,7 +179,7 @@ buildLib verbosity pkg_descr lbi lib clbi = do ["-G", display language] ++ concat [ ["-X", display ex] | ex <- usedExtensions bi ] ++ cppOptions (libBuildInfo lib) ++ - [ display modu | modu <- libModules lib ] + [ display modu | modu <- allLibModules lib clbi ] @@ -193,7 +193,7 @@ installLib -> Library -> ComponentLocalBuildInfo -> IO () -installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib _clbi = do +installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib clbi = do let progdb = withPrograms lbi runDbProgram verbosity haskellSuitePkgProgram progdb $ [ "install-library" @@ -201,7 +201,7 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib _clbi = do , "--target-dir", targetDir , "--dynlib-target-dir", dynlibTargetDir , "--package-id", display $ packageId pkg - ] ++ map display (libModules lib) + ] ++ map display (allLibModules lib clbi) registerPackage :: Verbosity diff --git a/Cabal/Distribution/Simple/InstallDirs.hs b/Cabal/Distribution/Simple/InstallDirs.hs index e3df56e2b88..76f02e3d980 100644 --- a/Cabal/Distribution/Simple/InstallDirs.hs +++ b/Cabal/Distribution/Simple/InstallDirs.hs @@ -402,10 +402,12 @@ initialPathTemplateEnv pkgId libname compiler platform = ++ abiTemplateEnv compiler platform packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv -packageTemplateEnv pkgId libname = +packageTemplateEnv pkgId uid = [(PkgNameVar, PathTemplate [Ordinary $ display (packageName pkgId)]) ,(PkgVerVar, PathTemplate [Ordinary $ display (packageVersion pkgId)]) - ,(LibNameVar, PathTemplate [Ordinary $ display libname]) + -- Invariant: uid is actually a HashedUnitId. Hard to enforce because + -- it's an API change. + ,(LibNameVar, PathTemplate [Ordinary $ display uid]) ,(PkgIdVar, PathTemplate [Ordinary $ display pkgId]) ] diff --git a/Cabal/Distribution/Simple/JHC.hs b/Cabal/Distribution/Simple/JHC.hs index e6d475ece21..61daa441283 100644 --- a/Cabal/Distribution/Simple/JHC.hs +++ b/Cabal/Distribution/Simple/JHC.hs @@ -125,7 +125,7 @@ buildLib verbosity pkg_descr lbi lib clbi = do writeFileAtomic pfile . BS.Char8.pack $ jhcPkgConf pkg_descr runProgram verbosity jhcProg $ ["--build-hl="++pfile, "-o", hlfile] ++ - args ++ map display (libModules lib) + args ++ map display (allLibModules lib clbi) -- | Building an executable for JHC. -- Currently C source files are not supported. diff --git a/Cabal/Distribution/Simple/LHC.hs b/Cabal/Distribution/Simple/LHC.hs index 5c7ddd5a2cf..bb57deaea81 100644 --- a/Cabal/Distribution/Simple/LHC.hs +++ b/Cabal/Distribution/Simple/LHC.hs @@ -312,7 +312,7 @@ buildLib verbosity pkg_descr lbi lib clbi = do let ghcArgs = ["-package-name", display pkgid ] ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity - ++ map display (libModules lib) + ++ map display (allLibModules lib clbi) lhcWrap x = ["--build-library", "--ghc-opts=" ++ unwords x] ghcArgsProf = ghcArgs ++ ["-prof", @@ -326,7 +326,7 @@ buildLib verbosity pkg_descr lbi lib clbi = do "-osuf", "dyn_o", "-fPIC" ] ++ hcSharedOptions GHC libBi - unless (null (libModules lib)) $ + unless (null (allLibModules lib clbi)) $ do ifVanillaLib forceVanillaLib (runGhcProg $ lhcWrap ghcArgs) ifProfLib (runGhcProg $ lhcWrap ghcArgsProf) ifSharedLib (runGhcProg $ lhcWrap ghcArgsShared) @@ -354,26 +354,26 @@ buildLib verbosity pkg_descr lbi lib clbi = do stubObjs <- fmap catMaybes $ sequenceA [ findFileWithExtension [objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] + | x <- allLibModules lib clbi ] stubProfObjs <- fmap catMaybes $ sequenceA [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] + | x <- allLibModules lib clbi ] stubSharedObjs <- fmap catMaybes $ sequenceA [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] + | x <- allLibModules lib clbi ] - hObjs <- getHaskellObjects lib lbi + hObjs <- getHaskellObjects lib lbi clbi pref objExtension True hProfObjs <- if (withProfLib lbi) - then getHaskellObjects lib lbi + then getHaskellObjects lib lbi clbi pref ("p_" ++ objExtension) True else return [] hSharedObjs <- if (withSharedLib lbi) - then getHaskellObjects lib lbi + then getHaskellObjects lib lbi clbi pref ("dyn_" ++ objExtension) False else return [] @@ -535,12 +535,12 @@ hackThreadedFlag verbosity comp prof bi -- when using -split-objs, we need to search for object files in the -- Module_split directory for each module. -getHaskellObjects :: Library -> LocalBuildInfo +getHaskellObjects :: Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath -> String -> Bool -> NoCallStackIO [FilePath] -getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs +getHaskellObjects lib lbi clbi pref wanted_obj_ext allow_split_objs | splitObjs lbi && allow_split_objs = do let dirs = [ pref (ModuleName.toFilePath x ++ "_split") - | x <- libModules lib ] + | x <- allLibModules lib clbi ] objss <- traverse getDirectoryContents dirs let objs = [ dir obj | (objs',dir) <- zip objss dirs, obj <- objs', @@ -549,7 +549,7 @@ getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs return objs | otherwise = return [ pref ModuleName.toFilePath x <.> wanted_obj_ext - | x <- libModules lib ] + | x <- allLibModules lib clbi ] constructGHCCmdLine @@ -717,11 +717,11 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do createDirectoryIfMissingVerbose verbosity True dst installOrdinaryFile verbosity (src n) (dst n) copyModuleFiles ext = - findModuleFiles [builtDir] [ext] (libModules lib) + findModuleFiles [builtDir] [ext] (allLibModules lib clbi) >>= installOrdinaryFiles verbosity targetDir ifVanilla $ copyModuleFiles "hi" ifProf $ copyModuleFiles "p_hi" - hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib) + hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (allLibModules lib clbi) flip traverse_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase srcFile] -- copy the built library files over: @@ -738,7 +738,7 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do ghciLibName = mkGHCiLibName lib_name sharedLibName = mkSharedLibName cid lib_name - hasLib = not $ null (libModules lib) + hasLib = not $ null (allLibModules lib clbi) && null (cSources (libBuildInfo lib)) ifVanilla = when (hasLib && withVanillaLib lbi) ifProf = when (hasLib && withProfLib lbi) diff --git a/Cabal/Distribution/Simple/LocalBuildInfo.hs b/Cabal/Distribution/Simple/LocalBuildInfo.hs index d713d5f6740..0bf081336dc 100644 --- a/Cabal/Distribution/Simple/LocalBuildInfo.hs +++ b/Cabal/Distribution/Simple/LocalBuildInfo.hs @@ -47,6 +47,7 @@ module Distribution.Simple.LocalBuildInfo ( allComponentsInBuildOrder, componentsInBuildOrder, depLibraryPaths, + allLibModules, withAllComponentsInBuildOrder, withComponentsInBuildOrder, @@ -82,6 +83,7 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.PackageDescription import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package +import Distribution.ModuleName import Distribution.Simple.Compiler import Distribution.Simple.PackageIndex import Distribution.Simple.Utils @@ -102,12 +104,17 @@ componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath -- are only ever built once. With Backpack, we need a special case for -- libraries so that we can handle building them multiple times. componentBuildDir lbi clbi - = buildDir lbi case componentLocalName clbi of - CLibName -> "" - CSubLibName s -> s - CExeName s -> s - CTestName s -> s - CBenchName s -> s + = buildDir lbi + case componentLocalName clbi of + CLibName -> case unitIdHash (componentUnitId clbi) of + Just hash -> hash + Nothing -> "" + CSubLibName s -> case unitIdHash (componentUnitId clbi) of + Just hash -> s ++ "-" ++ hash + Nothing -> s + CExeName s -> s + CTestName s -> s + CBenchName s -> s {-# DEPRECATED getComponentLocalBuildInfo "This function is not well-defined, because a 'ComponentName' does not uniquely identify a 'ComponentLocalBuildInfo'. If you have a 'TargetInfo', you should use 'targetCLBI' to get the 'ComponentLocalBuildInfo'. Otherwise, use 'componentNameTargets' to get all possible 'ComponentLocalBuildInfo's. This will be removed in Cabal 2.2." #-} getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo @@ -287,6 +294,16 @@ depLibraryPaths inplace relative lbi clbi = do then canonicalizePath p else return p +-- | Get all module names that needed to be built by GHC; i.e., all +-- of these 'ModuleName's have interface files associated with them +-- that need to be installed. +allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName] +allLibModules lib clbi = + ordNub $ + explicitLibModules lib ++ + case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> map fst insts + _ -> [] -- ----------------------------------------------------------------------------- -- Wrappers for a couple functions from InstallDirs diff --git a/Cabal/Distribution/Simple/PackageIndex.hs b/Cabal/Distribution/Simple/PackageIndex.hs index 27f69bb5fcb..88ee48b79cc 100644 --- a/Cabal/Distribution/Simple/PackageIndex.hs +++ b/Cabal/Distribution/Simple/PackageIndex.hs @@ -113,6 +113,7 @@ import Prelude () import Distribution.Compat.Prelude hiding (lookup) import Distribution.Package +import Distribution.Backpack import Distribution.ModuleName import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Version @@ -394,7 +395,8 @@ lookupUnitId index uid = Map.lookup uid (unitIdIndex index) -- lookupComponentId :: PackageIndex a -> ComponentId -> Maybe a -lookupComponentId index uid = Map.lookup (SimpleUnitId uid) (unitIdIndex index) +lookupComponentId index cid = + Map.lookup (newSimpleUnitId cid) (unitIdIndex index) -- | Backwards compatibility for Cabal pre-1.24. {-# DEPRECATED lookupInstalledPackageId "Use lookupUnitId instead" #-} @@ -665,8 +667,9 @@ moduleNameIndex index = IPI.ExposedModule m reexport <- IPI.exposedModules pkg case reexport of Nothing -> return (m, [pkg]) - Just (Module _ m') | m == m' -> [] - | otherwise -> return (m', [pkg]) + Just (OpenModuleVar _) -> [] + Just (OpenModule _ m') | m == m' -> [] + | otherwise -> return (m', [pkg]) -- The heuristic is this: we want to prefer the original package -- which originally exported a module. However, if a reexport -- also *renamed* the module (m /= m'), then we have to use the diff --git a/Cabal/Distribution/Simple/PreProcess.hs b/Cabal/Distribution/Simple/PreProcess.hs index a3d5eac49e4..44f113e3c68 100644 --- a/Cabal/Distribution/Simple/PreProcess.hs +++ b/Cabal/Distribution/Simple/PreProcess.hs @@ -151,8 +151,10 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = case comp of (CLib lib@Library{ libBuildInfo = bi }) -> do let dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi] - setupMessage verbosity "Preprocessing library" (packageId pd) - for_ (map ModuleName.toFilePath $ libModules lib) $ + extra | componentIsPublic clbi = "" + | otherwise = " '" ++ display (componentUnitId clbi) ++ "' for" + setupMessage verbosity ("Preprocessing library" ++ extra) (packageId pd) + for_ (map ModuleName.toFilePath $ allLibModules lib clbi) $ pre dirs (componentBuildDir lbi clbi) (localHandlers bi) (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do let exeDir = buildDir lbi nm nm ++ "-tmp" diff --git a/Cabal/Distribution/Simple/Program/GHC.hs b/Cabal/Distribution/Simple/Program/GHC.hs index 9b73903872d..25a26049acd 100644 --- a/Cabal/Distribution/Simple/Program/GHC.hs +++ b/Cabal/Distribution/Simple/Program/GHC.hs @@ -19,8 +19,8 @@ module Distribution.Simple.Program.GHC ( import Prelude () import Distribution.Compat.Prelude +import Distribution.Backpack import Distribution.Simple.GHC.ImplInfo -import Distribution.Package import Distribution.PackageDescription hiding (Flag) import Distribution.ModuleName import Distribution.Simple.Compiler hiding (Flag) @@ -83,13 +83,18 @@ data GhcOptions = GhcOptions { -- (we need to handle backwards compatibility.) ghcOptThisUnitId :: Flag String, + ghcOptInstantiatedWith :: [(ModuleName, OpenModule)], + + -- | No code? (But we turn on interface writing + ghcOptNoCode :: Flag Bool, + -- | GHC package databases to use, the @ghc -package-conf@ flag. ghcOptPackageDBs :: PackageDBStack, -- | The GHC packages to bring into scope when compiling, -- the @ghc -package-id@ flags. ghcOptPackages :: - NubListR (UnitId, ModuleRenaming), + NubListR (OpenUnitId, ModuleRenaming), -- | Start with a clean package set; the @ghc -hide-all-packages@ flag ghcOptHideAllPackages :: Flag Bool, @@ -398,6 +403,16 @@ renderGhcOptions comp _platform@(Platform _arch os) opts , this_arg ] | this_arg <- flag ghcOptThisUnitId ] + , if null (ghcOptInstantiatedWith opts) + then [] + else "-instantiated-with" + : intercalate "," (map (\(n,m) -> display n ++ "=" + ++ display m) + (ghcOptInstantiatedWith opts)) + : [] + + , concat [ ["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode ] + , [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ] , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ] diff --git a/Cabal/Distribution/Simple/Program/HcPkg.hs b/Cabal/Distribution/Simple/Program/HcPkg.hs index 347c4776bf3..fbf1f33cd08 100644 --- a/Cabal/Distribution/Simple/Program/HcPkg.hs +++ b/Cabal/Distribution/Simple/Program/HcPkg.hs @@ -315,7 +315,7 @@ mungePackagePaths pkgroot pkginfo = -- field, so if it is missing then we fill it as the source package ID. setUnitId :: InstalledPackageInfo -> InstalledPackageInfo setUnitId pkginfo@InstalledPackageInfo { - installedUnitId = SimpleUnitId cid, + installedUnitId = UnitId cid _, sourcePackageId = pkgid } | cid == mkComponentId "" = pkginfo { diff --git a/Cabal/Distribution/Simple/Program/Run.hs b/Cabal/Distribution/Simple/Program/Run.hs index 55f799965ac..44b7f2b33c3 100644 --- a/Cabal/Distribution/Simple/Program/Run.hs +++ b/Cabal/Distribution/Simple/Program/Run.hs @@ -193,6 +193,8 @@ getExtraPathEnv env extras = do return [("PATH", Just path')] -- | Return the current environment extended with the given overrides. +-- If an entry is specified twice in @overrides@, the second entry takes +-- precedence. -- getEffectiveEnvironment :: [(String, Maybe String)] -> NoCallStackIO (Maybe [(String, String)]) diff --git a/Cabal/Distribution/Simple/Register.hs b/Cabal/Distribution/Simple/Register.hs index b97d731d509..dbf1a7437a6 100644 --- a/Cabal/Distribution/Simple/Register.hs +++ b/Cabal/Distribution/Simple/Register.hs @@ -51,6 +51,7 @@ import Distribution.Compat.Prelude import Distribution.Types.TargetInfo import Distribution.Types.LocalBuildInfo +import Distribution.Types.ComponentLocalBuildInfo import Distribution.Simple.LocalBuildInfo import Distribution.Simple.BuildPaths @@ -199,7 +200,6 @@ registerAll pkg lbi regFlags ipis where ys = take m xs number i = lpad (length (show num_ipis)) (show i) for_ (zip ([1..] :: [Int]) ipis) $ \(i, installedPkgInfo) -> - -- TODO: This will need a hashUnitId when Backpack comes. writeUTF8File (regFile (number i ++ "-" ++ display (IPI.installedUnitId installedPkgInfo))) (IPI.showInstalledPackageInfo installedPkgInfo) @@ -389,6 +389,7 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi pkgName = componentCompatPackageName clbi }, IPI.installedUnitId = componentUnitId clbi, + IPI.instantiatedWith = componentInstantiatedWith clbi, IPI.compatPackageKey = componentCompatPackageKey clbi, IPI.license = license pkg, IPI.copyright = copyright pkg, @@ -401,6 +402,7 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi IPI.description = description pkg, IPI.category = category pkg, IPI.abiHash = abi_hash, + IPI.indefinite = componentIsIndefinite clbi, IPI.exposed = libExposed lib, IPI.exposedModules = componentExposedModules clbi, IPI.hiddenModules = otherModules bi, @@ -419,7 +421,9 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi IPI.extraGHCiLibraries = extraGHCiLibs bi, IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, IPI.includes = includes bi, - IPI.depends = map fst (componentPackageDeps clbi), + --TODO: unclear what the root cause of the + -- duplication is, but we nub it here for now: + IPI.depends = ordNub $ map fst (componentPackageDeps clbi), IPI.ccOptions = [], -- Note. NOT ccOptions bi! -- We don't want cc-options to be propagated -- to C compilations in other packages. @@ -433,7 +437,7 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi where bi = libBuildInfo lib (absinc, relinc) = partition isAbsolute (includeDirs bi) - hasModules = not $ null (libModules lib) + hasModules = not $ null (allLibModules lib clbi) hasLibrary = hasModules || not (null (cSources bi)) || (not (null (jsSources bi)) && compilerFlavor (compiler lbi) == GHCJS) diff --git a/Cabal/Distribution/Simple/Setup.hs b/Cabal/Distribution/Simple/Setup.hs index 14789301a87..359f6610ad7 100644 --- a/Cabal/Distribution/Simple/Setup.hs +++ b/Cabal/Distribution/Simple/Setup.hs @@ -83,6 +83,7 @@ import Distribution.ReadE import Distribution.Text import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp +import Distribution.ModuleName import Distribution.Package import Distribution.PackageDescription hiding (Flag) import Distribution.Simple.Command hiding (boolOpt, boolOpt') @@ -412,6 +413,10 @@ data ConfigFlags = ConfigFlags { -- dependencies. configDependencies :: [(PackageName, ComponentId)], -- ^The packages depended on. + configInstantiateWith :: [(ModuleName, Module)], + -- ^ The requested Backpack instantiation. If empty, either this + -- package does not use Backpack, or we just want to typecheck + -- the indefinite package. configConfigurationsFlags :: FlagAssignment, configTests :: Flag Bool, -- ^Enable test suite compilation configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation @@ -556,6 +561,18 @@ configureCommand progDb = CommandUI configProgramArgs (\v fs -> fs { configProgramArgs = v }) } +-- | Inverse to 'dispModSubstEntry'. +parseModSubstEntry :: Parse.ReadP r (ModuleName, Module) +parseModSubstEntry = + do k <- parse + _ <- Parse.char '=' + v <- parse + return (k, v) + +-- | Pretty-print a single entry of a module substitution. +dispModSubstEntry :: (ModuleName, Module) -> Disp.Doc +dispModSubstEntry (k, v) = disp k <<>> Disp.char '=' <<>> disp v + configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions showOrParseArgs = [optionVerbosity configVerbosity @@ -767,6 +784,13 @@ configureOptions showOrParseArgs = (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parseDependency)) (map (\x -> display (fst x) ++ "=" ++ display (snd x)))) + ,option "" ["instantiate-with"] + "A mapping of signature names to concrete module instantiations." + configInstantiateWith (\v flags -> flags { configInstantiateWith = v }) + (reqArg "NAME=MOD" + (readP_to_E ("Cannot parse module substitution: " ++) (fmap (:[]) parseModSubstEntry)) + (map (Disp.renderStyle defaultStyle . dispModSubstEntry))) + ,option "" ["tests"] "dependency checking and compilation for test suites listed in the package description file." configTests (\v flags -> flags { configTests = v }) diff --git a/Cabal/Distribution/Simple/SrcDist.hs b/Cabal/Distribution/Simple/SrcDist.hs index 90e97c84c9a..e514ce671b5 100644 --- a/Cabal/Distribution/Simple/SrcDist.hs +++ b/Cabal/Distribution/Simple/SrcDist.hs @@ -156,8 +156,12 @@ listPackageSourcesOrdinary verbosity pkg_descr pps = [ -- Library sources. fmap concat - . withAllLib $ \Library { exposedModules = modules, libBuildInfo = libBi } -> - allSourcesBuildInfo libBi pps modules + . withAllLib $ \Library { + exposedModules = modules, + signatures = sigs, + libBuildInfo = libBi + } -> + allSourcesBuildInfo libBi pps (modules ++ sigs) -- Executables sources. , fmap concat @@ -437,7 +441,7 @@ allSourcesBuildInfo bi pps modules = do where nonEmpty x _ [] = x nonEmpty _ f xs = f xs - suffixes = ppSuffixes pps ++ ["hs", "lhs"] + suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"] notFound m = die $ "Error: Could not find module: " ++ display m ++ " with any suffix: " ++ show suffixes ++ ". If the module " ++ "is autogenerated it should be added to 'autogen-modules'." diff --git a/Cabal/Distribution/Simple/UHC.hs b/Cabal/Distribution/Simple/UHC.hs index 6903199197e..b595d6d8cd8 100644 --- a/Cabal/Distribution/Simple/UHC.hs +++ b/Cabal/Distribution/Simple/UHC.hs @@ -185,7 +185,7 @@ buildLib verbosity pkg_descr lbi lib clbi = do -- suboptimal: UHC does not understand module names, so -- we replace periods by path separators ++ map (map (\ c -> if c == '.' then pathSeparator else c)) - (map display (libModules lib)) + (map display (allLibModules lib clbi)) runUhcProg uhcArgs diff --git a/Cabal/Distribution/Types/BuildInfo.hs b/Cabal/Distribution/Types/BuildInfo.hs index 2b849e89a55..da13f419f5c 100644 --- a/Cabal/Distribution/Types/BuildInfo.hs +++ b/Cabal/Distribution/Types/BuildInfo.hs @@ -17,15 +17,13 @@ module Distribution.Types.BuildInfo ( import Prelude () import Distribution.Compat.Prelude -import Distribution.Types.ModuleRenaming +import Distribution.Types.IncludeRenaming import Distribution.Package import Distribution.ModuleName import Distribution.Compiler import Language.Haskell.Extension -import qualified Data.Map as Map - -- Consider refactoring into executable and library versions. data BuildInfo = BuildInfo { buildable :: Bool, -- ^ component is buildable here @@ -61,7 +59,7 @@ data BuildInfo = BuildInfo { -- with x-, stored in a -- simple assoc-list. targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target - targetBuildRenaming :: Map PackageName ModuleRenaming + backpackIncludes :: [(PackageName, IncludeRenaming)] } deriving (Generic, Show, Read, Eq, Typeable, Data) @@ -98,7 +96,7 @@ instance Monoid BuildInfo where sharedOptions = [], customFieldsBI = [], targetBuildDepends = [], - targetBuildRenaming = Map.empty + backpackIncludes = [] } mappend = (<>) @@ -133,13 +131,12 @@ instance Semigroup BuildInfo where sharedOptions = combine sharedOptions, customFieldsBI = combine customFieldsBI, targetBuildDepends = combineNub targetBuildDepends, - targetBuildRenaming = combineMap targetBuildRenaming + backpackIncludes = combine backpackIncludes } where combine field = field a `mappend` field b combineNub field = nub (combine field) combineMby field = field b `mplus` field a - combineMap field = Map.unionWith mappend (field a) (field b) emptyBuildInfo :: BuildInfo emptyBuildInfo = mempty diff --git a/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs b/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs index 79eb824623f..e57a9dca066 100644 --- a/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs +++ b/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs @@ -3,12 +3,15 @@ module Distribution.Types.ComponentLocalBuildInfo ( ComponentLocalBuildInfo(..), + componentIsIndefinite, componentComponentId, ) where import Prelude () import Distribution.Compat.Prelude +import Distribution.ModuleName +import Distribution.Backpack import Distribution.Compat.Graph import Distribution.Types.ComponentName @@ -27,8 +30,12 @@ data ComponentLocalBuildInfo -- identify the ComponentLocalBuildInfo. componentLocalName :: ComponentName, -- | The computed 'UnitId' which uniquely identifies this - -- component. + -- component. Might be hashed. componentUnitId :: UnitId, + -- | Is this an indefinite component (i.e. has unfilled holes)? + componentIsIndefinite_ :: Bool, + -- | How the component was instantiated + componentInstantiatedWith :: [(ModuleName, OpenModule)], -- | Resolved internal and external package dependencies for this component. -- The 'BuildInfo' specifies a set of build dependencies that must be -- satisfied in terms of version ranges. This field fixes those dependencies @@ -39,7 +46,7 @@ data ComponentLocalBuildInfo -- to hide or rename modules. This is what gets translated into -- @-package-id@ arguments. This is a modernized version of -- 'componentPackageDeps', which is kept around for BC purposes. - componentIncludes :: [(UnitId, ModuleRenaming)], + componentIncludes :: [(OpenUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], -- | The internal dependencies which induce a graph on the -- 'ComponentLocalBuildInfo' of this package. This does NOT @@ -62,7 +69,7 @@ data ComponentLocalBuildInfo componentLocalName :: ComponentName, componentUnitId :: UnitId, componentPackageDeps :: [(UnitId, PackageId)], - componentIncludes :: [(UnitId, ModuleRenaming)], + componentIncludes :: [(OpenUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] } @@ -70,7 +77,7 @@ data ComponentLocalBuildInfo componentLocalName :: ComponentName, componentUnitId :: UnitId, componentPackageDeps :: [(UnitId, PackageId)], - componentIncludes :: [(UnitId, ModuleRenaming)], + componentIncludes :: [(OpenUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] @@ -79,7 +86,7 @@ data ComponentLocalBuildInfo componentLocalName :: ComponentName, componentUnitId :: UnitId, componentPackageDeps :: [(UnitId, PackageId)], - componentIncludes :: [(UnitId, ModuleRenaming)], + componentIncludes :: [(OpenUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] } @@ -93,5 +100,8 @@ instance IsNode ComponentLocalBuildInfo where nodeNeighbors = componentInternalDeps componentComponentId :: ComponentLocalBuildInfo -> ComponentId -componentComponentId clbi = case componentUnitId clbi of - SimpleUnitId cid -> cid +componentComponentId clbi = unitIdComponentId (componentUnitId clbi) + +componentIsIndefinite :: ComponentLocalBuildInfo -> Bool +componentIsIndefinite LibComponentLocalBuildInfo{ componentIsIndefinite_ = b } = b +componentIsIndefinite _ = False diff --git a/Cabal/Distribution/Types/IncludeRenaming.hs b/Cabal/Distribution/Types/IncludeRenaming.hs new file mode 100644 index 00000000000..f972b76ccd3 --- /dev/null +++ b/Cabal/Distribution/Types/IncludeRenaming.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.IncludeRenaming ( + IncludeRenaming(..), + defaultIncludeRenaming, + isDefaultIncludeRenaming, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.ModuleRenaming + +import Distribution.Text + +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<+>), text) +import Distribution.Compat.ReadP + +-- --------------------------------------------------------------------------- +-- Module renaming + +-- | A renaming on an include: (provides renaming, requires renaming) +data IncludeRenaming + = IncludeRenaming { + includeProvidesRn :: ModuleRenaming, + includeRequiresRn :: ModuleRenaming + } + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + +instance Binary IncludeRenaming + +-- | The 'defaultIncludeRenaming' applied when you only @build-depends@ +-- on a package. +defaultIncludeRenaming :: IncludeRenaming +defaultIncludeRenaming = IncludeRenaming defaultRenaming defaultRenaming + +-- | Is an 'IncludeRenaming' the default one? +isDefaultIncludeRenaming :: IncludeRenaming -> Bool +isDefaultIncludeRenaming (IncludeRenaming p r) = isDefaultRenaming p && isDefaultRenaming r + +instance Text IncludeRenaming where + disp (IncludeRenaming prov_rn req_rn) = + disp prov_rn + <+> (if isDefaultRenaming req_rn + then Disp.empty + else text "requires" <+> disp req_rn) + parse = do + prov_rn <- parse + req_rn <- (string "requires" >> skipSpaces >> parse) <++ return defaultRenaming + -- Requirements don't really care if they're mentioned + -- or not (since you can't thin a requirement.) But + -- we have a little hack in Configure to combine + -- the provisions and requirements together before passing + -- them to GHC, and so the most neutral choice for a requirement + -- is for the "with" field to be False, so we correctly + -- thin provisions. + return (IncludeRenaming prov_rn req_rn) diff --git a/Cabal/Distribution/Types/Library.hs b/Cabal/Distribution/Types/Library.hs index a8f40126296..a15588a3dfe 100644 --- a/Cabal/Distribution/Types/Library.hs +++ b/Cabal/Distribution/Types/Library.hs @@ -4,8 +4,9 @@ module Distribution.Types.Library ( Library(..), emptyLibrary, + explicitLibModules, + libModulesAutogen, libModules, - libModulesAutogen ) where import Prelude () @@ -19,7 +20,7 @@ data Library = Library { libName :: Maybe String, exposedModules :: [ModuleName], reexportedModules :: [ModuleReexport], - requiredSignatures:: [ModuleName], -- ^ What sigs need implementations? + signatures:: [ModuleName], -- ^ What sigs need implementations? libExposed :: Bool, -- ^ Is the lib to be exposed by default? libBuildInfo :: BuildInfo } @@ -32,7 +33,7 @@ instance Monoid Library where libName = mempty, exposedModules = mempty, reexportedModules = mempty, - requiredSignatures = mempty, + signatures = mempty, libExposed = True, libBuildInfo = mempty } @@ -43,7 +44,7 @@ instance Semigroup Library where libName = combine libName, exposedModules = combine exposedModules, reexportedModules = combine reexportedModules, - requiredSignatures = combine requiredSignatures, + signatures = combine signatures, libExposed = libExposed a && libExposed b, -- so False propagates libBuildInfo = combine libBuildInfo } @@ -53,14 +54,26 @@ emptyLibrary :: Library emptyLibrary = mempty -- | Get all the module names from the library (exposed and internal modules) --- which need to be compiled. (This does not include reexports, which --- do not need to be compiled.) -libModules :: Library -> [ModuleName] -libModules lib = exposedModules lib +-- which are explicitly listed in the package description which would +-- need to be compiled. (This does not include reexports, which +-- do not need to be compiled.) This may not include all modules for which +-- GHC generated interface files (i.e., implicit modules.) +explicitLibModules :: Library -> [ModuleName] +explicitLibModules lib = exposedModules lib ++ otherModules (libBuildInfo lib) - ++ requiredSignatures lib + ++ signatures lib -- | Get all the auto generated module names from the library, exposed or not. -- This are a subset of 'libModules'. libModulesAutogen :: Library -> [ModuleName] libModulesAutogen lib = autogenModules (libBuildInfo lib) + +-- | Backwards-compatibility shim for 'explicitLibModules'. In most cases, +-- you actually want 'allLibModules', which returns all modules that will +-- actually be compiled, as opposed to those which are explicitly listed +-- in the package description ('explicitLibModules'); unfortunately, the +-- type signature for 'allLibModules' is incompatible since we need a +-- 'ComponentLocalBuildInfo'. +{-# DEPRECATED libModules "If you want all modules that are built with a library, use 'allLibModules'. Otherwise, use 'explicitLibModules' for ONLY the modules explicitly mentioned in the package description." #-} +libModules :: Library -> [ModuleName] +libModules = explicitLibModules diff --git a/Cabal/Distribution/Types/LocalBuildInfo.hs b/Cabal/Distribution/Types/LocalBuildInfo.hs index 60a8e99a284..2817e6a66e7 100644 --- a/Cabal/Distribution/Types/LocalBuildInfo.hs +++ b/Cabal/Distribution/Types/LocalBuildInfo.hs @@ -162,9 +162,7 @@ instance Binary LocalBuildInfo -- 'LocalBuildInfo' if it exists, or make a fake component ID based -- on the package ID. localComponentId :: LocalBuildInfo -> ComponentId -localComponentId lbi - = case localUnitId lbi of - SimpleUnitId cid -> cid +localComponentId lbi = unitIdComponentId (localUnitId lbi) -- | Extract the 'PackageIdentifier' of a 'LocalBuildInfo'. -- This is a "safe" use of 'localPkgDescr' diff --git a/Cabal/Distribution/Types/ModuleRenaming.hs b/Cabal/Distribution/Types/ModuleRenaming.hs index 835ab7f98ce..3b360120a69 100644 --- a/Cabal/Distribution/Types/ModuleRenaming.hs +++ b/Cabal/Distribution/Types/ModuleRenaming.hs @@ -4,70 +4,78 @@ module Distribution.Types.ModuleRenaming ( ModuleRenaming(..), defaultRenaming, - lookupRenaming, + isDefaultRenaming, ) where import Prelude () -import Distribution.Compat.Prelude +import Distribution.Compat.Prelude hiding (empty) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ((<++)) -import Distribution.Package import Distribution.ModuleName import Distribution.Text -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<+>), text) -import qualified Data.Map as Map - --- --------------------------------------------------------------------------- --- Module renaming +import Text.PrettyPrint -- | Renaming applied to the modules provided by a package. -- The boolean indicates whether or not to also include all of the -- original names of modules. Thus, @ModuleRenaming False []@ is -- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@ -- is, "expose all modules, but also expose @Data.Bool@ as @Bool@". +-- If a renaming is omitted you get the 'DefaultRenaming'. +-- +-- (NB: This is a list not a map so that we can preserve order.) -- -data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)] +data ModuleRenaming + -- | A module renaming/thinning; e.g., @(A as B, C as C)@ + -- brings @B@ and @C@ into scope. + = ModuleRenaming [(ModuleName, ModuleName)] + -- | The default renaming, bringing all exported modules + -- into scope. + | DefaultRenaming + -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all + -- exported modules into scope except the hidden ones. + | HidingRenaming [ModuleName] deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) +-- | The default renaming, if something is specified in @build-depends@ +-- only. defaultRenaming :: ModuleRenaming -defaultRenaming = ModuleRenaming True [] +defaultRenaming = DefaultRenaming -lookupRenaming :: Package pkg => pkg -> Map PackageName ModuleRenaming -> ModuleRenaming -lookupRenaming = Map.findWithDefault defaultRenaming . packageName +-- | Tests if its the default renaming; we can use a more compact syntax +-- in 'Distribution.Types.IncludeRenaming.IncludeRenaming' in this case. +isDefaultRenaming :: ModuleRenaming -> Bool +isDefaultRenaming DefaultRenaming = True +isDefaultRenaming _ = False instance Binary ModuleRenaming where -instance Monoid ModuleRenaming where - mempty = ModuleRenaming False [] - mappend = (<>) - -instance Semigroup ModuleRenaming where - ModuleRenaming b rns <> ModuleRenaming b' rns' - = ModuleRenaming (b || b') (rns ++ rns') -- TODO: dedupe? - -- NB: parentheses are mandatory, because later we may extend this syntax -- to allow "hiding (A, B)" or other modifier words. instance Text ModuleRenaming where - disp (ModuleRenaming True []) = Disp.empty - disp (ModuleRenaming b vs) = (if b then text "with" else Disp.empty) <+> dispRns - where dispRns = Disp.parens - (Disp.hsep - (Disp.punctuate Disp.comma (map dispEntry vs))) - dispEntry (orig, new) + disp DefaultRenaming = empty + disp (HidingRenaming hides) + = text "hiding" <+> parens (hsep (punctuate comma (map disp hides))) + disp (ModuleRenaming rns) + = parens . hsep $ punctuate comma (map dispEntry rns) + where dispEntry (orig, new) | orig == new = disp orig | otherwise = disp orig <+> text "as" <+> disp new - parse = do Parse.string "with" >> Parse.skipSpaces - fmap (ModuleRenaming True) parseRns - <++ fmap (ModuleRenaming False) parseRns - <++ return (ModuleRenaming True []) + parse = do fmap ModuleRenaming parseRns + <++ parseHidingRenaming + <++ return DefaultRenaming where parseRns = do rns <- Parse.between (Parse.char '(') (Parse.char ')') parseList Parse.skipSpaces return rns + parseHidingRenaming = do + _ <- Parse.string "hiding" + Parse.skipSpaces + hides <- Parse.between (Parse.char '(') (Parse.char ')') + (Parse.sepBy parse (Parse.char ',' >> Parse.skipSpaces)) + return (HidingRenaming hides) parseList = Parse.sepBy parseEntry (Parse.char ',' >> Parse.skipSpaces) parseEntry :: Parse.ReadP r (ModuleName, ModuleName) diff --git a/Cabal/Distribution/Utils/Base62.hs b/Cabal/Distribution/Utils/Base62.hs new file mode 100644 index 00000000000..ad3bc10fea8 --- /dev/null +++ b/Cabal/Distribution/Utils/Base62.hs @@ -0,0 +1,22 @@ + +-- | Implementation of base-62 encoding, which we use when computing hashes +-- for fully instantiated unit ids. +module Distribution.Utils.Base62 (hashToBase62) where + +import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) +import Numeric ( showIntAtBase ) +import Data.Char ( chr ) + +-- | Hash a string using GHC's fingerprinting algorithm (a 128-bit +-- MD5 hash) and then encode the resulting hash in base 62. +hashToBase62 :: String -> String +hashToBase62 s = showFingerprint $ fingerprintString s + where + showIntAtBase62 x = showIntAtBase 62 representBase62 x "" + representBase62 x + | x < 10 = chr (48 + x) + | x < 36 = chr (65 + x - 10) + | x < 62 = chr (97 + x - 36) + | otherwise = '@' + showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b + diff --git a/Cabal/Distribution/Utils/LogProgress.hs b/Cabal/Distribution/Utils/LogProgress.hs new file mode 100644 index 00000000000..2ee3afdbea1 --- /dev/null +++ b/Cabal/Distribution/Utils/LogProgress.hs @@ -0,0 +1,41 @@ +module Distribution.Utils.LogProgress ( + LogProgress, + LogMsg(..), + runLogProgress, + warnProgress, + infoProgress, +) where + +import Distribution.Utils.Progress +import Distribution.Verbosity +import Distribution.Simple.Utils +import Text.PrettyPrint (Doc, (<+>), text, render) +import Control.Monad (when) + +-- | The 'Progress' monad with specialized logging and +-- error messages. +type LogProgress a = Progress LogMsg Doc a + +-- | A tracing message which will be output at some verbosity. +data LogMsg = LogMsg Verbosity Doc + +-- | Run 'LogProgress', outputting traces according to 'Verbosity', +-- 'die' if there is an error. +runLogProgress :: Verbosity -> LogProgress a -> IO a +runLogProgress verbosity = foldProgress step_fn fail_fn return + where + step_fn :: LogMsg -> IO a -> IO a + step_fn (LogMsg v doc) go = do + when (verbosity >= v) $ + putStrLn (render doc) + go + fail_fn :: Doc -> IO a + fail_fn doc = die (render doc) + +-- | Output a warning trace message in 'LogProgress'. +warnProgress :: Doc -> LogProgress () +warnProgress s = stepProgress (LogMsg normal (text "Warning:" <+> s)) + +-- | Output an informational trace message in 'LogProgress'. +infoProgress :: Doc -> LogProgress () +infoProgress s = stepProgress (LogMsg verbose s) diff --git a/Cabal/Distribution/Utils/MapAccum.hs b/Cabal/Distribution/Utils/MapAccum.hs new file mode 100644 index 00000000000..b7a0eae3bc2 --- /dev/null +++ b/Cabal/Distribution/Utils/MapAccum.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE CPP #-} +module Distribution.Utils.MapAccum (mapAccumM) where + +import Distribution.Compat.Prelude +import Prelude () + +-- Like StateT but with return tuple swapped +newtype StateM s m a = StateM { runStateM :: s -> m (s, a) } + +instance Functor m => Functor (StateM s m) where + fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s) + +instance +#if __GLASGOW_HASKELL__ < 709 + (Functor m, Monad m) +#else + Monad m +#endif + => Applicative (StateM s m) where + pure x = StateM $ \s -> return (s, x) + StateM f <*> StateM x = StateM $ \s -> do (s', f') <- f s + (s'', x') <- x s' + return (s'', f' x') + +-- | Monadic variant of 'mapAccumL'. +mapAccumM :: +#if __GLASGOW_HASKELL__ < 709 + (Functor m, Monad m, Traversable t) +#else + (Monad m, Traversable t) +#endif + => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c) +mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s + diff --git a/Cabal/Distribution/Utils/Progress.hs b/Cabal/Distribution/Utils/Progress.hs new file mode 100644 index 00000000000..d834c87962c --- /dev/null +++ b/Cabal/Distribution/Utils/Progress.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +-- Note: This module was copied from cabal-install. + +-- | A progress monad, which we use to report failure and logging from +-- otherwise pure code. +module Distribution.Utils.Progress + ( Progress + , stepProgress + , failProgress + , foldProgress + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import qualified Data.Monoid as Mon + + +-- | A type to represent the unfolding of an expensive long running +-- calculation that may fail (or maybe not expensive, but complicated!) +-- We may get intermediate steps before the final +-- result which may be used to indicate progress and\/or logging messages. +-- +-- TODO: Apply Codensity to avoid left-associativity problem. +-- See http://comonad.com/reader/2011/free-monads-for-less/ and +-- http://blog.ezyang.com/2012/01/problem-set-the-codensity-transformation/ +-- +data Progress step fail done = Step step (Progress step fail done) + | Fail fail + | Done done + deriving (Functor) + +-- | Emit a step and then continue. +-- +stepProgress :: step -> Progress step fail () +stepProgress step = Step step (Done ()) + +-- | Fail the computation. +failProgress :: fail -> Progress step fail done +failProgress err = Fail err + +-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two +-- base cases, one for a final result and one for failure. +-- +-- Eg to convert into a simple 'Either' result use: +-- +-- > foldProgress (flip const) Left Right +-- +foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) + -> Progress step fail done -> a +foldProgress step err done = fold + where fold (Step s p) = step s (fold p) + fold (Fail f) = err f + fold (Done r) = done r + +instance Monad (Progress step fail) where + return = pure + p >>= f = foldProgress Step Fail f p + +instance Applicative (Progress step fail) where + pure a = Done a + p <*> x = foldProgress Step Fail (flip fmap x) p + +instance Monoid fail => Alternative (Progress step fail) where + empty = Fail Mon.mempty + p <|> q = foldProgress Step (const q) Done p diff --git a/Cabal/Distribution/Utils/UnionFind.hs b/Cabal/Distribution/Utils/UnionFind.hs new file mode 100644 index 00000000000..7af4177ccae --- /dev/null +++ b/Cabal/Distribution/Utils/UnionFind.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE NondecreasingIndentation #-} +-- | A simple mutable union-find data structure. +-- +-- It is used in a unification algorithm for backpack mix-in linking. +-- +-- This implementation is based off of the one in \"The Essence of ML Type +-- Inference\". (N.B. the union-find package is also based off of this.) +-- +module Distribution.Utils.UnionFind ( + Point, + fresh, + find, + union, + equivalent, +) where + +import Data.STRef +import Control.Monad +import Control.Monad.ST + +-- | A variable which can be unified; alternately, this can be thought +-- of as an equivalence class with a distinguished representative. +newtype Point s a = Point (STRef s (Link s a)) + deriving (Eq) + +-- | Mutable write to a 'Point' +writePoint :: Point s a -> Link s a -> ST s () +writePoint (Point v) = writeSTRef v + +-- | Read the current value of 'Point'. +readPoint :: Point s a -> ST s (Link s a) +readPoint (Point v) = readSTRef v + +-- | The internal data structure for a 'Point', which either records +-- the representative element of an equivalence class, or a link to +-- the 'Point' that actually stores the representative type. +data Link s a + -- NB: it is too bad we can't say STRef Int#; the weights remain boxed + = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a) + | Link {-# UNPACK #-} !(Point s a) + +-- | Create a fresh equivalence class with one element. +fresh :: a -> ST s (Point s a) +fresh desc = do + weight <- newSTRef 1 + descriptor <- newSTRef desc + Point `fmap` newSTRef (Info weight descriptor) + +-- | Flatten any chains of links, returning a 'Point' +-- which points directly to the canonical representation. +repr :: Point s a -> ST s (Point s a) +repr point = readPoint point >>= \r -> + case r of + Link point' -> do + point'' <- repr point' + when (point'' /= point') $ do + writePoint point =<< readPoint point' + return point'' + Info _ _ -> return point + +-- | Return the canonical element of an equivalence +-- class 'Point'. +find :: Point s a -> ST s a +find point = + -- Optimize length 0 and 1 case at expense of + -- general case + readPoint point >>= \r -> + case r of + Info _ d_ref -> readSTRef d_ref + Link point' -> readPoint point' >>= \r' -> + case r' of + Info _ d_ref -> readSTRef d_ref + Link _ -> repr point >>= find + +-- | Unify two equivalence classes, so that they share +-- a canonical element. Keeps the descriptor of point2. +union :: Point s a -> Point s a -> ST s () +union refpoint1 refpoint2 = do + point1 <- repr refpoint1 + point2 <- repr refpoint2 + when (point1 /= point2) $ do + l1 <- readPoint point1 + l2 <- readPoint point2 + case (l1, l2) of + (Info wref1 dref1, Info wref2 dref2) -> do + weight1 <- readSTRef wref1 + weight2 <- readSTRef wref2 + -- Should be able to optimize the == case separately + if weight1 >= weight2 + then do + writePoint point2 (Link point1) + -- The weight calculation here seems a bit dodgy + writeSTRef wref1 (weight1 + weight2) + writeSTRef dref1 =<< readSTRef dref2 + else do + writePoint point1 (Link point2) + writeSTRef wref2 (weight1 + weight2) + _ -> error "UnionFind.union: repr invariant broken" + +-- | Test if two points are in the same equivalence class. +equivalent :: Point s a -> Point s a -> ST s Bool +equivalent point1 point2 = liftM2 (==) (repr point1) (repr point2) diff --git a/Cabal/changelog b/Cabal/changelog index 89327b192c9..fa1aad75723 100644 --- a/Cabal/changelog +++ b/Cabal/changelog @@ -126,6 +126,11 @@ as an argument to './Setup configure' (#3158). * Macros 'VERSION_$pkgname' and 'MIN_VERSION_$pkgname' are now also generated for the current package. (#3235). + * Backpack is supported! Two new fields supported in Cabal + files: signatures and backpack-includes; and a new flag + to setup scripts, '--instantiate-with'. See + https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst + for more details. 1.22.0.0 Johan Tibell January 2015 * Support GHC 7.10. diff --git a/Cabal/tests/PackageTests/Ambiguity/p/Dupe.hs b/Cabal/tests/PackageTests/Ambiguity/p/Dupe.hs new file mode 100644 index 00000000000..908b17a017d --- /dev/null +++ b/Cabal/tests/PackageTests/Ambiguity/p/Dupe.hs @@ -0,0 +1,2 @@ +module Dupe where +pkg = "p" diff --git a/Cabal/tests/PackageTests/Ambiguity/p/p.cabal b/Cabal/tests/PackageTests/Ambiguity/p/p.cabal new file mode 100644 index 00000000000..957f972d872 --- /dev/null +++ b/Cabal/tests/PackageTests/Ambiguity/p/p.cabal @@ -0,0 +1,12 @@ +name: p +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Dupe + build-depends: base + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Ambiguity/package-import/A.hs b/Cabal/tests/PackageTests/Ambiguity/package-import/A.hs new file mode 100644 index 00000000000..8f8d99e565c --- /dev/null +++ b/Cabal/tests/PackageTests/Ambiguity/package-import/A.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} + +import qualified "p" Dupe as PDupe +import qualified "q" Dupe as QDupe + +main = putStrLn (PDupe.pkg ++ " " ++ QDupe.pkg) + diff --git a/Cabal/tests/PackageTests/Ambiguity/package-import/package-import.cabal b/Cabal/tests/PackageTests/Ambiguity/package-import/package-import.cabal new file mode 100644 index 00000000000..395d81f16d1 --- /dev/null +++ b/Cabal/tests/PackageTests/Ambiguity/package-import/package-import.cabal @@ -0,0 +1,13 @@ +name: package-import +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +executable package-import + main-is: A.hs + other-extensions: PackageImports + build-depends: base, p, q + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Ambiguity/q/Dupe.hs b/Cabal/tests/PackageTests/Ambiguity/q/Dupe.hs new file mode 100644 index 00000000000..baa7e7ff267 --- /dev/null +++ b/Cabal/tests/PackageTests/Ambiguity/q/Dupe.hs @@ -0,0 +1,2 @@ +module Dupe where +pkg = "q" diff --git a/Cabal/tests/PackageTests/Ambiguity/q/q.cabal b/Cabal/tests/PackageTests/Ambiguity/q/q.cabal new file mode 100644 index 00000000000..8f412403d0e --- /dev/null +++ b/Cabal/tests/PackageTests/Ambiguity/q/q.cabal @@ -0,0 +1,12 @@ +name: q +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Dupe + build-depends: base + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Ambiguity/reexport-test/Main.hs b/Cabal/tests/PackageTests/Ambiguity/reexport-test/Main.hs new file mode 100644 index 00000000000..90df771060f --- /dev/null +++ b/Cabal/tests/PackageTests/Ambiguity/reexport-test/Main.hs @@ -0,0 +1,5 @@ +module Main where +import qualified PDupe +import qualified QDupe + +main = putStrLn (PDupe.pkg ++ " " ++ QDupe.pkg) diff --git a/Cabal/tests/PackageTests/Ambiguity/reexport-test/reexport-test.cabal b/Cabal/tests/PackageTests/Ambiguity/reexport-test/reexport-test.cabal new file mode 100644 index 00000000000..a78a8642cef --- /dev/null +++ b/Cabal/tests/PackageTests/Ambiguity/reexport-test/reexport-test.cabal @@ -0,0 +1,12 @@ +name: reexport-test +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +executable reexport-test + main-is: Main.hs + build-depends: base, reexport + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Ambiguity/reexport/reexport.cabal b/Cabal/tests/PackageTests/Ambiguity/reexport/reexport.cabal new file mode 100644 index 00000000000..977c64aaf51 --- /dev/null +++ b/Cabal/tests/PackageTests/Ambiguity/reexport/reexport.cabal @@ -0,0 +1,12 @@ +name: reexport +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.21 + +library + reexported-modules: p:Dupe as PDupe, q:Dupe as QDupe + build-depends: base, p, q + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Includes1/A.hs b/Cabal/tests/PackageTests/Backpack/Includes1/A.hs new file mode 100644 index 00000000000..e2aa2976731 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes1/A.hs @@ -0,0 +1,2 @@ +module A where +import Data.Map diff --git a/Cabal/tests/PackageTests/Backpack/Includes1/B.hs b/Cabal/tests/PackageTests/Backpack/Includes1/B.hs new file mode 100644 index 00000000000..391138dd357 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes1/B.hs @@ -0,0 +1,3 @@ +module B where +import A +import Data.Set diff --git a/Cabal/tests/PackageTests/Backpack/Includes1/Includes1.cabal b/Cabal/tests/PackageTests/Backpack/Includes1/Includes1.cabal new file mode 100644 index 00000000000..c5c0aa4c552 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes1/Includes1.cabal @@ -0,0 +1,13 @@ +name: Includes1 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base, containers + exposed-modules: A B + backpack-includes: containers (Data.Map) + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Includes2/Includes2.cabal b/Cabal/tests/PackageTests/Backpack/Includes2/Includes2.cabal new file mode 100644 index 00000000000..d376e784f7f --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes2/Includes2.cabal @@ -0,0 +1,41 @@ +name: Includes2 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library mylib + build-depends: base + signatures: Database + exposed-modules: Mine + hs-source-dirs: mylib + default-language: Haskell2010 + +library mysql + build-depends: base + exposed-modules: Database.MySQL + hs-source-dirs: mysql + default-language: Haskell2010 + +library postgresql + build-depends: base + exposed-modules: Database.PostgreSQL + hs-source-dirs: postgresql + default-language: Haskell2010 + +library + build-depends: base, mysql, postgresql, mylib + backpack-includes: + mylib (Mine as Mine.MySQL) requires (Database as Database.MySQL), + mylib (Mine as Mine.PostgreSQL) requires (Database as Database.PostgreSQL) + exposed-modules: App + hs-source-dirs: src + default-language: Haskell2010 + +executable exe + build-depends: base, Includes2 + main-is: Main.hs + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Includes2/exe/Main.hs b/Cabal/tests/PackageTests/Backpack/Includes2/exe/Main.hs new file mode 100644 index 00000000000..865b7f2b489 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes2/exe/Main.hs @@ -0,0 +1,3 @@ +import App + +main = print app diff --git a/Cabal/tests/PackageTests/Backpack/Includes2/exe/exe.cabal b/Cabal/tests/PackageTests/Backpack/Includes2/exe/exe.cabal new file mode 100644 index 00000000000..707ea843e4c --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes2/exe/exe.cabal @@ -0,0 +1,12 @@ +name: exe +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +executable exe + build-depends: base, src + main-is: Main.hs + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Includes2/fail.cabal b/Cabal/tests/PackageTests/Backpack/Includes2/fail.cabal new file mode 100644 index 00000000000..5be128a517e --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes2/fail.cabal @@ -0,0 +1,35 @@ +name: fail +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library mylib + build-depends: base + signatures: Database + exposed-modules: Mine + hs-source-dirs: mylib + default-language: Haskell2010 + +library mysql + build-depends: base + exposed-modules: Database.MySQL + hs-source-dirs: mysql + default-language: Haskell2010 + +library postgresql + build-depends: base + exposed-modules: Database.PostgreSQL + hs-source-dirs: postgresql + default-language: Haskell2010 + +library + build-depends: base, mysql, postgresql, mylib + backpack-includes: + mysql (Database.MySQL as Database), + postgresql (Database.PostgreSQL as Database) + exposed-modules: App + hs-source-dirs: src + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Includes2/mylib/Database.hsig b/Cabal/tests/PackageTests/Backpack/Includes2/mylib/Database.hsig new file mode 100644 index 00000000000..725d795f94a --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes2/mylib/Database.hsig @@ -0,0 +1,3 @@ +signature Database where +data Database +databaseName :: String diff --git a/Cabal/tests/PackageTests/Backpack/Includes2/mylib/Mine.hs b/Cabal/tests/PackageTests/Backpack/Includes2/mylib/Mine.hs new file mode 100644 index 00000000000..20b4c0d404c --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes2/mylib/Mine.hs @@ -0,0 +1,4 @@ +module Mine where +import Database +data Mine = Mine Database +mine = "mine" ++ databaseName diff --git a/Cabal/tests/PackageTests/Backpack/Includes2/mylib/mylib.cabal b/Cabal/tests/PackageTests/Backpack/Includes2/mylib/mylib.cabal new file mode 100644 index 00000000000..cc0e3e3ec28 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes2/mylib/mylib.cabal @@ -0,0 +1,13 @@ +name: mylib +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base + signatures: Database + exposed-modules: Mine + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Includes2/mysql/Database/MySQL.hs b/Cabal/tests/PackageTests/Backpack/Includes2/mysql/Database/MySQL.hs new file mode 100644 index 00000000000..b49cdb42849 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes2/mysql/Database/MySQL.hs @@ -0,0 +1,3 @@ +module Database.MySQL where +data Database = Database Int +databaseName = "mysql" diff --git a/Cabal/tests/PackageTests/Backpack/Includes2/mysql/mysql.cabal b/Cabal/tests/PackageTests/Backpack/Includes2/mysql/mysql.cabal new file mode 100644 index 00000000000..bb331f5c836 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes2/mysql/mysql.cabal @@ -0,0 +1,12 @@ +name: mysql +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base + exposed-modules: Database.MySQL + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Includes2/postgresql/Database/PostgreSQL.hs b/Cabal/tests/PackageTests/Backpack/Includes2/postgresql/Database/PostgreSQL.hs new file mode 100644 index 00000000000..9cc64f12d61 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes2/postgresql/Database/PostgreSQL.hs @@ -0,0 +1,3 @@ +module Database.PostgreSQL where +data Database = Database Bool +databaseName = "postgresql" diff --git a/Cabal/tests/PackageTests/Backpack/Includes2/postgresql/postgresql.cabal b/Cabal/tests/PackageTests/Backpack/Includes2/postgresql/postgresql.cabal new file mode 100644 index 00000000000..1ba91f5d81b --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes2/postgresql/postgresql.cabal @@ -0,0 +1,12 @@ +name: postgresql +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base + exposed-modules: Database.PostgreSQL + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Includes2/src/App.hs b/Cabal/tests/PackageTests/Backpack/Includes2/src/App.hs new file mode 100644 index 00000000000..f5213de2c16 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes2/src/App.hs @@ -0,0 +1,7 @@ +module App where +import Database.MySQL +import Database.PostgreSQL +import qualified Mine.MySQL +import qualified Mine.PostgreSQL + +app = Mine.MySQL.mine ++ " " ++ Mine.PostgreSQL.mine diff --git a/Cabal/tests/PackageTests/Backpack/Includes2/src/src.cabal b/Cabal/tests/PackageTests/Backpack/Includes2/src/src.cabal new file mode 100644 index 00000000000..77d3b9bfd24 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes2/src/src.cabal @@ -0,0 +1,15 @@ +name: src +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base, mysql, postgresql, mylib + backpack-includes: + mylib (Mine as Mine.MySQL) requires (Database as Database.MySQL), + mylib (Mine as Mine.PostgreSQL) requires (Database as Database.PostgreSQL) + exposed-modules: App + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Includes3/Includes3.cabal b/Cabal/tests/PackageTests/Backpack/Includes3/Includes3.cabal new file mode 100644 index 00000000000..a2de17f2988 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes3/Includes3.cabal @@ -0,0 +1,23 @@ +name: Includes3 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library sigs + build-depends: base + signatures: Data.Map + hs-source-dirs: sigs + +library indef + build-depends: base, sigs + exposed-modules: Foo + hs-source-dirs: indef + +executable exe + build-depends: base, containers, indef + main-is: Main.hs + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Includes3/exe/Main.hs b/Cabal/tests/PackageTests/Backpack/Includes3/exe/Main.hs new file mode 100644 index 00000000000..e0cb6d02c6e --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes3/exe/Main.hs @@ -0,0 +1,4 @@ +import qualified Data.Map as Map +import Data.Map (Map) +import Foo +main = print $ f (+1) (Map.fromList [(0,1),(2,3)] :: Map Int Int) diff --git a/Cabal/tests/PackageTests/Backpack/Includes3/exe/exe.cabal b/Cabal/tests/PackageTests/Backpack/Includes3/exe/exe.cabal new file mode 100644 index 00000000000..2422fffc031 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes3/exe/exe.cabal @@ -0,0 +1,12 @@ +name: exe +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +executable exe + build-depends: base, containers, indef + main-is: Main.hs + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Includes3/indef/Foo.hs b/Cabal/tests/PackageTests/Backpack/Includes3/indef/Foo.hs new file mode 100644 index 00000000000..5be3e4b85b0 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes3/indef/Foo.hs @@ -0,0 +1,6 @@ +module Foo where + +import Data.Map + +f :: (a -> b) -> Map k a -> Map k b +f = fmap diff --git a/Cabal/tests/PackageTests/Backpack/Includes3/indef/indef.cabal b/Cabal/tests/PackageTests/Backpack/Includes3/indef/indef.cabal new file mode 100644 index 00000000000..ff1a4c512fa --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes3/indef/indef.cabal @@ -0,0 +1,11 @@ +name: indef +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base, sigs + exposed-modules: Foo diff --git a/Cabal/tests/PackageTests/Backpack/Includes3/sigs/Data/Map.hsig b/Cabal/tests/PackageTests/Backpack/Includes3/sigs/Data/Map.hsig new file mode 100644 index 00000000000..997ec1aa576 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes3/sigs/Data/Map.hsig @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +signature Data.Map where +type role Map nominal representational +data Map k a +instance Functor (Map k) diff --git a/Cabal/tests/PackageTests/Backpack/Includes3/sigs/sigs.cabal b/Cabal/tests/PackageTests/Backpack/Includes3/sigs/sigs.cabal new file mode 100644 index 00000000000..0263fe2a742 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes3/sigs/sigs.cabal @@ -0,0 +1,11 @@ +name: sigs +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base + signatures: Data.Map diff --git a/Cabal/tests/PackageTests/Backpack/Includes4/Includes4.cabal b/Cabal/tests/PackageTests/Backpack/Includes4/Includes4.cabal new file mode 100644 index 00000000000..ea7b01d4fe2 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes4/Includes4.cabal @@ -0,0 +1,25 @@ +name: Includes4 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library indef + build-depends: base + signatures: A, B, Rec + exposed-modules: C + hs-source-dirs: indef + default-language: Haskell2010 + +library impl + build-depends: base + exposed-modules: A, B, Rec + hs-source-dirs: impl + default-language: Haskell2010 + +executable exe + build-depends: indef, impl, base + main-is: Main.hs + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Includes4/Main.hs b/Cabal/tests/PackageTests/Backpack/Includes4/Main.hs new file mode 100644 index 00000000000..deff3c42855 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes4/Main.hs @@ -0,0 +1,2 @@ +import C +main = putStrLn (take 10 (show x)) diff --git a/Cabal/tests/PackageTests/Backpack/Includes4/impl/A.hs b/Cabal/tests/PackageTests/Backpack/Includes4/impl/A.hs new file mode 100644 index 00000000000..07415f6d39b --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes4/impl/A.hs @@ -0,0 +1,4 @@ +module A where +import B +data A = A B + deriving (Show) diff --git a/Cabal/tests/PackageTests/Backpack/Includes4/impl/A.hs-boot b/Cabal/tests/PackageTests/Backpack/Includes4/impl/A.hs-boot new file mode 100644 index 00000000000..48d09c3a1e8 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes4/impl/A.hs-boot @@ -0,0 +1,3 @@ +module A where +data A +instance Show A diff --git a/Cabal/tests/PackageTests/Backpack/Includes4/impl/B.hs b/Cabal/tests/PackageTests/Backpack/Includes4/impl/B.hs new file mode 100644 index 00000000000..db413d7f7c6 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes4/impl/B.hs @@ -0,0 +1,4 @@ +module B where +import {-# SOURCE #-} A +data B = B A + deriving (Show) diff --git a/Cabal/tests/PackageTests/Backpack/Includes4/impl/Rec.hs b/Cabal/tests/PackageTests/Backpack/Includes4/impl/Rec.hs new file mode 100644 index 00000000000..41f9996fd80 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes4/impl/Rec.hs @@ -0,0 +1,3 @@ +module Rec(A(..), B(..)) where +import A +import B diff --git a/Cabal/tests/PackageTests/Backpack/Includes4/indef/A.hsig b/Cabal/tests/PackageTests/Backpack/Includes4/indef/A.hsig new file mode 100644 index 00000000000..9a058de5efa --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes4/indef/A.hsig @@ -0,0 +1,2 @@ +signature A(A(..)) where +import Rec diff --git a/Cabal/tests/PackageTests/Backpack/Includes4/indef/B.hsig b/Cabal/tests/PackageTests/Backpack/Includes4/indef/B.hsig new file mode 100644 index 00000000000..bc14a717115 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes4/indef/B.hsig @@ -0,0 +1,2 @@ +signature B(B(..)) where +import Rec diff --git a/Cabal/tests/PackageTests/Backpack/Includes4/indef/C.hs b/Cabal/tests/PackageTests/Backpack/Includes4/indef/C.hs new file mode 100644 index 00000000000..1d44c0b3033 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes4/indef/C.hs @@ -0,0 +1,4 @@ +module C where +import A +import B +x = A (B x) diff --git a/Cabal/tests/PackageTests/Backpack/Includes4/indef/Rec.hsig b/Cabal/tests/PackageTests/Backpack/Includes4/indef/Rec.hsig new file mode 100644 index 00000000000..d132a48da98 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes4/indef/Rec.hsig @@ -0,0 +1,3 @@ +signature Rec(A(..), B(..)) where +data A = A B +data B = B A diff --git a/Cabal/tests/PackageTests/Backpack/Includes5/A.hs b/Cabal/tests/PackageTests/Backpack/Includes5/A.hs new file mode 100644 index 00000000000..8958c14a1dc --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes5/A.hs @@ -0,0 +1,2 @@ +module A where +import Quxbaz diff --git a/Cabal/tests/PackageTests/Backpack/Includes5/B.hs b/Cabal/tests/PackageTests/Backpack/Includes5/B.hs new file mode 100644 index 00000000000..9cf3a891f48 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes5/B.hs @@ -0,0 +1,2 @@ +module B where +import Foobar -- fails diff --git a/Cabal/tests/PackageTests/Backpack/Includes5/Includes5.cabal b/Cabal/tests/PackageTests/Backpack/Includes5/Includes5.cabal new file mode 100644 index 00000000000..afbff068d4e --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes5/Includes5.cabal @@ -0,0 +1,25 @@ +name: Includes5 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library impl + build-depends: base + exposed-modules: Foobar, Quxbaz + hs-source-dirs: impl + default-language: Haskell2010 + +library good + build-depends: base, impl + backpack-includes: impl hiding (Foobar) + exposed-modules: A + default-language: Haskell2010 + +library bad + build-depends: base, impl, good + backpack-includes: impl hiding (Foobar) + exposed-modules: B + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Includes5/impl/Foobar.hs b/Cabal/tests/PackageTests/Backpack/Includes5/impl/Foobar.hs new file mode 100644 index 00000000000..eab54be4485 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes5/impl/Foobar.hs @@ -0,0 +1 @@ +module Foobar where diff --git a/Cabal/tests/PackageTests/Backpack/Includes5/impl/Quxbaz.hs b/Cabal/tests/PackageTests/Backpack/Includes5/impl/Quxbaz.hs new file mode 100644 index 00000000000..b47992788d2 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Includes5/impl/Quxbaz.hs @@ -0,0 +1 @@ +module Quxbaz where diff --git a/Cabal/tests/PackageTests/Backpack/Indef1/Indef1.cabal b/Cabal/tests/PackageTests/Backpack/Indef1/Indef1.cabal new file mode 100644 index 00000000000..c2828f72cfd --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Indef1/Indef1.cabal @@ -0,0 +1,13 @@ +name: Indef1 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + exposed-modules: Provide + signatures: Map + build-depends: base + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Indef1/Map.hsig b/Cabal/tests/PackageTests/Backpack/Indef1/Map.hsig new file mode 100644 index 00000000000..997ec1aa576 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Indef1/Map.hsig @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +signature Data.Map where +type role Map nominal representational +data Map k a +instance Functor (Map k) diff --git a/Cabal/tests/PackageTests/Backpack/Indef1/Provide.hs b/Cabal/tests/PackageTests/Backpack/Indef1/Provide.hs new file mode 100644 index 00000000000..3e2c51efa68 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Indef1/Provide.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Provide where +import Map +newtype MyMap a = MyMap (Map String a) + deriving (Functor) diff --git a/Cabal/tests/PackageTests/Backpack/Reexport1/p/P.hs b/Cabal/tests/PackageTests/Backpack/Reexport1/p/P.hs new file mode 100644 index 00000000000..fc4877ad85e --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Reexport1/p/P.hs @@ -0,0 +1 @@ +module P where diff --git a/Cabal/tests/PackageTests/Backpack/Reexport1/p/p.cabal b/Cabal/tests/PackageTests/Backpack/Reexport1/p/p.cabal new file mode 100644 index 00000000000..44de4de3832 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Reexport1/p/p.cabal @@ -0,0 +1,14 @@ +name: p +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + backpack-includes: containers (Data.Map as Map) + exposed-modules: P + reexported-modules: Map + build-depends: base, containers + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/Backpack/Reexport1/q/Q.hs b/Cabal/tests/PackageTests/Backpack/Reexport1/q/Q.hs new file mode 100644 index 00000000000..52ec664be3d --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Reexport1/q/Q.hs @@ -0,0 +1,2 @@ +module Q where +import Map diff --git a/Cabal/tests/PackageTests/Backpack/Reexport1/q/q.cabal b/Cabal/tests/PackageTests/Backpack/Reexport1/q/q.cabal new file mode 100644 index 00000000000..0364622c0c6 --- /dev/null +++ b/Cabal/tests/PackageTests/Backpack/Reexport1/q/q.cabal @@ -0,0 +1,12 @@ +name: q +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Q + build-depends: base, p + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/PackageTester.hs b/Cabal/tests/PackageTests/PackageTester.hs index 280e720c5c8..ab8e025a556 100644 --- a/Cabal/tests/PackageTests/PackageTester.hs +++ b/Cabal/tests/PackageTests/PackageTester.hs @@ -28,6 +28,7 @@ module PackageTests.PackageTester , cabal' , cabal_build , cabal_install + , cabal_install_with_docs , ghcPkg , ghcPkg' , compileSetup @@ -149,7 +150,8 @@ runTestM suite name subname m = do testShouldFail = False, testCurrentPackage = ".", testPackageDb = False, - testEnvironment = [] + -- Try to avoid Unicode output + testEnvironment = [("LC_ALL", Just "C")] } void (runReaderT (cleanup >> m) (suite, test)) where @@ -420,6 +422,17 @@ cabal_install args = do cabal "register" [] return () +-- | This abstracts the common pattern of "installing" a package, +-- with haddock documentation. +cabal_install_with_docs :: [String] -> TestM () +cabal_install_with_docs args = do + cabal "configure" args + cabal "build" [] + cabal "haddock" [] + cabal "copy" [] + cabal "register" [] + return () + -- | Determines what Setup executable to run and runs it doCabal :: [String] -- ^ extra arguments -> TestM Result @@ -669,14 +682,11 @@ whenGhcVersion p m = do withPackage :: FilePath -> TestM a -> TestM a withPackage f = withReaderT (\(suite, test) -> (suite, test { testCurrentPackage = f })) --- TODO: Really should accumulate... but I think to do this --- properly we can't just append +-- We append to the environment list, as per 'getEffectiveEnvironment' +-- which prefers the latest override. withEnv :: [(String, Maybe String)] -> TestM a -> TestM a withEnv e m = do - (_, test0) <- ask - when (not (null (testEnvironment test0))) - $ error "nested withEnv (not yet) supported" - withReaderT (\(suite, test) -> (suite, test { testEnvironment = e })) m + withReaderT (\(suite, test) -> (suite, test { testEnvironment = testEnvironment test ++ e })) m withPackageDb :: TestM a -> TestM a withPackageDb m = do diff --git a/Cabal/tests/PackageTests/ReexportedModules/containers-dupe/Data/Map.hs b/Cabal/tests/PackageTests/ReexportedModules/containers-dupe/Data/Map.hs new file mode 100644 index 00000000000..492020cbc3d --- /dev/null +++ b/Cabal/tests/PackageTests/ReexportedModules/containers-dupe/Data/Map.hs @@ -0,0 +1,3 @@ +module Data.Map where + +conflict = True diff --git a/Cabal/tests/PackageTests/ReexportedModules/containers-dupe/containers-dupe.cabal b/Cabal/tests/PackageTests/ReexportedModules/containers-dupe/containers-dupe.cabal new file mode 100644 index 00000000000..6f1cd7b3417 --- /dev/null +++ b/Cabal/tests/PackageTests/ReexportedModules/containers-dupe/containers-dupe.cabal @@ -0,0 +1,12 @@ +name: containers-dupe +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Data.Map + build-depends: base + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/ReexportedModules/p/Private.hs b/Cabal/tests/PackageTests/ReexportedModules/p/Private.hs new file mode 100644 index 00000000000..055075bd9a0 --- /dev/null +++ b/Cabal/tests/PackageTests/ReexportedModules/p/Private.hs @@ -0,0 +1,2 @@ +module Private where +modname = "Private" diff --git a/Cabal/tests/PackageTests/ReexportedModules/p/Public.hs b/Cabal/tests/PackageTests/ReexportedModules/p/Public.hs new file mode 100644 index 00000000000..97cfda0a0b8 --- /dev/null +++ b/Cabal/tests/PackageTests/ReexportedModules/p/Public.hs @@ -0,0 +1,2 @@ +module Public where +modname = "Public" diff --git a/Cabal/tests/PackageTests/ReexportedModules/p/fail-ambiguous.cabal b/Cabal/tests/PackageTests/ReexportedModules/p/fail-ambiguous.cabal new file mode 100644 index 00000000000..5f282b67df6 --- /dev/null +++ b/Cabal/tests/PackageTests/ReexportedModules/p/fail-ambiguous.cabal @@ -0,0 +1,10 @@ +name: p +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.21 + +library + build-depends: base, containers, containers-dupe + reexported-modules: Data.Map as Map diff --git a/Cabal/tests/PackageTests/ReexportedModules/p/fail-missing.cabal b/Cabal/tests/PackageTests/ReexportedModules/p/fail-missing.cabal new file mode 100644 index 00000000000..afb6bd8c830 --- /dev/null +++ b/Cabal/tests/PackageTests/ReexportedModules/p/fail-missing.cabal @@ -0,0 +1,10 @@ +name: p +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.21 + +library + build-depends: base + reexported-modules: Missing as Foobar diff --git a/Cabal/tests/PackageTests/ReexportedModules/p/fail-other.cabal b/Cabal/tests/PackageTests/ReexportedModules/p/fail-other.cabal new file mode 100644 index 00000000000..b94575fdc86 --- /dev/null +++ b/Cabal/tests/PackageTests/ReexportedModules/p/fail-other.cabal @@ -0,0 +1,12 @@ +name: p +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.21 + +library + exposed-modules: Public + other-modules: Private + build-depends: base + reexported-modules: Private as Reprivate diff --git a/Cabal/tests/PackageTests/ReexportedModules/p/p.cabal b/Cabal/tests/PackageTests/ReexportedModules/p/p.cabal index cde514334fd..8acdf656331 100644 --- a/Cabal/tests/PackageTests/ReexportedModules/p/p.cabal +++ b/Cabal/tests/PackageTests/ReexportedModules/p/p.cabal @@ -6,8 +6,12 @@ build-type: Simple cabal-version: >=1.21 library + exposed-modules: Public + other-modules: Private build-depends: base, containers reexported-modules: containers:Data.Map as DataMap, Data.Graph, Data.Set as Set, - containers:Data.Tree + containers:Data.Tree, + Public as Republic + -- NB: Private is not reexportable diff --git a/Cabal/tests/PackageTests/ReexportedModules/q/A.hs b/Cabal/tests/PackageTests/ReexportedModules/q/A.hs index 1f2f8bb678c..d68dacafbb3 100644 --- a/Cabal/tests/PackageTests/ReexportedModules/q/A.hs +++ b/Cabal/tests/PackageTests/ReexportedModules/q/A.hs @@ -3,3 +3,5 @@ import DataMap import Data.Graph import Set import Data.Tree +import Public +import Republic diff --git a/Cabal/tests/PackageTests/Tests.hs b/Cabal/tests/PackageTests/Tests.hs index 1a22d5fcd0f..a31aecbdfa9 100644 --- a/Cabal/tests/PackageTests/Tests.hs +++ b/Cabal/tests/PackageTests/Tests.hs @@ -28,6 +28,8 @@ import Control.Monad import System.Directory import Test.Tasty (mkTimeout, localOption) +import qualified Data.Char as Char + tests :: SuiteConfig -> TestTreeM () tests config = do @@ -206,11 +208,47 @@ tests config = do tc "OrderFlags" $ cabal_build [] -- Test that reexported modules build correctly - tc "ReexportedModules" . whenGhcVersion (>= mkVersion [7,9]) $ do + tcs "ReexportedModules" "p" . whenGhcVersion (>= mkVersion [7,9]) $ do withPackageDb $ do - withPackage "p" $ cabal_install [] + withPackage "p" $ cabal_install ["--cabal-file", "p.cabal"] withPackage "q" $ do cabal_build [] + tcs "ReexportedModules" "fail-other" . whenGhcVersion (>= mkVersion [7,9]) $ do + withPackage "p" $ do + r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail-other.cabal"] + assertOutputContains "Private" r + tcs "ReexportedModules" "fail-ambiguous" . whenGhcVersion (>= mkVersion [7,9]) $ do + withPackageDb $ do + withPackage "containers-dupe" $ cabal_install [] + withPackage "p" $ do + r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail-ambiguous.cabal"] + assertOutputContains "Data.Map" r + tcs "ReexportedModules" "fail-missing" . whenGhcVersion (>= mkVersion [7,9]) $ do + withPackage "p" $ do + r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail-missing.cabal"] + assertOutputContains "Missing" r + + -- Test that module name ambiguity can be resolved using package + -- qualified imports. (Paper Backpack doesn't natively support + -- this but we must!) + tcs "Ambiguity" "package-import" $ do + withPackageDb $ do + withPackage "p" $ cabal_install [] + withPackage "q" $ cabal_install [] + withPackage "package-import" $ do + cabal_build [] + runExe' "package-import" [] >>= assertOutputContains "p q" + + -- Test that we can resolve a module name ambiguity when reexporting + -- by explicitly specifying what package we want. + tcs "Ambiguity" "reexport" . whenGhcVersion (>= mkVersion [7,9]) $ do + withPackageDb $ do + withPackage "p" $ cabal_install [] + withPackage "q" $ cabal_install [] + withPackage "reexport" $ cabal_install [] + withPackage "reexport-test" $ do + cabal_build [] + runExe' "reexport-test" [] >>= assertOutputContains "p q" -- Test that Cabal computes different IPIDs when the source changes. tc "UniqueIPID" . withPackageDb $ do @@ -590,6 +628,119 @@ tests config = do assertOutputContains "There is no component" =<< shouldFail (cabal' "build" ["not-buildable-exe"]) + tc "Backpack/Includes1" . whenGhcVersion (>= mkVersion [8,1]) $ do + cabal "configure" [] + r <- shouldFail $ cabal' "build" [] + assertBool "error should be in B.hs" $ + resultOutput r =~ "^B.hs:" + assertBool "error should be \"Could not find module Data.Set\"" $ + resultOutput r =~ "(Could not find module|Failed to load interface).*Data.Set" + + tcs "Backpack/Includes2" "internal" . whenGhcVersion (>= mkVersion [8,1]) $ do + withPackageDb $ do + cabal_install ["--cabal-file", "Includes2.cabal"] + -- TODO: haddock for internal method doesn't work + runExe' "exe" [] >>= assertOutputContains "minemysql minepostgresql" + + tcs "Backpack/Includes2" "internal-fail" . whenGhcVersion (>= mkVersion [8,1]) $ do + withPackageDb $ do + r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail.cabal"] + assertOutputContains "mysql" r + + tcs "Backpack/Includes2" "external" . whenGhcVersion (>= mkVersion [8,1]) $ do + withPackageDb $ do + withPackage "mylib" $ cabal_install_with_docs ["--ipid", "mylib-0.1.0.0"] + withPackage "mysql" $ cabal_install_with_docs ["--ipid", "mysql-0.1.0.0"] + withPackage "postgresql" $ cabal_install_with_docs ["--ipid", "postgresql-0.1.0.0"] + withPackage "mylib" $ + cabal_install_with_docs ["--ipid", "mylib-0.1.0.0", + "--instantiate-with", "Database=mysql-0.1.0.0:Database.MySQL"] + withPackage "mylib" $ + cabal_install_with_docs ["--ipid", "mylib-0.1.0.0", + "--instantiate-with", "Database=postgresql-0.1.0.0:Database.PostgreSQL"] + withPackage "src" $ cabal_install_with_docs [] + withPackage "exe" $ do + cabal_install_with_docs [] + runExe' "exe" [] >>= assertOutputContains "minemysql minepostgresql" + + tcs "Backpack/Includes2" "per-component" . whenGhcVersion (>= mkVersion [8,1]) $ do + withPackageDb $ do + let cabal_install' args = cabal_install_with_docs (["--cabal-file", "Includes2.cabal"] ++ args) + cabal_install' ["mylib", "--cid", "mylib-0.1.0.0"] + cabal_install' ["mysql", "--cid", "mysql-0.1.0.0"] + cabal_install' ["postgresql", "--cid", "postgresql-0.1.0.0"] + cabal_install' ["mylib", "--cid", "mylib-0.1.0.0", + "--instantiate-with", "Database=mysql-0.1.0.0:Database.MySQL"] + cabal_install' ["mylib", "--cid", "mylib-0.1.0.0", + "--instantiate-with", "Database=postgresql-0.1.0.0:Database.PostgreSQL"] + cabal_install' ["Includes2"] + cabal_install' ["exe"] + runExe' "exe" [] >>= assertOutputContains "minemysql minepostgresql" + + tcs "Backpack/Includes3" "internal" . whenGhcVersion (>= mkVersion [8,1]) $ do + withPackageDb $ do + cabal_install [] + -- TODO: refactorize + pkg_dir <- packageDir + _ <- run (Just pkg_dir) "touch" ["indef/Foo.hs"] + cabal "build" [] + runExe' "exe" [] >>= assertOutputContains "fromList [(0,2),(2,4)]" + + tcs "Backpack/Includes3" "external-fail" . whenGhcVersion (>= mkVersion [8,1]) $ do + withPackageDb $ do + withPackage "sigs" $ cabal_install [] + withPackage "indef" $ cabal_install [] + -- Forgot to build the instantiated versions! + withPackage "exe" $ do + r <- shouldFail $ cabal' "configure" [] + assertOutputContains "indef-0.1.0.0" r + return () + + tcs "Backpack/Includes3" "external-ok" . whenGhcVersion (>= mkVersion [8,1]) $ do + withPackageDb $ do + containers_result <- ghcPkg' "field" ["--global", "containers", "id"] + containers_id <- case stripPrefix "id: " (resultOutput containers_result) of + Just x -> return (takeWhile (not . Char.isSpace) x) + Nothing -> error "could not determine id of containers" + withPackage "sigs" $ cabal_install_with_docs ["--ipid", "sigs-0.1.0.0"] + withPackage "indef" $ cabal_install_with_docs ["--ipid", "indef-0.1.0.0"] + withPackage "sigs" $ do + -- NB: this REUSES the dist directory that we typechecked + -- indefinitely, but it's OK; the recompile checker should get it. + cabal_install_with_docs ["--ipid", "sigs-0.1.0.0", + "--instantiate-with", "Data.Map=" ++ containers_id ++ ":Data.Map"] + withPackage "indef" $ do + -- Ditto. + cabal_install_with_docs ["--ipid", "indef-0.1.0.0", + "--instantiate-with", "Data.Map=" ++ containers_id ++ ":Data.Map"] + withPackage "exe" $ do + cabal_install [] + runExe' "exe" [] >>= assertOutputContains "fromList [(0,2),(2,4)]" + + tcs "Backpack/Includes3" "external-explicit" . whenGhcVersion (>= mkVersion [8,1]) $ do + withPackageDb $ do + withPackage "sigs" $ cabal_install_with_docs ["--cid", "sigs-0.1.0.0", "lib:sigs"] + withPackage "indef" $ cabal_install_with_docs ["--cid", "indef-0.1.0.0", "--dependency=sigs=sigs-0.1.0.0", "lib:indef"] + + tc "Backpack/Includes4" . whenGhcVersion (>= mkVersion [8,1]) $ do + withPackageDb $ do + cabal_install [] + runExe' "exe" [] >>= assertOutputContains "A (B (A (B" + + tc "Backpack/Includes5" . whenGhcVersion (>= mkVersion [8,1]) $ do + cabal "configure" [] + r <- shouldFail $ cabal' "build" [] + assertOutputContains "Foobar" r + assertOutputContains "Failed to load" r + return () + + tc "Backpack/Reexport1" . whenGhcVersion (>= mkVersion [8,1]) $ do + withPackageDb $ do + withPackage "p" $ cabal_install_with_docs [] + withPackage "q" $ do + cabal_build [] + cabal "haddock" [] + where ghc_pkg_guess bin_name = do cwd <- packageDir diff --git a/cabal-install/Distribution/Client/BuildTarget.hs b/cabal-install/Distribution/Client/BuildTarget.hs index 2b8151f7514..9f7539e46f6 100644 --- a/cabal-install/Distribution/Client/BuildTarget.hs +++ b/cabal-install/Distribution/Client/BuildTarget.hs @@ -51,7 +51,7 @@ import Distribution.PackageDescription , Executable(..) , TestSuite(..), TestSuiteInterface(..), testModules , Benchmark(..), BenchmarkInterface(..), benchmarkModules - , BuildInfo(..), libModules, exeModules ) + , BuildInfo(..), explicitLibModules, exeModules ) import Distribution.ModuleName ( ModuleName, toFilePath ) import Distribution.Simple.LocalBuildInfo @@ -1100,7 +1100,9 @@ componentStringName _ (CTestName name) = name componentStringName _ (CBenchName name) = name componentModules :: Component -> [ModuleName] -componentModules (CLib lib) = libModules lib +-- I think it's unlikely users will ask to build a requirement +-- which is not mentioned locally. +componentModules (CLib lib) = explicitLibModules lib componentModules (CExe exe) = exeModules exe componentModules (CTest test) = testModules test componentModules (CBench bench) = benchmarkModules bench diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 4dfed4e7524..624c0b91141 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -274,6 +274,7 @@ instance Semigroup SavedConfig where -- TODO: NubListify configProgramArgs = lastNonEmpty configProgramArgs, configProgramPathExtra = lastNonEmptyNL configProgramPathExtra, + configInstantiateWith = lastNonEmpty configInstantiateWith, configHcFlavor = combine configHcFlavor, configHcPath = combine configHcPath, configHcPkg = combine configHcPkg, diff --git a/cabal-install/Distribution/Client/DistDirLayout.hs b/cabal-install/Distribution/Client/DistDirLayout.hs index c69d862601b..2e47379f12a 100644 --- a/cabal-install/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/Distribution/Client/DistDirLayout.hs @@ -127,8 +127,9 @@ defaultDistDirLayout projectRootDirectory = NoOptimisation -> "noopt" NormalOptimisation -> "" MaximumOptimisation -> "opt") - (case distParamUnitId params of -- For Backpack - SimpleUnitId _ -> "") + (case distParamUnitId params of + UnitId _ (Just hash) -> hash + UnitId _ Nothing -> "") distUnpackedSrcRootDirectory = distDirectory "src" distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory diff --git a/cabal-install/Distribution/Client/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs index 8aa508a22fa..826bf19031e 100644 --- a/cabal-install/Distribution/Client/InstallPlan.hs +++ b/cabal-install/Distribution/Client/InstallPlan.hs @@ -35,6 +35,7 @@ module Distribution.Client.InstallPlan ( depends, fromSolverInstallPlan, + fromSolverInstallPlanWithProgress, configureInstallPlan, remove, installed, @@ -85,6 +86,8 @@ import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.InstSolverPackage +import Distribution.Utils.LogProgress + -- TODO: Need this when we compute final UnitIds -- import qualified Distribution.Simple.Configure as Configure @@ -435,6 +438,38 @@ fromSolverInstallPlan f plan = -- on neighbor SolverId, which must have all been done already -- by the reverse top-sort (we assume the graph is not broken). + +fromSolverInstallPlanWithProgress :: + (IsUnit ipkg, IsUnit srcpkg) + => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) + -> SolverInstallPlan.SolverPlanPackage + -> LogProgress [GenericPlanPackage ipkg srcpkg] ) + -> SolverInstallPlan + -> LogProgress (GenericInstallPlan ipkg srcpkg) +fromSolverInstallPlanWithProgress f plan = do + (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, []) + (SolverInstallPlan.reverseTopologicalOrder plan) + return $ mkInstallPlan (Graph.fromList pkgs'') + (SolverInstallPlan.planIndepGoals plan) + where + f' (pidMap, ipiMap, pkgs) pkg = do + pkgs' <- f (mapDep pidMap ipiMap) pkg + let (pidMap', ipiMap') + = case nodeKey pkg of + PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) + PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) + return (pidMap', ipiMap', pkgs' ++ pkgs) + + mapDep _ ipiMap (PreExistingId _pid uid) + | Just pkgs <- Map.lookup uid ipiMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid) + mapDep pidMap _ (PlannedId pid) + | Just pkgs <- Map.lookup pid pidMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid) + -- This shouldn't happen, since mapDep should only be called + -- on neighbor SolverId, which must have all been done already + -- by the reverse top-sort (we assume the graph is not broken). + -- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. -- Similar to 'elaboratedInstallPlan' configureInstallPlan :: SolverInstallPlan -> InstallPlan @@ -458,8 +493,8 @@ configureInstallPlan solverPlan = Cabal.NoFlag (packageId spkg) PD.CLibName - (map confInstId (CD.libraryDeps deps)) - (solverPkgFlags spkg), + (Just (map confInstId (CD.libraryDeps deps), + solverPkgFlags spkg)), confPkgSource = solverPkgSource spkg, confPkgFlags = solverPkgFlags spkg, confPkgStanzas = solverPkgStanzas spkg, diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index 365f4e30467..5c92bc9b17f 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -539,6 +539,7 @@ convertToLegacyAllPackageConfig configHcFlavor = projectConfigHcFlavor, configHcPath = projectConfigHcPath, configHcPkg = projectConfigHcPkg, + configInstantiateWith = mempty, configVanillaLib = mempty, configProfLib = mempty, configSharedLib = mempty, @@ -604,6 +605,7 @@ convertToLegacyPerPackageConfig PackageConfig {..} = configHcFlavor = mempty, configHcPath = mempty, configHcPkg = mempty, + configInstantiateWith = mempty, configVanillaLib = packageConfigVanillaLib, configProfLib = packageConfigProfLib, configSharedLib = packageConfigSharedLib, diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index b2c584753d5..ecf73c7cfdc 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -74,6 +74,9 @@ import Distribution.Client.FetchUtils import qualified Hackage.Security.Client as Sec import Distribution.Client.Setup hiding (packageName, cabalVersion) import Distribution.Utils.NubList +import Distribution.Utils.LogProgress +import Distribution.Utils.Progress (failProgress) +import Distribution.Utils.MapAccum import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ComponentDeps (ComponentDeps) @@ -86,7 +89,9 @@ import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Settings +import Distribution.ModuleName import Distribution.Package hiding (InstalledPackageId, installedPackageId) import Distribution.System @@ -109,6 +114,13 @@ import Distribution.Simple.LocalBuildInfo (ComponentName(..)) import qualified Distribution.Simple.Register as Cabal import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.ComponentsGraph +import Distribution.Backpack.ModuleShape +import Distribution.Backpack.FullUnitId +import Distribution.Backpack + import Distribution.Simple.Utils hiding (matchFileGlob) import Distribution.Version import Distribution.Verbosity @@ -117,13 +129,15 @@ import Distribution.Text import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph(IsNode(..)) +import Text.PrettyPrint (text, (<+>)) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Control.Monad +import qualified Data.Traversable as T import Control.Monad.State as State import Control.Exception -import Data.List (groupBy, mapAccumL) +import Data.List (groupBy) import Data.Either import Data.Function import System.FilePath @@ -311,7 +325,10 @@ rebuildInstallPlan verbosity localPackages phaseMaintainPlanOutputs elaboratedPlan elaboratedShared - return (elaboratedPlan, elaboratedShared, projectConfig) + let instantiatedPlan = phaseInstantiatePlan elaboratedPlan + liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) + + return (instantiatedPlan, elaboratedShared, projectConfig) -- The improved plan changes each time we install something, whereas -- the underlying elaborated plan only changes when input config @@ -546,8 +563,10 @@ rebuildInstallPlan verbosity getPackageSourceHashes verbosity withRepoCtx solverPlan defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler - let (elaboratedPlan, elaboratedShared) = + (elaboratedPlan, elaboratedShared) + <- liftIO . runLogProgress verbosity $ elaborateInstallPlan + verbosity platform compiler progdb pkgConfigDB distDirLayout cabalDirLayout @@ -565,6 +584,10 @@ rebuildInstallPlan verbosity projectConfigShared projectConfigBuildOnly + phaseInstantiatePlan :: ElaboratedInstallPlan + -> ElaboratedInstallPlan + phaseInstantiatePlan plan = instantiateInstallPlan plan + -- Update the files we maintain that reflect our current build environment. -- In particular we maintain a JSON representation of the elaborated -- install plan (but not the improved plan since that reflects the state @@ -674,7 +697,7 @@ getInstalledStorePackages :: FilePath -- ^ store directory -> Rebuild (Set UnitId) getInstalledStorePackages storeDirectory = do paths <- getDirectoryContentsMonitored storeDirectory - return $ Set.fromList [ SimpleUnitId (mkComponentId path) + return $ Set.fromList [ newSimpleUnitId (mkComponentId path) | path <- paths, valid path ] where valid ('.':_) = False @@ -1014,7 +1037,7 @@ planPackages comp platform solver SolverSettings{..} -- matching that of the classic @cabal install --user@ or @--global@ -- elaborateInstallPlan - :: Platform -> Compiler -> ProgramDb -> PkgConfigDb + :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb -> DistDirLayout -> CabalDirLayout -> SolverInstallPlan @@ -1024,8 +1047,8 @@ elaborateInstallPlan -> ProjectConfigShared -> PackageConfig -> Map PackageName PackageConfig - -> (ElaboratedInstallPlan, ElaboratedSharedConfig) -elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB + -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) +elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB DistDirLayout{..} cabalDirLayout@CabalDirLayout{cabalStorePackageDB} solverPlan localPackages @@ -1033,8 +1056,9 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB defaultInstallDirs _sharedPackageConfig localPackagesConfig - perPackageConfig = - (elaboratedInstallPlan, elaboratedSharedConfig) + perPackageConfig = do + x <- elaboratedInstallPlan + return (x, elaboratedSharedConfig) where elaboratedSharedConfig = ElaboratedSharedConfig { @@ -1044,72 +1068,127 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB } elaboratedInstallPlan = - flip InstallPlan.fromSolverInstallPlan solverPlan $ \mapDep planpkg -> + flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> case planpkg of SolverInstallPlan.PreExisting pkg -> - [InstallPlan.PreExisting (instSolverPkgIPI pkg)] + return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] SolverInstallPlan.Configured pkg -> - -- SolverPackage - let pd = PD.packageDescription (packageDescription (solverPkgSource pkg)) - eligible - -- At this point in time, only non-Custom setup scripts - -- are supported. Implementing per-component builds with - -- Custom would require us to create a new 'ElabSetup' - -- type, and teach all of the code paths how to handle it. - -- Once you've implemented that, delete this guard. - | fromMaybe PD.Custom (PD.buildType pd) == PD.Custom - = False - -- Only non-Custom or sufficiently recent Custom - -- scripts can be expanded. - | otherwise - = (fromMaybe PD.Custom (PD.buildType pd) /= PD.Custom - -- This is when we started distributing dependencies - -- per component (instead of glomming them altogether - -- and distributing to everything.) I didn't feel - -- like implementing the legacy behavior. - && PD.specVersion pd >= mkVersion [1,7,1] - ) - || PD.specVersion pd >= mkVersion [2,0,0] - in map InstallPlan.Configured $ if eligible - then elaborateSolverToComponents mapDep pkg - else [elaborateSolverToPackage mapDep pkg] + map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg + -- NB: We don't INSTANTIATE packages at this point. That's + -- a post-pass. This makes it simpler to compute dependencies. elaborateSolverToComponents :: (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc - -> [ElaboratedConfiguredPackage] + -> LogProgress [ElaboratedConfiguredPackage] elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) - = snd (mapAccumL buildComponent (Map.empty, Map.empty) comps_graph) + | Right g <- toComponentsGraph (elabEnabledSpec elab0) pd = do + (_, comps) <- mapAccumM buildComponent + ((Map.empty, Map.empty), Map.empty, Map.empty) + (map fst g) + let is_public_lib ElaboratedConfiguredPackage{..} = + case elabPkgOrComp of + ElabComponent comp -> compSolverName comp == CD.ComponentLib + _ -> False + modShape = case find is_public_lib comps of + Nothing -> emptyModuleShape + Just ElaboratedConfiguredPackage{..} -> elabModuleShape + return $ if eligible + then comps + else [(elaborateSolverToPackage mapDep spkg) { + elabModuleShape = modShape + }] + | otherwise = failProgress (text "component cycle in" <+> disp pkgid) where - elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon mapDep spkg - comps_graph = - case Cabal.mkComponentsGraph - elabEnabledSpec - elabPkgDescription - elabInternalPackages of - Left _ -> error ("component cycle in " ++ display elabPkgSourceId) - Right g -> g - - buildComponent :: (Map PackageName ConfiguredId, Map String (ConfiguredId, FilePath)) - -> (Cabal.Component, [Cabal.ComponentName]) - -> ((Map PackageName ConfiguredId, Map String (ConfiguredId, FilePath)), - ElaboratedConfiguredPackage) - buildComponent (internal_map, exe_map) (comp, _cdeps) = - ((internal_map', exe_map'), elab) + eligible + -- At this point in time, only non-Custom setup scripts + -- are supported. Implementing per-component builds with + -- Custom would require us to create a new 'ElabSetup' + -- type, and teach all of the code paths how to handle it. + -- Once you've implemented this, swap it for the code below. + = fromMaybe PD.Custom (PD.buildType (elabPkgDescription elab0)) /= PD.Custom + {- + -- Only non-Custom or sufficiently recent Custom + -- scripts can be build per-component. + = (fromMaybe PD.Custom (PD.buildType pd) /= PD.Custom) + || PD.specVersion pd >= mkVersion [2,0,0] + -} + + elab0 = elaborateSolverToCommon mapDep spkg + pkgid = elabPkgSourceId elab0 + pd = elabPkgDescription elab0 + + buildComponent + :: (ConfiguredComponentMap, + LinkedComponentMap, + Map ComponentId FilePath) + -> Cabal.Component + -> LogProgress + ((ConfiguredComponentMap, + LinkedComponentMap, + Map ComponentId FilePath), + ElaboratedConfiguredPackage) + buildComponent (cc_map, lc_map, exe_map) comp = do + infoProgress $ dispConfiguredComponent cc + let -- Use of invariant: DefUnitId indicates that if + -- there is no hash, it must have an empty + -- instnatiation. + lookup_uid def_uid = + case unDefUnitId def_uid of + UnitId sub_cid Nothing -> FullUnitId sub_cid Map.empty + -- TODO: This case CAN happen if we have pre-existing + -- instantiated things. Fix eventually. + uid -> error ("lookup_uid: " ++ display uid) + lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0) + (Map.union external_lc_map lc_map) cc + let lc_map' = extendLinkedComponentMap lc lc_map + infoProgress $ dispLinkedComponent lc + -- NB: For inplace NOT InstallPaths.bindir installDirs; for an + -- inplace build those values are utter nonsense. So we + -- have to guess where the directory is going to be. + -- Fortunately this is "stable" part of Cabal API. + -- But the way we get the build directory is A HORRIBLE + -- HACK. + let elab = elab1 { + elabModuleShape = lc_shape lc, + elabUnitId = abstractUnitId (lc_uid lc), + elabLinkedInstantiatedWith = Map.fromList (lc_insts lc), + elabPkgOrComp = ElabComponent $ elab_comp { + compLinkedLibDependencies = map fst (lc_depends lc), + compNonSetupDependencies = + ordNub (map (abstractUnitId . fst) (lc_depends lc)) + } + } + inplace_bin_dir + | shouldBuildInplaceOnly spkg + = distBuildDirectory + (elabDistDirParams elaboratedSharedConfig elab) + "build" case Cabal.componentNameString cname of + Just n -> n + Nothing -> "" + | otherwise + = InstallDirs.bindir install_dirs + exe_map' = Map.insert cid inplace_bin_dir exe_map + return ((cc_map', lc_map', exe_map'), elab) where - elab = elab0 { - elabUnitId = SimpleUnitId cid, -- Backpack later! + elab1 = elab0 { elabInstallDirs = install_dirs, elabRequiresRegistration = requires_reg, - elabPkgOrComp = ElabComponent $ ElaboratedComponent {..} + elabPkgOrComp = ElabComponent $ elab_comp } + elab_comp = ElaboratedComponent {..} + compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" + compNonSetupDependencies = error "buildComponent: compNonSetupDependencies" + + cc = toConfiguredComponent pd cid external_cc_map cc_map comp + cc_map' = extendConfiguredComponentMap cc cc_map cid :: ComponentId - cid = case elabBuildStyle of + cid = case elabBuildStyle elab0 of BuildInplaceOnly -> mkComponentId $ - display elabPkgSourceId ++ "-inplace" ++ + display pkgid ++ "-inplace" ++ (case Cabal.componentNameString cname of Nothing -> "" Just s -> "-" ++ s) @@ -1117,7 +1196,7 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB hashedInstalledPackageId (packageHashInputs elaboratedSharedConfig - elab) -- knot tied + elab1) -- knot tied cname = Cabal.componentName comp requires_reg = case cname of @@ -1126,74 +1205,38 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB _ -> False compComponentName = Just cname compSolverName = CD.componentNameToComponent cname + -- NB: compLinkedLibDependencies and + -- compNonSetupDependencies are defined when we define + -- 'elab'. compLibDependencies = - concatMap (elaborateLibSolverId mapDep) - (CD.select (== compSolverName) deps0) ++ - internal_lib_deps + concatMap (elaborateLibSolverId mapDep) external_lib_dep_sids compExeDependencies = - (map confInstId $ - concatMap (elaborateExeSolverId mapDep) - (CD.select (== compSolverName) exe_deps0)) ++ - internal_exe_deps + map confInstId + (concatMap (elaborateExeSolverId mapDep) external_exe_dep_sids) ++ + cc_internal_build_tools cc compExeDependencyPaths = concatMap (elaborateExePath mapDep) (CD.select (== compSolverName) exe_deps0) ++ - internal_exe_paths + [ path + | cid' <- compExeDependencies + , Just path <- [Map.lookup cid' exe_map]] + + bi = Cabal.componentBuildInfo comp compPkgConfigDependencies = [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! " - ++ display pn ++ " from " ++ display elabPkgSourceId) + ++ display pn ++ " from " + ++ display (elabPkgSourceId elab1)) (pkgConfigDbPkgVersion pkgConfigDB pn)) | Dependency pn _ <- PD.pkgconfigDepends bi ] - bi = Cabal.componentBuildInfo comp - confid = ConfiguredId elabPkgSourceId cid - compSetupDependencies = concatMap (elaborateLibSolverId mapDep) (CD.setupDeps deps0) - internal_lib_deps - = [ confid' - | Dependency pkgname _ <- PD.targetBuildDepends bi - , Just confid' <- [Map.lookup pkgname internal_map] ] - (internal_exe_deps, internal_exe_paths) - = unzip $ - [ (confInstId confid', path) - | Dependency (unPackageName -> toolname) _ <- PD.buildTools bi - , toolname `elem` map PD.exeName (PD.executables elabPkgDescription) - , Just (confid', path) <- [Map.lookup toolname exe_map] - ] - - internal_map' = case cname of - CLibName - -> Map.insert (packageName elabPkgSourceId) confid internal_map - CSubLibName libname - -> Map.insert (mkPackageName libname) confid internal_map - _ -> internal_map - exe_map' = case cname of - CExeName exename - -> Map.insert exename (confid, inplace_bin_dir) exe_map - _ -> exe_map - - -- NB: For inplace NOT InstallPaths.bindir installDirs; for an - -- inplace build those values are utter nonsense. So we - -- have to guess where the directory is going to be. - -- Fortunately this is "stable" part of Cabal API. - -- But the way we get the build directory is A HORRIBLE - -- HACK. - inplace_bin_dir - | shouldBuildInplaceOnly spkg - = distBuildDirectory - (elabDistDirParams elaboratedSharedConfig elab) - "build" case Cabal.componentNameString cname of - Just n -> n - Nothing -> "" - | otherwise - = InstallDirs.bindir install_dirs install_dirs | shouldBuildInplaceOnly spkg -- use the ordinary default install dirs = (InstallDirs.absoluteInstallDirs - elabPkgSourceId - (SimpleUnitId cid) + pkgid + (newSimpleUnitId cid) (compilerInfo compiler) InstallDirs.NoCopyDest platform @@ -1210,9 +1253,40 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB (compilerId compiler) cid - elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverId -> [ConfiguredId] - elaborateLibSolverId mapDep = map configuredId . filter is_lib . mapDep + external_lib_dep_sids = CD.select (== compSolverName) deps0 + external_lib_dep_pkgs = concatMap (elaborateLibSolverId' mapDep) external_lib_dep_sids + external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 + external_cc_map = Map.fromList (map mkPkgNameMapping external_lib_dep_pkgs) + external_lc_map = Map.fromList (map mkShapeMapping external_lib_dep_pkgs) + + componentId = unitIdComponentId . installedUnitId + + mkPkgNameMapping :: ElaboratedPlanPackage + -> (PackageName, (ComponentId, PackageId)) + mkPkgNameMapping dpkg = + (packageName dpkg, (componentId dpkg, packageId dpkg)) + + mkShapeMapping :: ElaboratedPlanPackage + -> (ComponentId, (OpenUnitId, ModuleShape)) + mkShapeMapping dpkg = + (componentId dpkg, (indef_uid, shape)) + where + shape = planPkgShape dpkg + indef_uid = + IndefFullUnitId (unitIdComponentId (installedUnitId dpkg)) + (Map.fromList [ (req, OpenModuleVar req) + | req <- Set.toList (modShapeRequires shape)]) + + planPkgShape :: ElaboratedPlanPackage -> ModuleShape + planPkgShape (InstallPlan.PreExisting dipkg) = shapeInstalledPackage dipkg + planPkgShape (InstallPlan.Configured elab') + = elabModuleShape elab' + planPkgShape (InstallPlan.Installed elab') + = elabModuleShape elab' + + elaborateLibSolverId' :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverId -> [ElaboratedPlanPackage] + elaborateLibSolverId' mapDep = filter is_lib . mapDep where is_lib (InstallPlan.PreExisting _) = True is_lib (InstallPlan.Configured elab) = case elabPkgOrComp elab of @@ -1220,6 +1294,10 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB ElabComponent comp -> compSolverName comp == CD.ComponentLib is_lib (InstallPlan.Installed _) = unexpectedState + elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverId -> [ConfiguredId] + elaborateLibSolverId mapDep = map configuredId . elaborateLibSolverId' mapDep + elaborateExeSolverId :: (SolverId -> [ElaboratedPlanPackage]) -> SolverId -> [ConfiguredId] elaborateExeSolverId mapDep = map configuredId . filter is_exe . mapDep @@ -1272,7 +1350,8 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB where elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon mapDep pkg elab = elab0 { - elabUnitId = SimpleUnitId pkgInstalledId, + elabUnitId = newSimpleUnitId pkgInstalledId, + elabLinkedInstantiatedWith = Map.empty, elabInstallDirs = install_dirs, elabRequiresRegistration = requires_reg, elabPkgOrComp = ElabPackage $ ElaboratedPackage {..} @@ -1316,7 +1395,7 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB -- use the ordinary default install dirs = (InstallDirs.absoluteInstallDirs pkgid - (SimpleUnitId pkgInstalledId) + (newSimpleUnitId pkgInstalledId) (compilerInfo compiler) InstallDirs.NoCopyDest platform @@ -1345,9 +1424,12 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB -- These get filled in later elabUnitId = error "elaborateSolverToCommon: elabUnitId" + elabInstantiatedWith = Map.empty + elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith" elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" elabRequiresRegistration = error "elaborateSolverToCommon: elabRequiresRegistration" + elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" elabPkgSourceId = pkgid elabPkgDescription = let Right (desc, _) = @@ -1603,6 +1685,108 @@ instance IsNode NonSetupLibDepSolverPlanPackage where nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg) = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg) +type InstS = Map UnitId ElaboratedPlanPackage +type InstM a = State InstS a + +instantiateInstallPlan :: ElaboratedInstallPlan -> ElaboratedInstallPlan +instantiateInstallPlan plan = + InstallPlan.new (IndependentGoals False) (Graph.fromList (Map.elems ready_map)) + where + pkgs = InstallPlan.toList plan + + cmap = Map.fromList [ (unitIdComponentId (nodeKey pkg), pkg) | pkg <- pkgs ] + + instantiateUnitId :: ComponentId -> Map ModuleName Module + -> InstM DefUnitId + instantiateUnitId cid insts = state $ \s -> + case Map.lookup uid s of + Nothing -> + -- Knot tied + let (r, s') = runState (instantiateComponent uid cid insts) + (Map.insert uid r s) + in (def_uid, Map.insert uid r s') + Just _ -> (def_uid, s) + where + def_uid = mkDefUnitId cid insts + uid = unDefUnitId def_uid + + instantiateComponent + :: UnitId -> ComponentId -> Map ModuleName Module + -> InstM ElaboratedPlanPackage + instantiateComponent uid cid insts + | Just planpkg <- Map.lookup cid cmap + = case planpkg of + InstallPlan.Configured (elab@ElaboratedConfiguredPackage + { elabPkgOrComp = ElabComponent comp }) -> do + deps <- mapM (substUnitId insts) + (compLinkedLibDependencies comp) + let getDep (Module dep_uid _) = [dep_uid] + return $ InstallPlan.Configured elab { + elabUnitId = uid, + elabInstantiatedWith = insts, + elabPkgOrComp = ElabComponent comp { + compNonSetupDependencies = + (if Map.null insts then [] else [newSimpleUnitId cid]) ++ + ordNub (map unDefUnitId + (deps ++ concatMap getDep (Map.elems insts))) + } + } + _ -> return planpkg + | otherwise = error ("instantiateComponent: " ++ display cid) + + substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId + substUnitId _ (DefiniteUnitId uid) = + return uid + substUnitId subst (IndefFullUnitId cid insts) = do + insts' <- substSubst subst insts + instantiateUnitId cid insts' + + -- NB: NOT composition + substSubst :: Map ModuleName Module + -> Map ModuleName OpenModule + -> InstM (Map ModuleName Module) + substSubst subst insts = T.mapM (substModule subst) insts + + substModule :: Map ModuleName Module -> OpenModule -> InstM Module + substModule subst (OpenModuleVar mod_name) + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" + substModule subst (OpenModule uid mod_name) = do + uid' <- substUnitId subst uid + return (Module uid' mod_name) + + indefiniteUnitId :: ComponentId -> InstM UnitId + indefiniteUnitId cid = do + let uid = newSimpleUnitId cid + r <- indefiniteComponent uid cid + state $ \s -> (uid, Map.insert uid r s) + + indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage + indefiniteComponent _uid cid + | Just planpkg <- Map.lookup cid cmap + = case planpkg of + InstallPlan.Configured elab@ElaboratedConfiguredPackage + { elabPkgOrComp = ElabComponent comp } -> + return $ InstallPlan.Configured elab { + elabPkgOrComp = ElabComponent comp { + compNonSetupDependencies = + ordNub (map abstractUnitId (compLinkedLibDependencies comp)) + } + } + _ -> return planpkg -- shouldn't happen + | otherwise = error ("indefiniteComponent: " ++ display cid) + + ready_map = execState work Map.empty + + work = forM_ pkgs $ \pkg -> + case pkg of + InstallPlan.Configured elab + | not (Map.null (elabLinkedInstantiatedWith elab)) + -> indefiniteUnitId (unitIdComponentId (nodeKey elab)) + >> return () + _ -> instantiateUnitId (unitIdComponentId (nodeKey pkg)) Map.empty + >> return () + --------------------------- -- Build targets -- @@ -1702,6 +1886,7 @@ elabBuildTargetWholeComponents elab = [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ] + ------------------------------------------------------------------------------ -- * Install plan pruning ------------------------------------------------------------------------------ @@ -1967,15 +2152,15 @@ pruneInstallPlanPass2 pkgs = hasReverseLibDeps :: Set UnitId hasReverseLibDeps = - Set.fromList [ SimpleUnitId (confInstId depid) + Set.fromList [ depid | InstallPlan.Configured pkg <- pkgs - , depid <- elabLibDependencies pkg ] + , depid <- elabOrderLibDependencies pkg ] hasReverseExeDeps :: Set UnitId hasReverseExeDeps = - Set.fromList [ SimpleUnitId depid + Set.fromList [ depid | InstallPlan.Configured pkg <- pkgs - , depid <- elabExeDependencies pkg ] + , depid <- elabOrderExeDependencies pkg ] mapConfiguredPackage :: (srcpkg -> srcpkg') -> InstallPlan.GenericPlanPackage ipkg srcpkg @@ -2354,6 +2539,8 @@ setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) configCabalFilePath = mempty configVerbosity = toFlag verbosity + configInstantiateWith = Map.toList elabInstantiatedWith + configIPID = case elabPkgOrComp of ElabPackage pkg -> toFlag (display (pkgInstalledId pkg)) ElabComponent _ -> mempty diff --git a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs index 51d1017d279..9ca86f64977 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs @@ -16,7 +16,9 @@ module Distribution.Client.ProjectPlanning.Types ( elabDistDirParams, elabExeDependencyPaths, elabLibDependencies, + elabOrderLibDependencies, elabExeDependencies, + elabOrderExeDependencies, elabSetupDependencies, elabPkgConfigDependencies, @@ -49,6 +51,9 @@ import Distribution.Client.SolverInstallPlan ( SolverInstallPlan ) import Distribution.Client.DistDirLayout +import Distribution.Backpack +import Distribution.Backpack.ModuleShape + import Distribution.Types.ComponentRequestedSpec import Distribution.Package hiding (InstalledPackageId, installedPackageId) @@ -117,6 +122,9 @@ data ElaboratedConfiguredPackage -- | The 'UnitId' which uniquely identifies this item in a build plan elabUnitId :: UnitId, + elabInstantiatedWith :: Map ModuleName Module, + elabLinkedInstantiatedWith :: Map ModuleName OpenModule, + -- | The 'PackageId' of the originating package elabPkgSourceId :: PackageId, @@ -124,6 +132,9 @@ data ElaboratedConfiguredPackage -- package that is overloaded with an internal component name elabInternalPackages :: Map PackageName ComponentName, + -- | Shape of the package/component, for Backpack. + elabModuleShape :: ModuleShape, + -- | A total flag assignment for the package. -- TODO: Actually this can be per-component if we drop -- all flags that don't affect a component. @@ -265,11 +276,7 @@ instance HasUnitId ElaboratedConfiguredPackage where instance IsNode ElaboratedConfiguredPackage where type Key ElaboratedConfiguredPackage = UnitId nodeKey = elabUnitId - nodeNeighbors elab = case elabPkgOrComp elab of - -- Important not to have duplicates: otherwise InstallPlan gets - -- confused. NB: this DOES include setup deps. - ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg)) - ElabComponent comp -> compOrderDependencies comp + nodeNeighbors = elabOrderDependencies instance Binary ElaboratedConfiguredPackage @@ -292,31 +299,74 @@ elabDistDirParams shared elab = DistDirParams { distParamOptimization = elabOptimization elab } +-- | The full set of dependencies which dictate what order we +-- need to build things in the install plan: "order dependencies" +-- balls everything together. This is mostly only useful for +-- ordering; if you are, for example, trying to compute what +-- @--dependency@ flags to pass to a Setup script, you need to +-- use 'elabLibDependencies'. This method is the same as +-- 'nodeNeighbors'. +-- +-- NB: this method DOES include setup deps. +elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderDependencies elab = + case elabPkgOrComp elab of + -- Important not to have duplicates: otherwise InstallPlan gets + -- confused. + ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg)) + ElabComponent comp -> compOrderDependencies comp + +-- | Like 'elabOrderDependencies', but only returns dependencies on +-- libraries. +elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderLibDependencies elab = + case elabPkgOrComp elab of + ElabPackage _ -> map (newSimpleUnitId . confInstId) (elabLibDependencies elab) + ElabComponent comp -> compOrderLibDependencies comp + -- | The library dependencies (i.e., the libraries we depend on, NOT -- the dependencies of the library), NOT including setup dependencies. +-- These are passed to the @Setup@ script via @--dependency@. elabLibDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] -elabLibDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } - = ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) -elabLibDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } - = compLibDependencies comp - +elabLibDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) + ElabComponent comp -> compLibDependencies comp + +-- | Like 'elabOrderDependencies', but only returns dependencies on +-- executables. (This coincides with 'elabExeDependencies'.) +elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderExeDependencies = + map newSimpleUnitId . elabExeDependencies + +-- | The executable dependencies (i.e., the executables we depend on); +-- these are the executables we must add to the PATH before we invoke +-- the setup script. elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId] -elabExeDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } - = map confInstId (CD.nonSetupDeps (pkgExeDependencies pkg)) -elabExeDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } - = compExeDependencies comp - +elabExeDependencies elab = + case elabPkgOrComp elab of + -- TODO: pkgExeDependencies being ConfiguredId is slightly awkward + ElabPackage pkg -> map confInstId (CD.nonSetupDeps (pkgExeDependencies pkg)) + ElabComponent comp -> compExeDependencies comp + +-- | This returns the paths of all the executables we depend on; we +-- must add these paths to PATH before invoking the setup script. +-- (This is usually what you want, not 'elabExeDependencies', if you +-- actually want to build something.) elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] -elabExeDependencyPaths ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } - = CD.nonSetupDeps (pkgExeDependencyPaths pkg) -elabExeDependencyPaths ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } - = compExeDependencyPaths comp - +elabExeDependencyPaths elab = + case elabPkgOrComp elab of + ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencyPaths pkg) + ElabComponent comp -> compExeDependencyPaths comp + +-- | The setup dependencies (the library dependencies of the setup executable; +-- note that it is not legal for setup scripts to have executable +-- dependencies at the moment.) elabSetupDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] -elabSetupDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } - = CD.setupDeps (pkgLibDependencies pkg) -elabSetupDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } - = compSetupDependencies comp +elabSetupDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) + ElabComponent comp -> compSetupDependencies comp elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PackageName, Maybe Version)] elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } @@ -324,7 +374,6 @@ elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPack elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } = compPkgConfigDependencies comp - -- | Some extra metadata associated with an -- 'ElaboratedConfiguredPackage' which indicates that the "package" -- in question is actually a single component to be built. Arguably @@ -339,15 +388,24 @@ data ElaboratedComponent -- | The name of the component to be built. Nothing if -- it's a setup dep. compComponentName :: Maybe ComponentName, - -- | The library dependencies of this component. + -- | The *external* library dependencies of this component. We + -- pass this to the configure script. compLibDependencies :: [ConfiguredId], - -- | The executable dependencies of this component. + -- | The linked dependencies of the component which combined with the + -- substitution in 'elabComponentId' specify the dependencies we + -- care about from the perspective of ORDERING builds. It's more + -- precise than 'compLibDependencies', and also stores information + -- about internal dependencies. + compLinkedLibDependencies :: [OpenUnitId], + -- | The executable dependencies of this component (including + -- internal executables). compExeDependencies :: [ComponentId], -- | The @pkg-config@ dependencies of the component compPkgConfigDependencies :: [(PackageName, Maybe Version)], -- | The paths all our executable dependencies will be installed -- to once they are installed. compExeDependencyPaths :: [FilePath], + compNonSetupDependencies :: [UnitId], -- | The setup dependencies. TODO: Remove this when setups -- are components of their own. compSetupDependencies :: [ConfiguredId] @@ -356,12 +414,21 @@ data ElaboratedComponent instance Binary ElaboratedComponent +-- | See 'elabOrderDependencies'. compOrderDependencies :: ElaboratedComponent -> [UnitId] compOrderDependencies comp = - -- TODO: Change this with Backpack! - map (SimpleUnitId . confInstId) (compLibDependencies comp) - ++ map SimpleUnitId (compExeDependencies comp) - ++ map (SimpleUnitId . confInstId) (compSetupDependencies comp) + compOrderLibDependencies comp + ++ compOrderExeDependencies comp + +-- | See 'elabOrderExeDependencies'. +compOrderExeDependencies :: ElaboratedComponent -> [UnitId] +compOrderExeDependencies = map newSimpleUnitId . compExeDependencies + +-- | See 'elabOrderLibDependencies'. +compOrderLibDependencies :: ElaboratedComponent -> [UnitId] +compOrderLibDependencies comp = + compNonSetupDependencies comp + ++ map (newSimpleUnitId . confInstId) (compSetupDependencies comp) data ElaboratedPackage = ElaboratedPackage { @@ -394,10 +461,12 @@ data ElaboratedPackage instance Binary ElaboratedPackage +-- | See 'elabOrderDependencies'. This gives the unflattened version, +-- which can be useful in some circumstances. pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] pkgOrderDependencies pkg = - fmap (map (SimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend` - fmap (map (SimpleUnitId . confInstId)) (pkgExeDependencies pkg) + fmap (map (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend` + fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) -- | This is used in the install plan to indicate how the package will be -- built. diff --git a/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal-install/Distribution/Client/SetupWrapper.hs index e13bd7ca4b6..febd44758fa 100644 --- a/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/Distribution/Client/SetupWrapper.hs @@ -30,8 +30,9 @@ import Distribution.Version ( Version, mkVersion, versionNumbers, VersionRange, anyVersion , intersectVersionRanges, orLaterVersion , withinRange ) +import qualified Distribution.Backpack as Backpack import Distribution.Package - ( UnitId(..), ComponentId, PackageId, mkPackageName + ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId, PackageId, mkPackageName , PackageIdentifier(..), packageVersion, packageName, Dependency(..) ) import Distribution.PackageDescription ( GenericPackageDescription(packageDescription) @@ -817,7 +818,9 @@ getExternalSetupMethod verbosity options pkg bt = do if any (isCabalPkgId . snd) (useDependencies options') then [] else cabalDep - addRenaming (ipid, _) = (SimpleUnitId ipid, defaultRenaming) + addRenaming (ipid, _) = + -- Assert 'DefUnitId' invariant + (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)), defaultRenaming) cppMacrosFile = setupDir "setup_macros.h" ghcOptions = mempty { -- Respect -v0, but don't crank up verbosity on GHC if diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index 447d7f66556..ad0ad5a12bb 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/cabal-install/Distribution/Client/Types.hs @@ -22,8 +22,8 @@ module Distribution.Client.Types where import Distribution.Package ( PackageName, PackageId, Package(..) - , UnitId(..), ComponentId, HasUnitId(..) - , PackageInstalled(..), unitIdComponentId ) + , UnitId, ComponentId, HasUnitId(..) + , PackageInstalled(..), unitIdComponentId, newSimpleUnitId ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.PackageDescription @@ -113,11 +113,11 @@ instance HasConfiguredId (ConfiguredPackage loc) where -- 'ConfiguredPackage' is the legacy codepath, we are guaranteed -- to never have a nontrivial 'UnitId' instance PackageFixedDeps (ConfiguredPackage loc) where - depends = fmap (map (SimpleUnitId . confInstId)) . confPkgDeps + depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps instance IsNode (ConfiguredPackage loc) where type Key (ConfiguredPackage loc) = UnitId - nodeKey = SimpleUnitId . confPkgId + nodeKey = newSimpleUnitId . confPkgId -- TODO: if we update ConfiguredPackage to support order-only -- dependencies, need to include those here. -- NB: have to deduplicate, otherwise the planner gets confused @@ -153,7 +153,7 @@ instance Package (ConfiguredPackage loc) where -- Never has nontrivial UnitId instance HasUnitId (ConfiguredPackage loc) where - installedUnitId = SimpleUnitId . confPkgId + installedUnitId = newSimpleUnitId . confPkgId instance PackageInstalled (ConfiguredPackage loc) where installedDepends = CD.flatDeps . depends diff --git a/cabal-install/Distribution/Solver/Modular/Package.hs b/cabal-install/Distribution/Solver/Modular/Package.hs index d9dfdc19fb2..6058f306034 100644 --- a/cabal-install/Distribution/Solver/Modular/Package.hs +++ b/cabal-install/Distribution/Solver/Modular/Package.hs @@ -19,6 +19,7 @@ module Distribution.Solver.Modular.Package import Data.List as L import Distribution.Package -- from Cabal +import Distribution.Text (display) import Distribution.Solver.Modular.Version import Distribution.Solver.Types.PackagePath @@ -57,10 +58,9 @@ showI (I v InRepo) = showVer v showI (I v (Inst uid)) = showVer v ++ "/installed" ++ shortId uid where -- A hack to extract the beginning of the package ABI hash - shortId (SimpleUnitId cid) - = snip (splitAt 4) (++ "...") + shortId = snip (splitAt 4) (++ "...") . snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':) - $ unComponentId cid + . display snip p f xs = case p xs of (ys, zs) -> (if L.null zs then id else f) ys diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 4c53fc93ae3..29457db4c1d 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -22,6 +22,30 @@ Extra-Source-Files: -- Generated with '../Cabal/misc/gen-extra-source-files.sh' -- Do NOT edit this section manually; instead, run the script. -- BEGIN gen-extra-source-files + tests/IntegrationTests/backpack/includes2-external.sh + tests/IntegrationTests/backpack/includes2-internal.sh + tests/IntegrationTests/backpack/includes2/Includes2.cabal + tests/IntegrationTests/backpack/includes2/exe/Main.hs + tests/IntegrationTests/backpack/includes2/exe/exe.cabal + tests/IntegrationTests/backpack/includes2/mylib/Mine.hs + tests/IntegrationTests/backpack/includes2/mylib/mylib.cabal + tests/IntegrationTests/backpack/includes2/mysql/Database/MySQL.hs + tests/IntegrationTests/backpack/includes2/mysql/mysql.cabal + tests/IntegrationTests/backpack/includes2/postgresql/Database/PostgreSQL.hs + tests/IntegrationTests/backpack/includes2/postgresql/postgresql.cabal + tests/IntegrationTests/backpack/includes2/src/App.hs + tests/IntegrationTests/backpack/includes2/src/src.cabal + tests/IntegrationTests/backpack/includes3-external.sh + tests/IntegrationTests/backpack/includes3-internal.sh + tests/IntegrationTests/backpack/includes3/Includes3.cabal + tests/IntegrationTests/backpack/includes3/exe/Main.hs + tests/IntegrationTests/backpack/includes3/exe/Setup.hs + tests/IntegrationTests/backpack/includes3/exe/exe.cabal + tests/IntegrationTests/backpack/includes3/indef/Foo.hs + tests/IntegrationTests/backpack/includes3/indef/Setup.hs + tests/IntegrationTests/backpack/includes3/indef/indef.cabal + tests/IntegrationTests/backpack/includes3/sigs/Setup.hs + tests/IntegrationTests/backpack/includes3/sigs/sigs.cabal tests/IntegrationTests/common.sh tests/IntegrationTests/custom-setup/Cabal-99998/Cabal.cabal tests/IntegrationTests/custom-setup/Cabal-99998/CabalMessage.hs diff --git a/cabal-install/changelog b/cabal-install/changelog index 84ba9767479..d8cd726e18a 100644 --- a/cabal-install/changelog +++ b/cabal-install/changelog @@ -24,6 +24,9 @@ '.../$pkgid.log' to '.../$compiler/$libname.log' (#3807). * Added a new command, 'cabal reconfigure', which re-runs 'configure' with the most recently used flags (#2214). + * Support for building Backpack packages. See + https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst + for more details. 1.24.0.0 Ryan Thomas March 2016 * If there are multiple remote repos, 'cabal update' now updates diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2-external.sh b/cabal-install/tests/IntegrationTests/backpack/includes2-external.sh new file mode 100644 index 00000000000..4c49bd6b244 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2-external.sh @@ -0,0 +1,9 @@ +#!/bin/sh +. ./common.sh + +require_ghc_ge 801 + +cd includes2 +mv cabal.project.external cabal.project +cabal new-build exe +dist-newstyle/build/*/*/exe-*/c/exe/build/exe/exe | fgrep "minemysql minepostgresql" diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2-internal.sh b/cabal-install/tests/IntegrationTests/backpack/includes2-internal.sh new file mode 100644 index 00000000000..cd3538280a7 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2-internal.sh @@ -0,0 +1,9 @@ +#!/bin/sh +. ./common.sh + +require_ghc_ge 801 + +cd includes2 +mv cabal.project.internal cabal.project +cabal new-build exe +dist-newstyle/build/*/*/Includes2-*/c/exe/build/exe/exe | fgrep "minemysql minepostgresql" diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/Includes2.cabal b/cabal-install/tests/IntegrationTests/backpack/includes2/Includes2.cabal new file mode 100644 index 00000000000..d376e784f7f --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/Includes2.cabal @@ -0,0 +1,41 @@ +name: Includes2 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library mylib + build-depends: base + signatures: Database + exposed-modules: Mine + hs-source-dirs: mylib + default-language: Haskell2010 + +library mysql + build-depends: base + exposed-modules: Database.MySQL + hs-source-dirs: mysql + default-language: Haskell2010 + +library postgresql + build-depends: base + exposed-modules: Database.PostgreSQL + hs-source-dirs: postgresql + default-language: Haskell2010 + +library + build-depends: base, mysql, postgresql, mylib + backpack-includes: + mylib (Mine as Mine.MySQL) requires (Database as Database.MySQL), + mylib (Mine as Mine.PostgreSQL) requires (Database as Database.PostgreSQL) + exposed-modules: App + hs-source-dirs: src + default-language: Haskell2010 + +executable exe + build-depends: base, Includes2 + main-is: Main.hs + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.external b/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.external new file mode 100644 index 00000000000..f9c72e6e446 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.external @@ -0,0 +1 @@ +packages: mylib mysql src exe postgresql diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.internal b/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.internal new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.internal @@ -0,0 +1 @@ +packages: . diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/exe/Main.hs b/cabal-install/tests/IntegrationTests/backpack/includes2/exe/Main.hs new file mode 100644 index 00000000000..865b7f2b489 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/exe/Main.hs @@ -0,0 +1,3 @@ +import App + +main = print app diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/exe/exe.cabal b/cabal-install/tests/IntegrationTests/backpack/includes2/exe/exe.cabal new file mode 100644 index 00000000000..707ea843e4c --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/exe/exe.cabal @@ -0,0 +1,12 @@ +name: exe +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +executable exe + build-depends: base, src + main-is: Main.hs + default-language: Haskell2010 diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Database.hsig b/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Database.hsig new file mode 100644 index 00000000000..725d795f94a --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Database.hsig @@ -0,0 +1,3 @@ +signature Database where +data Database +databaseName :: String diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Mine.hs b/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Mine.hs new file mode 100644 index 00000000000..20b4c0d404c --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Mine.hs @@ -0,0 +1,4 @@ +module Mine where +import Database +data Mine = Mine Database +mine = "mine" ++ databaseName diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/mylib.cabal b/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/mylib.cabal new file mode 100644 index 00000000000..cc0e3e3ec28 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/mylib.cabal @@ -0,0 +1,13 @@ +name: mylib +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base + signatures: Database + exposed-modules: Mine + default-language: Haskell2010 diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/Database/MySQL.hs b/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/Database/MySQL.hs new file mode 100644 index 00000000000..b49cdb42849 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/Database/MySQL.hs @@ -0,0 +1,3 @@ +module Database.MySQL where +data Database = Database Int +databaseName = "mysql" diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/mysql.cabal b/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/mysql.cabal new file mode 100644 index 00000000000..bb331f5c836 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/mysql.cabal @@ -0,0 +1,12 @@ +name: mysql +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base + exposed-modules: Database.MySQL + default-language: Haskell2010 diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/Database/PostgreSQL.hs b/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/Database/PostgreSQL.hs new file mode 100644 index 00000000000..9cc64f12d61 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/Database/PostgreSQL.hs @@ -0,0 +1,3 @@ +module Database.PostgreSQL where +data Database = Database Bool +databaseName = "postgresql" diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/postgresql.cabal b/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/postgresql.cabal new file mode 100644 index 00000000000..1ba91f5d81b --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/postgresql.cabal @@ -0,0 +1,12 @@ +name: postgresql +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base + exposed-modules: Database.PostgreSQL + default-language: Haskell2010 diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/src/App.hs b/cabal-install/tests/IntegrationTests/backpack/includes2/src/App.hs new file mode 100644 index 00000000000..f5213de2c16 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/src/App.hs @@ -0,0 +1,7 @@ +module App where +import Database.MySQL +import Database.PostgreSQL +import qualified Mine.MySQL +import qualified Mine.PostgreSQL + +app = Mine.MySQL.mine ++ " " ++ Mine.PostgreSQL.mine diff --git a/cabal-install/tests/IntegrationTests/backpack/includes2/src/src.cabal b/cabal-install/tests/IntegrationTests/backpack/includes2/src/src.cabal new file mode 100644 index 00000000000..77d3b9bfd24 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes2/src/src.cabal @@ -0,0 +1,15 @@ +name: src +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base, mysql, postgresql, mylib + backpack-includes: + mylib (Mine as Mine.MySQL) requires (Database as Database.MySQL), + mylib (Mine as Mine.PostgreSQL) requires (Database as Database.PostgreSQL) + exposed-modules: App + default-language: Haskell2010 diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3-external.sh b/cabal-install/tests/IntegrationTests/backpack/includes3-external.sh new file mode 100644 index 00000000000..a13fc9deed4 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3-external.sh @@ -0,0 +1,9 @@ +#!/bin/sh +. ./common.sh + +require_ghc_ge 801 + +cd includes3 +mv cabal.project.external cabal.project +cabal new-build exe +dist-newstyle/build/*/*/exe-*/c/exe/build/exe/exe | fgrep "fromList [(0,2),(2,4)]" diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3-internal.sh b/cabal-install/tests/IntegrationTests/backpack/includes3-internal.sh new file mode 100644 index 00000000000..c1f41dbcace --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3-internal.sh @@ -0,0 +1,9 @@ +#!/bin/sh +. ./common.sh + +require_ghc_ge 801 + +cd includes3 +mv cabal.project.internal cabal.project +cabal new-build exe +dist-newstyle/build/*/*/Includes3-*/c/exe/build/exe/exe | fgrep "fromList [(0,2),(2,4)]" diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3/Includes3.cabal b/cabal-install/tests/IntegrationTests/backpack/includes3/Includes3.cabal new file mode 100644 index 00000000000..a2de17f2988 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3/Includes3.cabal @@ -0,0 +1,23 @@ +name: Includes3 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library sigs + build-depends: base + signatures: Data.Map + hs-source-dirs: sigs + +library indef + build-depends: base, sigs + exposed-modules: Foo + hs-source-dirs: indef + +executable exe + build-depends: base, containers, indef + main-is: Main.hs + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.external b/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.external new file mode 100644 index 00000000000..4c9d75fb7f7 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.external @@ -0,0 +1 @@ +packages: exe indef sigs diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.internal b/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.internal new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.internal @@ -0,0 +1 @@ +packages: . diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3/exe/Main.hs b/cabal-install/tests/IntegrationTests/backpack/includes3/exe/Main.hs new file mode 100644 index 00000000000..e0cb6d02c6e --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3/exe/Main.hs @@ -0,0 +1,4 @@ +import qualified Data.Map as Map +import Data.Map (Map) +import Foo +main = print $ f (+1) (Map.fromList [(0,1),(2,3)] :: Map Int Int) diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3/exe/Setup.hs b/cabal-install/tests/IntegrationTests/backpack/includes3/exe/Setup.hs new file mode 100644 index 00000000000..9a994af677b --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3/exe/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3/exe/exe.cabal b/cabal-install/tests/IntegrationTests/backpack/includes3/exe/exe.cabal new file mode 100644 index 00000000000..2422fffc031 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3/exe/exe.cabal @@ -0,0 +1,12 @@ +name: exe +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +executable exe + build-depends: base, containers, indef + main-is: Main.hs + default-language: Haskell2010 diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3/indef/Foo.hs b/cabal-install/tests/IntegrationTests/backpack/includes3/indef/Foo.hs new file mode 100644 index 00000000000..5be3e4b85b0 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3/indef/Foo.hs @@ -0,0 +1,6 @@ +module Foo where + +import Data.Map + +f :: (a -> b) -> Map k a -> Map k b +f = fmap diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3/indef/Setup.hs b/cabal-install/tests/IntegrationTests/backpack/includes3/indef/Setup.hs new file mode 100644 index 00000000000..9a994af677b --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3/indef/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3/indef/indef.cabal b/cabal-install/tests/IntegrationTests/backpack/includes3/indef/indef.cabal new file mode 100644 index 00000000000..ff1a4c512fa --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3/indef/indef.cabal @@ -0,0 +1,11 @@ +name: indef +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base, sigs + exposed-modules: Foo diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Data/Map.hsig b/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Data/Map.hsig new file mode 100644 index 00000000000..997ec1aa576 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Data/Map.hsig @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +signature Data.Map where +type role Map nominal representational +data Map k a +instance Functor (Map k) diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Setup.hs b/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Setup.hs new file mode 100644 index 00000000000..9a994af677b --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/sigs.cabal b/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/sigs.cabal new file mode 100644 index 00000000000..0263fe2a742 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/sigs.cabal @@ -0,0 +1,11 @@ +name: sigs +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base + signatures: Data.Map