From be218c724c614d371a96331af751bc4a10dd402e Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Thu, 4 Aug 2016 17:06:38 -0700 Subject: [PATCH 01/46] Ignore cabal.project.local Signed-off-by: Edward Z. Yang --- .gitignore | 1 + 1 file changed, 1 insertion(+) 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 From d32d14582bbad68a4508b6094ab9eb0b1e25eab2 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Wed, 4 May 2016 16:17:36 -0700 Subject: [PATCH 02/46] Accumulate environment in 'withEnv'. Signed-off-by: Edward Z. Yang --- Cabal/Distribution/Simple/Program/Run.hs | 2 ++ Cabal/tests/PackageTests/PackageTester.hs | 9 +++------ 2 files changed, 5 insertions(+), 6 deletions(-) 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/tests/PackageTests/PackageTester.hs b/Cabal/tests/PackageTests/PackageTester.hs index 280e720c5c8..d21349a4657 100644 --- a/Cabal/tests/PackageTests/PackageTester.hs +++ b/Cabal/tests/PackageTests/PackageTester.hs @@ -669,14 +669,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 From 6059c6b357ee644e7001cfd227f9f150d16d4a23 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Thu, 14 Jul 2016 00:15:53 -0700 Subject: [PATCH 03/46] Add more reexported module tests Signed-off-by: Edward Z. Yang --- Cabal/Cabal.cabal | 5 +++++ .../containers-dupe/Data/Map.hs | 3 +++ .../containers-dupe/containers-dupe.cabal | 12 ++++++++++++ .../ReexportedModules/p/fail-ambiguous.cabal | 10 ++++++++++ .../ReexportedModules/p/fail-missing.cabal | 10 ++++++++++ .../ReexportedModules/p/fail-other.cabal | 12 ++++++++++++ Cabal/tests/PackageTests/Tests.hs | 18 ++++++++++++++++-- 7 files changed, 68 insertions(+), 2 deletions(-) create mode 100644 Cabal/tests/PackageTests/ReexportedModules/containers-dupe/Data/Map.hs create mode 100644 Cabal/tests/PackageTests/ReexportedModules/containers-dupe/containers-dupe.cabal create mode 100644 Cabal/tests/PackageTests/ReexportedModules/p/fail-ambiguous.cabal create mode 100644 Cabal/tests/PackageTests/ReexportedModules/p/fail-missing.cabal create mode 100644 Cabal/tests/PackageTests/ReexportedModules/p/fail-other.cabal diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 2bc052c6cfb..90c3e9cddc8 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -207,6 +207,11 @@ 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/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 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/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/Tests.hs b/Cabal/tests/PackageTests/Tests.hs index 1a22d5fcd0f..ad8aef99508 100644 --- a/Cabal/tests/PackageTests/Tests.hs +++ b/Cabal/tests/PackageTests/Tests.hs @@ -206,11 +206,25 @@ 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 (>= Version [7,9] []) $ do + withPackage "p" $ do + r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail-other.cabal"] + assertOutputContains "Private" r + tcs "ReexportedModules" "fail-ambiguous" . whenGhcVersion (>= Version [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 (>= Version [7,9] []) $ do + withPackage "p" $ do + r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail-missing.cabal"] + assertOutputContains "Missing" r -- Test that Cabal computes different IPIDs when the source changes. tc "UniqueIPID" . withPackageDb $ do From a642a28b305aa829c860e7ff5854db87ba1875f4 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Tue, 19 Jul 2016 13:57:31 -0700 Subject: [PATCH 04/46] Refactor libModules in to explicitLibModules and allLibModules. Signed-off-by: Edward Z. Yang --- Cabal/Distribution/PackageDescription.hs | 2 +- .../Distribution/PackageDescription/Check.hs | 10 +++++---- Cabal/Distribution/Simple/BuildTarget.hs | 9 +++++++- Cabal/Distribution/Simple/GHC.hs | 16 +++++++------- Cabal/Distribution/Simple/GHC/Internal.hs | 6 +++-- Cabal/Distribution/Simple/GHCJS.hs | 10 ++++----- Cabal/Distribution/Simple/HaskellSuite.hs | 6 ++--- Cabal/Distribution/Simple/JHC.hs | 2 +- Cabal/Distribution/Simple/LHC.hs | 22 ++++++++++--------- Cabal/Distribution/Simple/LocalBuildInfo.hs | 7 ++++++ Cabal/Distribution/Simple/PreProcess.hs | 2 +- Cabal/Distribution/Simple/Register.hs | 2 +- Cabal/Distribution/Simple/UHC.hs | 2 +- Cabal/Distribution/Types/Library.hs | 9 ++++---- .../Distribution/Client/BuildTarget.hs | 6 +++-- 15 files changed, 67 insertions(+), 44 deletions(-) diff --git a/Cabal/Distribution/PackageDescription.hs b/Cabal/Distribution/PackageDescription.hs index dc74121b548..e8709b2e488 100644 --- a/Cabal/Distribution/PackageDescription.hs +++ b/Cabal/Distribution/PackageDescription.hs @@ -35,7 +35,7 @@ module Distribution.PackageDescription ( withLib, hasPublicLib, hasLibs, - libModules, + explicitLibModules, libModulesAutogen, -- ** Executables diff --git a/Cabal/Distribution/PackageDescription/Check.hs b/Cabal/Distribution/PackageDescription/Check.hs index f135dd1d642..dc2c273c0c3 100644 --- a/Cabal/Distribution/PackageDescription/Check.hs +++ b/Cabal/Distribution/PackageDescription/Check.hs @@ -233,7 +233,8 @@ 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 -> "" @@ -248,7 +249,7 @@ checkLibrary pkg lib = -- 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] @@ -1342,7 +1344,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/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/GHC.hs b/Cabal/Distribution/Simple/GHC.hs index 63fa0e85ab9..0fdccda8bf6 100644 --- a/Cabal/Distribution/Simple/GHC.hs +++ b/Cabal/Distribution/Simple/GHC.hs @@ -528,7 +528,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,7 +580,7 @@ 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 && @@ -641,7 +641,7 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do -- exports. ifReplLib $ do - when (null (libModules lib)) $ warn verbosity "No exposed modules" + when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" ifReplLib (runGhcProg replOpts) -- link: @@ -663,17 +663,17 @@ 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 libTargetDir objExtension True @@ -1169,7 +1169,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,7 +1179,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/GHC/Internal.hs b/Cabal/Distribution/Simple/GHC/Internal.hs index b5fb8446700..6cbfad8e112 100644 --- a/Cabal/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/Distribution/Simple/GHC/Internal.hs @@ -361,7 +361,7 @@ getHaskellObjects _implInfo lib lbi 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,7 +370,9 @@ 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 ] + where + clbi = getComponentLocalBuildInfo lbi CLibName mkGhcOptPackages :: ComponentLocalBuildInfo -> [(UnitId, ModuleRenaming)] diff --git a/Cabal/Distribution/Simple/GHCJS.hs b/Cabal/Distribution/Simple/GHCJS.hs index 7928eb6fa6c..9f967385ef9 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: @@ -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/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/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..262c264a843 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,15 +354,15 @@ 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 pref objExtension True @@ -540,7 +540,7 @@ getHaskellObjects :: Library -> LocalBuildInfo getHaskellObjects lib lbi 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,9 @@ 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 ] + where + clbi = getComponentLocalBuildInfo lbi CLibName constructGHCCmdLine @@ -717,11 +719,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 +740,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..3c70aeb18e9 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 @@ -287,6 +289,11 @@ depLibraryPaths inplace relative lbi clbi = do then canonicalizePath p else return p +-- TODO: doc +allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName] +allLibModules lib clbi = + explicitLibModules lib + -- TODO: add more stuff -- ----------------------------------------------------------------------------- -- Wrappers for a couple functions from InstallDirs diff --git a/Cabal/Distribution/Simple/PreProcess.hs b/Cabal/Distribution/Simple/PreProcess.hs index a3d5eac49e4..153f5c901a3 100644 --- a/Cabal/Distribution/Simple/PreProcess.hs +++ b/Cabal/Distribution/Simple/PreProcess.hs @@ -152,7 +152,7 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = case comp of let dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi] setupMessage verbosity "Preprocessing library" (packageId pd) - for_ (map ModuleName.toFilePath $ libModules lib) $ + 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/Register.hs b/Cabal/Distribution/Simple/Register.hs index b97d731d509..681f17cfeb7 100644 --- a/Cabal/Distribution/Simple/Register.hs +++ b/Cabal/Distribution/Simple/Register.hs @@ -433,7 +433,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/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/Library.hs b/Cabal/Distribution/Types/Library.hs index a8f40126296..7ade4f82c8b 100644 --- a/Cabal/Distribution/Types/Library.hs +++ b/Cabal/Distribution/Types/Library.hs @@ -4,7 +4,7 @@ module Distribution.Types.Library ( Library(..), emptyLibrary, - libModules, + explicitLibModules, libModulesAutogen ) where @@ -54,9 +54,10 @@ 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 +-- 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 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 From 99e83f8788995bd46e0d7a6846ac9b2f3049149f Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Tue, 19 Jul 2016 14:11:18 -0700 Subject: [PATCH 05/46] Put in backwards compatibility shim for libModules. Signed-off-by: Edward Z. Yang --- Cabal/Distribution/PackageDescription.hs | 1 + Cabal/Distribution/Types/Library.hs | 16 ++++++++++++++-- 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/Cabal/Distribution/PackageDescription.hs b/Cabal/Distribution/PackageDescription.hs index e8709b2e488..85aa0a36431 100644 --- a/Cabal/Distribution/PackageDescription.hs +++ b/Cabal/Distribution/PackageDescription.hs @@ -37,6 +37,7 @@ module Distribution.PackageDescription ( hasLibs, explicitLibModules, libModulesAutogen, + libModules, -- ** Executables Executable(..), diff --git a/Cabal/Distribution/Types/Library.hs b/Cabal/Distribution/Types/Library.hs index 7ade4f82c8b..324e71e121f 100644 --- a/Cabal/Distribution/Types/Library.hs +++ b/Cabal/Distribution/Types/Library.hs @@ -5,7 +5,8 @@ module Distribution.Types.Library ( Library(..), emptyLibrary, explicitLibModules, - libModulesAutogen + libModulesAutogen, + libModules, ) where import Prelude () @@ -53,7 +54,8 @@ 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 +-- 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] @@ -65,3 +67,13 @@ explicitLibModules lib = exposedModules lib -- 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 From 9e8fea3ea2113f98034acfb69b50af8a7b8058f7 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sun, 2 Oct 2016 02:27:11 +0100 Subject: [PATCH 06/46] Update 'getHaskellObjects' to take 'ComponentLocalBuildInfo' Eliminating the use of deprecated 'getComponentLocalBuildInfo' --- Cabal/Distribution/Simple/GHC.hs | 6 +++--- Cabal/Distribution/Simple/GHC/Internal.hs | 5 ++--- Cabal/Distribution/Simple/GHCJS.hs | 6 +++--- Cabal/Distribution/Simple/LHC.hs | 12 +++++------- 4 files changed, 13 insertions(+), 16 deletions(-) diff --git a/Cabal/Distribution/Simple/GHC.hs b/Cabal/Distribution/Simple/GHC.hs index 0fdccda8bf6..8225b075aa5 100644 --- a/Cabal/Distribution/Simple/GHC.hs +++ b/Cabal/Distribution/Simple/GHC.hs @@ -675,16 +675,16 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files , 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 [] diff --git a/Cabal/Distribution/Simple/GHC/Internal.hs b/Cabal/Distribution/Simple/GHC/Internal.hs index 6cbfad8e112..a25ef0e4635 100644 --- a/Cabal/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/Distribution/Simple/GHC/Internal.hs @@ -356,8 +356,9 @@ 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) @@ -371,8 +372,6 @@ getHaskellObjects _implInfo lib lbi pref wanted_obj_ext allow_split_objs | otherwise = return [ pref ModuleName.toFilePath x <.> wanted_obj_ext | x <- allLibModules lib clbi ] - where - clbi = getComponentLocalBuildInfo lbi CLibName mkGhcOptPackages :: ComponentLocalBuildInfo -> [(UnitId, ModuleRenaming)] diff --git a/Cabal/Distribution/Simple/GHCJS.hs b/Cabal/Distribution/Simple/GHCJS.hs index 9f967385ef9..217ee72ef51 100644 --- a/Cabal/Distribution/Simple/GHCJS.hs +++ b/Cabal/Distribution/Simple/GHCJS.hs @@ -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 [] diff --git a/Cabal/Distribution/Simple/LHC.hs b/Cabal/Distribution/Simple/LHC.hs index 262c264a843..bb57deaea81 100644 --- a/Cabal/Distribution/Simple/LHC.hs +++ b/Cabal/Distribution/Simple/LHC.hs @@ -364,16 +364,16 @@ buildLib verbosity pkg_descr lbi lib clbi = do (ModuleName.toFilePath x ++"_stub") | 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,9 +535,9 @@ 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 <- allLibModules lib clbi ] @@ -550,8 +550,6 @@ getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs | otherwise = return [ pref ModuleName.toFilePath x <.> wanted_obj_ext | x <- allLibModules lib clbi ] - where - clbi = getComponentLocalBuildInfo lbi CLibName constructGHCCmdLine From 7ad384d18149b219ff5bd04bbf6a9e8cc294ef51 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sun, 2 Oct 2016 02:35:02 +0100 Subject: [PATCH 07/46] Eliminate unused field names of Module constructor --- Cabal/Distribution/Package.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/Cabal/Distribution/Package.hs b/Cabal/Distribution/Package.hs index bc37caefb0d..425ee7bb4dd 100644 --- a/Cabal/Distribution/Package.hs +++ b/Cabal/Distribution/Package.hs @@ -145,8 +145,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 UnitId ModuleName deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary Module From 7637d0675ba810ae7c7f567532c8ed69790e6fa8 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 06:20:19 +0100 Subject: [PATCH 08/46] A minor improvement to convenience libraries We force convenience libraries to NOT be exposed (they're private, after all.) This will help us on some of our test cases. --- Cabal/Distribution/PackageDescription/Configuration.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) 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 ) From cbc1a1de2181b702d042fa25e7c1cf3e3ece92c0 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sun, 2 Oct 2016 03:12:45 +0100 Subject: [PATCH 09/46] Add a parser for 'key' field of InstalledPackageInfo Rather than reusing the one for ComponentId. --- Cabal/Distribution/InstalledPackageInfo.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/Cabal/Distribution/InstalledPackageInfo.hs b/Cabal/Distribution/InstalledPackageInfo.hs index 86fe5df8feb..559c6c0bea3 100644 --- a/Cabal/Distribution/InstalledPackageInfo.hs +++ b/Cabal/Distribution/InstalledPackageInfo.hs @@ -55,6 +55,7 @@ import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.Graph import Text.PrettyPrint as Disp +import qualified Data.Char as Char -- ----------------------------------------------------------------------------- -- The InstalledPackageInfo type @@ -233,6 +234,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 +258,8 @@ basicFieldDescrs = , simpleField "id" disp parse installedUnitId (\pk pkg -> pkg{installedUnitId=pk}) - -- NB: parse these as component IDs , simpleField "key" - (disp . mkComponentId) (fmap unComponentId parse) + dispCompatPackageKey parseCompatPackageKey compatPackageKey (\pk pkg -> pkg{compatPackageKey=pk}) , simpleField "license" disp parseLicenseQ From d7bd90789935969698f617f67be841fa1564a76f Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sun, 2 Oct 2016 02:58:41 +0100 Subject: [PATCH 10/46] Introduce the new representation of UnitId 'SimpleUnitId' constructor renamed to 'UnitId', and augmented with a new field 'Maybe String' recording a hash that uniquely identifies an instantiated unit of the library 'ComponentId'. 'UnitId' can't be used to represent partially instantiated unit identifiers; see Distribution.Backpack for how we handle that. Previous uses of 'SimpleUnitId' should now use 'newSimpleUnitId'. 'unitIdComponentId' folded into a record selector for 'ComponentId'. --- Cabal/Distribution/InstalledPackageInfo.hs | 3 +- Cabal/Distribution/Package.hs | 86 ++++++++++++++++--- Cabal/Distribution/Simple/Configure.hs | 4 +- Cabal/Distribution/Simple/PackageIndex.hs | 3 +- Cabal/Distribution/Simple/Program/HcPkg.hs | 2 +- .../Types/ComponentLocalBuildInfo.hs | 3 +- Cabal/Distribution/Types/LocalBuildInfo.hs | 4 +- .../Distribution/Client/DistDirLayout.hs | 5 +- .../Distribution/Client/ProjectPlanning.hs | 14 +-- .../Client/ProjectPlanning/Types.hs | 10 +-- .../Distribution/Client/SetupWrapper.hs | 4 +- cabal-install/Distribution/Client/Types.hs | 10 +-- .../Distribution/Solver/Modular/Package.hs | 6 +- 13 files changed, 105 insertions(+), 49 deletions(-) diff --git a/Cabal/Distribution/InstalledPackageInfo.hs b/Cabal/Distribution/InstalledPackageInfo.hs index 559c6c0bea3..8750c135b45 100644 --- a/Cabal/Distribution/InstalledPackageInfo.hs +++ b/Cabal/Distribution/InstalledPackageInfo.hs @@ -104,8 +104,7 @@ data InstalledPackageInfo deriving (Eq, Generic, Read, Show) 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. diff --git a/Cabal/Distribution/Package.hs b/Cabal/Distribution/Package.hs index 425ee7bb4dd..adcaed3ab62 100644 --- a/Cabal/Distribution/Package.hs +++ b/Cabal/Distribution/Package.hs @@ -26,8 +26,8 @@ module Distribution.Package ( ComponentId, unComponentId, mkComponentId, UnitId(..), mkUnitId, + newSimpleUnitId, mkLegacyUnitId, - unitIdComponentId, getHSLibraryName, InstalledPackageId, -- backwards compat @@ -163,8 +163,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'. @@ -208,24 +211,79 @@ 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 'IndefUnitId', in that it is always +-- installed, whereas 'IndefUnitId' 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 'IndefUnitId'). 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 + +-- | 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/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index cb4e31e8533..c9c5befb26a 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -1781,7 +1781,7 @@ computeCompatPackageKey -> Version -> UnitId -> String -computeCompatPackageKey comp pkg_name pkg_version (SimpleUnitId cid) +computeCompatPackageKey comp pkg_name pkg_version (UnitId cid _) | not (packageKeySupported comp) = display pkg_name ++ "-" ++ display pkg_version | not (unifiedIPIDRequired comp) = @@ -1901,7 +1901,7 @@ mkComponentsLocalBuildInfo cfg use_external_internal comp installedPackages (componentName component) (getDeps (componentName component)) flagAssignment - uid = SimpleUnitId cid + uid = newSimpleUnitId 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 diff --git a/Cabal/Distribution/Simple/PackageIndex.hs b/Cabal/Distribution/Simple/PackageIndex.hs index 27f69bb5fcb..c2db8838f1a 100644 --- a/Cabal/Distribution/Simple/PackageIndex.hs +++ b/Cabal/Distribution/Simple/PackageIndex.hs @@ -394,7 +394,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" #-} 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/Types/ComponentLocalBuildInfo.hs b/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs index 79eb824623f..4498a3818c4 100644 --- a/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs +++ b/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs @@ -93,5 +93,4 @@ instance IsNode ComponentLocalBuildInfo where nodeNeighbors = componentInternalDeps componentComponentId :: ComponentLocalBuildInfo -> ComponentId -componentComponentId clbi = case componentUnitId clbi of - SimpleUnitId cid -> cid +componentComponentId clbi = unitIdComponentId (componentUnitId clbi) 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-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/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index b2c584753d5..73dafc84998 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -674,7 +674,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 @@ -1099,7 +1099,7 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB ((internal_map', exe_map'), elab) where elab = elab0 { - elabUnitId = SimpleUnitId cid, -- Backpack later! + elabUnitId = newSimpleUnitId cid, -- Backpack later! elabInstallDirs = install_dirs, elabRequiresRegistration = requires_reg, elabPkgOrComp = ElabComponent $ ElaboratedComponent {..} @@ -1193,7 +1193,7 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB -- use the ordinary default install dirs = (InstallDirs.absoluteInstallDirs elabPkgSourceId - (SimpleUnitId cid) + (newSimpleUnitId cid) (compilerInfo compiler) InstallDirs.NoCopyDest platform @@ -1272,7 +1272,7 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB where elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon mapDep pkg elab = elab0 { - elabUnitId = SimpleUnitId pkgInstalledId, + elabUnitId = newSimpleUnitId pkgInstalledId, elabInstallDirs = install_dirs, elabRequiresRegistration = requires_reg, elabPkgOrComp = ElabPackage $ ElaboratedPackage {..} @@ -1316,7 +1316,7 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB -- use the ordinary default install dirs = (InstallDirs.absoluteInstallDirs pkgid - (SimpleUnitId pkgInstalledId) + (newSimpleUnitId pkgInstalledId) (compilerInfo compiler) InstallDirs.NoCopyDest platform @@ -1967,13 +1967,13 @@ pruneInstallPlanPass2 pkgs = hasReverseLibDeps :: Set UnitId hasReverseLibDeps = - Set.fromList [ SimpleUnitId (confInstId depid) + Set.fromList [ newSimpleUnitId (confInstId depid) | InstallPlan.Configured pkg <- pkgs , depid <- elabLibDependencies pkg ] hasReverseExeDeps :: Set UnitId hasReverseExeDeps = - Set.fromList [ SimpleUnitId depid + Set.fromList [ newSimpleUnitId depid | InstallPlan.Configured pkg <- pkgs , depid <- elabExeDependencies pkg ] diff --git a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs index 51d1017d279..8fbb6fb2572 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs @@ -359,9 +359,9 @@ instance Binary ElaboratedComponent compOrderDependencies :: ElaboratedComponent -> [UnitId] compOrderDependencies comp = -- TODO: Change this with Backpack! - map (SimpleUnitId . confInstId) (compLibDependencies comp) - ++ map SimpleUnitId (compExeDependencies comp) - ++ map (SimpleUnitId . confInstId) (compSetupDependencies comp) + map (newSimpleUnitId . confInstId) (compLibDependencies comp) + ++ map newSimpleUnitId (compExeDependencies comp) + ++ map (newSimpleUnitId . confInstId) (compSetupDependencies comp) data ElaboratedPackage = ElaboratedPackage { @@ -396,8 +396,8 @@ instance Binary ElaboratedPackage 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..100e46d8ac3 100644 --- a/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/Distribution/Client/SetupWrapper.hs @@ -31,7 +31,7 @@ import Distribution.Version , intersectVersionRanges, orLaterVersion , withinRange ) import Distribution.Package - ( UnitId(..), ComponentId, PackageId, mkPackageName + ( newSimpleUnitId, ComponentId, PackageId, mkPackageName , PackageIdentifier(..), packageVersion, packageName, Dependency(..) ) import Distribution.PackageDescription ( GenericPackageDescription(packageDescription) @@ -817,7 +817,7 @@ getExternalSetupMethod verbosity options pkg bt = do if any (isCabalPkgId . snd) (useDependencies options') then [] else cabalDep - addRenaming (ipid, _) = (SimpleUnitId ipid, defaultRenaming) + addRenaming (ipid, _) = (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 From fdf30f80a8271db9660a9c5df338939275e4a2dc Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 05:02:16 +0100 Subject: [PATCH 11/46] Add D.Backpack module with IndefUnitId and IndefModule types This module defines the key data types 'IndefUnitId' and 'IndefModule', which represent components which are partially instantiated with holes in them. The intent is that they can be substituted over (Distribution.Backpack.ModSubst), and once all the holes are filled they can be improved into proper 'UnitId's, which can then be installed. Also add Distribution.Util.Base62 module containing an implementation of base-62 encoding, which we use when computing hashes for fully instantiated unit ids. --- Cabal/Cabal.cabal | 2 + Cabal/Distribution/Backpack.hs | 224 +++++++++++++++++++++++++++++ Cabal/Distribution/Utils/Base62.hs | 22 +++ 3 files changed, 248 insertions(+) create mode 100644 Cabal/Distribution/Backpack.hs create mode 100644 Cabal/Distribution/Utils/Base62.hs diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 90c3e9cddc8..d2505c05cc4 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -315,6 +315,7 @@ library -Wnoncanonical-monadfail-instances exposed-modules: + Distribution.Backpack Distribution.Compat.CreatePipe Distribution.Compat.Environment Distribution.Compat.Exception @@ -422,6 +423,7 @@ library Distribution.Compat.Binary other-modules: + 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..e000ed8c66a --- /dev/null +++ b/Cabal/Distribution/Backpack.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This module defines the core data types for Backpack. For more +-- details, see: +-- +-- + +module Distribution.Backpack ( + -- * IndefUnitId + IndefUnitId(..), + indefUnitIdComponentId, + indefUnitIdFreeHoles, + + -- * IndefModule + IndefModule(..), + indefModuleFreeHoles, + + -- * IndefModuleSubst + IndefModuleSubst, + dispIndefModuleSubst, + dispIndefModuleSubstEntry, + parseIndefModuleSubst, + parseIndefModuleSubstEntry, + indefModuleSubstFreeHoles, + + -- * 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 + +----------------------------------------------------------------------- +-- IndefUnitId + +-- | An 'IndefUnitId' describes a (possibly partially) instantiated +-- Backpack component, with a description of how the holes are filled +-- in. Unlike 'IndefUnitId', 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 'IndefUnitId 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. +-- +-- IndefUnitId 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 'IndefUnitId' into 'UnitId'. +-- +-- For more details see the Backpack spec +-- +-- + +data IndefUnitId + -- | Identifies a component which may have some unfilled holes; + -- specifying its 'ComponentId' and its 'IndefModuleSubst'. + -- TODO: Invariant that 'IndefModuleSubst' is non-empty? + -- See also the Text instance. + = IndefFullUnitId ComponentId IndefModuleSubst + -- | 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 'IndefUnitId' + -- is guaranteed not to have any holes. + | IndefUnitId UnitId + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +-- TODO: cache holes? + +instance Binary IndefUnitId + +instance NFData IndefUnitId where + rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst + rnf (IndefUnitId uid) = rnf uid + +instance Text IndefUnitId 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 (dispIndefModuleSubst insts) + disp (IndefUnitId uid) = disp uid + parse = parseIndefUnitId <++ fmap IndefUnitId parse + where + parseIndefUnitId = do + cid <- parse + insts <- Parse.between (Parse.char '[') (Parse.char ']') + parseIndefModuleSubst + return (IndefFullUnitId cid insts) + +-- | Get the 'ComponentId' of an 'IndefUnitId'. +indefUnitIdComponentId :: IndefUnitId -> ComponentId +indefUnitIdComponentId (IndefFullUnitId cid _) = cid +indefUnitIdComponentId (IndefUnitId uid) = unitIdComponentId uid + +-- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'. +indefUnitIdFreeHoles :: IndefUnitId -> Set ModuleName +indefUnitIdFreeHoles (IndefFullUnitId _ insts) = indefModuleSubstFreeHoles insts +indefUnitIdFreeHoles _ = Set.empty + +----------------------------------------------------------------------- +-- IndefModule + +-- | Unlike a 'Module', an 'IndefModule' is either an ordinary +-- module from some unit, OR an 'IndefModuleVar', representing a +-- hole that needs to be filled in. Substitutions are over +-- module variables. +data IndefModule + = IndefModule IndefUnitId ModuleName + | IndefModuleVar ModuleName + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +instance Binary IndefModule + +instance NFData IndefModule where + rnf (IndefModule uid mod_name) = rnf uid `seq` rnf mod_name + rnf (IndefModuleVar mod_name) = rnf mod_name + +instance Text IndefModule where + disp (IndefModule uid mod_name) = + hcat [disp uid, Disp.text ":", disp mod_name] + disp (IndefModuleVar mod_name) = + hcat [Disp.char '<', disp mod_name, Disp.char '>'] + parse = parseModuleVar <++ parseIndefModule + where + parseIndefModule = do + uid <- parse + _ <- Parse.char ':' + mod_name <- parse + return (IndefModule uid mod_name) + parseModuleVar = do + _ <- Parse.char '<' + mod_name <- parse + _ <- Parse.char '>' + return (IndefModuleVar mod_name) + +-- | Get the set of holes ('ModuleVar') embedded in a 'Module'. +indefModuleFreeHoles :: IndefModule -> Set ModuleName +indefModuleFreeHoles (IndefModuleVar mod_name) = Set.singleton mod_name +indefModuleFreeHoles (IndefModule uid _n) = indefUnitIdFreeHoles uid + +----------------------------------------------------------------------- +-- IndefModuleSubst + +-- | An explicit substitution on modules. +-- +-- NB: These substitutions are NOT idempotent, for example, a +-- valid substitution is (A -> B, B -> A). +type IndefModuleSubst = Map ModuleName IndefModule + +-- | Pretty-print the entries of a module substitution, suitable +-- for embedding into a 'IndefUnitId' or passing to GHC via @--instantiate-with@. +dispIndefModuleSubst :: IndefModuleSubst -> Disp.Doc +dispIndefModuleSubst subst + = Disp.hcat + . Disp.punctuate Disp.comma + $ map dispIndefModuleSubstEntry (Map.toAscList subst) + +-- | Pretty-print a single entry of a module substitution. +dispIndefModuleSubstEntry :: (ModuleName, IndefModule) -> Disp.Doc +dispIndefModuleSubstEntry (k, v) = disp k <<>> Disp.char '=' <<>> disp v + +-- | Inverse to 'dispModSubst'. +parseIndefModuleSubst :: ReadP r IndefModuleSubst +parseIndefModuleSubst = fmap Map.fromList + . flip Parse.sepBy (Parse.char ',') + $ parseIndefModuleSubstEntry + +-- | Inverse to 'dispModSubstEntry'. +parseIndefModuleSubstEntry :: ReadP r (ModuleName, IndefModule) +parseIndefModuleSubstEntry = + do k <- parse + _ <- Parse.char '=' + v <- parse + return (k, v) + +-- | Get the set of holes ('ModuleVar') embedded in a 'IndefModuleSubst'. +-- This is NOT the domain of the substitution. +indefModuleSubstFreeHoles :: IndefModuleSubst -> Set ModuleName +indefModuleSubstFreeHoles insts = Set.unions (map indefModuleFreeHoles (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 :: IndefUnitId -> UnitId +abstractUnitId (IndefUnitId uid) = 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 'IndefModule', +-- you are responsible for recursively converting 'IndefModule' +-- 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/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 + From 5b378e489c0967322d83d1114f6babccf39c94b4 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 06:37:31 +0100 Subject: [PATCH 12/46] Update GhcOptions to use IndefUnitId for -package-id We will use this when building indefinite libraries. --- Cabal/Distribution/Simple/GHC/Internal.hs | 6 ++++-- Cabal/Distribution/Simple/Program/GHC.hs | 4 ++-- cabal-install/Distribution/Client/SetupWrapper.hs | 4 +++- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/Cabal/Distribution/Simple/GHC/Internal.hs b/Cabal/Distribution/Simple/GHC/Internal.hs index a25ef0e4635..0aca5cb2f9a 100644 --- a/Cabal/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/Distribution/Simple/GHC/Internal.hs @@ -37,6 +37,7 @@ import Distribution.Compat.Prelude import Distribution.Simple.GHC.ImplInfo import Distribution.Package +import Distribution.Backpack import Distribution.InstalledPackageInfo import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.PackageDescription as PD hiding (Flag) @@ -374,8 +375,9 @@ getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs | x <- allLibModules lib clbi ] mkGhcOptPackages :: ComponentLocalBuildInfo - -> [(UnitId, ModuleRenaming)] -mkGhcOptPackages = componentIncludes + -> [(IndefUnitId, ModuleRenaming)] +mkGhcOptPackages = map (\(uid, mr) -> (IndefUnitId uid, mr)) + . componentIncludes substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo substTopDir topDir ipo diff --git a/Cabal/Distribution/Simple/Program/GHC.hs b/Cabal/Distribution/Simple/Program/GHC.hs index 9b73903872d..2f636d77682 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) @@ -89,7 +89,7 @@ data GhcOptions = GhcOptions { -- | The GHC packages to bring into scope when compiling, -- the @ghc -package-id@ flags. ghcOptPackages :: - NubListR (UnitId, ModuleRenaming), + NubListR (IndefUnitId, ModuleRenaming), -- | Start with a clean package set; the @ghc -hide-all-packages@ flag ghcOptHideAllPackages :: Flag Bool, diff --git a/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal-install/Distribution/Client/SetupWrapper.hs index 100e46d8ac3..cb5750104ac 100644 --- a/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/Distribution/Client/SetupWrapper.hs @@ -30,6 +30,7 @@ import Distribution.Version ( Version, mkVersion, versionNumbers, VersionRange, anyVersion , intersectVersionRanges, orLaterVersion , withinRange ) +import qualified Distribution.Backpack as Backpack import Distribution.Package ( newSimpleUnitId, ComponentId, PackageId, mkPackageName , PackageIdentifier(..), packageVersion, packageName, Dependency(..) ) @@ -817,7 +818,8 @@ getExternalSetupMethod verbosity options pkg bt = do if any (isCabalPkgId . snd) (useDependencies options') then [] else cabalDep - addRenaming (ipid, _) = (newSimpleUnitId ipid, defaultRenaming) + addRenaming (ipid, _) = + (Backpack.IndefUnitId (newSimpleUnitId ipid), defaultRenaming) cppMacrosFile = setupDir "setup_macros.h" ghcOptions = mempty { -- Respect -v0, but don't crank up verbosity on GHC if From 305935d9cc4d50a1a1002710bf319209042b5593 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 06:41:27 +0100 Subject: [PATCH 13/46] Support for GHC flags -instantiated-with and -fno-code New GhcOptions fields, 'ghcOptInstantiatedWith' for @-instantiated-with@ and 'ghcOptNoCode' for @-fno-code@. --- Cabal/Distribution/Simple/Program/GHC.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/Cabal/Distribution/Simple/Program/GHC.hs b/Cabal/Distribution/Simple/Program/GHC.hs index 2f636d77682..65e763692e2 100644 --- a/Cabal/Distribution/Simple/Program/GHC.hs +++ b/Cabal/Distribution/Simple/Program/GHC.hs @@ -83,6 +83,11 @@ data GhcOptions = GhcOptions { -- (we need to handle backwards compatibility.) ghcOptThisUnitId :: Flag String, + ghcOptInstantiatedWith :: [(ModuleName, IndefModule)], + + -- | No code? (But we turn on interface writing + ghcOptNoCode :: Flag Bool, + -- | GHC package databases to use, the @ghc -package-conf@ flag. ghcOptPackageDBs :: PackageDBStack, @@ -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 ] From 3de0e4c43d17a78a9ef261f11619e8cdbb549f85 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 05:06:10 +0100 Subject: [PATCH 14/46] Backpack InstalledPackageInfo representation changes New field, @instantiated-with@, which records the full module substitution (it is dropped when we do 'improveUnitId'). For flexibility in the case of indefinite packages, some occurences of Module are relaxed to IndefModule (exposedReexport). This is just for convenience; in the case of a definite package these reexports and instantiations are guaranteed to be 'Module's. This patch also includes the minimal changes in other modules needed due to the representation change. --- Cabal/Distribution/InstalledPackageInfo.hs | 18 ++++++++++++++++-- Cabal/Distribution/Simple/Configure.hs | 9 +++++---- Cabal/Distribution/Simple/GHC/IPI642.hs | 1 + Cabal/Distribution/Simple/PackageIndex.hs | 6 ++++-- Cabal/Distribution/Simple/Register.hs | 1 + 5 files changed, 27 insertions(+), 8 deletions(-) diff --git a/Cabal/Distribution/InstalledPackageInfo.hs b/Cabal/Distribution/InstalledPackageInfo.hs index 8750c135b45..fb7bcaf56f0 100644 --- a/Cabal/Distribution/InstalledPackageInfo.hs +++ b/Cabal/Distribution/InstalledPackageInfo.hs @@ -47,6 +47,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 @@ -56,6 +57,7 @@ import Distribution.Compat.Graph import Text.PrettyPrint as Disp import qualified Data.Char as Char +import qualified Data.Map as Map -- ----------------------------------------------------------------------------- -- The InstalledPackageInfo type @@ -67,6 +69,11 @@ data InstalledPackageInfo -- these parts are exactly the same as PackageDescription sourcePackageId :: PackageId, installedUnitId :: UnitId, + -- INVARIANT: if this package is definite, IndefModule's + -- IndefUnitId directly records UnitId. If it is + -- indefinite, IndefModule is always an IndefModuleVar + -- with the same ModuleName as the key. + instantiatedWith :: [(ModuleName, IndefModule)], compatPackageKey :: String, license :: License, copyright :: String, @@ -81,6 +88,8 @@ data InstalledPackageInfo -- these parts are required by an installed package only: abiHash :: AbiHash, exposed :: Bool, + -- INVARIANT: if the package is definite, IndefModule's + -- IndefUnitId directly records UnitId. exposedModules :: [ExposedModule], hiddenModules :: [ModuleName], trusted :: Bool, @@ -92,6 +101,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], @@ -135,6 +146,7 @@ emptyInstalledPackageInfo = InstalledPackageInfo { sourcePackageId = PackageIdentifier (mkPackageName "") nullVersion, installedUnitId = mkUnitId "", + instantiatedWith = [], compatPackageKey = "", license = UnspecifiedLicense, copyright = "", @@ -175,7 +187,7 @@ emptyInstalledPackageInfo data ExposedModule = ExposedModule { exposedName :: ModuleName, - exposedReexport :: Maybe Module + exposedReexport :: Maybe IndefModule } deriving (Eq, Generic, Read, Show) @@ -195,7 +207,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 @@ -257,6 +268,9 @@ basicFieldDescrs = , simpleField "id" disp parse installedUnitId (\pk pkg -> pkg{installedUnitId=pk}) + , simpleField "instantiated-with" + (dispIndefModuleSubst . Map.fromList) (fmap Map.toList parseIndefModuleSubst) + instantiatedWith (\iw pkg -> pkg{instantiatedWith=iw}) , simpleField "key" dispCompatPackageKey parseCompatPackageKey compatPackageKey (\pk pkg -> pkg{compatPackageKey=pk}) diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index c9c5befb26a..2eff490e8f8 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -66,6 +66,7 @@ import Distribution.Utils.NubList import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.PreProcess import Distribution.Package +import Distribution.Backpack import qualified Distribution.InstalledPackageInfo as Installed import Distribution.InstalledPackageInfo (InstalledPackageInfo ,emptyInstalledPackageInfo) @@ -2004,8 +2005,8 @@ resolveModuleReexports installedPackages srcpkgid key externalPkgDeps lib = , let exportingPackageName = packageName srcpkgid definingModuleName = visibleModuleName definingPackageId = key - originalModule = Module definingPackageId - definingModuleName + originalModule = IndefModule (IndefUnitId definingPackageId) + definingModuleName exposedModule = Installed.ExposedModule visibleModuleName (Just originalModule) ] @@ -2022,8 +2023,8 @@ resolveModuleReexports installedPackages srcpkgid key externalPkgDeps lib = -- In this case the reexport will point to this package. Nothing -> return exposedModule { Installed.exposedReexport = - Just (Module - (Installed.installedUnitId pkg) + Just (IndefModule + (IndefUnitId (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 diff --git a/Cabal/Distribution/Simple/GHC/IPI642.hs b/Cabal/Distribution/Simple/GHC/IPI642.hs index 14f1ad4ea53..63f46d6e18f 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), diff --git a/Cabal/Distribution/Simple/PackageIndex.hs b/Cabal/Distribution/Simple/PackageIndex.hs index c2db8838f1a..9017e8ee706 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 @@ -666,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 (IndefModuleVar _) -> [] + Just (IndefModule _ 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/Register.hs b/Cabal/Distribution/Simple/Register.hs index 681f17cfeb7..2273f81243f 100644 --- a/Cabal/Distribution/Simple/Register.hs +++ b/Cabal/Distribution/Simple/Register.hs @@ -389,6 +389,7 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi pkgName = componentCompatPackageName clbi }, IPI.installedUnitId = componentUnitId clbi, + IPI.instantiatedWith = [], --TODO fill in properly IPI.compatPackageKey = componentCompatPackageKey clbi, IPI.license = license pkg, IPI.copyright = copyright pkg, From 8d31f43baa2aedd5c81770582f936ce03f29b179 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 05:14:30 +0100 Subject: [PATCH 15/46] Rename .cabal required-signatures field to signatures Change of .cabal file syntax: rename @required-signatures@ field to just @signatures@. Update the parser and error messages that mention the field. Also rename the corresponding field in the Library type. --- Cabal/Distribution/PackageDescription/Check.hs | 8 ++++---- Cabal/Distribution/PackageDescription/Parse.hs | 4 ++-- Cabal/Distribution/Simple/Build.hs | 2 +- Cabal/Distribution/Types/Library.hs | 8 ++++---- 4 files changed, 11 insertions(+), 11 deletions(-) diff --git a/Cabal/Distribution/PackageDescription/Check.hs b/Cabal/Distribution/PackageDescription/Check.hs index dc2c273c0c3..9ce18366733 100644 --- a/Cabal/Distribution/PackageDescription/Check.hs +++ b/Cabal/Distribution/PackageDescription/Check.hs @@ -241,11 +241,11 @@ checkLibrary pkg lib = 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 diff --git a/Cabal/Distribution/PackageDescription/Parse.hs b/Cabal/Distribution/PackageDescription/Parse.hs index 306468166e6..60185753d9d 100644 --- a/Cabal/Distribution/PackageDescription/Parse.hs +++ b/Cabal/Distribution/PackageDescription/Parse.hs @@ -177,8 +177,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}) diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index 9daafd53caf..707a49a6bee 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -416,7 +416,7 @@ testSuiteLibV09AsLibAndExe pkg_descr libName = Nothing, exposedModules = [ m ], reexportedModules = [], - requiredSignatures = [], + signatures = [], libExposed = True, libBuildInfo = bi } diff --git a/Cabal/Distribution/Types/Library.hs b/Cabal/Distribution/Types/Library.hs index 324e71e121f..a15588a3dfe 100644 --- a/Cabal/Distribution/Types/Library.hs +++ b/Cabal/Distribution/Types/Library.hs @@ -20,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 } @@ -33,7 +33,7 @@ instance Monoid Library where libName = mempty, exposedModules = mempty, reexportedModules = mempty, - requiredSignatures = mempty, + signatures = mempty, libExposed = True, libBuildInfo = mempty } @@ -44,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 } @@ -61,7 +61,7 @@ emptyLibrary = mempty 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'. From 1017f7100e99d3d8d1eda387ab926a832d1180f8 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 06:05:16 +0100 Subject: [PATCH 16/46] Replace the module renaming/thinning system We had an old implementation of 'ModuleRenaming', with the assumption that it would be used directly in build-depends; since we have dropped this assumption, we can refactor 'ModuleRenaming' and we do so. The main idea is to make the data type more directly reflect the syntax you can specify in a Cabal file; so the default renaming and an explicit thinning renaming are now different constructors. It's no longer possible to use the "with" syntax, but it's not necessary either, since we have a special backpack-includes field to specify renamings, so we don't need them to be Monoidal. There is also a new syntax for 'hiding', which just lets you hide some modules when including a package. Handy! Previously, we recorded 'ModuleRenaming' in @build-depends@, but separated it out when we stored in 'BuildInfo'. We now go even further, by changing it from a 'Map' (the only thing @build-depends@ could support) to a list (so that a package name can be specified multiple times.) This is good because now a user can instantiate something several times, which is useful in Backpack. Also add the new field @backpack-includes@ which can be used to exert fine-grained control over what modules a package brings into scope, include it multiple times, etc. In the .cabal checks, replace 'depsUsingThinningRenamingSyntax' with a more direct check to see if @backpack-includes@ was used. Dropped the legacy 'lookupRenaming' export from ModuleRenaming and PackageDescription; we will shortly not use it anymore. As an intermediate hack we have a local definition in Configure, but this will go away shortly. --- Cabal/Cabal.cabal | 1 + Cabal/Distribution/PackageDescription.hs | 3 +- .../Distribution/PackageDescription/Check.hs | 17 ++--- .../Distribution/PackageDescription/Parse.hs | 16 ++++- Cabal/Distribution/Simple/Build.hs | 4 +- Cabal/Distribution/Simple/Configure.hs | 15 ++-- Cabal/Distribution/Types/BuildInfo.hs | 11 ++- Cabal/Distribution/Types/IncludeRenaming.hs | 59 ++++++++++++++++ Cabal/Distribution/Types/ModuleRenaming.hs | 70 +++++++++++-------- 9 files changed, 134 insertions(+), 62 deletions(-) create mode 100644 Cabal/Distribution/Types/IncludeRenaming.hs diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index d2505c05cc4..e4e4ddb1e37 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -401,6 +401,7 @@ library Distribution.Types.Library Distribution.Types.ModuleReexport Distribution.Types.ModuleRenaming + Distribution.Types.IncludeRenaming Distribution.Types.SetupBuildInfo Distribution.Types.TestSuite Distribution.Types.TestSuiteInterface diff --git a/Cabal/Distribution/PackageDescription.hs b/Cabal/Distribution/PackageDescription.hs index 85aa0a36431..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(..), diff --git a/Cabal/Distribution/PackageDescription/Check.hs b/Cabal/Distribution/PackageDescription/Check.hs index 9ce18366733..686f58db3bc 100644 --- a/Cabal/Distribution/PackageDescription/Check.hs +++ b/Cabal/Distribution/PackageDescription/Check.hs @@ -1007,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)) $ @@ -1242,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 diff --git a/Cabal/Distribution/PackageDescription/Parse.hs b/Cabal/Distribution/PackageDescription/Parse.hs index 60185753d9d..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) -- ----------------------------------------------------------------------------- @@ -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 707a49a6bee..ae1625c99fa 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -67,7 +67,6 @@ 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 ( (), (<.>) ) @@ -454,8 +453,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' diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index 2eff490e8f8..a5e0558333f 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -62,6 +62,7 @@ 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 @@ -1000,9 +1001,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." @@ -1933,9 +1933,14 @@ mkComponentsLocalBuildInfo cfg use_external_internal comp installedPackages | pkgid <- selectSubset bi internalPkgDeps ] else [ (Installed.installedUnitId pkg, packageId pkg) | pkg <- externalPkgDeps ] - includes = map (\(i,p) -> (i,lookupRenaming p cprns)) cpds + -- TODO: this is an intermediate stage in introducing backpack + -- so this is a bit of a hack. It will be completely replaced. + includes = map (\(i,p) -> (i,lookupRenaming p)) cpds + lookupRenaming p = case Map.lookup (packageName p) cprns of + Nothing -> defaultRenaming + Just rns -> includeProvidesRn rns cprns = if newPackageDepsBehaviour pkg_descr - then targetBuildRenaming bi + then Map.fromList (backpackIncludes bi) else Map.empty dedup = Map.toList . Map.fromList 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/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/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) From be1a184c7555ba101f3a0b7ac2358f35491abf42 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 06:56:52 +0100 Subject: [PATCH 17/46] Extend ComponentLocalBuildInfo with backpack info (1) add 'componentInstantiatedWith' to record how a component was instantiated (analogous to @instantiated-with@) and (2) fix 'componentComponentId' for the new constructors in 'Module'. --- Cabal/Distribution/Simple/Build.hs | 5 ++++- Cabal/Distribution/Simple/Configure.hs | 4 +++- Cabal/Distribution/Simple/GHC/Internal.hs | 4 ++-- .../Types/ComponentLocalBuildInfo.hs | 21 ++++++++++++++----- 4 files changed, 25 insertions(+), 9 deletions(-) diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index ae1625c99fa..369e7ba1888 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 @@ -427,11 +428,13 @@ testSuiteLibV09AsLibAndExe pkg_descr 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] @@ -470,7 +473,7 @@ testSuiteLibV09AsLibAndExe pkg_descr componentExeDeps = [], componentLocalName = CExeName (stubName test), componentPackageDeps = deps, - componentIncludes = zip (map fst deps) (repeat defaultRenaming) + componentIncludes = zip (map (IndefUnitId . fst) deps) (repeat defaultRenaming) } testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index a5e0558333f..8c6fde11803 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -1861,6 +1861,8 @@ mkComponentsLocalBuildInfo cfg use_external_internal comp installedPackages componentInternalDeps = dep_uids, componentExeDeps = dep_exes, componentUnitId = uid, + componentInstantiatedWith = [], --TODO in later patch + componentIsIndefinite_ = False, --TODO in later patch componentLocalName = componentName component, componentIsPublic = libName lib == Nothing, componentCompatPackageKey = compat_key, @@ -1935,7 +1937,7 @@ mkComponentsLocalBuildInfo cfg use_external_internal comp installedPackages | pkg <- externalPkgDeps ] -- TODO: this is an intermediate stage in introducing backpack -- so this is a bit of a hack. It will be completely replaced. - includes = map (\(i,p) -> (i,lookupRenaming p)) cpds + includes = map (\(i,p) -> (IndefUnitId i,lookupRenaming p)) cpds lookupRenaming p = case Map.lookup (packageName p) cprns of Nothing -> defaultRenaming Just rns -> includeProvidesRn rns diff --git a/Cabal/Distribution/Simple/GHC/Internal.hs b/Cabal/Distribution/Simple/GHC/Internal.hs index 0aca5cb2f9a..ee6b0608831 100644 --- a/Cabal/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/Distribution/Simple/GHC/Internal.hs @@ -37,6 +37,7 @@ 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 @@ -376,8 +377,7 @@ getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs mkGhcOptPackages :: ComponentLocalBuildInfo -> [(IndefUnitId, ModuleRenaming)] -mkGhcOptPackages = map (\(uid, mr) -> (IndefUnitId uid, mr)) - . componentIncludes +mkGhcOptPackages = componentIncludes substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo substTopDir topDir ipo diff --git a/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs b/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs index 4498a3818c4..9c24a5eb404 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, IndefModule)], -- | 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 :: [(IndefUnitId, 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 :: [(IndefUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] } @@ -70,7 +77,7 @@ data ComponentLocalBuildInfo componentLocalName :: ComponentName, componentUnitId :: UnitId, componentPackageDeps :: [(UnitId, PackageId)], - componentIncludes :: [(UnitId, ModuleRenaming)], + componentIncludes :: [(IndefUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] @@ -79,7 +86,7 @@ data ComponentLocalBuildInfo componentLocalName :: ComponentName, componentUnitId :: UnitId, componentPackageDeps :: [(UnitId, PackageId)], - componentIncludes :: [(UnitId, ModuleRenaming)], + componentIncludes :: [(IndefUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] } @@ -94,3 +101,7 @@ instance IsNode ComponentLocalBuildInfo where componentComponentId :: ComponentLocalBuildInfo -> ComponentId componentComponentId clbi = unitIdComponentId (componentUnitId clbi) + +componentIsIndefinite :: ComponentLocalBuildInfo -> Bool +componentIsIndefinite LibComponentLocalBuildInfo{ componentIsIndefinite_ = b } = b +componentIsIndefinite _ = False From f2840cca2b14c67b31a05c9bedbe0409af2a8c71 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 07:19:07 +0100 Subject: [PATCH 18/46] Add the bulk of the new Backpack code This will shortly be used in the package configuration step. Distribution/Utils/Progress.hs A copy of the Progress monad from cabal-install solver, which we use to report failure and logging from otherwise pure code. Distribution/Backpack/ModSubst.hs Defines a type class ModSubst for semantic objects that can have module substitutions defined over them. Helps us define ModSubst functorially. Distribution/Backpack/ModuleScope.hs A module scope represents the set of required and provided modules which are "in scope", i.e., available for import and mix-in linking. This is not a simple mapping from module name to module, as we're permitted to have conflicting definitions for a module name as long as we don't actually use it. There's a comment which explains this more clearly in the file. These are based off of 'IndefModule' because not all modules in scope are necessarily fully instantiated. Distribution/Backpack/ModuleShape.hs A module shape describes the provisions and requirements of a library. It's similar to a module scope, except that every export must be unambiguous; it too is based off of 'IndefModule'. Distribution/Backpack/FullUnitId.hs An 'IndefUnitId' is not guaranteed to record a module substitution (it could be opaquely represented as a hash); a 'FullUnitId', however, IS guaranteed to do so. Given, for example, an installed package database, we can map opaque 'UnitId' into their expanded representation. This can be important to handle obscure unification problems when mix-in linking. Distribution/Backpack/UnifyM.hs The unification monad, unifiable variants of Module/UnitId (with conversions to and from), and low-level unification operations on them. Uses 'UnionFind' heavily. There is some commented out support for handling recursive unification. At present there is no surface syntax for representing such situations. (We would also need DFA minimization to canonicalize these regular trees.) Distribution/Backpack/MixLink.hs The actual implementation of mix-in linking, on top of the unification monad 'UnifyM'. The key function is 'mixLink', which takes two module scopes and links them together. Distribution/Utils/LogProgress.hs The progress monad, specialized with LogMsg traces and Doc errors. We provide a function to run such computations, outputting traces according to their 'Verbosity' and 'die'ing if there is an error. Distribution/Backpack/ComponentsGraph.hs A small helper function for handling the source-level graph of components (so, just the relationship between stanzas in a Cabal file.) This components graph will eventually get elaborated into a more complex graph with instantiations, etc. Distribution/Backpack/Id.hs A helper module which now contains the functions for computing component identifiers and compatibility package keys. This functionality used to live in Distribution.Simple.Configure but I split it out. There are also adjustments to handle the new Backpack functionality. Distribution/Backpack/ConfiguredComponent.hs A configured component is one for which we've resolved all source level dependencies (e.g., every entry in build-depends, we know the specific transitive versions of each thing we're going to use.) That means we have a 'ComponentId' for this component. This module also contains functions for creating a 'ConfiguredComponent' from a source 'Component'. Distribution/Backpack/LinkedComponent.hs A linked component is one which we have done mix-in linking for, so we know its 'IndefUnitId' and its 'IndefUnitId' dependencies. This module calls out to mix-in linking to actually do linking. The workhorse, in a sense! Distribution/Backpack/ReadyComponent.hs This module implements the instantiation process, where we zip through all of the fully instantiated components, and recursively instantiate their dependencies, so that we get a separate linked component per thing we need to compile, and also finishes off any top-level indefinite components. This gives us the final 'UnitId' for our units. This functionality is reimplemented in a different way in cabal-install; the assumptions are slightly different (in particular, in the library we can't assume we have access to all packages to build them; but in cabal-install we can assume it) so I didn't try to abstract over both implementations. Distribution/Backpack/PreExistingComponent.hs This is a "interoperability" data type which identifies precisely the information from a 'LinkedComponent' that can be derived from an 'InstalledPackageInfo'. --- Cabal/Cabal.cabal | 17 + .../Distribution/Backpack/ComponentsGraph.hs | 80 +++ Cabal/Distribution/Backpack/Configure.hs | 335 ++++++++++++ .../Backpack/ConfiguredComponent.hs | 235 +++++++++ Cabal/Distribution/Backpack/FullUnitId.hs | 26 + Cabal/Distribution/Backpack/Id.hs | 197 +++++++ .../Distribution/Backpack/LinkedComponent.hs | 309 +++++++++++ Cabal/Distribution/Backpack/MixLink.hs | 150 ++++++ Cabal/Distribution/Backpack/ModSubst.hs | 54 ++ Cabal/Distribution/Backpack/ModuleScope.hs | 86 ++++ Cabal/Distribution/Backpack/ModuleShape.hs | 83 +++ .../Backpack/PreExistingComponent.hs | 52 ++ Cabal/Distribution/Backpack/ReadyComponent.hs | 283 ++++++++++ Cabal/Distribution/Backpack/UnifyM.hs | 486 ++++++++++++++++++ Cabal/Distribution/Utils/LogProgress.hs | 41 ++ Cabal/Distribution/Utils/MapAccum.hs | 34 ++ Cabal/Distribution/Utils/Progress.hs | 67 +++ Cabal/Distribution/Utils/UnionFind.hs | 102 ++++ 18 files changed, 2637 insertions(+) create mode 100644 Cabal/Distribution/Backpack/ComponentsGraph.hs create mode 100644 Cabal/Distribution/Backpack/Configure.hs create mode 100644 Cabal/Distribution/Backpack/ConfiguredComponent.hs create mode 100644 Cabal/Distribution/Backpack/FullUnitId.hs create mode 100644 Cabal/Distribution/Backpack/Id.hs create mode 100644 Cabal/Distribution/Backpack/LinkedComponent.hs create mode 100644 Cabal/Distribution/Backpack/MixLink.hs create mode 100644 Cabal/Distribution/Backpack/ModSubst.hs create mode 100644 Cabal/Distribution/Backpack/ModuleScope.hs create mode 100644 Cabal/Distribution/Backpack/ModuleShape.hs create mode 100644 Cabal/Distribution/Backpack/PreExistingComponent.hs create mode 100644 Cabal/Distribution/Backpack/ReadyComponent.hs create mode 100644 Cabal/Distribution/Backpack/UnifyM.hs create mode 100644 Cabal/Distribution/Utils/LogProgress.hs create mode 100644 Cabal/Distribution/Utils/MapAccum.hs create mode 100644 Cabal/Distribution/Utils/Progress.hs create mode 100644 Cabal/Distribution/Utils/UnionFind.hs diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index e4e4ddb1e37..6633c01a7b4 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -316,6 +316,15 @@ library 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 @@ -418,12 +427,20 @@ 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 diff --git a/Cabal/Distribution/Backpack/ComponentsGraph.hs b/Cabal/Distribution/Backpack/ComponentsGraph.hs new file mode 100644 index 00000000000..828673f20ed --- /dev/null +++ b/Cabal/Distribution/Backpack/ComponentsGraph.hs @@ -0,0 +1,80 @@ +-- | 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 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.) +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..e6d96cf7762 --- /dev/null +++ b/Cabal/Distribution/Backpack/Configure.hs @@ -0,0 +1,335 @@ +{-# 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_indef_uid pkg, pc_shape pkg)) + | pkg <- prePkgDeps] + uid_lookup uid + | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid + = FullUnitId (Installed.installedComponentId pkg) + (Map.fromList (Installed.instantiatedWith pkg)) + | otherwise = error ("uid_lookup: " ++ display 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 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 == uid + , modname' == modname + = Installed.ExposedModule modname' Nothing + | otherwise + = Installed.ExposedModule modname' + (Just (IndefModule (IndefUnitId uid) modname)) + convIndefModuleExport (modname', modu@(IndefModule 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.) + | indefUnitIdComponentId uid == this_cid + , modname' == modname + = Installed.ExposedModule modname' Nothing + | otherwise + = Installed.ExposedModule modname' (Just modu) + convIndefModuleExport (_, IndefModuleVar _) + = error "convIndefModuleExport: top-level modvar" + exports = + -- Loses invariants + case rc_i rc of + Left indefc -> map convIndefModuleExport + $ Map.toList (indefc_provides indefc) + Right instc -> map convModuleExport + $ Map.toList (instc_provides instc) + insts = + case rc_i rc of + Left indefc -> [ (m, IndefModuleVar m) | m <- indefc_requires indefc ] + Right instc -> [ (m, IndefModule (IndefUnitId 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 = 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 = rc_internal_build_tools rc, + componentInternalDeps = internal_deps, + componentIncludes = includes + } + CTest _ -> + TestComponentLocalBuildInfo { + componentUnitId = this_uid, + componentLocalName = cname, + componentPackageDeps = cpds, + componentExeDeps = rc_internal_build_tools rc, + componentInternalDeps = internal_deps, + componentIncludes = includes + } + CBench _ -> + BenchComponentLocalBuildInfo { + componentUnitId = this_uid, + componentLocalName = cname, + componentPackageDeps = cpds, + componentExeDeps = 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) -> (IndefUnitId x,y)) (instc_includes instc) + internal_deps = + filter isInternal (nodeNeighbors rc) + ++ 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..839b0897e24 --- /dev/null +++ b/Cabal/Distribution/Backpack/FullUnitId.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Backpack.FullUnitId ( + FullUnitId(..), + FullDb, + expandIndefUnitId, + expandUnitId +) where + +import Distribution.Backpack +import Distribution.Package +import Distribution.Compat.Prelude + +-- Unlike IndefUnitId, which could direct to a UnitId. +data FullUnitId = FullUnitId ComponentId IndefModuleSubst + deriving (Show, Generic) + +type FullDb = UnitId -> FullUnitId + +expandIndefUnitId :: FullDb -> IndefUnitId -> FullUnitId +expandIndefUnitId _db (IndefFullUnitId cid subst) + = FullUnitId cid subst +expandIndefUnitId db (IndefUnitId uid) + = expandUnitId db uid + +expandUnitId :: FullDb -> UnitId -> 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..02f6363b435 --- /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 :: IndefUnitId, + lc_pkgid :: PackageId, + lc_insts :: [(ModuleName, IndefModule)], + lc_component :: Component, + lc_shape :: ModuleShape, + -- | Local buildTools dependencies + lc_internal_build_tools :: [IndefUnitId], + lc_public :: Bool, + lc_includes :: [(IndefUnitId, ModuleRenaming)], + -- PackageId here is a bit dodgy, but its just for + -- BC so it shouldn't matter. + lc_depends :: [(IndefUnitId, PackageId)] + } + +lc_cid :: LinkedComponent -> ComponentId +lc_cid = indefUnitIdComponentId . 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 (indefUnitIdFreeHoles (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 :: [((IndefUnitId, ModuleShape), PackageId, IncludeRenaming)] + unlinked_includes = [ (lookupUid cid, pid, rns) + | (cid, pid, rns) <- cid_includes ] + + lookupUid :: ComponentId -> (IndefUnitId, 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 :: [(IndefUnitId, PackageId)], + linked_includes :: [(IndefUnitId, 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 (IndefModuleVar 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, IndefModuleVar 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 + (IndefModule 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, IndefModule 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 (IndefUnitId, ModuleShape) + -> ConfiguredComponent + -> LogProgress (Map ComponentId (IndefUnitId, 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 (IndefUnitId, 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..aa718b744f8 --- /dev/null +++ b/Cabal/Distribution/Backpack/MixLink.hs @@ -0,0 +1,150 @@ +-- | See +module Distribution.Backpack.MixLink ( + mixLink, +) where + +import Prelude () +import Distribution.Compat.Prelude hiding (mod) + +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 + -> UnitId + -> 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..47cc44aee6b --- /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 :: IndefModuleSubst -> a -> a + +instance ModSubst IndefModule where + modSubst subst (IndefModule cid mod_name) = IndefModule (modSubst subst cid) mod_name + modSubst subst mod@(IndefModuleVar mod_name) + | Just mod' <- Map.lookup mod_name subst = mod' + | otherwise = mod + +instance ModSubst IndefUnitId 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)) + (indefModuleSubstFreeHoles 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..8db7cf1b9c3 --- /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 :: IndefModule + } + +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..9d9c56e935b --- /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 :: IndefModuleSubst, + 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 = IPI.installedUnitId ipi + provs = map shapeExposedModule (IPI.exposedModules ipi) + reqs = indefModuleSubstFreeHoles (Map.fromList (IPI.instantiatedWith ipi)) + shapeExposedModule (IPI.ExposedModule mod_name Nothing) + = (mod_name, IndefModule (IndefUnitId 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..ade3fcafb18 --- /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_indef_uid :: IndefUnitId, + 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_indef_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..e26038d6cf8 --- /dev/null +++ b/Cabal/Distribution/Backpack/ReadyComponent.hs @@ -0,0 +1,283 @@ +{-# 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 :: [(UnitId, ModuleRenaming)] + } + +data IndefiniteComponent + = IndefiniteComponent { + indefc_requires :: [ModuleName], + indefc_provides :: Map ModuleName IndefModule, + indefc_includes :: [(IndefUnitId, 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 :: [UnitId], + 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 UnitId + 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 (uid, Map.insert uid r s') + Just _ -> (uid, s) + where + -- The hashModuleSubst 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. + uid = UnitId cid (hashModuleSubst insts) + + 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_uid _) + | Just pid <- Map.lookup (unitIdComponentId dep_uid) pid_map + = [(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 + deps ++ concatMap getDep (Map.elems insts), + rc_i = Right instc + } + | otherwise = return Nothing + + substUnitId :: Map ModuleName Module -> IndefUnitId -> InstM UnitId + substUnitId _ (IndefUnitId 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 IndefModule + -> InstM (Map ModuleName Module) + substSubst subst insts = T.mapM (substModule subst) insts + + substModule :: Map ModuleName Module -> IndefModule -> InstM Module + substModule subst (IndefModuleVar mod_name) + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" + substModule subst (IndefModule 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 + else indefiniteUnitId (lc_cid lc) diff --git a/Cabal/Distribution/Backpack/UnifyM.hs b/Cabal/Distribution/Backpack/UnifyM.hs new file mode 100644 index 00000000000..402b6a0851b --- /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 UnitId + +-- | 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 + -> IndefUnitId + -> UnifyM s (UnitIdU s) +-- TODO: this could be more lazy if we know there are no internal +-- references +convertUnitId' _ (IndefUnitId 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 + -> IndefModule -> UnifyM s (ModuleU s) +convertModule' _stk (IndefModuleVar 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 (IndefModule uid mod_name) = do + uid_u <- convertUnitId' stk uid + liftST $ UnionFind.fresh (ModuleU uid_u mod_name) + +convertUnitId :: IndefUnitId -> UnifyM s (UnitIdU s) +convertUnitId = convertUnitId' emptyMuEnv + +convertModule :: IndefModule -> 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 IndefModule -> UnifyM s (Map ModuleName (ModuleU s)) +convertModuleSubst = T.mapM convertModule + +-- | Conversion of 'ModuleSubstU' to 'ModuleSubst' +convertModuleSubstU :: ModuleSubstU s -> UnifyM s IndefModuleSubst +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 IndefUnitId +convertUnitIdU' stk uid_u = do + x <- liftST $ UnionFind.find uid_u + case x of + UnitIdThunkU uid -> return (IndefUnitId 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 IndefModule +convertModuleU' stk mod_u = do + mod <- liftST $ UnionFind.find mod_u + case mod of + ModuleVarU mod_name -> return (IndefModuleVar mod_name) + ModuleU uid_u mod_name -> do + uid <- convertUnitIdU' stk uid_u + return (IndefModule uid mod_name) + +-- Helper functions + +convertUnitIdU :: UnitIdU s -> UnifyM s IndefUnitId +convertUnitIdU = convertUnitIdU' emptyMooEnv + +convertModuleU :: ModuleU s -> UnifyM s IndefModule +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 + :: ((IndefUnitId, 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 IndefModuleVar 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, IndefModuleVar 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/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) From 688b31e3f23c4f3363f41652eb2be9fdd6a01422 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 07:24:44 +0100 Subject: [PATCH 19/46] Use the new Backpack code for the configure step Many of the configure functions were factored out and moved to the new Backpack modules. The new configure action makes a call to Distribution.Backpack.Configure to setup the ComponentLocalBuildInfo. Also add an @--instantiate-with@ flag to ./Setup configure, so that cabal-install can specify how it wants to instantiate a package that it is building. Also do the minimal necessary adjustments in cabal-install. --- Cabal/Distribution/Simple/Build.hs | 2 +- Cabal/Distribution/Simple/Configure.hs | 649 ++---------------- Cabal/Distribution/Simple/Setup.hs | 24 + cabal-install/Distribution/Client/Config.hs | 1 + .../Distribution/Client/InstallPlan.hs | 4 +- .../Distribution/Client/ProjectPlanning.hs | 9 +- 6 files changed, 81 insertions(+), 608 deletions(-) diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index 369e7ba1888..9e226866a12 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -423,7 +423,7 @@ testSuiteLibV09AsLibAndExe pkg_descr -- 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 diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index 8c6fde11803..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, @@ -67,22 +66,18 @@ import Distribution.Utils.NubList import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.PreProcess import Distribution.Package -import Distribution.Backpack 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 @@ -92,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 @@ -105,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 @@ -113,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 @@ -133,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. @@ -492,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. @@ -505,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 @@ -515,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. -- @@ -638,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 <- @@ -1012,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 @@ -1022,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] -> @@ -1038,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)) $ @@ -1052,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'. @@ -1232,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 () @@ -1346,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". -- @@ -1599,502 +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 (UnitId 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, - componentInstantiatedWith = [], --TODO in later patch - componentIsIndefinite_ = False, --TODO in later patch - 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 = newSimpleUnitId 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 ] - -- TODO: this is an intermediate stage in introducing backpack - -- so this is a bit of a hack. It will be completely replaced. - includes = map (\(i,p) -> (IndefUnitId i,lookupRenaming p)) cpds - lookupRenaming p = case Map.lookup (packageName p) cprns of - Nothing -> defaultRenaming - Just rns -> includeProvidesRn rns - cprns = if newPackageDepsBehaviour pkg_descr - then Map.fromList (backpackIncludes 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 = IndefModule (IndefUnitId 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 (IndefModule - (IndefUnitId (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/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-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/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs index 8aa508a22fa..ff6fa0e1369 100644 --- a/cabal-install/Distribution/Client/InstallPlan.hs +++ b/cabal-install/Distribution/Client/InstallPlan.hs @@ -458,8 +458,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/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 73dafc84998..468631767ed 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -109,6 +109,8 @@ import Distribution.Simple.LocalBuildInfo (ComponentName(..)) import qualified Distribution.Simple.Register as Cabal import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Backpack.ComponentsGraph + import Distribution.Simple.Utils hiding (matchFileGlob) import Distribution.Version import Distribution.Verbosity @@ -1084,10 +1086,9 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB where elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon mapDep spkg comps_graph = - case Cabal.mkComponentsGraph + case toComponentsGraph elabEnabledSpec - elabPkgDescription - elabInternalPackages of + elabPkgDescription of Left _ -> error ("component cycle in " ++ display elabPkgSourceId) Right g -> g @@ -2354,6 +2355,8 @@ setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) configCabalFilePath = mempty configVerbosity = toFlag verbosity + configInstantiateWith = [] --TODO in later patches + configIPID = case elabPkgOrComp of ElabPackage pkg -> toFlag (display (pkgInstalledId pkg)) ElabComponent _ -> mempty From 2515cc2803668d15d38a108950a5704f6ca6c572 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Tue, 4 Oct 2016 04:12:14 +0100 Subject: [PATCH 20/46] allLibModules now includes every signature in the package These may NOT be explicitly specified in the Cabal file; we read it off of 'componentInstantiatedWith'. --- Cabal/Distribution/Simple/LocalBuildInfo.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/Cabal/Distribution/Simple/LocalBuildInfo.hs b/Cabal/Distribution/Simple/LocalBuildInfo.hs index 3c70aeb18e9..de915ea7602 100644 --- a/Cabal/Distribution/Simple/LocalBuildInfo.hs +++ b/Cabal/Distribution/Simple/LocalBuildInfo.hs @@ -289,11 +289,16 @@ depLibraryPaths inplace relative lbi clbi = do then canonicalizePath p else return p --- TODO: doc +-- | 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 = - explicitLibModules lib - -- TODO: add more stuff + ordNub $ + explicitLibModules lib ++ + case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> map fst insts + _ -> [] -- ----------------------------------------------------------------------------- -- Wrappers for a couple functions from InstallDirs From ef7235c75317ea4f06fd5abc6bb142beca65274c Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Tue, 4 Oct 2016 04:16:00 +0100 Subject: [PATCH 21/46] Generate package registraion with instantiation info Correctly setup 'instantiatedWith' in 'InstalledPackageInfo'. Also ensure that there are no duplicate entries in 'depends' (I couldn't find the root cause for duplication, so I just put the test here.) --- Cabal/Distribution/Simple/Register.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Cabal/Distribution/Simple/Register.hs b/Cabal/Distribution/Simple/Register.hs index 2273f81243f..27d00e43f30 100644 --- a/Cabal/Distribution/Simple/Register.hs +++ b/Cabal/Distribution/Simple/Register.hs @@ -389,7 +389,7 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi pkgName = componentCompatPackageName clbi }, IPI.installedUnitId = componentUnitId clbi, - IPI.instantiatedWith = [], --TODO fill in properly + IPI.instantiatedWith = componentInstantiatedWith clbi, IPI.compatPackageKey = componentCompatPackageKey clbi, IPI.license = license pkg, IPI.copyright = copyright pkg, @@ -420,7 +420,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. From 5173c9e4e97c0e7fe36741769d671092f71a562d Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Tue, 4 Oct 2016 04:28:06 +0100 Subject: [PATCH 22/46] Fix up component build directories to avoid clashes Now that we can build a component multiple times with different instantiations, we need to make sure we give each instantiation a different build directory; done in 'buildDir'. --- Cabal/Distribution/Simple/LocalBuildInfo.hs | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/Cabal/Distribution/Simple/LocalBuildInfo.hs b/Cabal/Distribution/Simple/LocalBuildInfo.hs index de915ea7602..0bf081336dc 100644 --- a/Cabal/Distribution/Simple/LocalBuildInfo.hs +++ b/Cabal/Distribution/Simple/LocalBuildInfo.hs @@ -104,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 From beff9e87eccfa9a76c9d7eebafc87d2361231133 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Tue, 4 Oct 2016 04:40:25 +0100 Subject: [PATCH 23/46] Pre-build, make empty .hsig files for each requirement of the library Part of the GHC/Cabal contract is that we always have a source file for everything GHC works on. --- Cabal/Distribution/Simple/Build.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index 9e226866a12..fc273e0c97f 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -70,7 +70,7 @@ import Distribution.Compat.Graph (IsNode(..)) import qualified Data.Set as Set import Data.List ( intersect ) -import System.FilePath ( (), (<.>) ) +import System.FilePath ( (), (<.>), takeDirectory ) import System.Directory ( getCurrentDirectory ) -- ----------------------------------------------------------------------------- @@ -587,5 +587,16 @@ 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 } -> + -- Harmless enough to do things even when they exist + 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) From 42af3567b040b845841a4ca50f396a9838ddce23 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Tue, 4 Oct 2016 04:45:39 +0100 Subject: [PATCH 24/46] Include signatures in SrcDist Count signatures as modules that we have to find, and when searching for modules, look for .hsig or .lhsig files (in addition to the usual .hs .lhs files) --- Cabal/Distribution/Simple/SrcDist.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) 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'." From fa79bdf0c49e0d46e7713a6508e30b7a590eb2c3 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Tue, 4 Oct 2016 04:52:44 +0100 Subject: [PATCH 25/46] Teach GHC how to build indefinite libraries These are libraries which don't have any code (uses 'whenHasCode' combinator). In principle this could also be extended to support building anything with no code. Also update 'ghcOptThisUnitId' and 'ghcOptInstantiatedWith' to have correct values. --- Cabal/Distribution/Simple/GHC.hs | 40 ++++++++++++++++------- Cabal/Distribution/Simple/GHC/Internal.hs | 5 +++ 2 files changed, 33 insertions(+), 12 deletions(-) diff --git a/Cabal/Distribution/Simple/GHC.hs b/Cabal/Distribution/Simple/GHC.hs index 8225b075aa5..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 @@ -587,7 +589,10 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do (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 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) @@ -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 @@ -1181,10 +1195,12 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do 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/Internal.hs b/Cabal/Distribution/Simple/GHC/Internal.hs index ee6b0608831..ba5d81d810f 100644 --- a/Cabal/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/Distribution/Simple/GHC/Internal.hs @@ -289,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), From 9e59b8620b31893a2743510e131f308e6af788f2 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Tue, 4 Oct 2016 04:55:23 +0100 Subject: [PATCH 26/46] Fixup haddock backpack support 1) Bugfix so that we get library source files from the correct directories (it was wrong previously; it only ever looked in the library directory) 2) Search for hsig/lhsig files when looking for source files --- Cabal/Distribution/Simple/Haddock.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) 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 From 26c670255a2a8103eaeebb5c564106f0b05759d9 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Tue, 4 Oct 2016 04:33:06 +0100 Subject: [PATCH 27/46] A few cleanups and minor things Add a clarification in packageTemplateEnv Improve the pre-processing message so we can see which unit is being built, not just the source component name. Debug output while building to print out the installed package info when we register information. Remove a done TODO about making sure the installed package registration files do not clash with each other, by including the full UnitId. This did not need any code changes here since dislaying the UnitId does the right thing. --- Cabal/Distribution/Simple/Build.hs | 1 + Cabal/Distribution/Simple/InstallDirs.hs | 6 ++++-- Cabal/Distribution/Simple/PreProcess.hs | 4 +++- Cabal/Distribution/Simple/Register.hs | 1 - 4 files changed, 8 insertions(+), 4 deletions(-) diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index fc273e0c97f..dc62f0abd21 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -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 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/PreProcess.hs b/Cabal/Distribution/Simple/PreProcess.hs index 153f5c901a3..44f113e3c68 100644 --- a/Cabal/Distribution/Simple/PreProcess.hs +++ b/Cabal/Distribution/Simple/PreProcess.hs @@ -151,7 +151,9 @@ 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) + 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 diff --git a/Cabal/Distribution/Simple/Register.hs b/Cabal/Distribution/Simple/Register.hs index 27d00e43f30..bc1ed259915 100644 --- a/Cabal/Distribution/Simple/Register.hs +++ b/Cabal/Distribution/Simple/Register.hs @@ -199,7 +199,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) From b5a4d9aac8fddd354f68cf39814610d125b500cb Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 21:29:10 -0700 Subject: [PATCH 28/46] Set LC_ALL=C when running package-tests to avoid Unicode output. Signed-off-by: Edward Z. Yang --- Cabal/tests/PackageTests/PackageTester.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Cabal/tests/PackageTests/PackageTester.hs b/Cabal/tests/PackageTests/PackageTester.hs index d21349a4657..1987006f306 100644 --- a/Cabal/tests/PackageTests/PackageTester.hs +++ b/Cabal/tests/PackageTests/PackageTester.hs @@ -149,7 +149,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 From a1f67b8f2cb766cbf482389b1975072bd6dc140b Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 21:31:14 -0700 Subject: [PATCH 29/46] package-tests helper cabal_install_with_docs for building with docs. Signed-off-by: Edward Z. Yang --- Cabal/tests/PackageTests/PackageTester.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/Cabal/tests/PackageTests/PackageTester.hs b/Cabal/tests/PackageTests/PackageTester.hs index 1987006f306..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 @@ -421,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 From 99204fa7c9e5a21349116c0667b551182e19c774 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 21:32:33 -0700 Subject: [PATCH 30/46] Fixup: make reexported modules tests build with abstract Version. Signed-off-by: Edward Z. Yang --- Cabal/tests/PackageTests/Tests.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Cabal/tests/PackageTests/Tests.hs b/Cabal/tests/PackageTests/Tests.hs index ad8aef99508..7ff8f97d40d 100644 --- a/Cabal/tests/PackageTests/Tests.hs +++ b/Cabal/tests/PackageTests/Tests.hs @@ -211,17 +211,17 @@ tests config = do withPackage "p" $ cabal_install ["--cabal-file", "p.cabal"] withPackage "q" $ do cabal_build [] - tcs "ReexportedModules" "fail-other" . whenGhcVersion (>= Version [7,9] []) $ do + 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 (>= Version [7,9] []) $ do + 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 (>= Version [7,9] []) $ do + tcs "ReexportedModules" "fail-missing" . whenGhcVersion (>= mkVersion [7,9]) $ do withPackage "p" $ do r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail-missing.cabal"] assertOutputContains "Missing" r From 6db73c7cc6fce57bb76078dff5f46d4dfbb416d7 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 21:36:54 -0700 Subject: [PATCH 31/46] Test reexporting locally defined exposed module. Signed-off-by: Edward Z. Yang --- Cabal/Cabal.cabal | 2 ++ Cabal/tests/PackageTests/ReexportedModules/p/Private.hs | 2 ++ Cabal/tests/PackageTests/ReexportedModules/p/Public.hs | 2 ++ Cabal/tests/PackageTests/ReexportedModules/p/p.cabal | 6 +++++- Cabal/tests/PackageTests/ReexportedModules/q/A.hs | 2 ++ 5 files changed, 13 insertions(+), 1 deletion(-) create mode 100644 Cabal/tests/PackageTests/ReexportedModules/p/Private.hs create mode 100644 Cabal/tests/PackageTests/ReexportedModules/p/Public.hs diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 6633c01a7b4..bde2660f1f1 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -209,6 +209,8 @@ extra-source-files: 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 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/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 From 45d75e1f449a59c189897303530c707d5d1431a0 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 21:37:27 -0700 Subject: [PATCH 32/46] Tests for Cabal's Backpack support. Signed-off-by: Edward Z. Yang --- Cabal/Cabal.cabal | 47 ++++++ Cabal/tests/PackageTests/Ambiguity/p/Dupe.hs | 2 + Cabal/tests/PackageTests/Ambiguity/p/p.cabal | 12 ++ .../Ambiguity/package-import/A.hs | 7 + .../package-import/package-import.cabal | 13 ++ Cabal/tests/PackageTests/Ambiguity/q/Dupe.hs | 2 + Cabal/tests/PackageTests/Ambiguity/q/q.cabal | 12 ++ .../Ambiguity/reexport-test/Main.hs | 5 + .../reexport-test/reexport-test.cabal | 12 ++ .../Ambiguity/reexport/reexport.cabal | 12 ++ .../PackageTests/Backpack/Includes1/A.hs | 2 + .../PackageTests/Backpack/Includes1/B.hs | 3 + .../Backpack/Includes1/Includes1.cabal | 13 ++ .../Backpack/Includes2/Includes2.cabal | 41 ++++++ .../Backpack/Includes2/exe/Main.hs | 3 + .../Backpack/Includes2/exe/exe.cabal | 12 ++ .../Backpack/Includes2/fail.cabal | 35 +++++ .../Backpack/Includes2/mylib/Database.hsig | 3 + .../Backpack/Includes2/mylib/Mine.hs | 4 + .../Backpack/Includes2/mylib/mylib.cabal | 13 ++ .../Includes2/mysql/Database/MySQL.hs | 3 + .../Backpack/Includes2/mysql/mysql.cabal | 12 ++ .../postgresql/Database/PostgreSQL.hs | 3 + .../Includes2/postgresql/postgresql.cabal | 12 ++ .../Backpack/Includes2/src/App.hs | 7 + .../Backpack/Includes2/src/src.cabal | 15 ++ .../Backpack/Includes3/Includes3.cabal | 23 +++ .../Backpack/Includes3/exe/Main.hs | 4 + .../Backpack/Includes3/exe/exe.cabal | 12 ++ .../Backpack/Includes3/indef/Foo.hs | 6 + .../Backpack/Includes3/indef/indef.cabal | 11 ++ .../Backpack/Includes3/sigs/Data/Map.hsig | 5 + .../Backpack/Includes3/sigs/sigs.cabal | 11 ++ .../Backpack/Includes4/Includes4.cabal | 25 ++++ .../PackageTests/Backpack/Includes4/Main.hs | 2 + .../PackageTests/Backpack/Includes4/impl/A.hs | 4 + .../Backpack/Includes4/impl/A.hs-boot | 3 + .../PackageTests/Backpack/Includes4/impl/B.hs | 4 + .../Backpack/Includes4/impl/Rec.hs | 3 + .../Backpack/Includes4/indef/A.hsig | 2 + .../Backpack/Includes4/indef/B.hsig | 2 + .../Backpack/Includes4/indef/C.hs | 4 + .../Backpack/Includes4/indef/Rec.hsig | 3 + .../PackageTests/Backpack/Includes5/A.hs | 2 + .../PackageTests/Backpack/Includes5/B.hs | 2 + .../Backpack/Includes5/Includes5.cabal | 25 ++++ .../Backpack/Includes5/impl/Foobar.hs | 1 + .../Backpack/Includes5/impl/Quxbaz.hs | 1 + .../PackageTests/Backpack/Indef1/Indef1.cabal | 13 ++ .../PackageTests/Backpack/Indef1/Map.hsig | 5 + .../PackageTests/Backpack/Indef1/Provide.hs | 5 + .../PackageTests/Backpack/Reexport1/p/P.hs | 1 + .../PackageTests/Backpack/Reexport1/p/p.cabal | 14 ++ .../PackageTests/Backpack/Reexport1/q/Q.hs | 2 + .../PackageTests/Backpack/Reexport1/q/q.cabal | 12 ++ Cabal/tests/PackageTests/Tests.hs | 137 ++++++++++++++++++ 56 files changed, 649 insertions(+) create mode 100644 Cabal/tests/PackageTests/Ambiguity/p/Dupe.hs create mode 100644 Cabal/tests/PackageTests/Ambiguity/p/p.cabal create mode 100644 Cabal/tests/PackageTests/Ambiguity/package-import/A.hs create mode 100644 Cabal/tests/PackageTests/Ambiguity/package-import/package-import.cabal create mode 100644 Cabal/tests/PackageTests/Ambiguity/q/Dupe.hs create mode 100644 Cabal/tests/PackageTests/Ambiguity/q/q.cabal create mode 100644 Cabal/tests/PackageTests/Ambiguity/reexport-test/Main.hs create mode 100644 Cabal/tests/PackageTests/Ambiguity/reexport-test/reexport-test.cabal create mode 100644 Cabal/tests/PackageTests/Ambiguity/reexport/reexport.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes1/A.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes1/B.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes1/Includes1.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes2/Includes2.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes2/exe/Main.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes2/exe/exe.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes2/fail.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes2/mylib/Database.hsig create mode 100644 Cabal/tests/PackageTests/Backpack/Includes2/mylib/Mine.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes2/mylib/mylib.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes2/mysql/Database/MySQL.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes2/mysql/mysql.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes2/postgresql/Database/PostgreSQL.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes2/postgresql/postgresql.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes2/src/App.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes2/src/src.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes3/Includes3.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes3/exe/Main.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes3/exe/exe.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes3/indef/Foo.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes3/indef/indef.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes3/sigs/Data/Map.hsig create mode 100644 Cabal/tests/PackageTests/Backpack/Includes3/sigs/sigs.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes4/Includes4.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes4/Main.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes4/impl/A.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes4/impl/A.hs-boot create mode 100644 Cabal/tests/PackageTests/Backpack/Includes4/impl/B.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes4/impl/Rec.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes4/indef/A.hsig create mode 100644 Cabal/tests/PackageTests/Backpack/Includes4/indef/B.hsig create mode 100644 Cabal/tests/PackageTests/Backpack/Includes4/indef/C.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes4/indef/Rec.hsig create mode 100644 Cabal/tests/PackageTests/Backpack/Includes5/A.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes5/B.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes5/Includes5.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Includes5/impl/Foobar.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Includes5/impl/Quxbaz.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Indef1/Indef1.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Indef1/Map.hsig create mode 100644 Cabal/tests/PackageTests/Backpack/Indef1/Provide.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Reexport1/p/P.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Reexport1/p/p.cabal create mode 100644 Cabal/tests/PackageTests/Backpack/Reexport1/q/Q.hs create mode 100644 Cabal/tests/PackageTests/Backpack/Reexport1/q/q.cabal diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index bde2660f1f1..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 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/Tests.hs b/Cabal/tests/PackageTests/Tests.hs index 7ff8f97d40d..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 @@ -226,6 +228,28 @@ tests config = 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 withPackage "P1" $ cabal "configure" [] @@ -604,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 From 2acefb2826f6551d094aee7faf8ea7a58b33a7df Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 21:39:34 -0700 Subject: [PATCH 33/46] Cabal changelog entry for Backpack. Signed-off-by: Edward Z. Yang --- Cabal/changelog | 5 +++++ 1 file changed, 5 insertions(+) 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. From 60b6643ac8f7f80e37010c8bfb945a68e0b5a722 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 21:45:02 -0700 Subject: [PATCH 34/46] cabal-install updates to handle configInstantiateWith. Signed-off-by: Edward Z. Yang --- cabal-install/Distribution/Client/ProjectConfig/Legacy.hs | 2 ++ 1 file changed, 2 insertions(+) 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, From 69cfeec2b95105ec907f67aa2371cb946dd901a9 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 21:45:10 -0700 Subject: [PATCH 35/46] cabal-install changes for Backpack. Here are the main changes: Distribution/Client/InstallPlan.hs New utility function 'fromSolverInstallPlanWithProgress' which is a monadic version of 'fromSolverInstallPlan'. This is because, with Backpack, the conversion from 'SolverInstallPlan' to 'InstallPlan' can fail/log. Distribution/Client/ProjectPlanning/Types.hs OK. A bunch of new information we need to track. New fields in 'ElaboratedConfiguredPackage': elabInstantiatedWith :: ModuleSubst (for --instantiated-with) elabLinkedInstantiatedWith :: IndefModuleSubst (intermediate) elabModuleShape :: ModuleShape (for mix-in linking) Here is how all the dependency functions relate to one another: elabOrderDependencies :: [UnitId] Used for nodeNeighbors, this just specifies what needs to be built before we build this module. These refer either to fully instantiated unit ids (hashed unit id) or uninstantiated unit ids (effectively component id) but never a partially instantiated unit id, since we never have an install item in our plan for a partially instantiated package. These dependencies are factored into two parts: elabOrderLibDependencies elabOrderExeDependencies which soley are used to determine if we need to enable executables/libraries of a package we are building (this isn't new) elabLibDependencies :: [ComponentId] These are the things we pass to Setup using the --dependency flag; so they are JUST ComponentId, not a full on UnitId. The mix-in linking process in Setup will reconstruct the necessary UnitId. elabExeDependencies :: [ComponentId] These are the things that we must add to the PATH to run. At the moment, this coincides with elabOrderExeDependencies. For components, there is also: compLinkedLibDependencies :: [IndefUnitId], The partially instantiated unit ids that GHC would be invoked with, if we were invoking it directly. This is used when we subsequently instantiate components. compNonSetupDependencies :: [UnitId] Non-setup, ORDER dependencies; i.e., everything that has to be built before us that is not a setup script. Distribution/Client/ProjectPlanning.hs The workhorse. Essentially, we redo all of the steps from Distribution.Backpack.Configure, but in the context of planning an entire install plan. The conversion from SolverInstallPlan to InstallPlan is responsible for mix-in linking (inside elaborateSolverToComponents); afterwards, instantiateInstallPlan is responsible for filling in the missing, instantiated packages which we need to compile. Signed-off-by: Edward Z. Yang --- .../Distribution/Client/InstallPlan.hs | 35 ++ .../Distribution/Client/ProjectPlanning.hs | 409 +++++++++++++----- .../Client/ProjectPlanning/Types.hs | 131 ++++-- 3 files changed, 429 insertions(+), 146 deletions(-) diff --git a/cabal-install/Distribution/Client/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs index ff6fa0e1369..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 diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 468631767ed..ce3813d8345 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,7 +114,12 @@ 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 @@ -119,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 @@ -313,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 @@ -548,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 @@ -567,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 @@ -1016,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 @@ -1026,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 @@ -1035,8 +1056,9 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB defaultInstallDirs _sharedPackageConfig localPackagesConfig - perPackageConfig = - (elaboratedInstallPlan, elaboratedSharedConfig) + perPackageConfig = do + x <- elaboratedInstallPlan + return (x, elaboratedSharedConfig) where elaboratedSharedConfig = ElaboratedSharedConfig { @@ -1046,71 +1068,122 @@ 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 toComponentsGraph - elabEnabledSpec - elabPkgDescription 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 lookup_uid (UnitId sub_cid Nothing) = FullUnitId sub_cid Map.empty + -- TODO: This case CAN happen if we have pre-existing + -- instantiated things. Fix eventually. + lookup_uid 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 = newSimpleUnitId 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) @@ -1118,7 +1191,7 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB hashedInstalledPackageId (packageHashInputs elaboratedSharedConfig - elab) -- knot tied + elab1) -- knot tied cname = Cabal.componentName comp requires_reg = case cname of @@ -1127,73 +1200,37 @@ 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 + pkgid (newSimpleUnitId cid) (compilerInfo compiler) InstallDirs.NoCopyDest @@ -1211,9 +1248,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, (IndefUnitId, ModuleShape)) + mkShapeMapping dpkg = + (componentId dpkg, (indef_uid, shape)) + where + shape = planPkgShape dpkg + indef_uid = + IndefFullUnitId (unitIdComponentId (installedUnitId dpkg)) + (Map.fromList [ (req, IndefModuleVar 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 @@ -1221,6 +1289,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 @@ -1274,6 +1346,7 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon mapDep pkg elab = elab0 { elabUnitId = newSimpleUnitId pkgInstalledId, + elabLinkedInstantiatedWith = Map.empty, elabInstallDirs = install_dirs, elabRequiresRegistration = requires_reg, elabPkgOrComp = ElabPackage $ ElaboratedPackage {..} @@ -1346,9 +1419,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, _) = @@ -1604,6 +1680,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 UnitId + 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 (uid, Map.insert uid r s') + Just _ -> (uid, s) + where + -- The hashModuleSubst 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. + uid = UnitId cid (hashModuleSubst insts) + + 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 (deps ++ concatMap getDep (Map.elems insts)) + } + } + _ -> return planpkg + | otherwise = error ("instantiateComponent: " ++ display cid) + + substUnitId :: Map ModuleName Module -> IndefUnitId -> InstM UnitId + substUnitId _ (IndefUnitId 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 IndefModule + -> InstM (Map ModuleName Module) + substSubst subst insts = T.mapM (substModule subst) insts + + substModule :: Map ModuleName Module -> IndefModule -> InstM Module + substModule subst (IndefModuleVar mod_name) + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" + substModule subst (IndefModule 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)) + _ -> instantiateUnitId (unitIdComponentId (nodeKey pkg)) Map.empty + --------------------------- -- Build targets -- @@ -1703,6 +1881,7 @@ elabBuildTargetWholeComponents elab = [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ] + ------------------------------------------------------------------------------ -- * Install plan pruning ------------------------------------------------------------------------------ @@ -1968,15 +2147,15 @@ pruneInstallPlanPass2 pkgs = hasReverseLibDeps :: Set UnitId hasReverseLibDeps = - Set.fromList [ newSimpleUnitId (confInstId depid) + Set.fromList [ depid | InstallPlan.Configured pkg <- pkgs - , depid <- elabLibDependencies pkg ] + , depid <- elabOrderLibDependencies pkg ] hasReverseExeDeps :: Set UnitId hasReverseExeDeps = - Set.fromList [ newSimpleUnitId depid + Set.fromList [ depid | InstallPlan.Configured pkg <- pkgs - , depid <- elabExeDependencies pkg ] + , depid <- elabOrderExeDependencies pkg ] mapConfiguredPackage :: (srcpkg -> srcpkg') -> InstallPlan.GenericPlanPackage ipkg srcpkg @@ -2355,7 +2534,7 @@ setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) configCabalFilePath = mempty configVerbosity = toFlag verbosity - configInstantiateWith = [] --TODO in later patches + configInstantiateWith = Map.toList elabInstantiatedWith configIPID = case elabPkgOrComp of ElabPackage pkg -> toFlag (display (pkgInstalledId pkg)) diff --git a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs index 8fbb6fb2572..616cb2b8e4d 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 IndefModule, + -- | 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 :: [IndefUnitId], + -- | 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 (newSimpleUnitId . confInstId) (compLibDependencies comp) - ++ map newSimpleUnitId (compExeDependencies comp) - ++ map (newSimpleUnitId . 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,6 +461,8 @@ 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 (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend` From 95710677f94895b77000cca712add16a091b7381 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 21:46:33 -0700 Subject: [PATCH 36/46] cabal-install changelog update for Backpack. Signed-off-by: Edward Z. Yang --- cabal-install/changelog | 3 +++ 1 file changed, 3 insertions(+) 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 From 1be2b2132c8e8ee5df581e00ecb5f1cd7ecb580b Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 21:47:28 -0700 Subject: [PATCH 37/46] Tests for cabal-install's Backpack support. Signed-off-by: Edward Z. Yang --- cabal-install/cabal-install.cabal | 24 +++++++++++ .../backpack/includes2-external.sh | 9 ++++ .../backpack/includes2-internal.sh | 9 ++++ .../backpack/includes2/Includes2.cabal | 41 +++++++++++++++++++ .../backpack/includes2/cabal.project.external | 1 + .../backpack/includes2/cabal.project.internal | 1 + .../backpack/includes2/exe/Main.hs | 3 ++ .../backpack/includes2/exe/exe.cabal | 12 ++++++ .../backpack/includes2/mylib/Database.hsig | 3 ++ .../backpack/includes2/mylib/Mine.hs | 4 ++ .../backpack/includes2/mylib/mylib.cabal | 13 ++++++ .../includes2/mysql/Database/MySQL.hs | 3 ++ .../backpack/includes2/mysql/mysql.cabal | 12 ++++++ .../postgresql/Database/PostgreSQL.hs | 3 ++ .../includes2/postgresql/postgresql.cabal | 12 ++++++ .../backpack/includes2/src/App.hs | 7 ++++ .../backpack/includes2/src/src.cabal | 15 +++++++ .../backpack/includes3-external.sh | 9 ++++ .../backpack/includes3-internal.sh | 9 ++++ .../backpack/includes3/Includes3.cabal | 23 +++++++++++ .../backpack/includes3/cabal.project.external | 1 + .../backpack/includes3/cabal.project.internal | 1 + .../backpack/includes3/exe/Main.hs | 4 ++ .../backpack/includes3/exe/Setup.hs | 2 + .../backpack/includes3/exe/exe.cabal | 12 ++++++ .../backpack/includes3/indef/Foo.hs | 6 +++ .../backpack/includes3/indef/Setup.hs | 2 + .../backpack/includes3/indef/indef.cabal | 11 +++++ .../backpack/includes3/sigs/Data/Map.hsig | 5 +++ .../backpack/includes3/sigs/Setup.hs | 2 + .../backpack/includes3/sigs/sigs.cabal | 11 +++++ 31 files changed, 270 insertions(+) create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2-external.sh create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2-internal.sh create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/Includes2.cabal create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.external create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.internal create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/exe/Main.hs create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/exe/exe.cabal create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Database.hsig create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Mine.hs create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/mylib/mylib.cabal create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/mysql/Database/MySQL.hs create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/mysql/mysql.cabal create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/Database/PostgreSQL.hs create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/postgresql.cabal create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/src/App.hs create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes2/src/src.cabal create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3-external.sh create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3-internal.sh create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3/Includes3.cabal create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.external create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.internal create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3/exe/Main.hs create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3/exe/Setup.hs create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3/exe/exe.cabal create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3/indef/Foo.hs create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3/indef/Setup.hs create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3/indef/indef.cabal create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Data/Map.hsig create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Setup.hs create mode 100644 cabal-install/tests/IntegrationTests/backpack/includes3/sigs/sigs.cabal 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/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 From fd89315629f72fb966b190b16a4b7ea91db45364 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sat, 1 Oct 2016 04:05:29 -0700 Subject: [PATCH 38/46] Rename IndefUnitId constructor to DefiniteUnitId Signed-off-by: Edward Z. Yang --- Cabal/Distribution/Backpack.hs | 12 ++++++------ Cabal/Distribution/Backpack/Configure.hs | 6 +++--- Cabal/Distribution/Backpack/FullUnitId.hs | 2 +- Cabal/Distribution/Backpack/ModuleShape.hs | 8 ++++++-- Cabal/Distribution/Backpack/ReadyComponent.hs | 2 +- Cabal/Distribution/Backpack/UnifyM.hs | 4 ++-- Cabal/Distribution/Simple/Build.hs | 2 +- cabal-install/Distribution/Client/ProjectPlanning.hs | 2 +- cabal-install/Distribution/Client/SetupWrapper.hs | 2 +- 9 files changed, 22 insertions(+), 18 deletions(-) diff --git a/Cabal/Distribution/Backpack.hs b/Cabal/Distribution/Backpack.hs index e000ed8c66a..f8c87eceaa1 100644 --- a/Cabal/Distribution/Backpack.hs +++ b/Cabal/Distribution/Backpack.hs @@ -85,7 +85,7 @@ data IndefUnitId -- been compiled and abbreviated as a hash. The embedded 'UnitId' -- MUST NOT be for an indefinite component; an 'IndefUnitId' -- is guaranteed not to have any holes. - | IndefUnitId UnitId + | DefiniteUnitId UnitId deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) -- TODO: cache holes? @@ -93,7 +93,7 @@ instance Binary IndefUnitId instance NFData IndefUnitId where rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst - rnf (IndefUnitId uid) = rnf uid + rnf (DefiniteUnitId uid) = rnf uid instance Text IndefUnitId where disp (IndefFullUnitId cid insts) @@ -101,8 +101,8 @@ instance Text IndefUnitId where -- better | Map.null insts = disp cid | otherwise = disp cid <<>> Disp.brackets (dispIndefModuleSubst insts) - disp (IndefUnitId uid) = disp uid - parse = parseIndefUnitId <++ fmap IndefUnitId parse + disp (DefiniteUnitId uid) = disp uid + parse = parseIndefUnitId <++ fmap DefiniteUnitId parse where parseIndefUnitId = do cid <- parse @@ -113,7 +113,7 @@ instance Text IndefUnitId where -- | Get the 'ComponentId' of an 'IndefUnitId'. indefUnitIdComponentId :: IndefUnitId -> ComponentId indefUnitIdComponentId (IndefFullUnitId cid _) = cid -indefUnitIdComponentId (IndefUnitId uid) = unitIdComponentId uid +indefUnitIdComponentId (DefiniteUnitId uid) = unitIdComponentId uid -- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'. indefUnitIdFreeHoles :: IndefUnitId -> Set ModuleName @@ -208,7 +208,7 @@ indefModuleSubstFreeHoles insts = Set.unions (map indefModuleFreeHoles (Map.elem -- 'IndefFullUnitId' be compiled; instead, we just depend on the -- installed indefinite unit installed at the 'ComponentId'. abstractUnitId :: IndefUnitId -> UnitId -abstractUnitId (IndefUnitId uid) = uid +abstractUnitId (DefiniteUnitId uid) = uid abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid -- | Take a module substitution and hash it into a string suitable for diff --git a/Cabal/Distribution/Backpack/Configure.hs b/Cabal/Distribution/Backpack/Configure.hs index e6d96cf7762..f0b24953eb5 100644 --- a/Cabal/Distribution/Backpack/Configure.hs +++ b/Cabal/Distribution/Backpack/Configure.hs @@ -248,7 +248,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs = Installed.ExposedModule modname' Nothing | otherwise = Installed.ExposedModule modname' - (Just (IndefModule (IndefUnitId uid) modname)) + (Just (IndefModule (DefiniteUnitId uid) modname)) convIndefModuleExport (modname', modu@(IndefModule 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 @@ -270,7 +270,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs insts = case rc_i rc of Left indefc -> [ (m, IndefModuleVar m) | m <- indefc_requires indefc ] - Right instc -> [ (m, IndefModule (IndefUnitId uid') m') + Right instc -> [ (m, IndefModule (DefiniteUnitId uid') m') | (m, Module uid' m') <- instc_insts instc ] in LibComponentLocalBuildInfo { componentPackageDeps = cpds, @@ -327,7 +327,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs Left indefc -> indefc_includes indefc Right instc -> - map (\(x,y) -> (IndefUnitId x,y)) (instc_includes instc) + map (\(x,y) -> (DefiniteUnitId x,y)) (instc_includes instc) internal_deps = filter isInternal (nodeNeighbors rc) ++ rc_internal_build_tools rc diff --git a/Cabal/Distribution/Backpack/FullUnitId.hs b/Cabal/Distribution/Backpack/FullUnitId.hs index 839b0897e24..268092a2ea2 100644 --- a/Cabal/Distribution/Backpack/FullUnitId.hs +++ b/Cabal/Distribution/Backpack/FullUnitId.hs @@ -19,7 +19,7 @@ type FullDb = UnitId -> FullUnitId expandIndefUnitId :: FullDb -> IndefUnitId -> FullUnitId expandIndefUnitId _db (IndefFullUnitId cid subst) = FullUnitId cid subst -expandIndefUnitId db (IndefUnitId uid) +expandIndefUnitId db (DefiniteUnitId uid) = expandUnitId db uid expandUnitId :: FullDb -> UnitId -> FullUnitId diff --git a/Cabal/Distribution/Backpack/ModuleShape.hs b/Cabal/Distribution/Backpack/ModuleShape.hs index 9d9c56e935b..a0234b40e7d 100644 --- a/Cabal/Distribution/Backpack/ModuleShape.hs +++ b/Cabal/Distribution/Backpack/ModuleShape.hs @@ -74,10 +74,14 @@ emptyModuleShape = ModuleShape Map.empty Set.empty shapeInstalledPackage :: IPI.InstalledPackageInfo -> ModuleShape shapeInstalledPackage ipi = ModuleShape (Map.fromList provs) reqs where - uid = IPI.installedUnitId ipi + insts = Map.fromList (IPI.instantiatedWith ipi) + uid = + if Set.null (indefModuleSubstFreeHoles insts) + then DefiniteUnitId (IPI.installedUnitId ipi) + else IndefFullUnitId (IPI.installedComponentId ipi) insts provs = map shapeExposedModule (IPI.exposedModules ipi) reqs = indefModuleSubstFreeHoles (Map.fromList (IPI.instantiatedWith ipi)) shapeExposedModule (IPI.ExposedModule mod_name Nothing) - = (mod_name, IndefModule (IndefUnitId uid) mod_name) + = (mod_name, IndefModule uid mod_name) shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) = (mod_name, mod) diff --git a/Cabal/Distribution/Backpack/ReadyComponent.hs b/Cabal/Distribution/Backpack/ReadyComponent.hs index e26038d6cf8..115a70ce964 100644 --- a/Cabal/Distribution/Backpack/ReadyComponent.hs +++ b/Cabal/Distribution/Backpack/ReadyComponent.hs @@ -222,7 +222,7 @@ toReadyComponents pid_map subst0 comps | otherwise = return Nothing substUnitId :: Map ModuleName Module -> IndefUnitId -> InstM UnitId - substUnitId _ (IndefUnitId uid) = + substUnitId _ (DefiniteUnitId uid) = return uid substUnitId subst (IndefFullUnitId cid insts) = do insts' <- substSubst subst insts diff --git a/Cabal/Distribution/Backpack/UnifyM.hs b/Cabal/Distribution/Backpack/UnifyM.hs index 402b6a0851b..6d5aed33aee 100644 --- a/Cabal/Distribution/Backpack/UnifyM.hs +++ b/Cabal/Distribution/Backpack/UnifyM.hs @@ -237,7 +237,7 @@ convertUnitId' :: MuEnv s -> UnifyM s (UnitIdU s) -- TODO: this could be more lazy if we know there are no internal -- references -convertUnitId' _ (IndefUnitId uid) = +convertUnitId' _ (DefiniteUnitId uid) = liftST $ UnionFind.fresh (UnitIdThunkU uid) convertUnitId' stk (IndefFullUnitId cid insts) = do fs <- fmap unify_uniq getUnifEnv @@ -314,7 +314,7 @@ convertUnitIdU' :: MooEnv -> UnitIdU s -> UnifyM s IndefUnitId convertUnitIdU' stk uid_u = do x <- liftST $ UnionFind.find uid_u case x of - UnitIdThunkU uid -> return (IndefUnitId uid) + UnitIdThunkU uid -> return (DefiniteUnitId uid) UnitIdU u cid insts_u -> case lookupMooEnv stk u of Just _i -> error "convertUnitIdU': mutual recursion" -- return (UnitIdVar i) diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index dc62f0abd21..18cadf53918 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -474,7 +474,7 @@ testSuiteLibV09AsLibAndExe pkg_descr componentExeDeps = [], componentLocalName = CExeName (stubName test), componentPackageDeps = deps, - componentIncludes = zip (map (IndefUnitId . fst) deps) (repeat defaultRenaming) + componentIncludes = zip (map (DefiniteUnitId . fst) deps) (repeat defaultRenaming) } testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index ce3813d8345..2867d435908 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -1732,7 +1732,7 @@ instantiateInstallPlan plan = | otherwise = error ("instantiateComponent: " ++ display cid) substUnitId :: Map ModuleName Module -> IndefUnitId -> InstM UnitId - substUnitId _ (IndefUnitId uid) = + substUnitId _ (DefiniteUnitId uid) = return uid substUnitId subst (IndefFullUnitId cid insts) = do insts' <- substSubst subst insts diff --git a/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal-install/Distribution/Client/SetupWrapper.hs index cb5750104ac..525e97529c0 100644 --- a/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/Distribution/Client/SetupWrapper.hs @@ -819,7 +819,7 @@ getExternalSetupMethod verbosity options pkg bt = do then [] else cabalDep addRenaming (ipid, _) = - (Backpack.IndefUnitId (newSimpleUnitId ipid), defaultRenaming) + (Backpack.DefiniteUnitId (newSimpleUnitId ipid), defaultRenaming) cppMacrosFile = setupDir "setup_macros.h" ghcOptions = mempty { -- Respect -v0, but don't crank up verbosity on GHC if From 42364776044e36fb4e85a1dba64a5475ebefd815 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sun, 2 Oct 2016 00:12:04 -0700 Subject: [PATCH 39/46] Add some more Backpack utility functions to InstalledPackageInfo. Signed-off-by: Edward Z. Yang --- Cabal/Distribution/Backpack/ModuleShape.hs | 8 ++---- Cabal/Distribution/InstalledPackageInfo.hs | 29 ++++++++++++++++++++++ 2 files changed, 31 insertions(+), 6 deletions(-) diff --git a/Cabal/Distribution/Backpack/ModuleShape.hs b/Cabal/Distribution/Backpack/ModuleShape.hs index a0234b40e7d..4a72fc4dbbe 100644 --- a/Cabal/Distribution/Backpack/ModuleShape.hs +++ b/Cabal/Distribution/Backpack/ModuleShape.hs @@ -74,13 +74,9 @@ emptyModuleShape = ModuleShape Map.empty Set.empty shapeInstalledPackage :: IPI.InstalledPackageInfo -> ModuleShape shapeInstalledPackage ipi = ModuleShape (Map.fromList provs) reqs where - insts = Map.fromList (IPI.instantiatedWith ipi) - uid = - if Set.null (indefModuleSubstFreeHoles insts) - then DefiniteUnitId (IPI.installedUnitId ipi) - else IndefFullUnitId (IPI.installedComponentId ipi) insts + uid = installedIndefUnitId ipi provs = map shapeExposedModule (IPI.exposedModules ipi) - reqs = indefModuleSubstFreeHoles (Map.fromList (IPI.instantiatedWith ipi)) + reqs = requiredSignatures ipi shapeExposedModule (IPI.ExposedModule mod_name Nothing) = (mod_name, IndefModule uid mod_name) shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) diff --git a/Cabal/Distribution/InstalledPackageInfo.hs b/Cabal/Distribution/InstalledPackageInfo.hs index fb7bcaf56f0..73bde5b641f 100644 --- a/Cabal/Distribution/InstalledPackageInfo.hs +++ b/Cabal/Distribution/InstalledPackageInfo.hs @@ -31,6 +31,9 @@ module Distribution.InstalledPackageInfo ( InstalledPackageInfo(..), installedComponentId, installedPackageId, + indefinite, + requiredSignatures, + installedIndefUnitId, ExposedModule(..), ParseResult(..), PError(..), PWarning, emptyInstalledPackageInfo, @@ -58,6 +61,8 @@ import Distribution.Compat.Graph import Text.PrettyPrint as Disp import qualified Data.Char as Char import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Set (Set) -- ----------------------------------------------------------------------------- -- The InstalledPackageInfo type @@ -114,6 +119,30 @@ data InstalledPackageInfo } deriving (Eq, Generic, Read, Show) +-- | Returns 'True' if this is an interface-file only indefinite +-- package which has not been instantiated. +indefinite :: InstalledPackageInfo -> Bool +indefinite ipi = + -- TODO: optimize a little + Set.null (indefModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi))) + +-- | 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 @IndefUnitId@ with the appropriate 'IndefModuleSubst'. +installedIndefUnitId :: InstalledPackageInfo -> IndefUnitId +installedIndefUnitId ipi = + if indefinite ipi + then IndefFullUnitId (installedComponentId ipi) + (Map.fromList (instantiatedWith ipi)) + else DefiniteUnitId (installedUnitId 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 = indefModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi)) + installedComponentId :: InstalledPackageInfo -> ComponentId installedComponentId ipi = unitIdComponentId (installedUnitId ipi) From 62ddf8e0882481261320a26561e649210cfd683b Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sun, 2 Oct 2016 00:39:53 -0700 Subject: [PATCH 40/46] Rename IndefUnitId to OpenUnitId. Signed-off-by: Edward Z. Yang --- Cabal/Distribution/Backpack.hs | 56 +++++++++---------- Cabal/Distribution/Backpack/Configure.hs | 4 +- Cabal/Distribution/Backpack/FullUnitId.hs | 10 ++-- .../Distribution/Backpack/LinkedComponent.hs | 26 ++++----- Cabal/Distribution/Backpack/ModSubst.hs | 2 +- Cabal/Distribution/Backpack/ModuleShape.hs | 2 +- .../Backpack/PreExistingComponent.hs | 4 +- Cabal/Distribution/Backpack/ReadyComponent.hs | 4 +- Cabal/Distribution/Backpack/UnifyM.hs | 10 ++-- Cabal/Distribution/InstalledPackageInfo.hs | 12 ++-- Cabal/Distribution/Package.hs | 6 +- Cabal/Distribution/Simple/GHC/Internal.hs | 2 +- Cabal/Distribution/Simple/Program/GHC.hs | 2 +- .../Types/ComponentLocalBuildInfo.hs | 8 +-- .../Distribution/Client/ProjectPlanning.hs | 4 +- .../Client/ProjectPlanning/Types.hs | 2 +- 16 files changed, 77 insertions(+), 77 deletions(-) diff --git a/Cabal/Distribution/Backpack.hs b/Cabal/Distribution/Backpack.hs index f8c87eceaa1..73cbc25678c 100644 --- a/Cabal/Distribution/Backpack.hs +++ b/Cabal/Distribution/Backpack.hs @@ -10,10 +10,10 @@ -- module Distribution.Backpack ( - -- * IndefUnitId - IndefUnitId(..), - indefUnitIdComponentId, - indefUnitIdFreeHoles, + -- * OpenUnitId + OpenUnitId(..), + openUnitIdComponentId, + openUnitIdFreeHoles, -- * IndefModule IndefModule(..), @@ -49,33 +49,33 @@ import Data.Set (Set) import qualified Data.Set as Set ----------------------------------------------------------------------- --- IndefUnitId +-- OpenUnitId --- | An 'IndefUnitId' describes a (possibly partially) instantiated +-- | An 'OpenUnitId' describes a (possibly partially) instantiated -- Backpack component, with a description of how the holes are filled --- in. Unlike 'IndefUnitId', the 'ModuleSubst' is kept in a structured +-- 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 'IndefUnitId uid'. +-- 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. -- --- IndefUnitId plays an important role when we are mix-in linking, +-- 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 'IndefUnitId' into 'UnitId'. +-- we instantiate 'OpenUnitId' into 'UnitId'. -- -- For more details see the Backpack spec -- -- -data IndefUnitId +data OpenUnitId -- | Identifies a component which may have some unfilled holes; -- specifying its 'ComponentId' and its 'IndefModuleSubst'. -- TODO: Invariant that 'IndefModuleSubst' is non-empty? @@ -83,42 +83,42 @@ data IndefUnitId = IndefFullUnitId ComponentId IndefModuleSubst -- | 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 'IndefUnitId' + -- MUST NOT be for an indefinite component; an 'OpenUnitId' -- is guaranteed not to have any holes. | DefiniteUnitId UnitId deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) -- TODO: cache holes? -instance Binary IndefUnitId +instance Binary OpenUnitId -instance NFData IndefUnitId where +instance NFData OpenUnitId where rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst rnf (DefiniteUnitId uid) = rnf uid -instance Text IndefUnitId where +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 (dispIndefModuleSubst insts) disp (DefiniteUnitId uid) = disp uid - parse = parseIndefUnitId <++ fmap DefiniteUnitId parse + parse = parseOpenUnitId <++ fmap DefiniteUnitId parse where - parseIndefUnitId = do + parseOpenUnitId = do cid <- parse insts <- Parse.between (Parse.char '[') (Parse.char ']') parseIndefModuleSubst return (IndefFullUnitId cid insts) --- | Get the 'ComponentId' of an 'IndefUnitId'. -indefUnitIdComponentId :: IndefUnitId -> ComponentId -indefUnitIdComponentId (IndefFullUnitId cid _) = cid -indefUnitIdComponentId (DefiniteUnitId uid) = unitIdComponentId uid +-- | Get the 'ComponentId' of an 'OpenUnitId'. +openUnitIdComponentId :: OpenUnitId -> ComponentId +openUnitIdComponentId (IndefFullUnitId cid _) = cid +openUnitIdComponentId (DefiniteUnitId uid) = unitIdComponentId uid -- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'. -indefUnitIdFreeHoles :: IndefUnitId -> Set ModuleName -indefUnitIdFreeHoles (IndefFullUnitId _ insts) = indefModuleSubstFreeHoles insts -indefUnitIdFreeHoles _ = Set.empty +openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName +openUnitIdFreeHoles (IndefFullUnitId _ insts) = indefModuleSubstFreeHoles insts +openUnitIdFreeHoles _ = Set.empty ----------------------------------------------------------------------- -- IndefModule @@ -128,7 +128,7 @@ indefUnitIdFreeHoles _ = Set.empty -- hole that needs to be filled in. Substitutions are over -- module variables. data IndefModule - = IndefModule IndefUnitId ModuleName + = IndefModule OpenUnitId ModuleName | IndefModuleVar ModuleName deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) @@ -159,7 +159,7 @@ instance Text IndefModule where -- | Get the set of holes ('ModuleVar') embedded in a 'Module'. indefModuleFreeHoles :: IndefModule -> Set ModuleName indefModuleFreeHoles (IndefModuleVar mod_name) = Set.singleton mod_name -indefModuleFreeHoles (IndefModule uid _n) = indefUnitIdFreeHoles uid +indefModuleFreeHoles (IndefModule uid _n) = openUnitIdFreeHoles uid ----------------------------------------------------------------------- -- IndefModuleSubst @@ -171,7 +171,7 @@ indefModuleFreeHoles (IndefModule uid _n) = indefUnitIdFreeHoles uid type IndefModuleSubst = Map ModuleName IndefModule -- | Pretty-print the entries of a module substitution, suitable --- for embedding into a 'IndefUnitId' or passing to GHC via @--instantiate-with@. +-- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@. dispIndefModuleSubst :: IndefModuleSubst -> Disp.Doc dispIndefModuleSubst subst = Disp.hcat @@ -207,7 +207,7 @@ indefModuleSubstFreeHoles insts = Set.unions (map indefModuleFreeHoles (Map.elem -- | 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 :: IndefUnitId -> UnitId +abstractUnitId :: OpenUnitId -> UnitId abstractUnitId (DefiniteUnitId uid) = uid abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid diff --git a/Cabal/Distribution/Backpack/Configure.hs b/Cabal/Distribution/Backpack/Configure.hs index f0b24953eb5..94e9ea0bb3d 100644 --- a/Cabal/Distribution/Backpack/Configure.hs +++ b/Cabal/Distribution/Backpack/Configure.hs @@ -91,7 +91,7 @@ configureComponentLocalBuildInfos (vcat (map dispConfiguredComponent graph1)) let shape_pkg_map = Map.fromList - [ (pc_cid pkg, (pc_indef_uid pkg, pc_shape pkg)) + [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg)) | pkg <- prePkgDeps] uid_lookup uid | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid @@ -253,7 +253,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs -- 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.) - | indefUnitIdComponentId uid == this_cid + | openUnitIdComponentId uid == this_cid , modname' == modname = Installed.ExposedModule modname' Nothing | otherwise diff --git a/Cabal/Distribution/Backpack/FullUnitId.hs b/Cabal/Distribution/Backpack/FullUnitId.hs index 268092a2ea2..78645ddeb98 100644 --- a/Cabal/Distribution/Backpack/FullUnitId.hs +++ b/Cabal/Distribution/Backpack/FullUnitId.hs @@ -2,7 +2,7 @@ module Distribution.Backpack.FullUnitId ( FullUnitId(..), FullDb, - expandIndefUnitId, + expandOpenUnitId, expandUnitId ) where @@ -10,16 +10,16 @@ import Distribution.Backpack import Distribution.Package import Distribution.Compat.Prelude --- Unlike IndefUnitId, which could direct to a UnitId. +-- Unlike OpenUnitId, which could direct to a UnitId. data FullUnitId = FullUnitId ComponentId IndefModuleSubst deriving (Show, Generic) type FullDb = UnitId -> FullUnitId -expandIndefUnitId :: FullDb -> IndefUnitId -> FullUnitId -expandIndefUnitId _db (IndefFullUnitId cid subst) +expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId +expandOpenUnitId _db (IndefFullUnitId cid subst) = FullUnitId cid subst -expandIndefUnitId db (DefiniteUnitId uid) +expandOpenUnitId db (DefiniteUnitId uid) = expandUnitId db uid expandUnitId :: FullDb -> UnitId -> FullUnitId diff --git a/Cabal/Distribution/Backpack/LinkedComponent.hs b/Cabal/Distribution/Backpack/LinkedComponent.hs index 02f6363b435..27035782734 100644 --- a/Cabal/Distribution/Backpack/LinkedComponent.hs +++ b/Cabal/Distribution/Backpack/LinkedComponent.hs @@ -46,22 +46,22 @@ import Text.PrettyPrint -- going to build it. data LinkedComponent = LinkedComponent { - lc_uid :: IndefUnitId, + lc_uid :: OpenUnitId, lc_pkgid :: PackageId, lc_insts :: [(ModuleName, IndefModule)], lc_component :: Component, lc_shape :: ModuleShape, -- | Local buildTools dependencies - lc_internal_build_tools :: [IndefUnitId], + lc_internal_build_tools :: [OpenUnitId], lc_public :: Bool, - lc_includes :: [(IndefUnitId, ModuleRenaming)], + lc_includes :: [(OpenUnitId, ModuleRenaming)], -- PackageId here is a bit dodgy, but its just for -- BC so it shouldn't matter. - lc_depends :: [(IndefUnitId, PackageId)] + lc_depends :: [(OpenUnitId, PackageId)] } lc_cid :: LinkedComponent -> ComponentId -lc_cid = indefUnitIdComponentId . lc_uid +lc_cid = openUnitIdComponentId . lc_uid dispLinkedComponent :: LinkedComponent -> Doc dispLinkedComponent lc = @@ -88,7 +88,7 @@ instance IsNode LinkedComponent where type Key LinkedComponent = UnitId nodeKey = lc_uid nodeNeighbors n = - if Set.null (indefUnitIdFreeHoles (lc_uid n)) + if Set.null (openUnitIdFreeHoles (lc_uid n)) then map fst (lc_depends n) else ordNub (map (generalizeUnitId . fst) (lc_depends n)) -} @@ -128,11 +128,11 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { -- 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 :: [((IndefUnitId, ModuleShape), PackageId, IncludeRenaming)] + unlinked_includes :: [((OpenUnitId, ModuleShape), PackageId, IncludeRenaming)] unlinked_includes = [ (lookupUid cid, pid, rns) | (cid, pid, rns) <- cid_includes ] - lookupUid :: ComponentId -> (IndefUnitId, ModuleShape) + lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) lookupUid cid = fromMaybe (error "linkComponent: lookupUid") (Map.lookup cid pkg_map) @@ -143,8 +143,8 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { -- TODO: the unification monad might return errors, in which -- case we have to deal. Use monadic bind for now. (linked_shape0 :: ModuleScope, - linked_deps :: [(IndefUnitId, PackageId)], - linked_includes :: [(IndefUnitId, ModuleRenaming)]) <- orErr $ runUnifyM verbosity db $ do + 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. @@ -261,14 +261,14 @@ toLinkedComponents toLinkedComponents verbosity db this_pid lc_map0 comps = fmap snd (mapAccumM go lc_map0 comps) where - go :: Map ComponentId (IndefUnitId, ModuleShape) + go :: Map ComponentId (OpenUnitId, ModuleShape) -> ConfiguredComponent - -> LogProgress (Map ComponentId (IndefUnitId, ModuleShape), LinkedComponent) + -> 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 (IndefUnitId, ModuleShape) +type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) extendLinkedComponentMap :: LinkedComponent -> LinkedComponentMap diff --git a/Cabal/Distribution/Backpack/ModSubst.hs b/Cabal/Distribution/Backpack/ModSubst.hs index 47cc44aee6b..4ac3522298f 100644 --- a/Cabal/Distribution/Backpack/ModSubst.hs +++ b/Cabal/Distribution/Backpack/ModSubst.hs @@ -35,7 +35,7 @@ instance ModSubst IndefModule where | Just mod' <- Map.lookup mod_name subst = mod' | otherwise = mod -instance ModSubst IndefUnitId where +instance ModSubst OpenUnitId where modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts) modSubst _subst uid = uid diff --git a/Cabal/Distribution/Backpack/ModuleShape.hs b/Cabal/Distribution/Backpack/ModuleShape.hs index 4a72fc4dbbe..e94cc55baed 100644 --- a/Cabal/Distribution/Backpack/ModuleShape.hs +++ b/Cabal/Distribution/Backpack/ModuleShape.hs @@ -74,7 +74,7 @@ emptyModuleShape = ModuleShape Map.empty Set.empty shapeInstalledPackage :: IPI.InstalledPackageInfo -> ModuleShape shapeInstalledPackage ipi = ModuleShape (Map.fromList provs) reqs where - uid = installedIndefUnitId ipi + uid = installedOpenUnitId ipi provs = map shapeExposedModule (IPI.exposedModules ipi) reqs = requiredSignatures ipi shapeExposedModule (IPI.ExposedModule mod_name Nothing) diff --git a/Cabal/Distribution/Backpack/PreExistingComponent.hs b/Cabal/Distribution/Backpack/PreExistingComponent.hs index ade3fcafb18..027dbbcbfcb 100644 --- a/Cabal/Distribution/Backpack/PreExistingComponent.hs +++ b/Cabal/Distribution/Backpack/PreExistingComponent.hs @@ -27,7 +27,7 @@ data PreExistingComponent pc_pkgname :: PackageName, pc_pkgid :: PackageId, pc_uid :: UnitId, - pc_indef_uid :: IndefUnitId, + pc_open_uid :: OpenUnitId, pc_shape :: ModuleShape } @@ -44,7 +44,7 @@ ipiToPreExistingComponent (pn, ipi) = pc_pkgname = pn, pc_pkgid = Installed.sourcePackageId ipi, pc_uid = Installed.installedUnitId ipi, - pc_indef_uid = + 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 index 115a70ce964..b482c6d7718 100644 --- a/Cabal/Distribution/Backpack/ReadyComponent.hs +++ b/Cabal/Distribution/Backpack/ReadyComponent.hs @@ -56,7 +56,7 @@ data IndefiniteComponent = IndefiniteComponent { indefc_requires :: [ModuleName], indefc_provides :: Map ModuleName IndefModule, - indefc_includes :: [(IndefUnitId, ModuleRenaming)] + indefc_includes :: [(OpenUnitId, ModuleRenaming)] } data ReadyComponent @@ -221,7 +221,7 @@ toReadyComponents pid_map subst0 comps } | otherwise = return Nothing - substUnitId :: Map ModuleName Module -> IndefUnitId -> InstM UnitId + substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM UnitId substUnitId _ (DefiniteUnitId uid) = return uid substUnitId subst (IndefFullUnitId cid insts) = do diff --git a/Cabal/Distribution/Backpack/UnifyM.hs b/Cabal/Distribution/Backpack/UnifyM.hs index 6d5aed33aee..1b1483477d2 100644 --- a/Cabal/Distribution/Backpack/UnifyM.hs +++ b/Cabal/Distribution/Backpack/UnifyM.hs @@ -233,7 +233,7 @@ emptyMuEnv = (IntMap.empty, -1) -- * @MuEnv@ - the environment for mu-binders. convertUnitId' :: MuEnv s - -> IndefUnitId + -> OpenUnitId -> UnifyM s (UnitIdU s) -- TODO: this could be more lazy if we know there are no internal -- references @@ -264,7 +264,7 @@ convertModule' stk (IndefModule uid mod_name) = do uid_u <- convertUnitId' stk uid liftST $ UnionFind.fresh (ModuleU uid_u mod_name) -convertUnitId :: IndefUnitId -> UnifyM s (UnitIdU s) +convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s) convertUnitId = convertUnitId' emptyMuEnv convertModule :: IndefModule -> UnifyM s (ModuleU s) @@ -310,7 +310,7 @@ lookupMooEnv (m, i) k = -- The workhorse functions -convertUnitIdU' :: MooEnv -> UnitIdU s -> UnifyM s IndefUnitId +convertUnitIdU' :: MooEnv -> UnitIdU s -> UnifyM s OpenUnitId convertUnitIdU' stk uid_u = do x <- liftST $ UnionFind.find uid_u case x of @@ -333,7 +333,7 @@ convertModuleU' stk mod_u = do -- Helper functions -convertUnitIdU :: UnitIdU s -> UnifyM s IndefUnitId +convertUnitIdU :: UnitIdU s -> UnifyM s OpenUnitId convertUnitIdU = convertUnitIdU' emptyMooEnv convertModuleU :: ModuleU s -> UnifyM s IndefModule @@ -361,7 +361,7 @@ data ModuleSourceU s = -- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do -- unification on it. convertInclude - :: ((IndefUnitId, ModuleShape), PackageId, IncludeRenaming) + :: ((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 diff --git a/Cabal/Distribution/InstalledPackageInfo.hs b/Cabal/Distribution/InstalledPackageInfo.hs index 73bde5b641f..9b78a99360a 100644 --- a/Cabal/Distribution/InstalledPackageInfo.hs +++ b/Cabal/Distribution/InstalledPackageInfo.hs @@ -33,7 +33,7 @@ module Distribution.InstalledPackageInfo ( installedPackageId, indefinite, requiredSignatures, - installedIndefUnitId, + installedOpenUnitId, ExposedModule(..), ParseResult(..), PError(..), PWarning, emptyInstalledPackageInfo, @@ -75,7 +75,7 @@ data InstalledPackageInfo sourcePackageId :: PackageId, installedUnitId :: UnitId, -- INVARIANT: if this package is definite, IndefModule's - -- IndefUnitId directly records UnitId. If it is + -- OpenUnitId directly records UnitId. If it is -- indefinite, IndefModule is always an IndefModuleVar -- with the same ModuleName as the key. instantiatedWith :: [(ModuleName, IndefModule)], @@ -94,7 +94,7 @@ data InstalledPackageInfo abiHash :: AbiHash, exposed :: Bool, -- INVARIANT: if the package is definite, IndefModule's - -- IndefUnitId directly records UnitId. + -- OpenUnitId directly records UnitId. exposedModules :: [ExposedModule], hiddenModules :: [ModuleName], trusted :: Bool, @@ -130,9 +130,9 @@ indefinite ipi = -- 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 @IndefUnitId@ with the appropriate 'IndefModuleSubst'. -installedIndefUnitId :: InstalledPackageInfo -> IndefUnitId -installedIndefUnitId ipi = +-- an @OpenUnitId@ with the appropriate 'IndefModuleSubst'. +installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId +installedOpenUnitId ipi = if indefinite ipi then IndefFullUnitId (installedComponentId ipi) (Map.fromList (instantiatedWith ipi)) diff --git a/Cabal/Distribution/Package.hs b/Cabal/Distribution/Package.hs index adcaed3ab62..ad1f61174e8 100644 --- a/Cabal/Distribution/Package.hs +++ b/Cabal/Distribution/Package.hs @@ -236,12 +236,12 @@ getHSLibraryName uid = "HS" ++ display uid -- holes, and each different combination is a unit (and has a separate -- 'UnitId'). -- --- 'UnitId' is distinct from 'IndefUnitId', in that it is always --- installed, whereas 'IndefUnitId' are intermediate unit identities +-- '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 'IndefUnitId'). See also +-- (but you can substitute over 'OpenUnitId'). See also -- "Distribution.Backpack.FullUnitId" for a mechanism for expanding an -- instantiated 'UnitId' to retrieve its mapping. -- diff --git a/Cabal/Distribution/Simple/GHC/Internal.hs b/Cabal/Distribution/Simple/GHC/Internal.hs index ba5d81d810f..df507e4d3ee 100644 --- a/Cabal/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/Distribution/Simple/GHC/Internal.hs @@ -381,7 +381,7 @@ getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs | x <- allLibModules lib clbi ] mkGhcOptPackages :: ComponentLocalBuildInfo - -> [(IndefUnitId, ModuleRenaming)] + -> [(OpenUnitId, ModuleRenaming)] mkGhcOptPackages = componentIncludes substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo diff --git a/Cabal/Distribution/Simple/Program/GHC.hs b/Cabal/Distribution/Simple/Program/GHC.hs index 65e763692e2..8b781caa338 100644 --- a/Cabal/Distribution/Simple/Program/GHC.hs +++ b/Cabal/Distribution/Simple/Program/GHC.hs @@ -94,7 +94,7 @@ data GhcOptions = GhcOptions { -- | The GHC packages to bring into scope when compiling, -- the @ghc -package-id@ flags. ghcOptPackages :: - NubListR (IndefUnitId, ModuleRenaming), + NubListR (OpenUnitId, ModuleRenaming), -- | Start with a clean package set; the @ghc -hide-all-packages@ flag ghcOptHideAllPackages :: Flag Bool, diff --git a/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs b/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs index 9c24a5eb404..e3c378d01ed 100644 --- a/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs +++ b/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs @@ -46,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 :: [(IndefUnitId, ModuleRenaming)], + componentIncludes :: [(OpenUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], -- | The internal dependencies which induce a graph on the -- 'ComponentLocalBuildInfo' of this package. This does NOT @@ -69,7 +69,7 @@ data ComponentLocalBuildInfo componentLocalName :: ComponentName, componentUnitId :: UnitId, componentPackageDeps :: [(UnitId, PackageId)], - componentIncludes :: [(IndefUnitId, ModuleRenaming)], + componentIncludes :: [(OpenUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] } @@ -77,7 +77,7 @@ data ComponentLocalBuildInfo componentLocalName :: ComponentName, componentUnitId :: UnitId, componentPackageDeps :: [(UnitId, PackageId)], - componentIncludes :: [(IndefUnitId, ModuleRenaming)], + componentIncludes :: [(OpenUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] @@ -86,7 +86,7 @@ data ComponentLocalBuildInfo componentLocalName :: ComponentName, componentUnitId :: UnitId, componentPackageDeps :: [(UnitId, PackageId)], - componentIncludes :: [(IndefUnitId, ModuleRenaming)], + componentIncludes :: [(OpenUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] } diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 2867d435908..cb07d4425fa 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -1262,7 +1262,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB (packageName dpkg, (componentId dpkg, packageId dpkg)) mkShapeMapping :: ElaboratedPlanPackage - -> (ComponentId, (IndefUnitId, ModuleShape)) + -> (ComponentId, (OpenUnitId, ModuleShape)) mkShapeMapping dpkg = (componentId dpkg, (indef_uid, shape)) where @@ -1731,7 +1731,7 @@ instantiateInstallPlan plan = _ -> return planpkg | otherwise = error ("instantiateComponent: " ++ display cid) - substUnitId :: Map ModuleName Module -> IndefUnitId -> InstM UnitId + substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM UnitId substUnitId _ (DefiniteUnitId uid) = return uid substUnitId subst (IndefFullUnitId cid insts) = do diff --git a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs index 616cb2b8e4d..ebc96032f1b 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs @@ -396,7 +396,7 @@ data ElaboratedComponent -- care about from the perspective of ORDERING builds. It's more -- precise than 'compLibDependencies', and also stores information -- about internal dependencies. - compLinkedLibDependencies :: [IndefUnitId], + compLinkedLibDependencies :: [OpenUnitId], -- | The executable dependencies of this component (including -- internal executables). compExeDependencies :: [ComponentId], From 2e42ca276b480eb88f7eae9b92bdd92ecacab111 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sun, 2 Oct 2016 13:33:01 -0700 Subject: [PATCH 41/46] Rename IndefModule to OpenModule. Signed-off-by: Edward Z. Yang --- Cabal/Distribution/Backpack.hs | 108 +++++++++--------- Cabal/Distribution/Backpack/Configure.hs | 14 +-- Cabal/Distribution/Backpack/FullUnitId.hs | 2 +- .../Distribution/Backpack/LinkedComponent.hs | 10 +- Cabal/Distribution/Backpack/ModSubst.hs | 10 +- Cabal/Distribution/Backpack/ModuleScope.hs | 2 +- Cabal/Distribution/Backpack/ModuleShape.hs | 4 +- Cabal/Distribution/Backpack/ReadyComponent.hs | 10 +- Cabal/Distribution/Backpack/UnifyM.hs | 24 ++-- Cabal/Distribution/InstalledPackageInfo.hs | 18 +-- Cabal/Distribution/Simple/PackageIndex.hs | 4 +- Cabal/Distribution/Simple/Program/GHC.hs | 2 +- .../Types/ComponentLocalBuildInfo.hs | 2 +- .../Distribution/Client/ProjectPlanning.hs | 10 +- .../Client/ProjectPlanning/Types.hs | 2 +- 15 files changed, 111 insertions(+), 111 deletions(-) diff --git a/Cabal/Distribution/Backpack.hs b/Cabal/Distribution/Backpack.hs index 73cbc25678c..0d5a1af04a5 100644 --- a/Cabal/Distribution/Backpack.hs +++ b/Cabal/Distribution/Backpack.hs @@ -15,17 +15,17 @@ module Distribution.Backpack ( openUnitIdComponentId, openUnitIdFreeHoles, - -- * IndefModule - IndefModule(..), - indefModuleFreeHoles, - - -- * IndefModuleSubst - IndefModuleSubst, - dispIndefModuleSubst, - dispIndefModuleSubstEntry, - parseIndefModuleSubst, - parseIndefModuleSubstEntry, - indefModuleSubstFreeHoles, + -- * OpenModule + OpenModule(..), + openModuleFreeHoles, + + -- * OpenModuleSubst + OpenModuleSubst, + dispOpenModuleSubst, + dispOpenModuleSubstEntry, + parseOpenModuleSubst, + parseOpenModuleSubstEntry, + openModuleSubstFreeHoles, -- * Conversions to 'UnitId' abstractUnitId, @@ -77,10 +77,10 @@ import qualified Data.Set as Set data OpenUnitId -- | Identifies a component which may have some unfilled holes; - -- specifying its 'ComponentId' and its 'IndefModuleSubst'. - -- TODO: Invariant that 'IndefModuleSubst' is non-empty? + -- specifying its 'ComponentId' and its 'OpenModuleSubst'. + -- TODO: Invariant that 'OpenModuleSubst' is non-empty? -- See also the Text instance. - = IndefFullUnitId ComponentId IndefModuleSubst + = 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' @@ -100,14 +100,14 @@ instance Text OpenUnitId where -- TODO: arguably a smart constructor to enforce invariant would be -- better | Map.null insts = disp cid - | otherwise = disp cid <<>> Disp.brackets (dispIndefModuleSubst insts) + | 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 ']') - parseIndefModuleSubst + parseOpenModuleSubst return (IndefFullUnitId cid insts) -- | Get the 'ComponentId' of an 'OpenUnitId'. @@ -117,89 +117,89 @@ openUnitIdComponentId (DefiniteUnitId uid) = unitIdComponentId uid -- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'. openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName -openUnitIdFreeHoles (IndefFullUnitId _ insts) = indefModuleSubstFreeHoles insts +openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts openUnitIdFreeHoles _ = Set.empty ----------------------------------------------------------------------- --- IndefModule +-- OpenModule --- | Unlike a 'Module', an 'IndefModule' is either an ordinary --- module from some unit, OR an 'IndefModuleVar', representing a +-- | 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 IndefModule - = IndefModule OpenUnitId ModuleName - | IndefModuleVar ModuleName +data OpenModule + = OpenModule OpenUnitId ModuleName + | OpenModuleVar ModuleName deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) -instance Binary IndefModule +instance Binary OpenModule -instance NFData IndefModule where - rnf (IndefModule uid mod_name) = rnf uid `seq` rnf mod_name - rnf (IndefModuleVar mod_name) = rnf mod_name +instance NFData OpenModule where + rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name + rnf (OpenModuleVar mod_name) = rnf mod_name -instance Text IndefModule where - disp (IndefModule uid mod_name) = +instance Text OpenModule where + disp (OpenModule uid mod_name) = hcat [disp uid, Disp.text ":", disp mod_name] - disp (IndefModuleVar mod_name) = + disp (OpenModuleVar mod_name) = hcat [Disp.char '<', disp mod_name, Disp.char '>'] - parse = parseModuleVar <++ parseIndefModule + parse = parseModuleVar <++ parseOpenModule where - parseIndefModule = do + parseOpenModule = do uid <- parse _ <- Parse.char ':' mod_name <- parse - return (IndefModule uid mod_name) + return (OpenModule uid mod_name) parseModuleVar = do _ <- Parse.char '<' mod_name <- parse _ <- Parse.char '>' - return (IndefModuleVar mod_name) + return (OpenModuleVar mod_name) -- | Get the set of holes ('ModuleVar') embedded in a 'Module'. -indefModuleFreeHoles :: IndefModule -> Set ModuleName -indefModuleFreeHoles (IndefModuleVar mod_name) = Set.singleton mod_name -indefModuleFreeHoles (IndefModule uid _n) = openUnitIdFreeHoles uid +openModuleFreeHoles :: OpenModule -> Set ModuleName +openModuleFreeHoles (OpenModuleVar mod_name) = Set.singleton mod_name +openModuleFreeHoles (OpenModule uid _n) = openUnitIdFreeHoles uid ----------------------------------------------------------------------- --- IndefModuleSubst +-- OpenModuleSubst -- | An explicit substitution on modules. -- -- NB: These substitutions are NOT idempotent, for example, a -- valid substitution is (A -> B, B -> A). -type IndefModuleSubst = Map ModuleName IndefModule +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@. -dispIndefModuleSubst :: IndefModuleSubst -> Disp.Doc -dispIndefModuleSubst subst +dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc +dispOpenModuleSubst subst = Disp.hcat . Disp.punctuate Disp.comma - $ map dispIndefModuleSubstEntry (Map.toAscList subst) + $ map dispOpenModuleSubstEntry (Map.toAscList subst) -- | Pretty-print a single entry of a module substitution. -dispIndefModuleSubstEntry :: (ModuleName, IndefModule) -> Disp.Doc -dispIndefModuleSubstEntry (k, v) = disp k <<>> Disp.char '=' <<>> disp v +dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Disp.Doc +dispOpenModuleSubstEntry (k, v) = disp k <<>> Disp.char '=' <<>> disp v -- | Inverse to 'dispModSubst'. -parseIndefModuleSubst :: ReadP r IndefModuleSubst -parseIndefModuleSubst = fmap Map.fromList +parseOpenModuleSubst :: ReadP r OpenModuleSubst +parseOpenModuleSubst = fmap Map.fromList . flip Parse.sepBy (Parse.char ',') - $ parseIndefModuleSubstEntry + $ parseOpenModuleSubstEntry -- | Inverse to 'dispModSubstEntry'. -parseIndefModuleSubstEntry :: ReadP r (ModuleName, IndefModule) -parseIndefModuleSubstEntry = +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 'IndefModuleSubst'. +-- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'. -- This is NOT the domain of the substitution. -indefModuleSubstFreeHoles :: IndefModuleSubst -> Set ModuleName -indefModuleSubstFreeHoles insts = Set.unions (map indefModuleFreeHoles (Map.elems insts)) +openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName +openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems insts)) ----------------------------------------------------------------------- -- Conversions to UnitId @@ -212,8 +212,8 @@ abstractUnitId (DefiniteUnitId uid) = 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 'IndefModule', --- you are responsible for recursively converting 'IndefModule' +-- '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 diff --git a/Cabal/Distribution/Backpack/Configure.hs b/Cabal/Distribution/Backpack/Configure.hs index 94e9ea0bb3d..3318534c7ba 100644 --- a/Cabal/Distribution/Backpack/Configure.hs +++ b/Cabal/Distribution/Backpack/Configure.hs @@ -248,8 +248,8 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs = Installed.ExposedModule modname' Nothing | otherwise = Installed.ExposedModule modname' - (Just (IndefModule (DefiniteUnitId uid) modname)) - convIndefModuleExport (modname', modu@(IndefModule uid 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.) @@ -258,19 +258,19 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs = Installed.ExposedModule modname' Nothing | otherwise = Installed.ExposedModule modname' (Just modu) - convIndefModuleExport (_, IndefModuleVar _) - = error "convIndefModuleExport: top-level modvar" + convOpenModuleExport (_, OpenModuleVar _) + = error "convOpenModuleExport: top-level modvar" exports = -- Loses invariants case rc_i rc of - Left indefc -> map convIndefModuleExport + 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, IndefModuleVar m) | m <- indefc_requires indefc ] - Right instc -> [ (m, IndefModule (DefiniteUnitId uid') m') + 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, diff --git a/Cabal/Distribution/Backpack/FullUnitId.hs b/Cabal/Distribution/Backpack/FullUnitId.hs index 78645ddeb98..15c7526c18e 100644 --- a/Cabal/Distribution/Backpack/FullUnitId.hs +++ b/Cabal/Distribution/Backpack/FullUnitId.hs @@ -11,7 +11,7 @@ import Distribution.Package import Distribution.Compat.Prelude -- Unlike OpenUnitId, which could direct to a UnitId. -data FullUnitId = FullUnitId ComponentId IndefModuleSubst +data FullUnitId = FullUnitId ComponentId OpenModuleSubst deriving (Show, Generic) type FullDb = UnitId -> FullUnitId diff --git a/Cabal/Distribution/Backpack/LinkedComponent.hs b/Cabal/Distribution/Backpack/LinkedComponent.hs index 27035782734..214da2c2ae3 100644 --- a/Cabal/Distribution/Backpack/LinkedComponent.hs +++ b/Cabal/Distribution/Backpack/LinkedComponent.hs @@ -48,7 +48,7 @@ data LinkedComponent = LinkedComponent { lc_uid :: OpenUnitId, lc_pkgid :: PackageId, - lc_insts :: [(ModuleName, IndefModule)], + lc_insts :: [(ModuleName, OpenModule)], lc_component :: Component, lc_shape :: ModuleShape, -- | Local buildTools dependencies @@ -151,7 +151,7 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { -- let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s) convertReq req = do - req_u <- convertModule (IndefModuleVar req) + 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 @@ -174,7 +174,7 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { -- the actual modules we export ourselves. Add them! let reqs = modScopeRequires linked_shape0 -- check that there aren't pre-filled requirements... - insts = [ (req, IndefModuleVar req) + insts = [ (req, OpenModuleVar req) | req <- Set.toList reqs ] this_uid = IndefFullUnitId this_cid . Map.fromList $ insts @@ -182,7 +182,7 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { local_exports = Map.fromListWith (++) $ [ (mod_name, [ModuleSource (packageName this_pid) defaultIncludeRenaming - (IndefModule this_uid mod_name)]) + (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 @@ -231,7 +231,7 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { provs <- foldM build_reexports Map.empty $ -- TODO: doublecheck we have checked for -- src_provs duplicates already! - [ (mod_name, IndefModule this_uid mod_name) | mod_name <- src_provs ] ++ + [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++ reexports_list let final_linked_shape = ModuleShape provs (modScopeRequires linked_shape) diff --git a/Cabal/Distribution/Backpack/ModSubst.hs b/Cabal/Distribution/Backpack/ModSubst.hs index 4ac3522298f..4f04ad30cdc 100644 --- a/Cabal/Distribution/Backpack/ModSubst.hs +++ b/Cabal/Distribution/Backpack/ModSubst.hs @@ -27,11 +27,11 @@ class ModSubst a where -- putting it on the right hand side, but for partial -- application it's more convenient to have it on the left -- hand side. - modSubst :: IndefModuleSubst -> a -> a + modSubst :: OpenModuleSubst -> a -> a -instance ModSubst IndefModule where - modSubst subst (IndefModule cid mod_name) = IndefModule (modSubst subst cid) mod_name - modSubst subst mod@(IndefModuleVar mod_name) +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 @@ -42,7 +42,7 @@ instance ModSubst OpenUnitId where instance ModSubst (Set ModuleName) where modSubst subst reqs = Set.union (Set.difference reqs (Map.keysSet subst)) - (indefModuleSubstFreeHoles subst) + (openModuleSubstFreeHoles subst) -- Substitutions are functorial. NB: this means that -- there is an @instance 'ModSubst' 'ModuleSubst'@! diff --git a/Cabal/Distribution/Backpack/ModuleScope.hs b/Cabal/Distribution/Backpack/ModuleScope.hs index 8db7cf1b9c3..f2477a7451c 100644 --- a/Cabal/Distribution/Backpack/ModuleScope.hs +++ b/Cabal/Distribution/Backpack/ModuleScope.hs @@ -71,7 +71,7 @@ data ModuleSource = -- with that as well msrc_pkgname :: PackageName, msrc_renaming :: IncludeRenaming, - msrc_module :: IndefModule + msrc_module :: OpenModule } instance ModSubst ModuleScope where diff --git a/Cabal/Distribution/Backpack/ModuleShape.hs b/Cabal/Distribution/Backpack/ModuleShape.hs index e94cc55baed..df98ceb77e4 100644 --- a/Cabal/Distribution/Backpack/ModuleShape.hs +++ b/Cabal/Distribution/Backpack/ModuleShape.hs @@ -27,7 +27,7 @@ import qualified Data.Set as Set -- a library. We can extract a 'ModuleShape' from an -- 'InstalledPackageInfo'. data ModuleShape = ModuleShape { - modShapeProvides :: IndefModuleSubst, + modShapeProvides :: OpenModuleSubst, modShapeRequires :: Set ModuleName } deriving (Eq, Show, Generic) @@ -78,6 +78,6 @@ shapeInstalledPackage ipi = ModuleShape (Map.fromList provs) reqs provs = map shapeExposedModule (IPI.exposedModules ipi) reqs = requiredSignatures ipi shapeExposedModule (IPI.ExposedModule mod_name Nothing) - = (mod_name, IndefModule uid mod_name) + = (mod_name, OpenModule uid mod_name) shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) = (mod_name, mod) diff --git a/Cabal/Distribution/Backpack/ReadyComponent.hs b/Cabal/Distribution/Backpack/ReadyComponent.hs index b482c6d7718..de5271ceb88 100644 --- a/Cabal/Distribution/Backpack/ReadyComponent.hs +++ b/Cabal/Distribution/Backpack/ReadyComponent.hs @@ -55,7 +55,7 @@ data InstantiatedComponent data IndefiniteComponent = IndefiniteComponent { indefc_requires :: [ModuleName], - indefc_provides :: Map ModuleName IndefModule, + indefc_provides :: Map ModuleName OpenModule, indefc_includes :: [(OpenUnitId, ModuleRenaming)] } @@ -230,15 +230,15 @@ toReadyComponents pid_map subst0 comps -- NB: NOT composition substSubst :: Map ModuleName Module - -> Map ModuleName IndefModule + -> Map ModuleName OpenModule -> InstM (Map ModuleName Module) substSubst subst insts = T.mapM (substModule subst) insts - substModule :: Map ModuleName Module -> IndefModule -> InstM Module - substModule subst (IndefModuleVar mod_name) + 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 (IndefModule uid mod_name) = do + substModule subst (OpenModule uid mod_name) = do uid' <- substUnitId subst uid return (Module uid' mod_name) diff --git a/Cabal/Distribution/Backpack/UnifyM.hs b/Cabal/Distribution/Backpack/UnifyM.hs index 1b1483477d2..d680dcb2c67 100644 --- a/Cabal/Distribution/Backpack/UnifyM.hs +++ b/Cabal/Distribution/Backpack/UnifyM.hs @@ -251,8 +251,8 @@ convertUnitId' stk (IndefFullUnitId cid insts) = do -- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i) convertModule' :: MuEnv s - -> IndefModule -> UnifyM s (ModuleU s) -convertModule' _stk (IndefModuleVar mod_name) = do + -> 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 @@ -260,14 +260,14 @@ convertModule' _stk (IndefModuleVar mod_name) = do writeUnifRef hmap (Map.insert mod_name mod hm) return mod Just mod -> return mod -convertModule' stk (IndefModule uid mod_name) = do +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 :: IndefModule -> UnifyM s (ModuleU s) +convertModule :: OpenModule -> UnifyM s (ModuleU s) convertModule = convertModule' emptyMuEnv @@ -279,11 +279,11 @@ convertModule = convertModule' emptyMuEnv type ModuleSubstU s = Map ModuleName (ModuleU s) -- | Conversion of 'ModuleSubst' to 'ModuleSubstU' -convertModuleSubst :: Map ModuleName IndefModule -> UnifyM s (Map ModuleName (ModuleU s)) +convertModuleSubst :: Map ModuleName OpenModule -> UnifyM s (Map ModuleName (ModuleU s)) convertModuleSubst = T.mapM convertModule -- | Conversion of 'ModuleSubstU' to 'ModuleSubst' -convertModuleSubstU :: ModuleSubstU s -> UnifyM s IndefModuleSubst +convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst convertModuleSubstU = T.mapM convertModuleU ----------------------------------------------------------------------- @@ -322,21 +322,21 @@ convertUnitIdU' stk uid_u = do insts <- T.forM insts_u $ convertModuleU' (extendMooEnv stk u) return (IndefFullUnitId cid insts) -convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s IndefModule +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 (IndefModuleVar mod_name) + ModuleVarU mod_name -> return (OpenModuleVar mod_name) ModuleU uid_u mod_name -> do uid <- convertUnitIdU' stk uid_u - return (IndefModule uid mod_name) + return (OpenModule uid mod_name) -- Helper functions convertUnitIdU :: UnitIdU s -> UnifyM s OpenUnitId convertUnitIdU = convertUnitIdU' emptyMooEnv -convertModuleU :: ModuleU s -> UnifyM s IndefModule +convertModuleU :: ModuleU s -> UnifyM s OpenModule convertModuleU = convertModuleU' emptyMooEnv -- | An empty 'ModuleScopeU'. @@ -400,7 +400,7 @@ convertInclude ((uid, ModuleShape provs reqs), pid, incl@(IncludeRenaming prov_r -- Requirement substitution. -- -- A -> X ==> A -> - let req_subst = fmap IndefModuleVar req_rename + let req_subst = fmap OpenModuleVar req_rename uid_u <- convertUnitId (modSubst req_subst uid) @@ -411,7 +411,7 @@ convertInclude ((uid, ModuleShape provs reqs), pid, incl@(IncludeRenaming prov_r -- -- A -> X ==> X -> , B -> reqs_u <- convertModuleSubst . Map.fromList $ - [ (k, IndefModuleVar k) + [ (k, OpenModuleVar k) | k <- map req_rename_fn (Set.toList reqs) ] diff --git a/Cabal/Distribution/InstalledPackageInfo.hs b/Cabal/Distribution/InstalledPackageInfo.hs index 9b78a99360a..30f535e231a 100644 --- a/Cabal/Distribution/InstalledPackageInfo.hs +++ b/Cabal/Distribution/InstalledPackageInfo.hs @@ -74,11 +74,11 @@ data InstalledPackageInfo -- these parts are exactly the same as PackageDescription sourcePackageId :: PackageId, installedUnitId :: UnitId, - -- INVARIANT: if this package is definite, IndefModule's + -- INVARIANT: if this package is definite, OpenModule's -- OpenUnitId directly records UnitId. If it is - -- indefinite, IndefModule is always an IndefModuleVar + -- indefinite, OpenModule is always an OpenModuleVar -- with the same ModuleName as the key. - instantiatedWith :: [(ModuleName, IndefModule)], + instantiatedWith :: [(ModuleName, OpenModule)], compatPackageKey :: String, license :: License, copyright :: String, @@ -93,7 +93,7 @@ data InstalledPackageInfo -- these parts are required by an installed package only: abiHash :: AbiHash, exposed :: Bool, - -- INVARIANT: if the package is definite, IndefModule's + -- INVARIANT: if the package is definite, OpenModule's -- OpenUnitId directly records UnitId. exposedModules :: [ExposedModule], hiddenModules :: [ModuleName], @@ -124,13 +124,13 @@ data InstalledPackageInfo indefinite :: InstalledPackageInfo -> Bool indefinite ipi = -- TODO: optimize a little - Set.null (indefModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi))) + Set.null (openModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi))) -- | 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 'IndefModuleSubst'. +-- an @OpenUnitId@ with the appropriate 'OpenModuleSubst'. installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId installedOpenUnitId ipi = if indefinite ipi @@ -141,7 +141,7 @@ installedOpenUnitId 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 = indefModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi)) +requiredSignatures ipi = openModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi)) installedComponentId :: InstalledPackageInfo -> ComponentId installedComponentId ipi = unitIdComponentId (installedUnitId ipi) @@ -216,7 +216,7 @@ emptyInstalledPackageInfo data ExposedModule = ExposedModule { exposedName :: ModuleName, - exposedReexport :: Maybe IndefModule + exposedReexport :: Maybe OpenModule } deriving (Eq, Generic, Read, Show) @@ -298,7 +298,7 @@ basicFieldDescrs = disp parse installedUnitId (\pk pkg -> pkg{installedUnitId=pk}) , simpleField "instantiated-with" - (dispIndefModuleSubst . Map.fromList) (fmap Map.toList parseIndefModuleSubst) + (dispOpenModuleSubst . Map.fromList) (fmap Map.toList parseOpenModuleSubst) instantiatedWith (\iw pkg -> pkg{instantiatedWith=iw}) , simpleField "key" dispCompatPackageKey parseCompatPackageKey diff --git a/Cabal/Distribution/Simple/PackageIndex.hs b/Cabal/Distribution/Simple/PackageIndex.hs index 9017e8ee706..88ee48b79cc 100644 --- a/Cabal/Distribution/Simple/PackageIndex.hs +++ b/Cabal/Distribution/Simple/PackageIndex.hs @@ -667,8 +667,8 @@ moduleNameIndex index = IPI.ExposedModule m reexport <- IPI.exposedModules pkg case reexport of Nothing -> return (m, [pkg]) - Just (IndefModuleVar _) -> [] - Just (IndefModule _ m') | m == m' -> [] + 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 diff --git a/Cabal/Distribution/Simple/Program/GHC.hs b/Cabal/Distribution/Simple/Program/GHC.hs index 8b781caa338..25a26049acd 100644 --- a/Cabal/Distribution/Simple/Program/GHC.hs +++ b/Cabal/Distribution/Simple/Program/GHC.hs @@ -83,7 +83,7 @@ data GhcOptions = GhcOptions { -- (we need to handle backwards compatibility.) ghcOptThisUnitId :: Flag String, - ghcOptInstantiatedWith :: [(ModuleName, IndefModule)], + ghcOptInstantiatedWith :: [(ModuleName, OpenModule)], -- | No code? (But we turn on interface writing ghcOptNoCode :: Flag Bool, diff --git a/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs b/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs index e3c378d01ed..e57a9dca066 100644 --- a/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs +++ b/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs @@ -35,7 +35,7 @@ data ComponentLocalBuildInfo -- | Is this an indefinite component (i.e. has unfilled holes)? componentIsIndefinite_ :: Bool, -- | How the component was instantiated - componentInstantiatedWith :: [(ModuleName, IndefModule)], + 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 diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index cb07d4425fa..77a73a9395d 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -1269,7 +1269,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB shape = planPkgShape dpkg indef_uid = IndefFullUnitId (unitIdComponentId (installedUnitId dpkg)) - (Map.fromList [ (req, IndefModuleVar req) + (Map.fromList [ (req, OpenModuleVar req) | req <- Set.toList (modShapeRequires shape)]) planPkgShape :: ElaboratedPlanPackage -> ModuleShape @@ -1740,15 +1740,15 @@ instantiateInstallPlan plan = -- NB: NOT composition substSubst :: Map ModuleName Module - -> Map ModuleName IndefModule + -> Map ModuleName OpenModule -> InstM (Map ModuleName Module) substSubst subst insts = T.mapM (substModule subst) insts - substModule :: Map ModuleName Module -> IndefModule -> InstM Module - substModule subst (IndefModuleVar mod_name) + 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 (IndefModule uid mod_name) = do + substModule subst (OpenModule uid mod_name) = do uid' <- substUnitId subst uid return (Module uid' mod_name) diff --git a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs index ebc96032f1b..9ca86f64977 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs @@ -123,7 +123,7 @@ data ElaboratedConfiguredPackage elabUnitId :: UnitId, elabInstantiatedWith :: Map ModuleName Module, - elabLinkedInstantiatedWith :: Map ModuleName IndefModule, + elabLinkedInstantiatedWith :: Map ModuleName OpenModule, -- | The 'PackageId' of the originating package elabPkgSourceId :: PackageId, From bd3040bda76948708f256d9afe8e08e80744e896 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sun, 2 Oct 2016 14:44:25 -0700 Subject: [PATCH 42/46] Add a new 'DefUnitId' type with invariant. The DefUnitId invariant says that the UnitId in a DefUnitId must in fact be a definite package (either with no holes, or fully instantiated.) This is in constrast to a UnitId, which can also identify an indefinite unit identifier. Signed-off-by: Edward Z. Yang --- Cabal/Distribution/Backpack.hs | 29 ++++++++++++++++-- Cabal/Distribution/Backpack/Configure.hs | 17 ++++++----- Cabal/Distribution/Backpack/FullUnitId.hs | 4 +-- Cabal/Distribution/Backpack/MixLink.hs | 3 +- Cabal/Distribution/Backpack/ReadyComponent.hs | 30 +++++++++++-------- Cabal/Distribution/Backpack/UnifyM.hs | 2 +- Cabal/Distribution/InstalledPackageInfo.hs | 7 ++--- Cabal/Distribution/Package.hs | 9 +++++- Cabal/Distribution/Simple/Build.hs | 6 +++- .../Distribution/Client/ProjectPlanning.hs | 26 +++++++++------- .../Distribution/Client/SetupWrapper.hs | 5 ++-- 11 files changed, 90 insertions(+), 48 deletions(-) diff --git a/Cabal/Distribution/Backpack.hs b/Cabal/Distribution/Backpack.hs index 0d5a1af04a5..d4dec7c9bcc 100644 --- a/Cabal/Distribution/Backpack.hs +++ b/Cabal/Distribution/Backpack.hs @@ -3,6 +3,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | This module defines the core data types for Backpack. For more -- details, see: @@ -14,6 +15,12 @@ module Distribution.Backpack ( OpenUnitId(..), openUnitIdComponentId, openUnitIdFreeHoles, + mkOpenUnitId, + + -- * DefUnitId + DefUnitId, + unDefUnitId, + mkDefUnitId, -- * OpenModule OpenModule(..), @@ -85,7 +92,7 @@ data OpenUnitId -- 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 UnitId + | DefiniteUnitId DefUnitId deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) -- TODO: cache holes? @@ -113,13 +120,29 @@ instance Text OpenUnitId where -- | Get the 'ComponentId' of an 'OpenUnitId'. openUnitIdComponentId :: OpenUnitId -> ComponentId openUnitIdComponentId (IndefFullUnitId cid _) = cid -openUnitIdComponentId (DefiniteUnitId uid) = unitIdComponentId uid +openUnitIdComponentId (DefiniteUnitId (DefUnitId uid)) = unitIdComponentId 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 (DefUnitId 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 = DefUnitId (UnitId cid (hashModuleSubst insts)) -- impose invariant! + ----------------------------------------------------------------------- -- OpenModule @@ -208,7 +231,7 @@ openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems -- 'IndefFullUnitId' be compiled; instead, we just depend on the -- installed indefinite unit installed at the 'ComponentId'. abstractUnitId :: OpenUnitId -> UnitId -abstractUnitId (DefiniteUnitId uid) = uid +abstractUnitId (DefiniteUnitId (DefUnitId uid)) = uid abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid -- | Take a module substitution and hash it into a string suitable for diff --git a/Cabal/Distribution/Backpack/Configure.hs b/Cabal/Distribution/Backpack/Configure.hs index 3318534c7ba..67f76fcbaf6 100644 --- a/Cabal/Distribution/Backpack/Configure.hs +++ b/Cabal/Distribution/Backpack/Configure.hs @@ -93,11 +93,12 @@ configureComponentLocalBuildInfos let shape_pkg_map = Map.fromList [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg)) | pkg <- prePkgDeps] - uid_lookup uid + 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 @@ -111,7 +112,7 @@ configureComponentLocalBuildInfos [ (Installed.installedComponentId pkg, Installed.sourcePackageId pkg) | (_, Module uid _) <- instantiate_with , Just pkg <- [PackageIndex.lookupUnitId - installedPackageSet uid] ] ++ + installedPackageSet (unDefUnitId uid)] ] ++ [ (lc_cid lc, lc_pkgid lc) | lc <- graph2 ] subst = Map.fromList instantiate_with @@ -243,7 +244,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs case rc_component rc of CLib _ -> let convModuleExport (modname', (Module uid modname)) - | this_uid == uid + | this_uid == unDefUnitId uid , modname' == modname = Installed.ExposedModule modname' Nothing | otherwise @@ -279,7 +280,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs componentIsIndefinite_ = is_indefinite, componentLocalName = cname, componentInternalDeps = internal_deps, - componentExeDeps = rc_internal_build_tools rc, + componentExeDeps = map unDefUnitId (rc_internal_build_tools rc), componentIncludes = includes, componentExposedModules = exports, componentIsPublic = rc_public rc, @@ -291,7 +292,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs componentUnitId = this_uid, componentLocalName = cname, componentPackageDeps = cpds, - componentExeDeps = rc_internal_build_tools rc, + componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc, componentInternalDeps = internal_deps, componentIncludes = includes } @@ -300,7 +301,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs componentUnitId = this_uid, componentLocalName = cname, componentPackageDeps = cpds, - componentExeDeps = rc_internal_build_tools rc, + componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc, componentInternalDeps = internal_deps, componentIncludes = includes } @@ -309,7 +310,7 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs componentUnitId = this_uid, componentLocalName = cname, componentPackageDeps = cpds, - componentExeDeps = rc_internal_build_tools rc, + componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc, componentInternalDeps = internal_deps, componentIncludes = includes } @@ -330,6 +331,6 @@ mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs map (\(x,y) -> (DefiniteUnitId x,y)) (instc_includes instc) internal_deps = filter isInternal (nodeNeighbors rc) - ++ rc_internal_build_tools rc + ++ map unDefUnitId (rc_internal_build_tools rc) diff --git a/Cabal/Distribution/Backpack/FullUnitId.hs b/Cabal/Distribution/Backpack/FullUnitId.hs index 15c7526c18e..cb5e3bf2364 100644 --- a/Cabal/Distribution/Backpack/FullUnitId.hs +++ b/Cabal/Distribution/Backpack/FullUnitId.hs @@ -14,7 +14,7 @@ import Distribution.Compat.Prelude data FullUnitId = FullUnitId ComponentId OpenModuleSubst deriving (Show, Generic) -type FullDb = UnitId -> FullUnitId +type FullDb = DefUnitId -> FullUnitId expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId expandOpenUnitId _db (IndefFullUnitId cid subst) @@ -22,5 +22,5 @@ expandOpenUnitId _db (IndefFullUnitId cid subst) expandOpenUnitId db (DefiniteUnitId uid) = expandUnitId db uid -expandUnitId :: FullDb -> UnitId -> FullUnitId +expandUnitId :: FullDb -> DefUnitId -> FullUnitId expandUnitId db uid = db uid diff --git a/Cabal/Distribution/Backpack/MixLink.hs b/Cabal/Distribution/Backpack/MixLink.hs index aa718b744f8..06e6352e48a 100644 --- a/Cabal/Distribution/Backpack/MixLink.hs +++ b/Cabal/Distribution/Backpack/MixLink.hs @@ -6,6 +6,7 @@ module Distribution.Backpack.MixLink ( import Prelude () import Distribution.Compat.Prelude hiding (mod) +import Distribution.Backpack import Distribution.Backpack.UnifyM import Distribution.Backpack.FullUnitId @@ -95,7 +96,7 @@ unifyUnitId uid1_u uid2_u unifyThunkWith :: ComponentId -> Map ModuleName (ModuleU s) -> UnitIdU s - -> UnitId + -> DefUnitId -> UnitIdU s -> UnifyM s () unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do diff --git a/Cabal/Distribution/Backpack/ReadyComponent.hs b/Cabal/Distribution/Backpack/ReadyComponent.hs index de5271ceb88..32b95f4af72 100644 --- a/Cabal/Distribution/Backpack/ReadyComponent.hs +++ b/Cabal/Distribution/Backpack/ReadyComponent.hs @@ -49,7 +49,7 @@ data InstantiatedComponent = InstantiatedComponent { instc_insts :: [(ModuleName, Module)], instc_provides :: Map ModuleName Module, - instc_includes :: [(UnitId, ModuleRenaming)] + instc_includes :: [(DefUnitId, ModuleRenaming)] } data IndefiniteComponent @@ -66,7 +66,7 @@ data ReadyComponent rc_component :: Component, -- build-tools don't participate in mix-in linking. -- (but what if they cold?) - rc_internal_build_tools :: [UnitId], + rc_internal_build_tools :: [DefUnitId], rc_public :: Bool, -- PackageId here is a bit dodgy, but its just for -- BC so it shouldn't matter. @@ -168,21 +168,22 @@ toReadyComponents pid_map subst0 comps cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ] instantiateUnitId :: ComponentId -> Map ModuleName Module - -> InstM UnitId + -> 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 (uid, Map.insert uid r s') - Just _ -> (uid, s) + in (def_uid, Map.insert uid r s') + Just _ -> (def_uid, s) where - -- The hashModuleSubst here indicates that we assume + -- 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. - uid = UnitId cid (hashModuleSubst insts) + def_uid = mkDefUnitId cid insts + uid = unDefUnitId def_uid instantiateComponent :: UnitId -> ComponentId -> Map ModuleName Module @@ -197,8 +198,10 @@ toReadyComponents pid_map subst0 comps x' <- substUnitId insts x return (x', y) build_tools <- mapM (substUnitId insts) (lc_internal_build_tools lc) - let getDep (Module dep_uid _) - | Just pid <- Map.lookup (unitIdComponentId dep_uid) pid_map + 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 { @@ -216,12 +219,13 @@ toReadyComponents pid_map subst0 comps -- NB: don't put the dep on the indef -- package here, since we DO NOT want -- to put it in 'depends' in the IPI - deps ++ concatMap getDep (Map.elems insts), + 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 UnitId + substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId substUnitId _ (DefiniteUnitId uid) = return uid substUnitId subst (IndefFullUnitId cid insts) = do @@ -279,5 +283,5 @@ toReadyComponents pid_map subst0 comps | otherwise = forM_ (Map.elems cmap) $ \lc -> if null (lc_insts lc) - then instantiateUnitId (lc_cid lc) Map.empty - else indefiniteUnitId (lc_cid 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 index d680dcb2c67..80723f229f8 100644 --- a/Cabal/Distribution/Backpack/UnifyM.hs +++ b/Cabal/Distribution/Backpack/UnifyM.hs @@ -181,7 +181,7 @@ data ModuleU' s -- | Contents of a mutable 'UnitIdU' reference. data UnitIdU' s = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s)) - | UnitIdThunkU UnitId + | UnitIdThunkU DefUnitId -- | A mutable version of 'Module' which can be imperatively unified. type ModuleU s = UnionFind.Point s (ModuleU' s) diff --git a/Cabal/Distribution/InstalledPackageInfo.hs b/Cabal/Distribution/InstalledPackageInfo.hs index 30f535e231a..53503c23bb5 100644 --- a/Cabal/Distribution/InstalledPackageInfo.hs +++ b/Cabal/Distribution/InstalledPackageInfo.hs @@ -132,11 +132,8 @@ indefinite ipi = -- For indefinite libraries, however, you will correctly get -- an @OpenUnitId@ with the appropriate 'OpenModuleSubst'. installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId -installedOpenUnitId ipi = - if indefinite ipi - then IndefFullUnitId (installedComponentId ipi) - (Map.fromList (instantiatedWith ipi)) - else DefiniteUnitId (installedUnitId ipi) +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. diff --git a/Cabal/Distribution/Package.hs b/Cabal/Distribution/Package.hs index ad1f61174e8..17910d5c06b 100644 --- a/Cabal/Distribution/Package.hs +++ b/Cabal/Distribution/Package.hs @@ -25,6 +25,7 @@ module Distribution.Package ( -- * Package keys/installed package IDs (used for linker symbols) ComponentId, unComponentId, mkComponentId, UnitId(..), + DefUnitId(..), mkUnitId, newSimpleUnitId, mkLegacyUnitId, @@ -145,7 +146,7 @@ instance NFData PackageIdentifier where -- module identities, e.g., when writing out reexported modules in -- the 'InstalledPackageInfo'. data Module = - Module UnitId ModuleName + Module DefUnitId ModuleName deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary Module @@ -268,6 +269,12 @@ instance Text UnitId where 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) + -- | Create a unit identity with no associated hash directly -- from a 'ComponentId'. newSimpleUnitId :: ComponentId -> UnitId diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index 18cadf53918..51744df7e57 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -474,7 +474,11 @@ testSuiteLibV09AsLibAndExe pkg_descr componentExeDeps = [], componentLocalName = CExeName (stubName test), componentPackageDeps = deps, - componentIncludes = zip (map (DefiniteUnitId . fst) deps) (repeat defaultRenaming) + -- Assert DefUnitId invariant! + -- Executable can't be indefinite, so dependencies must + -- be definite packages. + componentIncludes = zip (map (DefiniteUnitId . DefUnitId . fst) deps) + (repeat defaultRenaming) } testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 77a73a9395d..4e3d69cf5f9 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -1131,7 +1131,11 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB ElaboratedConfiguredPackage) buildComponent (cc_map, lc_map, exe_map) comp = do infoProgress $ dispConfiguredComponent cc - let lookup_uid (UnitId sub_cid Nothing) = FullUnitId sub_cid Map.empty + let -- Use of invariant: DefUnitId indicates that if + -- there is no hash, it must have an empty + -- instnatiation. + lookup_uid (DefUnitId (UnitId sub_cid Nothing)) + = FullUnitId sub_cid Map.empty -- TODO: This case CAN happen if we have pre-existing -- instantiated things. Fix eventually. lookup_uid uid = error ("lookup_uid: " ++ display uid) @@ -1692,21 +1696,18 @@ instantiateInstallPlan plan = cmap = Map.fromList [ (unitIdComponentId (nodeKey pkg), pkg) | pkg <- pkgs ] instantiateUnitId :: ComponentId -> Map ModuleName Module - -> InstM UnitId + -> 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 (uid, Map.insert uid r s') - Just _ -> (uid, s) + in (def_uid, Map.insert uid r s') + Just _ -> (def_uid, s) where - -- The hashModuleSubst 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. - uid = UnitId cid (hashModuleSubst insts) + def_uid = mkDefUnitId cid insts + uid = unDefUnitId def_uid instantiateComponent :: UnitId -> ComponentId -> Map ModuleName Module @@ -1725,13 +1726,14 @@ instantiateInstallPlan plan = elabPkgOrComp = ElabComponent comp { compNonSetupDependencies = (if Map.null insts then [] else [newSimpleUnitId cid]) ++ - ordNub (deps ++ concatMap getDep (Map.elems insts)) + ordNub (map unDefUnitId + (deps ++ concatMap getDep (Map.elems insts))) } } _ -> return planpkg | otherwise = error ("instantiateComponent: " ++ display cid) - substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM UnitId + substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId substUnitId _ (DefiniteUnitId uid) = return uid substUnitId subst (IndefFullUnitId cid insts) = do @@ -1780,7 +1782,9 @@ instantiateInstallPlan plan = InstallPlan.Configured elab | not (Map.null (elabLinkedInstantiatedWith elab)) -> indefiniteUnitId (unitIdComponentId (nodeKey elab)) + >> return () _ -> instantiateUnitId (unitIdComponentId (nodeKey pkg)) Map.empty + >> return () --------------------------- -- Build targets diff --git a/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal-install/Distribution/Client/SetupWrapper.hs index 525e97529c0..4a4e45275f0 100644 --- a/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/Distribution/Client/SetupWrapper.hs @@ -32,7 +32,7 @@ import Distribution.Version , withinRange ) import qualified Distribution.Backpack as Backpack import Distribution.Package - ( newSimpleUnitId, ComponentId, PackageId, mkPackageName + ( newSimpleUnitId, DefUnitId(..), ComponentId, PackageId, mkPackageName , PackageIdentifier(..), packageVersion, packageName, Dependency(..) ) import Distribution.PackageDescription ( GenericPackageDescription(packageDescription) @@ -819,7 +819,8 @@ getExternalSetupMethod verbosity options pkg bt = do then [] else cabalDep addRenaming (ipid, _) = - (Backpack.DefiniteUnitId (newSimpleUnitId ipid), defaultRenaming) + -- Assert 'DefUnitId' invariant + (Backpack.DefiniteUnitId (DefUnitId (newSimpleUnitId ipid)), defaultRenaming) cppMacrosFile = setupDir "setup_macros.h" ghcOptions = mempty { -- Respect -v0, but don't crank up verbosity on GHC if From c2870d7e4ee525da9c5640ffe02230e4bd6e450c Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sun, 2 Oct 2016 16:01:00 -0700 Subject: [PATCH 43/46] Make DefUnitId abstract, to avoid accidents. Signed-off-by: Edward Z. Yang --- Cabal/Distribution/Backpack.hs | 9 +++++---- Cabal/Distribution/Package.hs | 9 ++++++++- Cabal/Distribution/Simple/Build.hs | 2 +- cabal-install/Distribution/Client/ProjectPlanning.hs | 11 ++++++----- cabal-install/Distribution/Client/SetupWrapper.hs | 4 ++-- 5 files changed, 22 insertions(+), 13 deletions(-) diff --git a/Cabal/Distribution/Backpack.hs b/Cabal/Distribution/Backpack.hs index d4dec7c9bcc..a42b5581128 100644 --- a/Cabal/Distribution/Backpack.hs +++ b/Cabal/Distribution/Backpack.hs @@ -120,7 +120,7 @@ instance Text OpenUnitId where -- | Get the 'ComponentId' of an 'OpenUnitId'. openUnitIdComponentId :: OpenUnitId -> ComponentId openUnitIdComponentId (IndefFullUnitId cid _) = cid -openUnitIdComponentId (DefiniteUnitId (DefUnitId uid)) = unitIdComponentId uid +openUnitIdComponentId (DefiniteUnitId def_uid) = unitIdComponentId (unDefUnitId def_uid) -- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'. openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName @@ -132,7 +132,7 @@ openUnitIdFreeHoles _ = Set.empty mkOpenUnitId :: UnitId -> OpenModuleSubst -> OpenUnitId mkOpenUnitId uid insts = if Set.null (openModuleSubstFreeHoles insts) - then DefiniteUnitId (DefUnitId uid) -- invariant holds! + then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds! else IndefFullUnitId (unitIdComponentId uid) insts ----------------------------------------------------------------------- @@ -141,7 +141,8 @@ mkOpenUnitId uid insts = -- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation -- with no holes. mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId -mkDefUnitId cid insts = DefUnitId (UnitId cid (hashModuleSubst insts)) -- impose invariant! +mkDefUnitId cid insts = + unsafeMkDefUnitId (UnitId cid (hashModuleSubst insts)) -- impose invariant! ----------------------------------------------------------------------- -- OpenModule @@ -231,7 +232,7 @@ openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems -- 'IndefFullUnitId' be compiled; instead, we just depend on the -- installed indefinite unit installed at the 'ComponentId'. abstractUnitId :: OpenUnitId -> UnitId -abstractUnitId (DefiniteUnitId (DefUnitId uid)) = uid +abstractUnitId (DefiniteUnitId def_uid) = unDefUnitId def_uid abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid -- | Take a module substitution and hash it into a string suitable for diff --git a/Cabal/Distribution/Package.hs b/Cabal/Distribution/Package.hs index 17910d5c06b..da1710eaa88 100644 --- a/Cabal/Distribution/Package.hs +++ b/Cabal/Distribution/Package.hs @@ -25,7 +25,9 @@ module Distribution.Package ( -- * Package keys/installed package IDs (used for linker symbols) ComponentId, unComponentId, mkComponentId, UnitId(..), - DefUnitId(..), + DefUnitId, + unsafeMkDefUnitId, + unDefUnitId, mkUnitId, newSimpleUnitId, mkLegacyUnitId, @@ -275,6 +277,11 @@ instance Text UnitId where 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 diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index 51744df7e57..a756dd4edad 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -477,7 +477,7 @@ testSuiteLibV09AsLibAndExe pkg_descr -- Assert DefUnitId invariant! -- Executable can't be indefinite, so dependencies must -- be definite packages. - componentIncludes = zip (map (DefiniteUnitId . DefUnitId . fst) deps) + componentIncludes = zip (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps) (repeat defaultRenaming) } testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 4e3d69cf5f9..ecf73c7cfdc 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -1134,11 +1134,12 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB let -- Use of invariant: DefUnitId indicates that if -- there is no hash, it must have an empty -- instnatiation. - lookup_uid (DefUnitId (UnitId sub_cid Nothing)) - = FullUnitId sub_cid Map.empty - -- TODO: This case CAN happen if we have pre-existing - -- instantiated things. Fix eventually. - lookup_uid uid = error ("lookup_uid: " ++ display uid) + 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 diff --git a/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal-install/Distribution/Client/SetupWrapper.hs index 4a4e45275f0..febd44758fa 100644 --- a/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/Distribution/Client/SetupWrapper.hs @@ -32,7 +32,7 @@ import Distribution.Version , withinRange ) import qualified Distribution.Backpack as Backpack import Distribution.Package - ( newSimpleUnitId, DefUnitId(..), ComponentId, PackageId, mkPackageName + ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId, PackageId, mkPackageName , PackageIdentifier(..), packageVersion, packageName, Dependency(..) ) import Distribution.PackageDescription ( GenericPackageDescription(packageDescription) @@ -820,7 +820,7 @@ getExternalSetupMethod verbosity options pkg bt = do else cabalDep addRenaming (ipid, _) = -- Assert 'DefUnitId' invariant - (Backpack.DefiniteUnitId (DefUnitId (newSimpleUnitId ipid)), defaultRenaming) + (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)), defaultRenaming) cppMacrosFile = setupDir "setup_macros.h" ghcOptions = mempty { -- Respect -v0, but don't crank up verbosity on GHC if From 399e54a4fb0ae13fe0852ee82f3e1498a32cff07 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 20:47:30 -0700 Subject: [PATCH 44/46] Update toComponentsGraph comment. Signed-off-by: Edward Z. Yang --- Cabal/Distribution/Backpack/ComponentsGraph.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/Cabal/Distribution/Backpack/ComponentsGraph.hs b/Cabal/Distribution/Backpack/ComponentsGraph.hs index 828673f20ed..c96dd78f9a3 100644 --- a/Cabal/Distribution/Backpack/ComponentsGraph.hs +++ b/Cabal/Distribution/Backpack/ComponentsGraph.hs @@ -34,11 +34,10 @@ dispComponentsGraph graph = (vcat [ text "dependency" <+> disp cdep | cdep <- cdeps ]) | (c, cdeps) <- 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.) +-- | 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 From 2f93432d23cfb21990fe206ac2bd2d4ab9144321 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 3 Oct 2016 20:51:03 -0700 Subject: [PATCH 45/46] Clarify what hsig writing out is. Signed-off-by: Edward Z. Yang --- Cabal/Distribution/Simple/Build.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index a756dd4edad..8fbe360bb67 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -595,7 +595,12 @@ writeAutogenFiles verbosity pkg lbi clbi = do --TODO: document what we're doing here, and move it to its own function case clbi of LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - -- Harmless enough to do things even when they exist + -- 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" From cf7e3313ddd2600409439ad8ec64baccaceafc00 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Wed, 5 Oct 2016 20:10:12 -0700 Subject: [PATCH 46/46] Add a dedicated indefinite field to InstalledPackageInfo. Signed-off-by: Edward Z. Yang --- Cabal/Distribution/InstalledPackageInfo.hs | 13 ++++--------- Cabal/Distribution/Simple/GHC/IPI642.hs | 1 + Cabal/Distribution/Simple/Register.hs | 2 ++ 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/Cabal/Distribution/InstalledPackageInfo.hs b/Cabal/Distribution/InstalledPackageInfo.hs index 53503c23bb5..672145a6c93 100644 --- a/Cabal/Distribution/InstalledPackageInfo.hs +++ b/Cabal/Distribution/InstalledPackageInfo.hs @@ -31,7 +31,6 @@ module Distribution.InstalledPackageInfo ( InstalledPackageInfo(..), installedComponentId, installedPackageId, - indefinite, requiredSignatures, installedOpenUnitId, ExposedModule(..), @@ -61,7 +60,6 @@ import Distribution.Compat.Graph import Text.PrettyPrint as Disp import qualified Data.Char as Char import qualified Data.Map as Map -import qualified Data.Set as Set import Data.Set (Set) -- ----------------------------------------------------------------------------- @@ -92,6 +90,7 @@ 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. @@ -119,13 +118,6 @@ data InstalledPackageInfo } deriving (Eq, Generic, Read, Show) --- | Returns 'True' if this is an interface-file only indefinite --- package which has not been instantiated. -indefinite :: InstalledPackageInfo -> Bool -indefinite ipi = - -- TODO: optimize a little - Set.null (openModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi))) - -- | 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)@. @@ -185,6 +177,7 @@ emptyInstalledPackageInfo description = "", category = "", abiHash = mkAbiHash "", + indefinite = False, exposed = False, exposedModules = [], hiddenModules = [], @@ -336,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/Simple/GHC/IPI642.hs b/Cabal/Distribution/Simple/GHC/IPI642.hs index 63f46d6e18f..c364858c0d9 100644 --- a/Cabal/Distribution/Simple/GHC/IPI642.hs +++ b/Cabal/Distribution/Simple/GHC/IPI642.hs @@ -82,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/Register.hs b/Cabal/Distribution/Simple/Register.hs index bc1ed259915..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 @@ -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,