The Backpack patch.
authorEdward Z. Yang <ezyang@cs.stanford.edu>
Sat, 10 Oct 2015 19:01:14 +0000 (12:01 -0700)
committerEdward Z. Yang <ezyang@cs.stanford.edu>
Sat, 8 Oct 2016 07:20:34 +0000 (00:20 -0700)
Summary:
This patch implements Backpack for GHC.  It's a big patch but I've tried quite
hard to keep things, by-in-large, self-contained.

The user facing specification for Backpack can be found at:

    https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst

A guide to the implementation can be found at:

    https://github.com/ezyang/ghc-proposals/blob/backpack-impl/proposals/0000-backpack-impl.rst

Has a submodule update for Cabal, as well as a submodule update
for filepath to handle more strict checking of cabal-version.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
Test Plan: validate

Reviewers: simonpj, austin, simonmar, bgamari, goldfire

Subscribers: thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D1482

277 files changed:
compiler/backpack/BkpSyn.hs [new file with mode: 0644]
compiler/backpack/DriverBkp.hs [new file with mode: 0644]
compiler/backpack/NameShape.hs [new file with mode: 0644]
compiler/backpack/RnModIface.hs [new file with mode: 0644]
compiler/basicTypes/Module.hs
compiler/basicTypes/Module.hs-boot
compiler/basicTypes/Name.hs
compiler/deSugar/Desugar.hs
compiler/ghc.cabal.in
compiler/iface/IfaceEnv.hs
compiler/iface/IfaceEnv.hs-boot [new file with mode: 0644]
compiler/iface/IfaceSyn.hs
compiler/iface/LoadIface.hs
compiler/iface/LoadIface.hs-boot [new file with mode: 0644]
compiler/iface/MkIface.hs
compiler/iface/TcIface.hs
compiler/main/DriverPipeline.hs
compiler/main/DynFlags.hs
compiler/main/Finder.hs
compiler/main/GhcMake.hs
compiler/main/HscMain.hs
compiler/main/HscTypes.hs
compiler/main/PackageConfig.hs
compiler/main/PackageConfig.hs-boot [new file with mode: 0644]
compiler/main/Packages.hs
compiler/main/Packages.hs-boot
compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/rename/RnEnv.hs
compiler/rename/RnNames.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcBackpack.hs [new file with mode: 0644]
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnDriver.hs-boot [new file with mode: 0644]
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSplice.hs
compiler/types/InstEnv.hs
compiler/utils/Outputable.hs
ghc/Main.hs
libraries/Cabal
libraries/ghc-boot/GHC/PackageDb.hs
testsuite/.gitignore
testsuite/driver/extra_files.py
testsuite/driver/testglobals.py
testsuite/driver/testlib.py
testsuite/tests/backpack/Makefile [new file with mode: 0644]
testsuite/tests/backpack/cabal/Makefile [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/Main.hs [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/Makefile [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/Setup.hs [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/all.T [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/bkpcabal01.cabal [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/bkpcabal01.stdout [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/impl/H.hs [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/impl/I.hs [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/p/H.hsig [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/p/P.hs.in1 [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/p/P.hs.in2 [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/q/I.hsig [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/q/Q.hs.in1 [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal01/q/Q.hs.in2 [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal02/Makefile [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal02/Setup.hs [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal02/all.T [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.cabal [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.stderr [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.stdout [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal02/p/.gitignore [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal02/p/H.hsig.in1 [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal02/p/H.hsig.in2 [new file with mode: 0644]
testsuite/tests/backpack/cabal/bkpcabal02/q/H.hsig [new file with mode: 0644]
testsuite/tests/backpack/reexport/Makefile [new file with mode: 0644]
testsuite/tests/backpack/reexport/all.T [new file with mode: 0644]
testsuite/tests/backpack/reexport/bkpreex01.bkp [new file with mode: 0644]
testsuite/tests/backpack/reexport/bkpreex01.stderr [new file with mode: 0644]
testsuite/tests/backpack/reexport/bkpreex02.bkp [new file with mode: 0644]
testsuite/tests/backpack/reexport/bkpreex02.stderr [new file with mode: 0644]
testsuite/tests/backpack/reexport/bkpreex03.bkp [new file with mode: 0644]
testsuite/tests/backpack/reexport/bkpreex03.stderr [new file with mode: 0644]
testsuite/tests/backpack/reexport/bkpreex04.bkp [new file with mode: 0644]
testsuite/tests/backpack/reexport/bkpreex04.stderr [new file with mode: 0644]
testsuite/tests/backpack/reexport/bkpreex05.bkp [new file with mode: 0644]
testsuite/tests/backpack/reexport/bkpreex06.bkp [new file with mode: 0644]
testsuite/tests/backpack/reexport/bkpreex06.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/Makefile [new file with mode: 0644]
testsuite/tests/backpack/should_compile/all.T [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp01.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp01.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp01.stdout [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp01c.stdout [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp02.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp02.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp02.stdout [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp03.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp04.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp05.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp06.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp07.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp07.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp08.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp08.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp09.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp09.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp10.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp10.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp11.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp11.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp12.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp12.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp13.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp14.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp14.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp15.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp15.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp16.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp16.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp17.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp17.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp18.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp18.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp19.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp19.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp20.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp20.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp21.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp21.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp22.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp23.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp23.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp24.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp24.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp25.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp25.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp26.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp26.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp27.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp27.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp28.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp28.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp29.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp29.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp30.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp30.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp31.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp31.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp32.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp32.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp33.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp33.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp34.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp34.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp35.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp36.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_compile/bkp36.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/Makefile [new file with mode: 0644]
testsuite/tests/backpack/should_fail/all.T [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail01.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail01.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail03.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail03.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail04.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail04.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail05.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail05.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail06.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail06.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail07.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail07.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail09.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail09.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail10.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail10.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail11.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail11.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail12.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail12.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail13.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail13.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail14.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail14.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail15.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail16.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail16.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail17.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail17.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail18.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail18.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail19.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail19.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail20.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail20.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail21.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail21.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail22.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail22.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_run/Makefile [new file with mode: 0644]
testsuite/tests/backpack/should_run/all.T [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun01.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun01.stdout [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun02.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun02.stdout [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun03.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun03.stdout [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun04.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun04.stdout [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun05.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun05.stderr [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun05.stdout [moved from testsuite/tests/driver/sigof02/sigof02.stdout with 100% similarity]
testsuite/tests/backpack/should_run/bkprun06.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun06.stdout [moved from testsuite/tests/driver/sigof02/sigof02d.stdout with 100% similarity]
testsuite/tests/backpack/should_run/bkprun07.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun07.stdout [moved from testsuite/tests/driver/sigof01/sigof01.stdout with 100% similarity]
testsuite/tests/backpack/should_run/bkprun08.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_run/bkprun08.stdout [new file with mode: 0644]
testsuite/tests/cabal/cabal03/cabal03.stderr
testsuite/tests/driver/dynamicToo/dynamicToo005/Makefile
testsuite/tests/driver/dynamicToo/dynamicToo005/dynamicToo005.bkp [new file with mode: 0644]
testsuite/tests/driver/dynamicToo/dynamicToo006/A.hsig [deleted file]
testsuite/tests/driver/dynamicToo/dynamicToo006/B.hs [deleted file]
testsuite/tests/driver/dynamicToo/dynamicToo006/Makefile [deleted file]
testsuite/tests/driver/dynamicToo/dynamicToo006/test.T [deleted file]
testsuite/tests/driver/recomp005/recomp005.stdout
testsuite/tests/driver/sigof01/A.hs [deleted file]
testsuite/tests/driver/sigof01/B.hsig [deleted file]
testsuite/tests/driver/sigof01/Main.hs [deleted file]
testsuite/tests/driver/sigof01/Makefile [deleted file]
testsuite/tests/driver/sigof01/all.T [deleted file]
testsuite/tests/driver/sigof01/sigof01m.stdout [deleted file]
testsuite/tests/driver/sigof02/Double.hs [deleted file]
testsuite/tests/driver/sigof02/Main.hs [deleted file]
testsuite/tests/driver/sigof02/Makefile [deleted file]
testsuite/tests/driver/sigof02/Map.hsig [deleted file]
testsuite/tests/driver/sigof02/MapAsSet.hsig [deleted file]
testsuite/tests/driver/sigof02/all.T [deleted file]
testsuite/tests/driver/sigof02/sigof02.stderr [deleted file]
testsuite/tests/driver/sigof02/sigof02dm.stdout [deleted file]
testsuite/tests/driver/sigof02/sigof02dmt.stderr [deleted file]
testsuite/tests/driver/sigof02/sigof02dmt.stdout [deleted file]
testsuite/tests/driver/sigof02/sigof02dt.stderr [deleted file]
testsuite/tests/driver/sigof02/sigof02m.stderr [deleted file]
testsuite/tests/driver/sigof02/sigof02m.stdout [deleted file]
testsuite/tests/driver/sigof02/sigof02mt.stdout [deleted file]
testsuite/tests/driver/sigof03/A.hs [deleted file]
testsuite/tests/driver/sigof03/ASig1.hsig [deleted file]
testsuite/tests/driver/sigof03/ASig2.hsig [deleted file]
testsuite/tests/driver/sigof03/Main.hs [deleted file]
testsuite/tests/driver/sigof03/Makefile [deleted file]
testsuite/tests/driver/sigof03/all.T [deleted file]
testsuite/tests/driver/sigof04/Makefile [deleted file]
testsuite/tests/driver/sigof04/Sig.hsig [deleted file]
testsuite/tests/driver/sigof04/all.T [deleted file]
testsuite/tests/driver/sigof04/sigof04.stderr [deleted file]
testsuite/tests/ghci/scripts/T5979.stderr
testsuite/tests/haddock/haddock_examples/haddock.Test.stderr
testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.stderr
testsuite/tests/package/package07e.stderr
testsuite/tests/package/package08e.stderr
testsuite/tests/perf/haddock/all.T
testsuite/tests/plugins/T11244.stderr
testsuite/tests/safeHaskell/check/Check07.stderr
testsuite/tests/safeHaskell/check/Check08.stderr
testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr
testsuite/tests/typecheck/should_compile/all.T
testsuite/tests/typecheck/should_compile/tc264.hsig [deleted file]
testsuite/tests/typecheck/should_fail/T6018fail.stderr
testsuite/tests/typecheck/should_fail/all.T
testsuite/tests/typecheck/should_fail/tcfail219.hsig [deleted file]
testsuite/tests/typecheck/should_fail/tcfail219.stderr [deleted file]
testsuite/tests/typecheck/should_fail/tcfail220.hsig [deleted file]
testsuite/tests/typecheck/should_fail/tcfail220.stderr [deleted file]
testsuite/tests/typecheck/should_fail/tcfail221.hsig [deleted file]
testsuite/tests/typecheck/should_fail/tcfail221.stderr [deleted file]
testsuite/tests/typecheck/should_fail/tcfail222.hsig [deleted file]
testsuite/tests/typecheck/should_fail/tcfail222.stderr [deleted file]
utils/ghc-pkg/Main.hs

diff --git a/compiler/backpack/BkpSyn.hs b/compiler/backpack/BkpSyn.hs
new file mode 100644 (file)
index 0000000..ae03324
--- /dev/null
@@ -0,0 +1,77 @@
+-- | This is the syntax for bkp files which are parsed in 'ghc --backpack'
+-- mode.  This syntax is used purely for testing purposes.
+
+module BkpSyn (
+    -- * Backpack abstract syntax
+    HsUnitId(..),
+    LHsUnitId,
+    HsModuleSubst,
+    LHsModuleSubst,
+    HsModuleId(..),
+    LHsModuleId,
+    HsComponentId(..),
+    LHsUnit, HsUnit(..),
+    LHsUnitDecl, HsUnitDecl(..),
+    HsDeclType(..),
+    IncludeDecl(..),
+    LRenaming, Renaming(..),
+    ) where
+
+import HsSyn
+import RdrName
+import SrcLoc
+import Outputable
+import Module
+import PackageConfig
+
+{-
+************************************************************************
+*                                                                      *
+                        User syntax
+*                                                                      *
+************************************************************************
+-}
+
+data HsComponentId = HsComponentId {
+    hsPackageName :: PackageName,
+    hsComponentId :: ComponentId
+    }
+
+instance Outputable HsComponentId where
+    ppr (HsComponentId _pn cid) = ppr cid -- todo debug with pn
+
+data HsUnitId n = HsUnitId (Located n) [LHsModuleSubst n]
+type LHsUnitId n = Located (HsUnitId n)
+
+type HsModuleSubst n = (Located ModuleName, LHsModuleId n)
+type LHsModuleSubst n = Located (HsModuleSubst n)
+
+data HsModuleId n = HsModuleVar (Located ModuleName)
+                  | HsModuleId (LHsUnitId n) (Located ModuleName)
+type LHsModuleId n = Located (HsModuleId n)
+
+-- | Top level @unit@ declaration in a Backpack file.
+data HsUnit n = HsUnit {
+        hsunitName :: Located n,
+        hsunitBody :: [LHsUnitDecl n]
+    }
+type LHsUnit n = Located (HsUnit n)
+
+-- | A declaration in a package, e.g. a module or signature definition,
+-- or an include.
+data HsDeclType = ModuleD | SignatureD
+data HsUnitDecl n
+    = DeclD      HsDeclType (Located ModuleName) (Maybe (Located (HsModule RdrName)))
+    | IncludeD   (IncludeDecl n)
+type LHsUnitDecl n = Located (HsUnitDecl n)
+
+-- | An include of another unit
+data IncludeDecl n = IncludeDecl {
+        idUnitId :: LHsUnitId n,
+        idModRenaming :: Maybe [ LRenaming ]
+    }
+
+-- | Rename a module from one name to another.  The identity renaming
+-- means that the module should be brought into scope.
+data Renaming = Renaming { renameFrom :: ModuleName, renameTo :: ModuleName }
+type LRenaming = Located Renaming
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
new file mode 100644 (file)
index 0000000..25d2d92
--- /dev/null
@@ -0,0 +1,777 @@
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+
+-- | This is the driver for the 'ghc --backpack' mode, which
+-- is a reimplementation of the "package manager" bits of
+-- Backpack directly in GHC.  The basic method of operation
+-- is to compile packages and then directly insert them into
+-- GHC's in memory database.
+--
+-- The compilation products of this mode aren't really suitable
+-- for Cabal, because GHC makes up component IDs for the things
+-- it builds and doesn't serialize out the database contents.
+-- But it's still handy for constructing tests.
+
+module DriverBkp (doBackpack) where
+
+#include "HsVersions.h"
+
+-- In a separate module because it hooks into the parser.
+import BkpSyn
+
+import GHC hiding (Failed, Succeeded)
+import Packages
+import Parser
+import Lexer
+import GhcMonad
+import DynFlags
+import TcRnMonad
+import TcRnDriver
+import Module
+import HscTypes
+import StringBuffer
+import FastString
+import ErrUtils
+import SrcLoc
+import HscMain
+import UniqFM
+import UniqDFM
+import Outputable
+import Maybes
+import HeaderInfo
+import MkIface
+import GhcMake
+import UniqDSet
+import PrelNames
+import BasicTypes hiding (SuccessFlag(..))
+import Finder
+import Util
+
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.List
+import System.Exit
+import Control.Monad
+import System.FilePath
+import Data.Version
+
+-- for the unification
+import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+-- | Entry point to compile a Backpack file.
+doBackpack :: FilePath -> Ghc ()
+doBackpack src_filename = do
+    -- Apply options from file to dflags
+    dflags0 <- getDynFlags
+    let dflags1 = dflags0
+    src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename
+    (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
+    modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags})
+    -- Cribbed from: preprocessFile / DriverPipeline
+    liftIO $ checkProcessArgsResult dflags unhandled_flags
+    liftIO $ handleFlagWarnings dflags warns
+    -- TODO: Preprocessing not implemented
+
+    buf <- liftIO $ hGetStringBuffer src_filename
+    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
+    case unP parseBackpack (mkPState dflags buf loc) of
+        PFailed span err -> do
+            liftIO $ throwOneError (mkPlainErrMsg dflags span err)
+        POk _ pkgname_bkp -> do
+            -- OK, so we have an LHsUnit PackageName, but we want an
+            -- LHsUnit HsComponentId.  So let's rename it.
+            let bkp = renameHsUnits dflags (packageNameMap pkgname_bkp) pkgname_bkp
+            initBkpM src_filename bkp $
+                forM_ (zip [1..] bkp) $ \(i, lunit) -> do
+                    let comp_name = unLoc (hsunitName (unLoc lunit))
+                    msgTopPackage (i,length bkp) comp_name
+                    innerBkpM $ do
+                        let (cid, insts) = computeUnitId lunit
+                        if null insts
+                            then if cid == ComponentId (fsLit "main")
+                                    then compileExe lunit
+                                    else compileUnit cid []
+                            else typecheckUnit cid insts
+
+computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)])
+computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
+  where
+    cid = hsComponentId (unLoc (hsunitName unit))
+    reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))
+    get_reqs (DeclD SignatureD (L _ modname) _) = unitUniqDSet modname
+    get_reqs (DeclD ModuleD _ _) = emptyUniqDSet
+    get_reqs (IncludeD (IncludeDecl (L _ hsuid) _)) =
+        unitIdFreeHoles (convertHsUnitId hsuid)
+
+-- | Tiny enum for all types of Backpack operations we may do.
+data SessionType = ExeSession | TcSession | CompSession
+    deriving (Eq)
+
+-- | Create a temporary Session to do some sort of type checking or
+-- compilation.
+withBkpSession :: ComponentId
+               -> [(ModuleName, Module)]
+               -> [(UnitId, ModRenaming)]
+               -> SessionType   -- what kind of session are we doing
+               -> BkpM a        -- actual action to run
+               -> BkpM a
+withBkpSession cid insts deps session_type do_this = do
+    dflags <- getDynFlags
+    let (ComponentId cid_fs) = cid
+        is_primary = False
+        uid_str = unpackFS (hashUnitId cid insts)
+        cid_str = unpackFS cid_fs
+        -- There are multiple units in a single Backpack file, so we
+        -- need to separate out the results in those cases.  Right now,
+        -- we follow this hierarchy:
+        --      $outputdir/$compid          --> typecheck results
+        --      $outputdir/$compid/$unitid  --> compile results
+        key_base p | Just f <- p dflags = f
+                   | otherwise          = "."
+        sub_comp p | is_primary = p
+                   | otherwise = p </> cid_str
+        outdir p | CompSession <- session_type
+                 -- Special case when package is definite
+                 , not (null insts) = sub_comp (key_base p) </> uid_str
+                 | otherwise = sub_comp (key_base p)
+    withTempSession (overHscDynFlags (\dflags ->
+      -- If we're type-checking an indefinite package, we want to
+      -- turn on interface writing.  However, if the user also
+      -- explicitly passed in `-fno-code`, we DON'T want to write
+      -- interfaces unless the user also asked for `-fwrite-interface`.
+      (case session_type of
+        -- Make sure to write interfaces when we are type-checking
+        -- indefinite packages.
+        TcSession | hscTarget dflags /= HscNothing
+                  -> flip gopt_set Opt_WriteInterface
+                  | otherwise -> id
+        CompSession -> id
+        ExeSession -> id) $
+      dflags {
+        hscTarget   = case session_type of
+                        TcSession -> HscNothing
+                        _ -> hscTarget dflags,
+        thisUnitIdInsts = insts,
+        thisPackage =
+            case session_type of
+                TcSession -> newUnitId cid insts
+                -- No hash passed if no instances
+                _ | null insts -> newSimpleUnitId cid
+                  | otherwise  -> newHashedUnitId cid (Just (hashUnitId cid insts)),
+        -- Setup all of the output directories according to our hierarchy
+        objectDir   = Just (outdir objectDir),
+        hiDir       = Just (outdir hiDir),
+        stubDir     = Just (outdir stubDir),
+        -- Unset output-file for non exe builds
+        outputFile  = if session_type == ExeSession
+                        then outputFile dflags
+                        else Nothing,
+        -- Synthesized the flags
+        packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
+          let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)
+          in ExposePackage
+            (showSDoc dflags
+                (text "-unit-id" <+> ppr uid <+> ppr rn))
+            (UnitIdArg uid) rn) deps
+      } )) $ do
+        dflags <- getSessionDynFlags
+        -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
+        -- Calls initPackages
+        _ <- setSessionDynFlags dflags
+        do_this
+
+withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
+withBkpExeSession deps do_this = do
+    withBkpSession (unitIdComponentId mainUnitId) [] deps ExeSession do_this
+
+getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
+getSource cid = do
+    bkp_env <- getBkpEnv
+    case Map.lookup cid (bkp_table bkp_env) of
+        Nothing -> pprPanic "missing needed dependency" (ppr cid)
+        Just lunit -> return lunit
+
+typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
+typecheckUnit cid insts = do
+    lunit <- getSource cid
+    buildUnit TcSession cid insts lunit
+
+compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
+compileUnit cid insts = do
+    -- Let everyone know we're building this unit ID
+    msgUnitId (newUnitId cid insts)
+    lunit <- getSource cid
+    buildUnit CompSession cid insts lunit
+
+-- Invariant: this NEVER returns HashedUnitId
+hsunitDeps :: HsUnit HsComponentId -> [(UnitId, ModRenaming)]
+hsunitDeps unit = concatMap get_dep (hsunitBody unit)
+  where
+    get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn))) = [(convertHsUnitId hsuid, go mb_lrn)]
+      where go Nothing = ModRenaming True []
+            go (Just lrns) = ModRenaming False (map convRn lrns)
+              where convRn (L _ (Renaming from to)) = (from, to)
+    get_dep _ = []
+
+buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
+buildUnit session cid insts lunit = do
+    let deps_w_rns = hsunitDeps (unLoc lunit)
+        raw_deps = map fst deps_w_rns
+    dflags <- getDynFlags
+    -- The compilation dependencies are just the appropriately filled
+    -- in unit IDs which must be compiled before we can compile.
+    let hsubst = listToUFM insts
+        deps0 = map (renameHoleUnitId dflags hsubst) raw_deps
+
+    -- Build dependencies OR make sure they make sense. BUT NOTE,
+    -- we can only check the ones that are fully filled; the rest
+    -- we have to defer until we've typechecked our local signature.
+    -- TODO: work this into GhcMake!!
+    forM_ (zip [1..] deps0) $ \(i, dep) ->
+        case session of
+            TcSession -> return ()
+            _ -> compileInclude (length deps0) (i, dep)
+
+    dflags <- getDynFlags
+    -- IMPROVE IT
+    let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0
+
+    mb_old_eps <- case session of
+                    TcSession -> fmap Just getEpsGhc
+                    _ -> return Nothing
+
+    conf <- withBkpSession cid insts deps_w_rns session $ do
+
+        dflags <- getDynFlags
+        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
+        -- pprTrace "mod_graph" (ppr mod_graph) $ return ()
+
+        msg <- mkBackpackMsg
+        ok <- load' LoadAllTargets (Just msg) mod_graph
+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))
+
+        let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
+            export_mod ms = (ms_mod_name ms, ms_mod ms)
+            -- Export everything!
+            mods = [ export_mod ms | ms <- mod_graph, ms_hsc_src ms == HsSrcFile ]
+
+        -- Compile relevant only
+        hsc_env <- getSession
+        let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)
+            linkables = map (expectJust "bkp link" . hm_linkable)
+                      . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
+                      $ home_mod_infos
+            getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
+            obj_files = concatMap getOfiles linkables
+
+        let compat_fs = (case cid of ComponentId fs -> fs)
+            cand_compat_pn = PackageName compat_fs
+            compat_pn = case session of
+                            TcSession -> cand_compat_pn
+                            _ | [] <- insts -> cand_compat_pn
+                              | otherwise -> PackageName compat_fs
+
+        return InstalledPackageInfo {
+            -- Stub data
+            abiHash = "",
+            sourcePackageId = SourcePackageId compat_fs,
+            packageName = compat_pn,
+            packageVersion = makeVersion [0],
+            unitId = thisPackage dflags,
+            instantiatedWith = insts,
+            -- Slight inefficiency here haha
+            exposedModules = map (\(m,n) -> (m,Just n)) mods,
+            hiddenModules = [], -- TODO: doc only
+            depends = case session of
+                        -- Technically, we should state that we depend
+                        -- on all the indefinite libraries we used to
+                        -- typecheck this.  However, this field isn't
+                        -- really used for anything, so we leave it
+                        -- blank for now.
+                        TcSession -> []
+                        _ -> map (unwireUnitId dflags)
+                                $ deps ++ [ moduleUnitId mod
+                                          | (_, mod) <- insts
+                                          , not (isHoleModule mod) ],
+            ldOptions = case session of
+                            TcSession -> []
+                            _ -> obj_files,
+            importDirs = [ hi_dir ],
+            exposed = False,
+            -- nope
+            hsLibraries = [],
+            extraLibraries = [],
+            extraGHCiLibraries = [],
+            libraryDirs = [],
+            frameworks = [],
+            frameworkDirs = [],
+            ccOptions = [],
+            includes = [],
+            includeDirs = [],
+            haddockInterfaces = [],
+            haddockHTMLs = [],
+            trusted = False
+            }
+
+
+    addPackage conf
+    case mb_old_eps of
+        Just old_eps -> updateEpsGhc_ (const old_eps)
+        _ -> return ()
+
+compileExe :: LHsUnit HsComponentId -> BkpM ()
+compileExe lunit = do
+    msgUnitId mainUnitId
+    let deps_w_rns = hsunitDeps (unLoc lunit)
+        deps = map fst deps_w_rns
+        -- no renaming necessary
+    forM_ (zip [1..] deps) $ \(i, dep) ->
+        compileInclude (length deps) (i, dep)
+    withBkpExeSession deps_w_rns $ do
+        dflags <- getDynFlags
+        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
+        msg <- mkBackpackMsg
+        ok <- load' LoadAllTargets (Just msg) mod_graph
+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))
+
+addPackage :: GhcMonad m => PackageConfig -> m ()
+addPackage pkg = do
+    dflags0 <- GHC.getSessionDynFlags
+    case pkgDatabase dflags0 of
+        Nothing -> panic "addPackage: called too early"
+        Just pkgs -> do let dflags = dflags0 { pkgDatabase =
+                            Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }
+                        _ <- GHC.setSessionDynFlags dflags
+                        -- By this time, the global ref has probably already
+                        -- been forced, in which case doing this isn't actually
+                        -- going to do you any good.
+                        -- dflags <- GHC.getSessionDynFlags
+                        -- liftIO $ setUnsafeGlobalDynFlags dflags
+                        return ()
+
+-- Precondition: UnitId is NOT HashedUnitId
+compileInclude :: Int -> (Int, UnitId) -> BkpM ()
+compileInclude n (i, uid) = do
+    hsc_env <- getSession
+    let dflags = hsc_dflags hsc_env
+    msgInclude (i, n) uid
+    -- Check if we've compiled it already
+    case lookupPackage dflags uid of
+        Nothing -> do
+            case splitUnitIdInsts uid of
+                (_, Just insts) ->
+                    innerBkpM $ compileUnit (unitIdComponentId uid) insts
+                _ -> return ()
+        Just _ -> return ()
+
+-- ----------------------------------------------------------------------------
+-- Backpack monad
+
+-- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
+-- beyond the 'Session', c.f. 'BkpEnv'.
+type BkpM = IOEnv BkpEnv
+
+-- | Backpack environment.  NB: this has a 'Session' and not an 'HscEnv',
+-- because we are going to update the 'HscEnv' as we go.
+data BkpEnv
+    = BkpEnv {
+        -- | The session
+        bkp_session :: Session,
+        -- | The filename of the bkp file we're compiling
+        bkp_filename :: FilePath,
+        -- | Table of source units which we know how to compile
+        bkp_table :: Map ComponentId (LHsUnit HsComponentId),
+        -- | When a package we are compiling includes another package
+        -- which has not been compiled, we bump the level and compile
+        -- that.
+        bkp_level :: Int
+    }
+
+-- Blah, to get rid of the default instance for IOEnv
+-- TODO: just make a proper new monad for BkpM, rather than use IOEnv
+instance {-# OVERLAPPING #-} HasDynFlags BkpM where
+    getDynFlags = fmap hsc_dflags getSession
+
+instance GhcMonad BkpM where
+    getSession = do
+        Session s <- fmap bkp_session getEnv
+        readMutVar s
+    setSession hsc_env = do
+        Session s <- fmap bkp_session getEnv
+        writeMutVar s hsc_env
+
+-- | Get the current 'BkpEnv'.
+getBkpEnv :: BkpM BkpEnv
+getBkpEnv = getEnv
+
+-- | Get the nesting level, when recursively compiling modules.
+getBkpLevel :: BkpM Int
+getBkpLevel = bkp_level `fmap` getBkpEnv
+
+-- | Apply a function on 'DynFlags' on an 'HscEnv'
+overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
+overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) }
+
+-- | Run a 'BkpM' computation, with the nesting level bumped one.
+innerBkpM :: BkpM a -> BkpM a
+innerBkpM do_this = do
+    -- NB: withTempSession mutates, so we don't have to worry
+    -- about bkp_session being stale.
+    updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this
+
+-- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
+updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
+updateEpsGhc_ f = do
+    hsc_env <- getSession
+    liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))
+
+-- | Get the EPS from a 'GhcMonad'.
+getEpsGhc :: GhcMonad m => m ExternalPackageState
+getEpsGhc = do
+    hsc_env <- getSession
+    liftIO $ readIORef (hsc_EPS hsc_env)
+
+-- | Run 'BkpM' in 'Ghc'.
+initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
+initBkpM file bkp m = do
+    reifyGhc $ \session -> do
+    let env = BkpEnv {
+                    bkp_session = session,
+                    bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],
+                    bkp_filename = file,
+                    bkp_level = 0
+                }
+    runIOEnv env m
+
+-- ----------------------------------------------------------------------------
+-- Messaging
+
+-- | Print a compilation progress message, but with indentation according
+-- to @level@ (for nested compilation).
+backpackProgressMsg :: Int -> DynFlags -> String -> IO ()
+backpackProgressMsg level dflags msg =
+    compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg
+
+-- | Creates a 'Messager' for Backpack compilation; this is basically
+-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
+-- handles indentation.
+mkBackpackMsg :: BkpM Messager
+mkBackpackMsg = do
+    level <- getBkpLevel
+    return $ \hsc_env mod_index recomp mod_summary ->
+      let dflags = hsc_dflags hsc_env
+          showMsg msg reason =
+            backpackProgressMsg level dflags $
+                showModuleIndex mod_index ++
+                msg ++ showModMsg dflags (hscTarget dflags)
+                                  (recompileRequired recomp) mod_summary
+                    ++ reason
+      in case recomp of
+            MustCompile -> showMsg "Compiling " ""
+            UpToDate
+                | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  " ""
+                | otherwise -> return ()
+            RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
+
+-- | 'PprStyle' for Backpack messages; here we usually want the module to
+-- be qualified (so we can tell how it was instantiated.) But we try not
+-- to qualify packages so we can use simple names for them.
+backpackStyle :: PprStyle
+backpackStyle =
+    mkUserStyle
+        (QueryQualify neverQualifyNames
+                      alwaysQualifyModules
+                      neverQualifyPackages) AllTheWay
+
+-- | Message when we initially process a Backpack unit.
+msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
+msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
+    dflags <- getDynFlags
+    level <- getBkpLevel
+    liftIO . backpackProgressMsg level dflags
+        $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn
+
+-- | Message when we instantiate a Backpack unit.
+msgUnitId :: UnitId -> BkpM ()
+msgUnitId pk = do
+    dflags <- getDynFlags
+    level <- getBkpLevel
+    liftIO . backpackProgressMsg level dflags
+        $ "Instantiating " ++ renderWithStyle dflags (ppr pk) backpackStyle
+
+-- | Message when we include a Backpack unit.
+msgInclude :: (Int,Int) -> UnitId -> BkpM ()
+msgInclude (i,n) uid = do
+    dflags <- getDynFlags
+    level <- getBkpLevel
+    liftIO . backpackProgressMsg level dflags
+        $ showModuleIndex (i, n) ++ "Including " ++
+          renderWithStyle dflags (ppr uid) backpackStyle
+
+-- ----------------------------------------------------------------------------
+-- Conversion from PackageName to HsComponentId
+
+type PackageNameMap a = Map PackageName a
+
+-- For now, something really simple, since we're not actually going
+-- to use this for anything
+unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
+unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
+    = (pn, HsComponentId pn (ComponentId fs))
+
+packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
+packageNameMap units = Map.fromList (map unitDefines units)
+
+renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
+renameHsUnits dflags m units = map (fmap renameHsUnit) units
+  where
+
+    renamePackageName :: PackageName -> HsComponentId
+    renamePackageName pn =
+        case Map.lookup pn m of
+            Nothing ->
+                case lookupPackageName dflags pn of
+                    Nothing -> error "no package name"
+                    Just cid -> HsComponentId pn cid
+            Just hscid -> hscid
+
+    renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
+    renameHsUnit u =
+        HsUnit {
+            hsunitName = fmap renamePackageName (hsunitName u),
+            hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)
+        }
+
+    renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
+    renameHsUnitDecl (DeclD a b c) = DeclD a b c
+    renameHsUnitDecl (IncludeD idecl) =
+        IncludeD IncludeDecl {
+            idUnitId = fmap renameHsUnitId (idUnitId idecl),
+            idModRenaming = idModRenaming idecl
+        }
+
+    renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
+    renameHsUnitId (HsUnitId ln subst)
+        = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)
+
+    renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
+    renameHsModuleSubst (lk, lm)
+        = (lk, fmap renameHsModuleId lm)
+
+    renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
+    renameHsModuleId (HsModuleVar lm) = HsModuleVar lm
+    renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm
+
+convertHsUnitId :: HsUnitId HsComponentId -> UnitId
+convertHsUnitId (HsUnitId (L _ hscid) subst)
+    = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)
+
+convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
+convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)
+
+convertHsModuleId :: HsModuleId HsComponentId -> Module
+convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname
+convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname
+
+
+
+{-
+************************************************************************
+*                                                                      *
+                        Module graph construction
+*                                                                      *
+************************************************************************
+-}
+
+-- | This is our version of GhcMake.downsweep, but with a few modifications:
+--
+--  1. Every module is required to be mentioned, so we don't do any funny
+--     business with targets or recursively grabbing dependencies.  (We
+--     could support this in principle).
+--  2. We support inline modules, whose summary we have to synthesize ourself.
+--
+-- We don't bother trying to support GhcMake for now, it's more trouble
+-- than it's worth for inline modules.
+hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
+hsunitModuleGraph dflags unit = do
+    let decls = hsunitBody unit
+        pn = hsPackageName (unLoc (hsunitName unit))
+
+    --  1. Create a HsSrcFile/HsigFile summary for every
+    --  explicitly mentioned module/signature.
+    let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do
+          let hsc_src = case dt of
+                          ModuleD    -> HsSrcFile
+                          SignatureD -> HsigFile
+          Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
+        get_decl _ = return Nothing
+    nodes <- catMaybes `fmap` mapM get_decl decls
+
+    --  2. For each hole which does not already have an hsig file,
+    --  create an "empty" hsig file to induce compilation for the
+    --  requirement.
+    let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)
+                                | n <- nodes ]
+    req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) ->
+        let has_local = Map.member (mod_name, True) node_map
+        in if has_local
+            then return Nothing
+            else fmap Just $ summariseRequirement pn mod_name
+
+    -- 3. Return the kaboodle
+    return (nodes ++ req_nodes)
+
+summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
+summariseRequirement pn mod_name = do
+    hsc_env <- getSession
+    let dflags = hsc_dflags hsc_env
+
+    let PackageName pn_fs = pn
+    location <- liftIO $ mkHomeModLocation2 dflags mod_name
+                 (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
+
+    env <- getBkpEnv
+    time <- liftIO $ getModificationUTCTime (bkp_filename env)
+    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
+    let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
+
+    mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
+
+    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
+
+    return ModSummary {
+        ms_mod = mod,
+        ms_hsc_src = HsigFile,
+        ms_location = location,
+        ms_hs_date = time,
+        ms_obj_date = Nothing,
+        ms_iface_date = hi_timestamp,
+        ms_srcimps = [],
+        ms_textual_imps = extra_sig_imports,
+        ms_parsed_mod = Just (HsParsedModule {
+                hpm_module = L loc (HsModule {
+                        hsmodName = Just (L loc mod_name),
+                        hsmodExports = Nothing,
+                        hsmodImports = [],
+                        hsmodDecls = [],
+                        hsmodDeprecMessage = Nothing,
+                        hsmodHaddockModHeader = Nothing
+                    }),
+                hpm_src_files = [],
+                hpm_annotations = (Map.empty, Map.empty)
+            }),
+        ms_hspp_file = "", -- none, it came inline
+        ms_hspp_opts = dflags,
+        ms_hspp_buf = Nothing
+        }
+
+summariseDecl :: PackageName
+              -> HscSource
+              -> Located ModuleName
+              -> Maybe (Located (HsModule RdrName))
+              -> BkpM ModSummary
+summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
+summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
+    = do hsc_env <- getSession
+         let dflags = hsc_dflags hsc_env
+         -- TODO: this looks for modules in the wrong place
+         r <- liftIO $ summariseModule hsc_env
+                         Map.empty -- GHC API recomp not supported
+                         (hscSourceToIsBoot hsc_src)
+                         lmodname
+                         True -- Target lets you disallow, but not here
+                         Nothing -- GHC API buffer support not supported
+                         [] -- No exclusions
+         case r of
+            Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))
+            Just (Left err) -> throwOneError err
+            Just (Right summary) -> return summary
+
+-- | Up until now, GHC has assumed a single compilation target per source file.
+-- Backpack files with inline modules break this model, since a single file
+-- may generate multiple output files.  How do we decide to name these files?
+-- Should there only be one output file? This function our current heuristic,
+-- which is we make a "fake" module and use that.
+hsModuleToModSummary :: PackageName
+                     -> HscSource
+                     -> ModuleName
+                     -> Located (HsModule RdrName)
+                     -> BkpM ModSummary
+hsModuleToModSummary pn hsc_src modname
+                     hsmod@(L loc (HsModule _ _ imps _ _ _)) = do
+    hsc_env <- getSession
+    -- Sort of the same deal as in DriverPipeline's getLocation
+    -- Use the PACKAGE NAME to find the location
+    let PackageName unit_fs = pn
+        dflags = hsc_dflags hsc_env
+    -- Unfortunately, we have to define a "fake" location in
+    -- order to appease the various code which uses the file
+    -- name to figure out where to put, e.g. object files.
+    -- To add insult to injury, we don't even actually use
+    -- these filenames to figure out where the hi files go.
+    -- A travesty!
+    location0 <- liftIO $ mkHomeModLocation2 dflags modname
+                             (unpackFS unit_fs </>
+                              moduleNameSlashes modname)
+                              (case hsc_src of
+                                HsigFile -> "hsig"
+                                HsBootFile -> "hs-boot"
+                                HsSrcFile -> "hs")
+    -- DANGEROUS: bootifying can POISON the module finder cache
+    let location = case hsc_src of
+                        HsBootFile -> addBootSuffixLocn location0
+                        _ -> location0
+    -- This duplicates a pile of logic in GhcMake
+    env <- getBkpEnv
+    time <- liftIO $ getModificationUTCTime (bkp_filename env)
+    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
+
+    -- Also copied from 'getImports'
+    let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
+
+             -- GHC.Prim doesn't exist physically, so don't go looking for it.
+        ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
+                               ord_idecls
+
+        implicit_prelude = xopt LangExt.ImplicitPrelude dflags
+        implicit_imports = mkPrelImports modname loc
+                                         implicit_prelude imps
+        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
+
+    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
+
+    let normal_imports = map convImport (implicit_imports ++ ordinary_imps)
+    required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports
+
+    -- So that Finder can find it, even though it doesn't exist...
+    this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location
+    return ModSummary {
+            ms_mod = this_mod,
+            ms_hsc_src = hsc_src,
+            ms_location = location,
+            ms_hspp_file = (case hiDir dflags of
+                            Nothing -> ""
+                            Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",
+            ms_hspp_opts = dflags,
+            ms_hspp_buf = Nothing,
+            ms_srcimps = map convImport src_idecls,
+            ms_textual_imps = normal_imports
+                           -- We have to do something special here:
+                           -- due to merging, requirements may end up with
+                           -- extra imports
+                           ++ extra_sig_imports
+                           ++ required_by_imports,
+            -- This is our hack to get the parse tree to the right spot
+            ms_parsed_mod = Just (HsParsedModule {
+                    hpm_module = hsmod,
+                    hpm_src_files = [], -- TODO if we preprocessed it
+                    hpm_annotations = (Map.empty, Map.empty) -- BOGUS
+                }),
+            ms_hs_date = time,
+            ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
+            ms_iface_date = hi_timestamp
+        }
diff --git a/compiler/backpack/NameShape.hs b/compiler/backpack/NameShape.hs
new file mode 100644 (file)
index 0000000..568d700
--- /dev/null
@@ -0,0 +1,281 @@
+{-# LANGUAGE CPP #-}
+
+module NameShape(
+    NameShape(..),
+    emptyNameShape,
+    mkNameShape,
+    extendNameShape,
+    nameShapeExports,
+    substNameShape,
+    ) where
+
+#include "HsVersions.h"
+
+import Outputable
+import HscTypes
+import Module
+import UniqFM
+import Avail
+import FieldLabel
+
+import Name
+import NameEnv
+import TcRnMonad
+import Util
+import ListSetOps
+import IfaceEnv
+
+import Control.Monad
+
+-- Note [NameShape]
+-- ~~~~~~~~~~~~~~~~
+-- When we write a declaration in a signature, e.g., data T, we
+-- ascribe to it a *name variable*, e.g., {m.T}.  This
+-- name variable may be substituted with an actual original
+-- name when the signature is implemented (or even if we
+-- merge the signature with one which reexports this entity
+-- from another module).
+
+-- When we instantiate a signature m with a module M,
+-- we also need to substitute over names.  To do so, we must
+-- compute the *name substitution* induced by the *exports*
+-- of the module in question.  A NameShape represents
+-- such a name substitution for a single module instantiation.
+-- The "shape" in the name comes from the fact that the computation
+-- of a name substitution is essentially the *shaping pass* from
+-- Backpack'14, but in a far more restricted form.
+
+-- The name substitution for an export list is easy to explain.  If we are
+-- filling the module variable <m>, given an export N of the form
+-- M.n or {m'.n} (where n is an OccName), the induced name
+-- substitution is from {m.n} to N.  So, for example, if we have
+-- A=impl:B, and the exports of impl:B are impl:B.f and
+-- impl:C.g, then our name substitution is {A.f} to impl:B.f
+-- and {A.g} to impl:C.g
+
+
+
+
+-- The 'NameShape' type is defined in TcRnTypes, because TcRnTypes
+-- needs to refer to NameShape, and having TcRnTypes import
+-- NameShape (even by SOURCE) would cause a large number of
+-- modules to be pulled into the DynFlags cycle.
+{-
+data NameShape = NameShape {
+        ns_mod_name :: ModuleName,
+        ns_exports :: [AvailInfo],
+        ns_map :: OccEnv Name
+    }
+-}
+
+-- NB: substitution functions need 'HscEnv' since they need the name cache
+-- to allocate new names if we change the 'Module' of a 'Name'
+
+-- | Create an empty 'NameShape' (i.e., the renaming that
+-- would occur with an implementing module with no exports)
+-- for a specific hole @mod_name@.
+emptyNameShape :: ModuleName -> NameShape
+emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv
+
+-- | Create a 'NameShape' corresponding to an implementing
+-- module for the hole @mod_name@ that exports a list of 'AvailInfo's.
+mkNameShape :: ModuleName -> [AvailInfo] -> NameShape
+mkNameShape mod_name as =
+    NameShape mod_name as $ mkOccEnv $ do
+        a <- as
+        n <- availName a : availNames a
+        return (occName n, n)
+
+-- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's
+-- with Backpack style mix-in linking.  This is used solely when merging
+-- signatures together: we successively merge the exports of each
+-- signature until we have the final, full exports of the merged signature.
+--
+-- What makes this operation nontrivial is what we are supposed to do when
+-- we want to merge in an export for M.T when we already have an existing
+-- export {H.T}.  What should happen in this case is that {H.T} should be
+-- unified with @M.T@: we've determined a more *precise* identity for the
+-- export at 'OccName' @T@.
+--
+-- Note that we don't do unrestricted unification: only name holes from
+-- @ns_mod_name ns@ are flexible.  This is because we have a much more
+-- restricted notion of shaping than in Backpack'14: we do shaping
+-- *as* we do type-checking.  Thus, once we shape a signature, its
+-- exports are *final* and we're not allowed to refine them further,
+extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape)
+extendNameShape hsc_env ns as =
+    case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of
+        Left err -> return (Left err)
+        Right nsubst -> do
+            as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns)
+            as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as
+            let new_avails = mergeAvails as1 as2
+            return . Right $ ns {
+                ns_exports = new_avails,
+                -- TODO: stop repeatedly rebuilding the OccEnv
+                ns_map = mkOccEnv $ do
+                            a <- new_avails
+                            n <- availName a : availNames a
+                            return (occName n, n)
+                }
+
+-- | The export list associated with this 'NameShape' (i.e., what
+-- the exports of an implementing module which induces this 'NameShape'
+-- would be.)
+nameShapeExports :: NameShape -> [AvailInfo]
+nameShapeExports = ns_exports
+
+-- | Given a 'Name', substitute it according to the 'NameShape' implied
+-- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module
+-- exports @M.T@.
+substNameShape :: NameShape -> Name -> Name
+substNameShape ns n | nameModule n == ns_module ns
+                    , Just n' <- lookupOccEnv (ns_map ns) (occName n)
+                    = n'
+                    | otherwise
+                    = n
+
+-- | The 'Module' of any 'Name's a 'NameShape' has action over.
+ns_module :: NameShape -> Module
+ns_module = mkHoleModule . ns_mod_name
+
+{-
+************************************************************************
+*                                                                      *
+                        Name substitutions
+*                                                                      *
+************************************************************************
+-}
+
+-- | Substitution on @{A.T}@.  We enforce the invariant that the
+-- 'nameModule' of keys of this map have 'moduleUnitId' @hole@
+-- (meaning that if we have a hole substitution, the keys of the map
+-- are never affected.)  Alternately, this is ismorphic to
+-- @Map ('ModuleName', 'OccName') 'Name'@.
+type ShNameSubst = NameEnv Name
+
+-- NB: In this module, we actually only ever construct 'ShNameSubst'
+-- at a single 'ModuleName'.  But 'ShNameSubst' is more convenient to
+-- work with.
+
+-- | Substitute names in a 'Name'.
+substName :: ShNameSubst -> Name -> Name
+substName env n | Just n' <- lookupNameEnv env n = n'
+                | otherwise                      = n
+
+-- | Substitute names in an 'AvailInfo'.  This has special behavior
+-- for type constructors, where it is sufficient to substitute the 'availName'
+-- to induce a substitution on 'availNames'.
+substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
+substNameAvailInfo _ env (Avail p n) = return (Avail p (substName env n))
+substNameAvailInfo hsc_env env (AvailTC n ns fs) =
+    let mb_mod = fmap nameModule (lookupNameEnv env n)
+    in AvailTC (substName env n)
+        <$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns
+        <*> mapM (setNameFieldSelector hsc_env mb_mod) fs
+
+-- | Set the 'Module' of a 'FieldSelector'
+setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel
+setNameFieldSelector _ Nothing f = return f
+setNameFieldSelector hsc_env mb_mod (FieldLabel l b sel) = do
+    sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel
+    return (FieldLabel l b sel')
+
+{-
+************************************************************************
+*                                                                      *
+                        AvailInfo merging
+*                                                                      *
+************************************************************************
+-}
+
+-- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have
+-- already been unified ('uAvailInfos').
+mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo]
+mergeAvails as1 as2 =
+    let mkNE as = mkNameEnv [(availName a, a) | a <- as]
+    in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))
+
+-- | Join two 'AvailInfo's together.
+plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
+plusAvail a1 a2
+  | debugIsOn && availName a1 /= availName a2
+  = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2])
+plusAvail a1@(Avail {})         (Avail {})        = a1
+plusAvail (AvailTC _ [] [])     a2@(AvailTC {})   = a2
+plusAvail a1@(AvailTC {})       (AvailTC _ [] []) = a1
+plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)
+  = case (n1==s1, n2==s2) of  -- Maintain invariant the parent is first
+       (True,True)   -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
+                                   (fs1 `unionLists` fs2)
+       (True,False)  -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
+                                   (fs1 `unionLists` fs2)
+       (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
+                                   (fs1 `unionLists` fs2)
+       (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
+                                   (fs1 `unionLists` fs2)
+plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)
+  = AvailTC n1 ss1 (fs1 `unionLists` fs2)
+plusAvail (AvailTC n1 [] fs1)  (AvailTC _ ss2 fs2)
+  = AvailTC n1 ss2 (fs1 `unionLists` fs2)
+plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
+
+{-
+************************************************************************
+*                                                                      *
+                        AvailInfo unification
+*                                                                      *
+************************************************************************
+-}
+
+-- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@,
+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
+uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst
+uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $
+    let mkOE as = listToUFM $ do a <- as
+                                 n <- availNames a
+                                 return (nameOccName n, a)
+    in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv
+             (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))
+             -- Edward: I have to say, this is pretty clever.
+
+-- | Unify two 'AvailInfo's, given an existing substitution @subst@,
+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
+uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo
+           -> Either SDoc ShNameSubst
+uAvailInfo flexi subst (Avail _ n1) (Avail _ n2) = uName flexi subst n1 n2
+uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2
+uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine"
+                           <+> ppr a1 <+> text "with" <+> ppr a2
+                           <+> parens (text "one is a type, the other is a plain identifier")
+
+-- | Unify two 'Name's, given an existing substitution @subst@,
+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
+uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
+uName flexi subst n1 n2
+    | n1 == n2      = Right subst
+    | isFlexi n1    = uHoleName flexi subst n1 n2
+    | isFlexi n2    = uHoleName flexi subst n2 n1
+    | otherwise     = Left (text "While merging export lists, could not unify"
+                         <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra)
+  where
+    isFlexi n = isHoleName n && moduleName (nameModule n) == flexi
+    extra | isHoleName n1 || isHoleName n2
+          = text "Neither name variable originates from the current signature."
+          | otherwise
+          = empty
+
+-- | Unify a name @h@ which 'isHoleName' with another name, given an existing
+-- substitution @subst@, with only name holes from @flexi@ unifiable (all
+-- other name holes rigid.)
+uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name
+          -> Either SDoc ShNameSubst
+uHoleName flexi subst h n =
+    ASSERT( isHoleName h )
+    case lookupNameEnv subst h of
+        Just n' -> uName flexi subst n' n
+                -- Do a quick check if the other name is substituted.
+        Nothing | Just n' <- lookupNameEnv subst n ->
+                    ASSERT( isHoleName n ) uName flexi subst h n'
+                | otherwise ->
+                    Right (extendNameEnv subst h n)
diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs
new file mode 100644 (file)
index 0000000..536f0b0
--- /dev/null
@@ -0,0 +1,614 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | This module implements interface renaming, which is
+-- used to rewrite interface files on the fly when we
+-- are doing indefinite typechecking and need instantiations
+-- of modules which do not necessarily exist yet.
+
+module RnModIface(
+    rnModIface,
+    rnModExports,
+    ) where
+
+#include "HsVersions.h"
+
+import Outputable
+import HscTypes
+import Module
+import UniqFM
+import Avail
+import IfaceSyn
+import FieldLabel
+import Var
+
+import Name
+import TcRnMonad
+import Util
+import Fingerprint
+import BasicTypes
+
+-- a bit vexing
+import {-# SOURCE #-} LoadIface
+import DynFlags
+
+import qualified Data.Traversable as T
+
+import NameShape
+import IfaceEnv
+
+-- | What we have a generalized ModIface, which corresponds to
+-- a module that looks like p[A=<A>]:B.  We need a *specific* ModIface, e.g.
+-- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load
+-- up (either to merge it, or to just use during typechecking).
+--
+-- Suppose we have:
+--
+--  p[A=<A>]:M  ==>  p[A=q():A]:M
+--
+-- Substitute all occurrences of <A> with q():A (renameHoleModule).
+-- Then, for any Name of form {A.T}, replace the Name with
+-- the Name according to the exports of the implementing module.
+-- This works even for p[A=<B>]:M, since we just read in the
+-- exports of B.hi, which is assumed to be ready now.
+--
+-- This function takes an optional 'NameShape', which can be used
+-- to further refine the identities in this interface: suppose
+-- we read a declaration for {H.T} but we actually know that this
+-- should be Foo.T; then we'll also rename this (this is used
+-- when loading an interface to merge it into a requirement.)
+rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape
+           -> ModIface -> IO ModIface
+rnModIface hsc_env insts nsubst iface = do
+    initRnIface hsc_env iface insts nsubst $ do
+        mod <- rnModule (mi_module iface)
+        sig_of <- case mi_sig_of iface of
+                    Nothing -> return Nothing
+                    Just x  -> fmap Just (rnModule x)
+        exports <- mapM rnAvailInfo (mi_exports iface)
+        decls <- mapM rnIfaceDecl' (mi_decls iface)
+        insts <- mapM rnIfaceClsInst (mi_insts iface)
+        fams <- mapM rnIfaceFamInst (mi_fam_insts iface)
+        -- TODO:
+        -- mi_rules
+        -- mi_vect_info (LOW PRIORITY)
+        return iface { mi_module = mod
+                     , mi_sig_of = sig_of
+                     , mi_insts = insts
+                     , mi_fam_insts = fams
+                     , mi_exports = exports
+                     , mi_decls = decls }
+
+-- | Rename just the exports of a 'ModIface'.  Useful when we're doing
+-- shaping prior to signature merging.
+rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO [AvailInfo]
+rnModExports hsc_env insts iface
+    = initRnIface hsc_env iface insts Nothing
+    $ mapM rnAvailInfo (mi_exports iface)
+
+{-
+************************************************************************
+*                                                                      *
+                        ModIface substitution
+*                                                                      *
+************************************************************************
+-}
+
+-- | Initialize the 'ShIfM' monad.
+initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape
+            -> ShIfM a -> IO a
+initRnIface hsc_env iface insts nsubst do_this =
+    let hsubst = listToUFM insts
+        rn_mod = renameHoleModule (hsc_dflags hsc_env) hsubst
+        env = ShIfEnv {
+            sh_if_module = rn_mod (mi_module iface),
+            sh_if_semantic_module = rn_mod (mi_semantic_module iface),
+            sh_if_hole_subst = listToUFM insts,
+            sh_if_shape = nsubst
+        }
+    in initTcRnIf 'c' hsc_env env () do_this
+
+-- | Environment for 'ShIfM' monads.
+data ShIfEnv = ShIfEnv {
+        -- What we are renaming the ModIface to.  It assumed that
+        -- the original mi_module of the ModIface is
+        -- @generalizeModule (mi_module iface)@.
+        sh_if_module :: Module,
+        -- The semantic module that we are renaming to
+        sh_if_semantic_module :: Module,
+        -- Cached hole substitution, e.g.
+        -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@
+        sh_if_hole_subst :: ShHoleSubst,
+        -- An optional name substitution to be applied when renaming
+        -- the names in the interface.  If this is 'Nothing', then
+        -- we just load the target interface and look at the export
+        -- list to determine the renaming.
+        sh_if_shape :: Maybe NameShape
+    }
+
+getHoleSubst :: ShIfM ShHoleSubst
+getHoleSubst = fmap sh_if_hole_subst getGblEnv
+
+type ShIfM = TcRnIf ShIfEnv ()
+type Rename a = a -> ShIfM a
+
+
+rnModule :: Rename Module
+rnModule mod = do
+    hmap <- getHoleSubst
+    dflags <- getDynFlags
+    return (renameHoleModule dflags hmap mod)
+
+rnAvailInfo :: Rename AvailInfo
+rnAvailInfo (Avail p n) = Avail p <$> rnIfaceGlobal n
+rnAvailInfo (AvailTC n ns fs) = do
+    -- Why don't we rnIfaceGlobal the availName itself?  It may not
+    -- actually be exported by the module it putatively is from, in
+    -- which case we won't be able to tell what the name actually
+    -- is.  But for the availNames they MUST be exported, so they
+    -- will rename fine.
+    ns' <- mapM rnIfaceGlobal ns
+    fs' <- mapM rnFieldLabel fs
+    case ns' ++ map flSelector fs' of
+        [] -> panic "rnAvailInfoEmpty AvailInfo"
+        (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do
+                         n' <- setNameModule (Just (nameModule rep)) n
+                         return (AvailTC n' ns' fs')
+
+rnFieldLabel :: Rename FieldLabel
+rnFieldLabel (FieldLabel l b sel) = do
+    sel' <- rnIfaceGlobal sel
+    return (FieldLabel l b sel')
+
+
+
+
+-- | The key function.  This gets called on every Name embedded
+-- inside a ModIface.  Our job is to take a Name from some
+-- generalized unit ID p[A=<A>, B=<B>], and change
+-- it to the correct name for a (partially) instantiated unit
+-- ID, e.g. p[A=q[]:A, B=<B>].
+--
+-- There are two important things to do:
+--
+-- If a hole is substituted with a real module implementation,
+-- we need to look at that actual implementation to determine what
+-- the true identity of this name should be.  We'll do this by
+-- loading that module's interface and looking at the mi_exports.
+--
+-- However, there is one special exception: when we are loading
+-- the interface of a requirement.  In this case, we may not have
+-- the "implementing" interface, because we are reading this
+-- interface precisely to "merge it in".
+--
+--     External case:
+--         p[A=<B>]:A (and thisUnitId is something else)
+--     We are loading this in order to determine B.hi!  So
+--     don't load B.hi to find the exports.
+--
+--     Local case:
+--         p[A=<A>]:A (and thisUnitId is p[A=<A>])
+--     This should not happen, because the rename is not necessary
+--     in this case, but if it does we shouldn't load A.hi!
+--
+-- Compare me with 'tcIfaceGlobal'!
+
+-- In effect, this function needs compute the name substitution on the
+-- fly.  What it has is the name that we would like to substitute.
+-- If the name is not a hole name {M.x} (e.g. isHoleModule) then
+-- no renaming can take place (although the inner hole structure must
+-- be updated to account for the hole module renaming.)
+rnIfaceGlobal :: Name -> ShIfM Name
+rnIfaceGlobal n = do
+    hsc_env <- getTopEnv
+    let dflags = hsc_dflags hsc_env
+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
+    mb_nsubst <- fmap sh_if_shape getGblEnv
+    hmap <- getHoleSubst
+    let m = nameModule n
+        m' = renameHoleModule dflags hmap m
+    case () of
+       -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so,
+       -- do NOT assume B.hi is available.
+       -- In this case, rename {A.T} to {B.T} but don't look up exports.
+     _ | m' == iface_semantic_mod
+       , isHoleModule m'
+      -- NB: this could be Nothing for computeExports, we have
+      -- nothing to say.
+      -> do fmap (case mb_nsubst of
+                   Nothing -> id
+                   Just nsubst -> substNameShape nsubst)
+                $ setNameModule (Just m') n
+       -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the
+       -- export list is irrelevant.
+       | not (isHoleModule m)
+      -> setNameModule (Just m') n
+       -- The substitution was from <A> to p[]:A.
+       -- But this does not mean {A.T} goes to p[]:A.T:
+       -- p[]:A may reexport T from somewhere else.  Do the name
+       -- substitution.  Furthermore, we need
+       -- to make sure we pick the accurate name NOW,
+       -- or we might accidentally reject a merge.
+       | otherwise
+      -> do -- Make sure we look up the local interface if substitution
+            -- went from <A> to <B>.
+            let m'' = if isHoleModule m'
+                        -- Pull out the local guy!!
+                        then mkModule (thisPackage dflags) (moduleName m')
+                        else m'
+            iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env
+                            $ loadSysInterface (text "rnIfaceGlobal") m''
+            let nsubst = mkNameShape (moduleName m) (mi_exports iface)
+            return (substNameShape nsubst n)
+
+-- PILES AND PILES OF BOILERPLATE
+
+-- | Rename an 'IfaceClsInst', with special handling for an associated
+-- dictionary function.
+rnIfaceClsInst :: Rename IfaceClsInst
+rnIfaceClsInst cls_inst = do
+    n <- rnIfaceGlobal (ifInstCls cls_inst)
+    tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst)
+
+    hmap <- getHoleSubst
+    dflags <- getDynFlags
+
+    -- Note [Bogus DFun renamings]
+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    -- Every 'IfaceClsInst' is associated with a DFun; in fact, when
+    -- we are typechecking only, it is the ONLY place a DFun Id
+    -- can appear.  This DFun must refer to a DFun that is defined
+    -- elsewhere in the 'ModIface'.
+    --
+    -- Unfortunately, DFuns are not exported (don't appear in
+    -- mi_exports), so we can't look at the exports (as we do in
+    -- rnIfaceGlobal) to rename it.
+    --
+    -- We have to rename it to *something*.  So what we do depends
+    -- on the situation:
+    --
+    --  * If the instance wasn't defined in a signature, the DFun
+    --    have a name like p[A=<A>]:B.$fShowFoo.  This is the
+    --    easy case: just apply the module substitution to the
+    --    unit id and go our merry way.
+    --
+    --  * If the instance was defined in a signature, we are in
+    --    an interesting situation.  Suppose we are instantiating
+    --    the signature:
+    --
+    --      signature H where
+    --          instance F T           -- {H.$fxFT}
+    --      module H where
+    --          instance F T where ... -- p[]:H.$fFT
+    --
+    --    In an ideal world, we would map {H.$fxFT} to p[]:H.$fFT.
+    --    But we have no idea what the correct DFun is: the OccNames
+    --    don't match up.  Nor do we really want to wire up {H.$fxFT}
+    --    to p[]:H.$fFT: we'd rather have it point at the DFun
+    --    from the *signature's* interface, and use that type to
+    --    find the actual instance we want to compare against.
+    --
+    --    So, to handle this case, we have to do several things:
+    --
+    --      * In 'rnIfaceClsInst', we just blindly rename the
+    --        the identifier to something that looks vaguely plausible.
+    --        In the instantiating case, we just map {H.$fxFT}
+    --        to p[]:H.$fxFT.  In the merging case, we map
+    --        {H.$fxFT} to {H2.$fxFT}.
+    --
+    --      * In 'lookupIfaceTop', we arrange for the top-level DFun
+    --        to be assigned the very same identifier we picked
+    --        during renaming (p[]:H.$fxFT)
+    --
+    --      * Finally, in 'tcIfaceInstWithDFunTypeEnv', we make sure
+    --        to grab the correct 'TyThing' for the DFun directly
+    --        from the local type environment (which was constructed
+    --        using 'Name's from 'lookupIfaceTop').
+    --
+    --    It's all a bit of a giant Rube Goldberg machine, but it
+    --    seems to work!  Note that the name we pick here doesn't
+    --    really matter, since we throw it out shortly after
+    --    (for merging, we rename all of the DFuns so that they
+    --    are unique; for instantiation, the final interface never
+    --    mentions DFuns since they are implicitly exported.)  The
+    --    important thing is that it's consistent everywhere.
+
+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
+    let m = renameHoleModule dflags hmap $ nameModule (ifDFun cls_inst)
+    -- Doublecheck that this DFun was, indeed, locally defined.
+    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )
+    dfun <- setNameModule (Just m) (ifDFun cls_inst)
+    return cls_inst { ifInstCls = n
+                    , ifInstTys = tys
+                    , ifDFun = dfun
+                    }
+
+rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon)
+rnMaybeIfaceTyCon Nothing = return Nothing
+rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc
+
+rnIfaceFamInst :: Rename IfaceFamInst
+rnIfaceFamInst d = do
+    fam <- rnIfaceGlobal (ifFamInstFam d)
+    tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d)
+    axiom <- rnIfaceGlobal (ifFamInstAxiom d)
+    return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom }
+
+rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl)
+rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl
+
+rnIfaceDecl :: Rename IfaceDecl
+rnIfaceDecl d@IfaceId{} = do
+            ty <- rnIfaceType (ifType d)
+            details <- rnIfaceIdDetails (ifIdDetails d)
+            info <- rnIfaceIdInfo (ifIdInfo d)
+            return d { ifType = ty
+                     , ifIdDetails = details
+                     , ifIdInfo = info
+                     }
+rnIfaceDecl d@IfaceData{} = do
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            ctxt <- mapM rnIfaceType (ifCtxt d)
+            cons <- rnIfaceConDecls (ifCons d)
+            parent <- rnIfaceTyConParent (ifParent d)
+            return d { ifBinders = binders
+                     , ifCtxt = ctxt
+                     , ifCons = cons
+                     , ifParent = parent
+                     }
+rnIfaceDecl d@IfaceSynonym{} = do
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            syn_kind <- rnIfaceType (ifResKind d)
+            syn_rhs <- rnIfaceType (ifSynRhs d)
+            return d { ifBinders = binders
+                     , ifResKind = syn_kind
+                     , ifSynRhs = syn_rhs
+                     }
+rnIfaceDecl d@IfaceFamily{} = do
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            fam_kind <- rnIfaceType (ifResKind d)
+            fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d)
+            return d { ifBinders = binders
+                     , ifResKind = fam_kind
+                     , ifFamFlav = fam_flav
+                     }
+rnIfaceDecl d@IfaceClass{} = do
+            ctxt <- mapM rnIfaceType (ifCtxt d)
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            ats <- mapM rnIfaceAT (ifATs d)
+            sigs <- mapM rnIfaceClassOp (ifSigs d)
+            return d { ifCtxt = ctxt
+                     , ifBinders = binders
+                     , ifATs = ats
+                     , ifSigs = sigs
+                     }
+rnIfaceDecl d@IfaceAxiom{} = do
+            tycon <- rnIfaceTyCon (ifTyCon d)
+            ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d)
+            return d { ifTyCon = tycon
+                     , ifAxBranches = ax_branches
+                     }
+rnIfaceDecl d@IfacePatSyn{} =  do
+            let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b
+            pat_matcher <- rnPat (ifPatMatcher d)
+            pat_builder <- T.traverse rnPat (ifPatBuilder d)
+            pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d)
+            pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d)
+            pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d)
+            pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d)
+            pat_args <- mapM rnIfaceType (ifPatArgs d)
+            pat_ty <- rnIfaceType (ifPatTy d)
+            return d { ifPatMatcher = pat_matcher
+                     , ifPatBuilder = pat_builder
+                     , ifPatUnivBndrs = pat_univ_bndrs
+                     , ifPatExBndrs = pat_ex_bndrs
+                     , ifPatProvCtxt = pat_prov_ctxt
+                     , ifPatReqCtxt = pat_req_ctxt
+                     , ifPatArgs = pat_args
+                     , ifPatTy = pat_ty
+                     }
+
+rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav
+rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs)))
+    = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceGlobal n
+                                                <*> mapM rnIfaceAxBranch axs)
+rnIfaceFamTyConFlav flav = pure flav
+
+rnIfaceAT :: Rename IfaceAT
+rnIfaceAT (IfaceAT decl mb_ty)
+    = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty
+
+rnIfaceTyConParent :: Rename IfaceTyConParent
+rnIfaceTyConParent (IfDataInstance n tc args)
+    = IfDataInstance <$> rnIfaceGlobal n
+                     <*> rnIfaceTyCon tc
+                     <*> rnIfaceTcArgs args
+rnIfaceTyConParent IfNoParent = pure IfNoParent
+
+rnIfaceConDecls :: Rename IfaceConDecls
+rnIfaceConDecls (IfDataTyCon ds b fs)
+    = IfDataTyCon <$> mapM rnIfaceConDecl ds
+                  <*> return b
+                  <*> return fs
+rnIfaceConDecls (IfNewTyCon d b fs) = IfNewTyCon <$> rnIfaceConDecl d <*> return b <*> return fs
+rnIfaceConDecls (IfAbstractTyCon b) = pure (IfAbstractTyCon b)
+
+rnIfaceConDecl :: Rename IfaceConDecl
+rnIfaceConDecl d = do
+    con_ex_tvs <- mapM rnIfaceForAllBndr (ifConExTvs d)
+    let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t
+    con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)
+    con_ctxt <- mapM rnIfaceType (ifConCtxt d)
+    con_arg_tys <- mapM rnIfaceType (ifConArgTys d)
+    let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co
+        rnIfaceBang bang = pure bang
+    con_stricts <- mapM rnIfaceBang (ifConStricts d)
+    return d { ifConExTvs = con_ex_tvs
+             , ifConEqSpec = con_eq_spec
+             , ifConCtxt = con_ctxt
+             , ifConArgTys = con_arg_tys
+             , ifConStricts = con_stricts
+             }
+
+rnIfaceClassOp :: Rename IfaceClassOp
+rnIfaceClassOp (IfaceClassOp n ty dm) = IfaceClassOp n <$> rnIfaceType ty <*> rnMaybeDefMethSpec dm
+
+rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType))
+rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty
+rnMaybeDefMethSpec mb = return mb
+
+rnIfaceAxBranch :: Rename IfaceAxBranch
+rnIfaceAxBranch d = do
+    ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d)
+    lhs <- rnIfaceTcArgs (ifaxbLHS d)
+    rhs <- rnIfaceType (ifaxbRHS d)
+    return d { ifaxbTyVars = ty_vars
+             , ifaxbLHS = lhs
+             , ifaxbRHS = rhs }
+
+rnIfaceIdInfo :: Rename IfaceIdInfo
+rnIfaceIdInfo NoInfo = pure NoInfo
+rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is
+
+rnIfaceInfoItem :: Rename IfaceInfoItem
+rnIfaceInfoItem (HsUnfold lb if_unf)
+    = HsUnfold lb <$> rnIfaceUnfolding if_unf
+rnIfaceInfoItem i
+    = pure i
+
+rnIfaceUnfolding :: Rename IfaceUnfolding
+rnIfaceUnfolding (IfCoreUnfold stable if_expr)
+    = IfCoreUnfold stable <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfCompulsory if_expr)
+    = IfCompulsory <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr)
+    = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfDFunUnfold bs ops)
+    = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops
+
+rnIfaceExpr :: Rename IfaceExpr
+rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name)
+rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl
+rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty
+rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co
+rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args
+rnIfaceExpr (IfaceLam lam_bndr expr)
+    = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr
+rnIfaceExpr (IfaceApp fun arg)
+    = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg
+rnIfaceExpr (IfaceCase scrut case_bndr alts)
+    = IfaceCase <$> rnIfaceExpr scrut
+                <*> pure case_bndr
+                <*> mapM rnIfaceAlt alts
+rnIfaceExpr (IfaceECase scrut ty)
+    = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty
+rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
+    = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs)
+               <*> rnIfaceExpr body
+rnIfaceExpr (IfaceLet (IfaceRec pairs) body)
+    = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) ->
+                                        (,) <$> rnIfaceLetBndr bndr
+                                            <*> rnIfaceExpr rhs) pairs)
+               <*> rnIfaceExpr body
+rnIfaceExpr (IfaceCast expr co)
+    = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co
+rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit)
+rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty
+rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr
+
+rnIfaceBndrs :: Rename [IfaceBndr]
+rnIfaceBndrs = mapM rnIfaceBndr
+
+rnIfaceBndr :: Rename IfaceBndr
+rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty)
+rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceIdBndr <$> rnIfaceTvBndr tv_bndr
+
+rnIfaceTvBndr :: Rename IfaceTvBndr
+rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind
+
+rnIfaceTyConBinder :: Rename IfaceTyConBinder
+rnIfaceTyConBinder (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis
+
+rnIfaceAlt :: Rename IfaceAlt
+rnIfaceAlt (conalt, names, rhs)
+     = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs
+
+rnIfaceConAlt :: Rename IfaceConAlt
+rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ
+rnIfaceConAlt alt = pure alt
+
+rnIfaceLetBndr :: Rename IfaceLetBndr
+rnIfaceLetBndr (IfLetBndr fs ty info)
+    = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info
+
+rnIfaceLamBndr :: Rename IfaceLamBndr
+rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot
+
+rnIfaceCo :: Rename IfaceCoercion
+rnIfaceCo (IfaceReflCo role ty) = IfaceReflCo role <$> rnIfaceType ty
+rnIfaceCo (IfaceFunCo role co1 co2)
+    = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceTyConAppCo role tc cos)
+    = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos
+rnIfaceCo (IfaceAppCo co1 co2)
+    = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceForAllCo bndr co1 co2)
+    = IfaceForAllCo <$> rnIfaceTvBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl
+rnIfaceCo (IfaceAxiomInstCo n i cs)
+    = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs
+rnIfaceCo (IfaceUnivCo s r t1 t2)
+    = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2
+rnIfaceCo (IfaceSymCo c)
+    = IfaceSymCo <$> rnIfaceCo c
+rnIfaceCo (IfaceTransCo c1 c2)
+    = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
+rnIfaceCo (IfaceInstCo c1 c2)
+    = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
+rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c
+rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c
+rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c
+rnIfaceCo (IfaceAxiomRuleCo ax cos)
+    = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos
+rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c
+rnIfaceCo (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
+
+rnIfaceTyCon :: Rename IfaceTyCon
+rnIfaceTyCon (IfaceTyCon n info)
+    = IfaceTyCon <$> rnIfaceGlobal n <*> pure info
+
+rnIfaceExprs :: Rename [IfaceExpr]
+rnIfaceExprs = mapM rnIfaceExpr
+
+rnIfaceIdDetails :: Rename IfaceIdDetails
+rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b
+rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b
+rnIfaceIdDetails details = pure details
+
+rnIfaceType :: Rename IfaceType
+rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n)
+rnIfaceType (IfaceAppTy t1 t2)
+    = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceType t2
+rnIfaceType (IfaceLitTy l)         = return (IfaceLitTy l)
+rnIfaceType (IfaceFunTy t1 t2)
+    = IfaceFunTy <$> rnIfaceType t1 <*> rnIfaceType t2
+rnIfaceType (IfaceDFunTy t1 t2)
+    = IfaceDFunTy <$> rnIfaceType t1 <*> rnIfaceType t2
+rnIfaceType (IfaceTupleTy s i tks)
+    = IfaceTupleTy s i <$> rnIfaceTcArgs tks
+rnIfaceType (IfaceTyConApp tc tks)
+    = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceTcArgs tks
+rnIfaceType (IfaceForAllTy tv t)
+    = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t
+rnIfaceType (IfaceCoercionTy co)
+    = IfaceCoercionTy <$> rnIfaceCo co
+rnIfaceType (IfaceCastTy ty co)
+    = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co
+
+rnIfaceForAllBndr :: Rename IfaceForAllBndr
+rnIfaceForAllBndr (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis
+
+rnIfaceTcArgs :: Rename IfaceTcArgs
+rnIfaceTcArgs (ITC_Invis t ts) = ITC_Invis <$> rnIfaceType t <*> rnIfaceTcArgs ts
+rnIfaceTcArgs (ITC_Vis t ts) = ITC_Vis <$> rnIfaceType t <*> rnIfaceTcArgs ts
+rnIfaceTcArgs ITC_Nil = pure ITC_Nil
index c0e9080..7057db0 100644 (file)
@@ -21,18 +21,53 @@ module Module
         moduleNameString,
         moduleNameSlashes, moduleNameColons,
         moduleStableString,
+        moduleFreeHoles,
+        moduleIsDefinite,
         mkModuleName,
         mkModuleNameFS,
         stableModuleNameCmp,
 
         -- * The UnitId type
-        UnitId,
-        fsToUnitId,
+        ComponentId(..),
+        UnitId(..),
         unitIdFS,
-        stringToUnitId,
+        unitIdKey,
+        unitIdComponentId,
+        IndefUnitId(..),
+        HashedUnitId(..),
+        ShHoleSubst,
+
+        unitIdIsDefinite,
         unitIdString,
+        unitIdFreeHoles,
+
+        newUnitId,
+        newIndefUnitId,
+        newSimpleUnitId,
+        newHashedUnitId,
+        hashUnitId,
+        fsToUnitId,
+        stringToUnitId,
         stableUnitIdCmp,
 
+        -- * HOLE renaming
+        renameHoleUnitId,
+        renameHoleModule,
+        renameHoleUnitId',
+        renameHoleModule',
+
+        -- * Generalization
+        splitModuleInsts,
+        splitUnitIdInsts,
+        generalizeIndefUnitId,
+
+        -- * Parsers
+        parseModuleName,
+        parseUnitId,
+        parseComponentId,
+        parseModuleId,
+        parseModSubst,
+
         -- * Wired-in UnitIds
         -- $wired_in_packages
         primUnitId,
@@ -44,7 +79,7 @@ module Module
         dphParUnitId,
         mainUnitId,
         thisGhcUnitId,
-        holeUnitId, isHoleModule,
+        isHoleModule,
         interactiveUnitId, isInteractiveModule,
         wiredInUnitIds,
 
@@ -53,10 +88,19 @@ module Module
         moduleUnitId, moduleName,
         pprModule,
         mkModule,
+        mkHoleModule,
         stableModuleCmp,
         HasModule(..),
         ContainsModule(..),
 
+        -- * Virgin modules
+        VirginModule,
+        VirginUnitId,
+        VirginModuleEnv,
+
+        -- * Hole module
+        HoleModule,
+
         -- * The ModuleLocation type
         ModLocation(..),
         addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,
@@ -84,17 +128,29 @@ import Outputable
 import Unique
 import UniqFM
 import UniqDFM
+import UniqDSet
 import FastString
 import Binary
 import Util
 import Data.List
 import Data.Ord
-import {-# SOURCE #-} Packages
-import GHC.PackageDb (BinaryStringRep(..), DbModuleRep(..), DbModule(..))
-
+import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..))
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Unsafe as BS
+import qualified Data.ByteString.Char8 as BS.Char8
+import System.IO.Unsafe
+import Foreign.Ptr (castPtr)
+import GHC.Fingerprint
+import Encoding
+
+import qualified Text.ParserCombinators.ReadP as Parse
+import Text.ParserCombinators.ReadP (ReadP, (<++))
+import Data.Char (isAlphaNum)
 import Control.DeepSeq
 import Data.Coerce
 import Data.Data
+import Data.Function
 import Data.Map (Map)
 import Data.Set (Set)
 import qualified Data.Map as Map
@@ -102,9 +158,12 @@ import qualified Data.Set as Set
 import qualified FiniteMap as Map
 import System.FilePath
 
+import {-# SOURCE #-} DynFlags (DynFlags)
+import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap)
+
 -- Note [The identifier lexicon]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Package keys, installed package IDs, ABI hashes, package names,
+-- Unit IDs, installed package IDs, ABI hashes, package names,
 -- versions, there are a *lot* of different identifiers for closely
 -- related things.  What do they all mean? Here's what.  (See also
 -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Packages/Concepts )
@@ -323,12 +382,38 @@ moduleNameColons = dots_to_colons . moduleNameString
 -}
 
 -- | A Module is a pair of a 'UnitId' and a 'ModuleName'.
+--
+-- Module variables (i.e. @<H>@) which can be instantiated to a
+-- specific module at some later point in time are represented
+-- with 'moduleUnitId' set to 'holeUnitId' (this allows us to
+-- avoid having to make 'moduleUnitId' a partial operation.)
+--
 data Module = Module {
    moduleUnitId :: !UnitId,  -- pkg-1.0
    moduleName :: !ModuleName  -- A.B.C
   }
   deriving (Eq, Ord)
 
+-- | Calculate the free holes of a 'Module'.  If this set is non-empty,
+-- this module was defined in an indefinite library that had required
+-- signatures.
+--
+-- If a module has free holes, that means that substitutions can operate on it;
+-- if it has no free holes, substituting over a module has no effect.
+moduleFreeHoles :: Module -> UniqDSet ModuleName
+moduleFreeHoles m
+    | isHoleModule m = unitUniqDSet (moduleName m)
+    | otherwise = unitIdFreeHoles (moduleUnitId m)
+
+-- | A 'Module' is definite if it has no free holes.
+moduleIsDefinite :: Module -> Bool
+moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles
+
+-- | Create a module variable at some 'ModuleName'.
+-- See Note [Representation of module/name variables]
+mkHoleModule :: ModuleName -> Module
+mkHoleModule = mkModule holeUnitId
+
 instance Uniquable Module where
   getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n)
 
@@ -360,21 +445,20 @@ mkModule :: UnitId -> ModuleName -> Module
 mkModule = Module
 
 pprModule :: Module -> SDoc
-pprModule mod@(Module p n)  =
-  pprPackagePrefix p mod <> pprModuleName n
-
-pprPackagePrefix :: UnitId -> Module -> SDoc
-pprPackagePrefix p mod = getPprStyle doc
+pprModule mod@(Module p n)  = getPprStyle doc
  where
-   doc sty
-       | codeStyle sty =
-          if p == mainUnitId
+  doc sty
+    | codeStyle sty =
+        (if p == mainUnitId
                 then empty -- never qualify the main package in code
-                else ztext (zEncodeFS (unitIdFS p)) <> char '_'
-       | qualModule sty mod = ppr (moduleUnitId mod) <> char ':'
-                -- the PrintUnqualified tells us which modules have to
-                -- be qualified with package names
-       | otherwise = empty
+                else ztext (zEncodeFS (unitIdFS p)) <> char '_')
+            <> pprModuleName n
+    | qualModule sty mod =
+        if isHoleModule mod
+            then angleBrackets (pprModuleName n)
+            else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n
+    | otherwise =
+        pprModuleName n
 
 class ContainsModule t where
     extractModule :: t -> Module
@@ -382,9 +466,49 @@ class ContainsModule t where
 class HasModule m where
     getModule :: m Module
 
-instance DbModuleRep UnitId ModuleName Module where
+instance DbUnitIdModuleRep ComponentId UnitId ModuleName Module where
   fromDbModule (DbModule uid mod_name) = mkModule uid mod_name
-  toDbModule mod = DbModule (moduleUnitId mod) (moduleName mod)
+  fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name
+  fromDbUnitId (DbUnitId { dbUnitIdComponentId = cid, dbUnitIdInsts = insts })
+    = newUnitId cid insts
+  fromDbUnitId (DbHashedUnitId cid hash)
+    = newHashedUnitId cid (fmap mkFastStringByteString hash)
+  -- GHC never writes to the database, so it's not needed
+  toDbModule = error "toDbModule: not implemented"
+  toDbUnitId = error "toDbUnitId: not implemented"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{ComponentId}
+*                                                                      *
+************************************************************************
+-}
+
+-- | A 'ComponentId' consists of the package name, package version, component
+-- ID, the transitive dependencies of the component, and other information to
+-- uniquely identify the source code and build configuration of a component.
+--
+-- This used to be known as an 'InstalledPackageId', but a package can contain
+-- multiple components and a 'ComponentId' uniquely identifies a component
+-- within a package.  When a package only has one component, the 'ComponentId'
+-- coincides with the 'InstalledPackageId'
+newtype ComponentId        = ComponentId        FastString deriving (Eq, Ord)
+
+instance BinaryStringRep ComponentId where
+  fromStringRep = ComponentId . mkFastStringByteString
+  toStringRep (ComponentId s) = fastStringToByteString s
+
+instance Uniquable ComponentId where
+  getUnique (ComponentId n) = getUnique n
+
+instance Outputable ComponentId where
+  ppr cid@(ComponentId fs) =
+    getPprStyle $ \sty ->
+    sdocWithDynFlags $ \dflags ->
+      case componentIdString dflags cid of
+        Just str | not (debugStyle sty) -> text str
+        _ -> ftext fs
 
 {-
 ************************************************************************
@@ -394,15 +518,271 @@ instance DbModuleRep UnitId ModuleName Module where
 ************************************************************************
 -}
 
--- | A string which uniquely identifies a package.  For wired-in packages,
--- it is just the package name, but for user compiled packages, it is a hash.
--- ToDo: when the key is a hash, we can do more clever things than store
--- the hex representation and hash-cons those strings.
-newtype UnitId = PId FastString deriving Eq
-    -- here to avoid module loops with PackageConfig
+-- | A unit identifier uniquely identifies a library (e.g.,
+-- a package) in GHC.  In the absence of Backpack, unit identifiers
+-- are just strings ('SimpleUnitId'); however, if a library is
+-- parametrized over some signatures, these identifiers need
+-- more structure.
+data UnitId
+    = AnIndefUnitId {-# UNPACK #-} !IndefUnitId
+    | AHashedUnitId {-# UNPACK #-} !HashedUnitId
+    deriving (Typeable)
+
+unitIdFS :: UnitId -> FastString
+unitIdFS (AnIndefUnitId x) = indefUnitIdFS x
+unitIdFS (AHashedUnitId x) = hashedUnitIdFS x
+
+unitIdKey :: UnitId -> Unique
+unitIdKey (AnIndefUnitId x) = indefUnitIdKey x
+unitIdKey (AHashedUnitId x) = hashedUnitIdKey x
+
+unitIdComponentId :: UnitId -> ComponentId
+unitIdComponentId (AnIndefUnitId x) = indefUnitIdComponentId x
+unitIdComponentId (AHashedUnitId x) = hashedUnitIdComponentId x
+
+-- | A non-hashed unit identifier identifies an indefinite
+-- library (with holes) which has been *on-the-fly* instantiated
+-- with a substitution 'unitIdInsts_'.  These unit identifiers
+-- are recorded in interface files and installed package
+-- database entries for indefinite libraries.  We can substitute
+-- over these identifiers.
+--
+-- A non-hashed unit identifier pretty-prints to something like
+-- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the
+-- brackets enclose the module substitution).
+data IndefUnitId
+    = IndefUnitId {
+        -- | A private, uniquely identifying representation of
+        -- a UnitId.  This string is completely private to GHC
+        -- and is just used to get a unique; in particular, we don't use it for
+        -- symbols (indefinite libraries are not compiled).
+        indefUnitIdFS :: FastString,
+        -- | Cached unique of 'unitIdFS'.
+        indefUnitIdKey :: Unique,
+        -- | The component identity of the indefinite library that
+        -- is being instantiated.
+        indefUnitIdComponentId :: !ComponentId,
+        -- | The sorted (by 'ModuleName') instantiations of this library.
+        indefUnitIdInsts :: ![(ModuleName, Module)],
+        -- | A cache of the free module variables of 'unitIdInsts'.
+        -- This lets us efficiently tell if a 'UnitId' has been
+        -- fully instantiated (free module variables are empty)
+        -- and whether or not a substitution can have any effect.
+        indefUnitIdFreeHoles :: UniqDSet ModuleName
+    } deriving (Typeable)
+
+-- | A hashed unit identifier identifies an indefinite library which has
+-- been fully instantiated, compiled and installed to the package database.
+-- The ONLY source of hashed unit identifiers is the package database and
+-- the @-this-unit-id@ flag: if a non-hashed unit id is substituted into one
+-- with no holes, you don't necessarily get a hashed unit id: a hashed unit
+-- id means *you have actual code*.  To promote a fully instantiated unit
+-- identifier into a hashed unit identifier, you have to look it up in the
+-- package database.
+--
+-- Hashed unit identifiers don't record the full instantiation tree,
+-- making them a bit more efficient to work with.  This is possible
+-- because substituting over a hashed unit id is always a no-op
+-- (no free module variables)
+--
+-- Hashed unit identifiers look something like @p+af23SAj2dZ219@
+data HashedUnitId =
+    HashedUnitId {
+      -- | The full hashed unit identifier, including the component id
+      -- and the hash.
+      hashedUnitIdFS :: FastString,
+      -- | Cached unique of 'unitIdFS'.
+      hashedUnitIdKey :: Unique,
+      -- | The component identifier of the hashed unit identifier.
+      hashedUnitIdComponentId :: !ComponentId
+    }
+   deriving (Typeable)
+
+instance Eq IndefUnitId where
+  u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2
+
+instance Ord IndefUnitId where
+  u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2
+
+instance Outputable HashedUnitId where
+    ppr uid =
+        if hashedUnitIdComponentId uid == ComponentId (hashedUnitIdFS uid)
+            then ppr (hashedUnitIdComponentId uid)
+            else ftext (hashedUnitIdFS uid)
+
+instance Outputable IndefUnitId where
+    ppr uid =
+      -- getPprStyle $ \sty ->
+      ppr cid <>
+        (if not (null insts) -- pprIf
+          then
+            -- TODO: Print an instantiation if (1) we would not have qualified
+            -- the module and (2) the module name and module agree
+            let -- is_wanted (mod_name, mod) = qualModule sty mod
+                --                         || mod_name /= moduleName mod
+                (wanted, unwanted) = (insts, [])
+                    {-
+                    -- This was more annoying than helpful
+                    | debugStyle sty = (insts, [])
+                    | otherwise = partition is_wanted insts
+                    -}
+            in brackets (hsep
+                (punctuate comma $
+                    [ ppr modname <> text "=" <> ppr m
+                    | (modname, m) <- wanted] ++
+                    if not (null unwanted) then [text "..."] else []))
+          else empty)
+     where
+      cid   = indefUnitIdComponentId uid
+      insts = indefUnitIdInsts uid
+
+{-
+newtype DefiniteUnitId  = DefiniteUnitId  HashedUnitId
+    deriving (Eq, Ord, Outputable, Typeable)
+
+newtype InstalledUnitId = InstalledUnitId HashedUnitId
+    deriving (Eq, Ord, Outputable, Typeable)
+-}
+
+-- | A 'VirginModule' is a 'Module' which contains a 'VirginUnitId'.
+type VirginModule = Module
+
+-- | A virgin unit id is either a 'HashedUnitId',
+-- or a 'UnitId' whose instantiation all have the form @A=<A>@.
+-- Intuitively, virgin unit identifiers are those which are recorded
+-- in the installed package database and can be read off disk.
+type VirginUnitId = UnitId
+
+-- | A map keyed off of 'VirginModule'
+type VirginModuleEnv elt = ModuleEnv elt
+
+-- | A hole module is a 'Module' representing a required
+-- signature that we are going to merge in.  The unit id
+-- of such a hole module is guaranteed to be equipped with
+-- an instantiation.
+type HoleModule = (IndefUnitId, ModuleName)
+
+-- Note [UnitId to HashedUnitId improvement]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Just because a UnitId is definite (has no holes) doesn't
+-- mean it's necessarily a HashedUnitId; it could just be
+-- that over the course of renaming UnitIds on the fly
+-- while typechecking an indefinite library, we
+-- ended up with a fully instantiated unit id with no hash,
+-- since we haven't built it yet.  This is fine.
+--
+-- However, if there is a hashed unit id for this instantiation
+-- in the package database, we *better use it*, because
+-- that hashed unit id may be lurking in another interface,
+-- and chaos will ensue if we attempt to compare the two
+-- (the unitIdFS for a UnitId never corresponds to a Cabal-provided
+-- hash of a compiled instantiated library).
+--
+-- There is one last niggle which is not currently fixed:
+-- improvement based on the package database means that
+-- we might end up developing on a package that is not transitively
+-- depended upon by the packages the user specified directly
+-- via command line flags.  This could lead to strange and
+-- difficult to understand bugs if those instantiations are
+-- out of date.  The fix is that GHC has to be a bit more
+-- careful about what instantiated packages get put in the package database.
+-- I haven't implemented this yet.
+
+-- | Retrieve the set of free holes of a 'UnitId'.
+unitIdFreeHoles :: UnitId -> UniqDSet ModuleName
+unitIdFreeHoles (AnIndefUnitId x) = indefUnitIdFreeHoles x
+-- Hashed unit ids are always fully instantiated
+unitIdFreeHoles (AHashedUnitId _) = emptyUniqDSet
+
+instance Show UnitId where
+    show = unitIdString
+
+-- | A 'UnitId' is definite if it has no free holes.
+unitIdIsDefinite :: UnitId -> Bool
+unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles
+
+-- | Generate a uniquely identifying 'FastString' for a unit
+-- identifier.  This is a one-way function.  You can rely on one special
+-- property: if a unit identifier is in most general form, its 'FastString'
+-- coincides with its 'ComponentId'.  This hash is completely internal
+-- to GHC and is not used for symbol names or file paths.
+hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString
+hashUnitId (ComponentId fs_cid) sorted_holes
+    -- Make the special-case work.
+    | all (\(mod_name, m) -> mkHoleModule mod_name == m) sorted_holes = fs_cid
+hashUnitId cid sorted_holes =
+    mkFastStringByteString
+  . fingerprintUnitId (toStringRep cid)
+  $ rawHashUnitId sorted_holes
+
+rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint
+rawHashUnitId sorted_holes =
+    fingerprintByteString
+  . BS.concat $ do
+        (m, b) <- sorted_holes
+        [ toStringRep m,                BS.Char8.singleton ' ',
+          fastStringToByteString (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':',
+          toStringRep (moduleName b),   BS.Char8.singleton '\n']
+
+fingerprintByteString :: BS.ByteString -> Fingerprint
+fingerprintByteString bs = unsafePerformIO
+                         . BS.unsafeUseAsCStringLen bs
+                         $ \(p,l) -> fingerprintData (castPtr p) l
+
+fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString
+fingerprintUnitId prefix (Fingerprint a b)
+    = BS.concat
+    $ [ prefix
+      , BS.Char8.singleton '-'
+      , BS.Char8.pack (toBase62Padded a)
+      , BS.Char8.pack (toBase62Padded b) ]
+
+-- | Create a new, externally provided hashed unit id from
+-- a hash.
+newHashedUnitId :: ComponentId -> Maybe FastString -> UnitId
+newHashedUnitId cid@(ComponentId cid_fs) (Just fs)
+    = rawNewHashedUnitId cid (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
+newHashedUnitId cid@(ComponentId cid_fs) Nothing
+    = rawNewHashedUnitId cid cid_fs
+
+-- | Smart constructor for 'HashedUnitId'; input 'FastString'
+-- is assumed to be the FULL identifying string for this
+-- UnitId (e.g., it contains the 'ComponentId').
+rawNewHashedUnitId :: ComponentId -> FastString -> UnitId
+rawNewHashedUnitId cid fs = AHashedUnitId $ HashedUnitId {
+        hashedUnitIdFS = fs,
+        hashedUnitIdKey = getUnique fs,
+        hashedUnitIdComponentId = cid
+    }
+
+-- | Create a new, un-hashed unit identifier.
+newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId
+newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug...
+newUnitId cid insts = AnIndefUnitId $ newIndefUnitId cid insts
+
+newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId
+newIndefUnitId cid insts =
+    IndefUnitId {
+        indefUnitIdComponentId = cid,
+        indefUnitIdInsts = sorted_insts,
+        indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
+        indefUnitIdFS = fs,
+        indefUnitIdKey = getUnique fs
+    }
+  where
+     fs = hashUnitId cid sorted_insts
+     sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts
+
+
+pprUnitId :: UnitId -> SDoc
+pprUnitId (AHashedUnitId uid) = ppr uid
+pprUnitId (AnIndefUnitId uid) = ppr uid
+
+instance Eq UnitId where
+  uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2
 
 instance Uniquable UnitId where
- getUnique pid = getUnique (unitIdFS pid)
+  getUnique = unitIdKey
 
 instance Ord UnitId where
   nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2
@@ -421,28 +801,58 @@ stableUnitIdCmp :: UnitId -> UnitId -> Ordering
 stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2
 
 instance Outputable UnitId where
-   ppr pk = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags ->
-    case unitIdPackageIdString dflags pk of
-      Nothing -> ftext (unitIdFS pk)
-      Just pkg -> text pkg
-           -- Don't bother qualifying if it's wired in!
-           <> (if qualPackage sty pk && not (pk `elem` wiredInUnitIds)
-                then char '@' <> ftext (unitIdFS pk)
-                else empty)
+   ppr pk = pprUnitId pk
 
+-- Performance: would prefer to have a NameCache like thing
 instance Binary UnitId where
-  put_ bh pid = put_ bh (unitIdFS pid)
-  get bh = do { fs <- get bh; return (fsToUnitId fs) }
+  put_ bh (AHashedUnitId uid)
+    | cid == ComponentId fs = do
+        putByte bh 0
+        put_ bh fs
+    | otherwise = do
+        putByte bh 2
+        put_ bh cid
+        put_ bh fs
+   where
+    cid = hashedUnitIdComponentId uid
+    fs  = hashedUnitIdFS uid
+  put_ bh (AnIndefUnitId uid) = do
+    putByte bh 1
+    put_ bh cid
+    put_ bh insts
+   where
+    cid   = indefUnitIdComponentId uid
+    insts = indefUnitIdInsts uid
+  get bh = do b <- getByte bh
+              case b of
+                0 -> fmap fsToUnitId (get bh)
+                1 -> do
+                  cid   <- get bh
+                  insts <- get bh
+                  return (newUnitId cid insts)
+                _ -> do
+                  cid <- get bh
+                  fs  <- get bh
+                  return (rawNewHashedUnitId cid fs)
 
 instance BinaryStringRep UnitId where
-  fromStringRep = fsToUnitId . mkFastStringByteString
-  toStringRep   = fastStringToByteString . unitIdFS
+  fromStringRep bs = rawNewHashedUnitId (fromStringRep cid) (mkFastStringByteString bs)
+    where cid = BS.Char8.takeWhile (/='+') bs
+  -- GHC doesn't write to database
+  toStringRep   = error "BinaryStringRep UnitId: not implemented"
 
-fsToUnitId :: FastString -> UnitId
-fsToUnitId = PId
+instance Binary ComponentId where
+  put_ bh (ComponentId fs) = put_ bh fs
+  get bh = do { fs <- get bh; return (ComponentId fs) }
 
-unitIdFS :: UnitId -> FastString
-unitIdFS (PId fs) = fs
+-- | Create a new simple unit identifier (no holes) from a 'ComponentId'.
+newSimpleUnitId :: ComponentId -> UnitId
+newSimpleUnitId (ComponentId fs) = fsToUnitId fs
+
+-- | Create a new simple unit identifier from a 'FastString'.  Internally,
+-- this is primarily used to specify wired-in unit identifiers.
+fsToUnitId :: FastString -> UnitId
+fsToUnitId fs = rawNewHashedUnitId (ComponentId fs) fs
 
 stringToUnitId :: String -> UnitId
 stringToUnitId = fsToUnitId . mkFastString
@@ -450,6 +860,126 @@ stringToUnitId = fsToUnitId . mkFastString
 unitIdString :: UnitId -> String
 unitIdString = unpackFS . unitIdFS
 
+{-
+************************************************************************
+*                                                                      *
+                        Hole substitutions
+*                                                                      *
+************************************************************************
+-}
+
+-- | Substitution on module variables, mapping module names to module
+-- identifiers.
+type ShHoleSubst = ModuleNameEnv Module
+
+-- | Substitutes holes in a 'Module'.  NOT suitable for being called
+-- directly on a 'nameModule', see Note [Representation of module/name variable].
+-- @p[A=<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@;
+-- similarly, @<A>@ maps to @q():A@.
+renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module
+renameHoleModule dflags = renameHoleModule' (getPackageConfigMap dflags)
+
+-- | Substitutes holes in a 'UnitId', suitable for renaming when
+-- an include occurs; see Note [Representation of module/name variable].
+--
+-- @p[A=<A>]@ maps to @p[A=<B>]@ with @A=<B>@.
+renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId
+renameHoleUnitId dflags = renameHoleUnitId' (getPackageConfigMap dflags)
+
+-- | Like 'renameHoleModule', but requires only 'PackageConfigMap'
+-- so it can be used by "Packages".
+renameHoleModule' :: PackageConfigMap -> ShHoleSubst -> Module -> Module
+renameHoleModule' pkg_map env m
+  | not (isHoleModule m) =
+        let uid = renameHoleUnitId' pkg_map env (moduleUnitId m)
+        in mkModule uid (moduleName m)
+  | Just m' <- lookupUFM env (moduleName m) = m'
+  -- NB m = <Blah>, that's what's in scope.
+  | otherwise = m
+
+-- | Like 'renameHoleUnitId, but requires only 'PackageConfigMap'
+-- so it can be used by "Packages".
+renameHoleUnitId' :: PackageConfigMap -> ShHoleSubst -> UnitId -> UnitId
+renameHoleUnitId' pkg_map env uid =
+    case uid of
+      (AnIndefUnitId
+        IndefUnitId{ indefUnitIdComponentId = cid
+                   , indefUnitIdInsts       = insts
+                   , indefUnitIdFreeHoles   = fh })
+          -> if isNullUFM (intersectUFM_C const (udfmToUfm fh) env)
+                then uid
+                -- Functorially apply the substitution to the instantiation,
+                -- then check the 'PackageConfigMap' to see if there is
+                -- a compiled version of this 'UnitId' we can improve to.
+                -- See Note [UnitId to HashedUnitId] improvement
+                else improveUnitId pkg_map $
+                        newUnitId cid
+                            (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts)
+      _ -> uid
+
+-- | Given a possibly on-the-fly instantiated module, split it into
+-- a 'Module' that we definitely can find on-disk, as well as an
+-- instantiation if we need to instantiate it on the fly.  If the
+-- instantiation is @Nothing@ no on-the-fly renaming is needed.
+splitModuleInsts :: Module -> (VirginModule, Maybe [(ModuleName, Module)])
+splitModuleInsts m =
+    let (uid, mb_insts) = splitUnitIdInsts (moduleUnitId m)
+    in (mkModule uid (moduleName m), mb_insts)
+
+-- | See 'splitModuleInsts'.
+splitUnitIdInsts :: UnitId -> (VirginUnitId, Maybe [(ModuleName, Module)])
+splitUnitIdInsts (AnIndefUnitId iuid) =
+    (AnIndefUnitId (generalizeIndefUnitId iuid), Just (indefUnitIdInsts iuid))
+splitUnitIdInsts uid = (uid, Nothing)
+
+generalizeIndefUnitId :: IndefUnitId -> IndefUnitId
+generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid
+                                 , indefUnitIdInsts = insts } =
+    newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts)
+
+parseModuleName :: ReadP ModuleName
+parseModuleName = fmap mkModuleName
+                $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.")
+
+parseUnitId :: ReadP UnitId
+parseUnitId = parseFullUnitId <++ parseHashedUnitId <++ parseSimpleUnitId
+  where
+    parseFullUnitId = do cid <- parseComponentId
+                         insts <- parseModSubst
+                         return (newUnitId cid insts)
+    parseHashedUnitId = do cid <- parseComponentId
+                           _ <- Parse.char '+'
+                           hash <- Parse.munch1 isAlphaNum
+                           return (newHashedUnitId cid (Just (mkFastString hash)))
+    parseSimpleUnitId = do cid <- parseComponentId
+                           return (newSimpleUnitId cid)
+
+parseComponentId :: ReadP ComponentId
+parseComponentId = (ComponentId . mkFastString)  `fmap` Parse.munch1 abi_char
+   where abi_char c = isAlphaNum c || c `elem` "-_."
+
+parseModuleId :: ReadP Module
+parseModuleId = parseModuleVar <++ parseModule
+    where
+      parseModuleVar = do
+        _ <- Parse.char '<'
+        modname <- parseModuleName
+        _ <- Parse.char '>'
+        return (mkHoleModule modname)
+      parseModule = do
+        uid <- parseUnitId
+        _ <- Parse.char ':'
+        modname <- parseModuleName
+        return (mkModule uid modname)
+
+parseModSubst :: ReadP [(ModuleName, Module)]
+parseModSubst = Parse.between (Parse.char '[') (Parse.char ']')
+      . flip Parse.sepBy (Parse.char ',')
+      $ do k <- parseModuleName
+           _ <- Parse.char '='
+           v <- parseModuleId
+           return (k, v)
+
 
 -- -----------------------------------------------------------------------------
 -- $wired_in_packages
@@ -497,12 +1027,34 @@ mainUnitId      = fsToUnitId (fsLit "main")
 
 -- | This is a fake package id used to provide identities to any un-implemented
 -- signatures.  The set of hole identities is global over an entire compilation.
+-- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead.
+-- See Note [Representation of module/name variables]
 holeUnitId :: UnitId
 holeUnitId      = fsToUnitId (fsLit "hole")
 
 isInteractiveModule :: Module -> Bool
 isInteractiveModule mod = moduleUnitId mod == interactiveUnitId
 
+-- Note [Representation of module/name variables]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- In our ICFP'16, we use <A> to represent module holes, and {A.T} to represent
+-- name holes.  This could have been represented by adding some new cases
+-- to the core data types, but this would have made the existing 'nameModule'
+-- and 'moduleUnitId' partial, which would have required a lot of modifications
+-- to existing code.
+--
+-- Instead, we adopted the following encoding scheme:
+--
+--      <A>   ===> hole:A
+--      {A.T} ===> hole:A.T
+--
+-- This encoding is quite convenient, but it is also a bit dangerous too,
+-- because if you have a 'hole:A' you need to know if it's actually a
+-- 'Module' or just a module stored in a 'Name'; these two cases must be
+-- treated differently when doing substitutions.  'renameHoleModule'
+-- and 'renameHoleUnitId' assume they are NOT operating on a
+-- 'Name'; 'NameShape' handles name substitutions exclusively.
+
 isHoleModule :: Module -> Bool
 isHoleModule mod = moduleUnitId mod == holeUnitId
 
@@ -526,6 +1078,7 @@ wiredInUnitIds = [ primUnitId,
 
 -- | A map keyed off of 'Module's
 newtype ModuleEnv elt = ModuleEnv (Map NDModule elt)
+
 {-
 Note [ModuleEnv performance and determinism]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index d8b7a61..4cb35ca 100644 (file)
@@ -1,8 +1,11 @@
 module Module where
+import FastString
 
 data Module
 data ModuleName
 data UnitId
+newtype ComponentId = ComponentId FastString
+
 moduleName :: Module -> ModuleName
 moduleUnitId :: Module -> UnitId
 unitIdString :: UnitId -> String
index d1b05f3..bcb4309 100644 (file)
@@ -531,7 +531,12 @@ pprExternal sty uniq mod occ is_wired is_builtin
                                       pprNameSpaceBrief (occNameSpace occ),
                                       pprUnique uniq])
   | BuiltInSyntax <- is_builtin = ppr_occ_name occ  -- Never qualify builtin syntax
-  | otherwise                   = pprModulePrefix sty mod occ <> ppr_occ_name occ
+  | otherwise                   =
+        if isHoleModule mod
+            then case qualName sty mod occ of
+                    NameUnqual -> ppr_occ_name occ
+                    _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ)
+            else pprModulePrefix sty mod occ <> ppr_occ_name occ
   where
     pp_mod = sdocWithDynFlags $ \dflags ->
              if gopt Opt_SuppressModulePrefixes dflags
index 6a6c012..72d2f9b 100644 (file)
@@ -111,16 +111,21 @@ mkDependencies
 mkUsedNames :: TcGblEnv -> NameSet
 mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
 
-mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage]
-mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
+mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> [(Module, Fingerprint)] -> IO [Usage]
+mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged
   = do
     eps <- hscEPS hsc_env
     hashes <- mapM getFileHash dependent_files
     let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
                                        dir_imp_mods used_names
-    let usages = mod_usages ++ [ UsageFile { usg_file_path = f
+        usages = mod_usages ++ [ UsageFile { usg_file_path = f
                                            , usg_file_hash = hash }
                                | (f, hash) <- zip dependent_files hashes ]
+                            ++ [ UsageMergedRequirement
+                                    { usg_mod = mod,
+                                      usg_mod_hash = hash
+                                    }
+                               | (mod, hash) <- merged ]
     usages `seqList` return usages
     -- seq the list of Usages returned: occasionally these
     -- don't get evaluated for a while and we can end up hanging on to
@@ -265,7 +270,8 @@ deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
 
 deSugar hsc_env
         mod_loc
-        tcg_env@(TcGblEnv { tcg_mod          = mod,
+        tcg_env@(TcGblEnv { tcg_mod          = id_mod,
+                            tcg_semantic_mod = mod,
                             tcg_src          = hsc_src,
                             tcg_type_env     = type_env,
                             tcg_imports      = imports,
@@ -276,6 +282,7 @@ deSugar hsc_env
                             tcg_fix_env      = fix_env,
                             tcg_inst_env     = inst_env,
                             tcg_fam_inst_env = fam_inst_env,
+                            tcg_merged       = merged,
                             tcg_warns        = warns,
                             tcg_anns         = anns,
                             tcg_binds        = binds,
@@ -359,7 +366,10 @@ deSugar hsc_env
         ; used_th <- readIORef tc_splice_used
         ; dep_files <- readIORef dependent_files
         ; safe_mode <- finalSafeMode dflags tcg_env
-        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files
+        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files merged
+        -- id_mod /= mod when we are processing an hsig, but hsigs
+        -- never desugared and compiled (there's no code!)
+        ; MASSERT ( id_mod == mod )
 
         ; let mod_guts = ModGuts {
                 mg_module       = mod,
index b41c23a..67f0aa6 100644 (file)
@@ -133,6 +133,7 @@ Library
         cbits/genSym.c
 
     hs-source-dirs:
+        backpack
         basicTypes
         cmm
         codeGen
@@ -159,6 +160,10 @@ Library
         vectorise
 
     Exposed-Modules:
+        DriverBkp
+        BkpSyn
+        NameShape
+        RnModIface
         Avail
         BasicTypes
         ConLike
@@ -423,6 +428,7 @@ Library
         TcPat
         TcPatSyn
         TcRnDriver
+        TcBackpack
         TcRnMonad
         TcRnTypes
         TcRules
index ff2f648..96bd36f 100644 (file)
@@ -11,6 +11,7 @@ module IfaceEnv (
         extendIfaceIdEnv, extendIfaceTyVarEnv,
         tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
         lookupIfaceTyVar, extendIfaceEnvs,
+        setNameModule,
 
         ifaceExportNames,
 
@@ -174,6 +175,12 @@ externaliseName mod name
              ns'   = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }
          in (ns', name') }
 
+-- | Set the 'Module' of a 'Name'.
+setNameModule :: Maybe Module -> Name -> TcRnIf m n Name
+setNameModule Nothing n = return n
+setNameModule (Just m) n =
+    newGlobalBinder m (nameOccName n) (nameSrcSpan n)
+
 {-
 ************************************************************************
 *                                                                      *
@@ -330,8 +337,25 @@ extendIfaceEnvs tcvs thing_inside
 
 lookupIfaceTop :: OccName -> IfL Name
 -- Look up a top-level name from the current Iface module
-lookupIfaceTop occ
-  = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
+lookupIfaceTop occ = do
+    lcl_env <- getLclEnv
+    -- NB: this is a semantic module, see
+    -- Note [Identity versus semantic module]
+    mod <- getIfModule
+    case if_nsubst lcl_env of
+        -- NOT substNameShape because 'getIfModule' returns the
+        -- renamed module (d'oh!)
+        Just nsubst ->
+            case lookupOccEnv (ns_map nsubst) occ of
+              Just n' ->
+                -- I thought this would be help but it turns out
+                -- n' doesn't have any useful information. Drat!
+                -- return (setNameLoc n' (nameSrcSpan n))
+                return n'
+              -- This case can occur when we encounter a DFun;
+              -- see Note [Bogus DFun renamings]
+              Nothing -> lookupOrig mod occ
+        _ -> lookupOrig mod occ
 
 newIfaceName :: OccName -> IfL Name
 newIfaceName occ
diff --git a/compiler/iface/IfaceEnv.hs-boot b/compiler/iface/IfaceEnv.hs-boot
new file mode 100644 (file)
index 0000000..025c371
--- /dev/null
@@ -0,0 +1,9 @@
+module IfaceEnv where
+
+import Module
+import OccName
+import TcRnMonad
+import Name
+import SrcLoc
+
+newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
index 689452f..8a45dd5 100644 (file)
@@ -51,7 +51,6 @@ import ForeignCall
 import Annotations( AnnPayload, AnnTarget )
 import BasicTypes
 import Outputable
-import FastString
 import Module
 import SrcLoc
 import Fingerprint
@@ -126,7 +125,7 @@ data IfaceDecl
                  ifName    :: IfaceTopBndr,             -- Name of the class TyCon
                  ifRoles   :: [Role],                   -- Roles
                  ifBinders :: [IfaceTyConBinder],
-                 ifFDs     :: [FunDep FastString],      -- Functional dependencies
+                 ifFDs     :: [FunDep IfLclName],      -- Functional dependencies
                  ifATs     :: [IfaceAT],                -- Associated type families
                  ifSigs    :: [IfaceClassOp],           -- Method signatures
                  ifMinDef  :: BooleanFormula IfLclName  -- Minimal complete definition
index c5c3538..4e1fea0 100644 (file)
@@ -24,7 +24,9 @@ module LoadIface (
         findAndReadIface, readIface,    -- Used when reading the module's old interface
         loadDecls,      -- Should move to TcIface and be renamed
         initExternalPackageState,
+        moduleFreeHolesPrecise,
 
+        pprModIfaceSimple,
         ifaceStats, pprModIface, showIface
    ) where
 
@@ -69,6 +71,8 @@ import FastString
 import Fingerprint
 import Hooks
 import FieldLabel
+import RnModIface
+import UniqDSet
 
 import Control.Monad
 import Data.IORef
@@ -352,11 +356,7 @@ loadPluginInterface doc mod_name
 -- | A wrapper for 'loadInterface' that throws an exception if it fails
 loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface
 loadInterfaceWithException doc mod_name where_from
-  = do  { mb_iface <- loadInterface doc mod_name where_from
-        ; dflags <- getDynFlags
-        ; case mb_iface of
-            Failed err      -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))
-            Succeeded iface -> return iface }
+  = withException (loadInterface doc mod_name where_from)
 
 ------------------
 loadInterface :: SDoc -> Module -> WhereFrom
@@ -375,6 +375,12 @@ loadInterface :: SDoc -> Module -> WhereFrom
 -- is no longer used
 
 loadInterface doc_str mod from
+  | isHoleModule mod
+  -- Hole modules get special treatment
+  = do dflags <- getDynFlags
+       -- Redo search for our local hole module
+       loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from
+  | otherwise
   = do  {       -- Read the state
           (eps,hpt) <- getEpsAndHpt
         ; gbl_env <- getGblEnv
@@ -402,7 +408,7 @@ loadInterface doc_str mod from
                             WARN( hi_boot_file &&
                                   fmap fst (if_rec_types gbl_env) == Just mod,
                                   ppr mod )
-                            findAndReadIface doc_str mod hi_boot_file
+                            computeInterface doc_str hi_boot_file mod
         ; case read_result of {
             Failed err -> do
                 { let fake_iface = emptyModIface mod
@@ -423,12 +429,11 @@ loadInterface doc_str mod from
         -- But this is no longer valid because thNameToGhcName allows users to
         -- cause the system to load arbitrary interfaces (by supplying an appropriate
         -- Template Haskell original-name).
-            Succeeded (iface, file_path) ->
-
+            Succeeded (iface, loc) ->
         let
-            loc_doc = text file_path
+            loc_doc = text loc
         in
-        initIfaceLcl mod loc_doc (mi_boot iface) $ do
+        initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do
 
         --      Load the new ModIface into the External Package State
         -- Even home-package interfaces loaded by loadInterface
@@ -464,7 +469,8 @@ loadInterface doc_str mod from
                }
 
         ; updateEps_  $ \ eps ->
-           if elemModuleEnv mod (eps_PIT eps) then eps else
+           if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface
+           then eps else
                 eps {
                   eps_PIT          = extendModuleEnv (eps_PIT eps) mod final_iface,
                   eps_PTE          = addDeclsToPTE   (eps_PTE eps) new_eps_decls,
@@ -495,6 +501,91 @@ loadInterface doc_str mod from
         ; return (Succeeded final_iface)
     }}}}
 
+-- | Returns @True@ if a 'ModIface' comes from an external package.
+-- In this case, we should NOT load it into the EPS; the entities
+-- should instead come from the local merged signature interface.
+is_external_sig :: DynFlags -> ModIface -> Bool
+is_external_sig dflags iface =
+    -- It's a signature iface...
+    mi_semantic_module iface /= mi_module iface &&
+    -- and it's not from the local package
+    moduleUnitId (mi_module iface) /= thisPackage dflags
+
+-- | This is an improved version of 'findAndReadIface' which can also
+-- handle the case when a user requests @p[A=<B>]:M@ but we only
+-- have an interface for @p[A=<A>]:M@ (the indefinite interface.
+-- If we are not trying to build code, we load the interface we have,
+-- *instantiating it* according to how the holes are specified.
+-- (Of course, if we're actually building code, this is a hard error.)
+--
+-- In the presence of holes, 'computeInterface' has an important invariant:
+-- to load module M, its set of transitively reachable requirements must
+-- have an up-to-date local hi file for that requirement.  Note that if
+-- we are loading the interface of a requirement, this does not
+-- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require
+-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless
+-- we are actually typechecking p.)
+computeInterface ::
+       SDoc -> IsBootInterface -> Module
+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
+computeInterface doc_str hi_boot_file mod0 = do
+    MASSERT( not (isHoleModule mod0) )
+    dflags <- getDynFlags
+    case splitModuleInsts mod0 of
+        (imod, Just insts) | not (unitIdIsDefinite (thisPackage dflags)) -> do
+            r <- findAndReadIface doc_str imod hi_boot_file
+            case r of
+                Succeeded (iface0, path) -> do
+                    hsc_env <- getTopEnv
+                    r <- liftIO (rnModIface hsc_env insts Nothing iface0)
+                    return (Succeeded (r, path))
+                Failed err -> return (Failed err)
+        (mod, _) ->
+            findAndReadIface doc_str mod hi_boot_file
+
+-- | Compute the signatures which must be compiled in order to
+-- load the interface for a 'Module'.  The output of this function
+-- is always a subset of 'moduleFreeHoles'; it is more precise
+-- because in signature @p[A=<A>,B=<B>]:B@, although the free holes
+-- are A and B, B might not depend on A at all!
+--
+-- If this is invoked on a signature, this does NOT include the
+-- signature itself; e.g. precise free module holes of
+-- @p[A=<A>,B=<B>]:B@ never includes B.
+moduleFreeHolesPrecise
+    :: SDoc -> Module
+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName))
+moduleFreeHolesPrecise doc_str mod
+ | moduleIsDefinite mod = return (Succeeded emptyUniqDSet)
+ | otherwise =
+   case splitModuleInsts mod of
+    (imod, Just insts) -> do
+        traceIf (text "Considering whether to load" <+> ppr mod <+>
+                 text "to compute precise free module holes")
+        (eps, hpt) <- getEpsAndHpt
+        dflags <- getDynFlags
+        case tryEpsAndHpt dflags eps hpt `firstJust` tryDepsCache eps imod insts of
+            Just r -> return (Succeeded r)
+            Nothing -> readAndCache imod insts
+    (_, Nothing) -> return (Succeeded emptyUniqDSet)
+  where
+    tryEpsAndHpt dflags eps hpt =
+        fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod)
+    tryDepsCache eps imod insts =
+        case lookupModuleEnv (eps_free_holes eps) imod of
+            Just ifhs  -> Just (renameFreeHoles ifhs insts)
+            _otherwise -> Nothing
+    readAndCache imod insts = do
+        mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod False
+        case mb_iface of
+            Succeeded (iface, _) -> do
+                let ifhs = mi_free_holes iface
+                -- Cache it
+                updateEps_ (\eps ->
+                    eps { eps_free_holes = extendModuleEnv (eps_free_holes eps) imod ifhs })
+                return (Succeeded (renameFreeHoles ifhs insts))
+            Failed err -> return (Failed err)
+
 wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom
                -> MaybeErr MsgDoc IsBootInterface
 -- Figure out whether we want Foo.hi or Foo.hi-boot
@@ -678,7 +769,7 @@ This actually happened with P=base, Q=ghc-prim, via the AMP warnings.
 See Trac #8320.
 -}
 
-findAndReadIface :: SDoc -> Module
+findAndReadIface :: SDoc -> VirginModule
                  -> IsBootInterface     -- True  <=> Look for a .hi-boot file
                                         -- False <=> Look for .hi file
                  -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
@@ -687,7 +778,6 @@ findAndReadIface :: SDoc -> Module
 
         -- It *doesn't* add an error to the monad, because
         -- sometimes it's ok to fail... see notes with loadInterface
-
 findAndReadIface doc_str mod hi_boot_file
   = do traceIf (sep [hsep [text "Reading",
                            if hi_boot_file
@@ -710,7 +800,6 @@ findAndReadIface doc_str mod hi_boot_file
                mb_found <- liftIO (findExactModule hsc_env mod)
                case mb_found of
                    Found loc mod -> do
-
                        -- Found file, so read it
                        let file_path = addBootSuffix_maybe hi_boot_file
                                                            (ml_hi_file loc)
@@ -740,7 +829,11 @@ findAndReadIface doc_str mod hi_boot_file
                             -- Don't forget to fill in the package name...
           checkBuildDynamicToo (Succeeded (iface, filePath)) = do
               dflags <- getDynFlags
-              whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do
+              -- Indefinite interfaces are ALWAYS non-dynamic, and
+              -- that's OK.
+              let is_definite_iface = moduleIsDefinite (mi_module iface)
+              when is_definite_iface $
+                whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do
                   let ref = canGenerateDynamicToo dflags
                       dynFilePath = addBootSuffix_maybe hi_boot_file
                                   $ replaceExtension filePath (dynHiSuf dflags)
@@ -759,7 +852,7 @@ findAndReadIface doc_str mod hi_boot_file
 
 -- @readIface@ tries just the one file.
 
-readIface :: Module -> FilePath
+readIface :: VirginModule -> FilePath
           -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)
         -- Failed err    <=> file not found, or unreadable, or illegible
         -- Succeeded iface <=> successfully found and parsed
@@ -791,6 +884,7 @@ initExternalPackageState
   = EPS {
       eps_is_boot      = emptyUFM,
       eps_PIT          = emptyPackageIfaceTable,
+      eps_free_holes   = emptyModuleEnv,
       eps_PTE          = emptyTypeEnv,
       eps_inst_env     = emptyInstEnv,
       eps_fam_inst_env = emptyFamInstEnv,
@@ -868,6 +962,11 @@ showIface hsc_env filename = do
    let dflags = hsc_dflags hsc_env
    log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle (pprModIface iface)
 
+-- Show a ModIface but don't display details; suitable for ModIfaces stored in
+-- the EPT.
+pprModIfaceSimple :: ModIface -> SDoc
+pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface)))
+
 pprModIface :: ModIface -> SDoc
 -- Show a ModIface
 pprModIface iface
@@ -935,6 +1034,8 @@ pprUsage usage@UsageHomeModule{}
 pprUsage usage@UsageFile{}
   = hsep [text "addDependentFile",
           doubleQuotes (text (usg_file_path usage))]
+pprUsage usage@UsageMergedRequirement{}
+  = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
 
 pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
 pprUsageImport usage usg_mod'
diff --git a/compiler/iface/LoadIface.hs-boot b/compiler/iface/LoadIface.hs-boot
new file mode 100644 (file)
index 0000000..ff2b3ef
--- /dev/null
@@ -0,0 +1,7 @@
+module LoadIface where
+import Module (Module)
+import TcRnMonad (IfM)
+import HscTypes (ModIface)
+import Outputable (SDoc)
+
+loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
index 8115583..3ab898e 100644 (file)
@@ -19,6 +19,7 @@ module MkIface (
         checkOldIface,  -- See if recompilation is required, by
                         -- comparing version information
         RecompileRequired(..), recompileRequired,
+        mkIfaceExports,
 
         tyThingToIfaceDecl -- Converting things to their Iface equivalents
  ) where
@@ -165,10 +166,12 @@ mkIfaceTc :: HscEnv
           -> IO (ModIface, Bool)
 mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
   tc_result@TcGblEnv{ tcg_mod = this_mod,
+                      tcg_semantic_mod = semantic_mod,
                       tcg_src = hsc_src,
                       tcg_imports = imports,
                       tcg_rdr_env = rdr_env,
                       tcg_fix_env = fix_env,
+                      tcg_merged = merged,
                       tcg_warns = warns,
                       tcg_hpc = other_hpc_info,
                       tcg_th_splice_used = tc_splice_used,
@@ -180,7 +183,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
           let hpc_info = emptyHpcInfo other_hpc_info
           used_th <- readIORef tc_splice_used
           dep_files <- (readIORef dependent_files)
-          usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files
+          usages <- mkUsageInfo hsc_env semantic_mod (imp_mods imports) used_names dep_files merged
           mkIface_ hsc_env maybe_old_fingerprint
                    this_mod hsc_src
                    used_th deps rdr_env
@@ -212,7 +215,8 @@ mkIface_ hsc_env maybe_old_fingerprint
 --      to expose in the interface
 
   = do
-    let entities = typeEnvElts type_env
+    let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)
+        entities = typeEnvElts type_env
         decls  = [ tyThingToIfaceDecl entity
                  | entity <- entities,
                    let name = getName entity,
@@ -220,8 +224,12 @@ mkIface_ hsc_env maybe_old_fingerprint
                       -- No implicit Ids and class tycons in the interface file
                    not (isWiredInName name),
                       -- Nor wired-in things; the compiler knows about them anyhow
-                   nameIsLocalOrFrom this_mod name  ]
+                   nameIsLocalOrFrom semantic_mod name  ]
                       -- Sigh: see Note [Root-main Id] in TcRnDriver
+                      -- NB: ABSOLUTELY need to check against semantic_mod,
+                      -- because all of the names in an hsig p[H=<H>]:H
+                      -- are going to be for <H>, not the former id!
+                      -- See Note [Identity versus semantic module]
 
         fixities    = sortBy (comparing fst)
           [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
@@ -235,11 +243,14 @@ mkIface_ hsc_env maybe_old_fingerprint
         iface_vect_info = flattenVectInfo vect_info
         trust_info  = setSafeMode safe_mode
         annotations = map mkIfaceAnnotation anns
-        sig_of = getSigOf dflags (moduleName this_mod)
 
         intermediate_iface = ModIface {
               mi_module      = this_mod,
-              mi_sig_of      = sig_of,
+              -- Need to record this because it depends on the -instantiated-with flag
+              -- which could change
+              mi_sig_of      = if semantic_mod == this_mod
+                                then Nothing
+                                else Just semantic_mod,
               mi_hsc_src     = hsc_src,
               mi_deps        = deps,
               mi_usages      = usages,
@@ -349,21 +360,32 @@ writeIfaceFile dflags hi_file_path new_iface
 mkHashFun
         :: HscEnv                       -- needed to look up versions
         -> ExternalPackageState         -- ditto
-        -> (Name -> Fingerprint)
-mkHashFun hsc_env eps
-  = \name ->
-      let
-        mod = ASSERT2( isExternalName name, ppr name ) nameModule name
-        occ = nameOccName name
-        iface = lookupIfaceByModule dflags hpt pit mod `orElse`
-                   pprPanic "lookupVers2" (ppr mod <+> ppr occ)
-      in
-        snd (mi_hash_fn iface occ `orElse`
-                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))
+        -> (Name -> IO Fingerprint)
+mkHashFun hsc_env eps name
+  | isHoleModule orig_mod
+  = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))
+  | otherwise
+  = lookup orig_mod
   where
       dflags = hsc_dflags hsc_env
-      hpt    = hsc_HPT hsc_env
-      pit    = eps_PIT eps
+      hpt = hsc_HPT hsc_env
+      pit = eps_PIT eps
+      occ = nameOccName name
+      orig_mod = nameModule name
+      lookup mod = do
+        MASSERT2( isExternalName name, ppr name )
+        iface <- case lookupIfaceByModule dflags hpt pit mod of
+                  Just iface -> return iface
+                  Nothing -> do
+                      -- This can occur when we're writing out ifaces for
+                      -- requirements; we didn't do any /real/ typechecking
+                      -- so there's no guarantee everything is loaded.
+                      -- Kind of a heinous hack.
+                      iface <- initIfaceLoad hsc_env . withException
+                            $ loadInterface (text "lookupVers2") mod ImportBySystem
+                      return iface
+        return $ snd (mi_hash_fn iface occ `orElse`
+                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))
 
 -- ---------------------------------------------------------------------------
 -- Compute fingerprints for the interface
@@ -385,6 +407,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
         -- visible about the declaration that a client can depend on.
         -- see IfaceDeclABI below.
        declABI :: IfaceDecl -> IfaceDeclABI
+       -- TODO: I'm not sure if this should be semantic_mod or this_mod.
+       -- See also Note [Identity versus semantic module]
        declABI decl = (this_mod, decl, extras)
         where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts
                                   non_orph_fis decl
@@ -398,7 +422,10 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
 
        name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
        localOccs = map (getUnique . getParent . getOccName)
-                        . filter ((== this_mod) . name_module)
+                        -- NB: names always use semantic module, so
+                        -- filtering must be on the semantic module!
+                        -- See Note [Identity versus semantic module]
+                        . filter ((== semantic_mod) . name_module)
                         . nonDetEltsUFM
                    -- It's OK to use nonDetEltsUFM as localOccs is only
                    -- used to construct the edges and
@@ -434,10 +461,16 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
            -- wired-in names don't have fingerprints
           | otherwise
           = ASSERT2( isExternalName name, ppr name )
-            let hash | nameModule name /= this_mod =  global_hash_fn name
-                     | otherwise = snd (lookupOccEnv local_env (getOccName name)
+            let hash | nameModule name /= semantic_mod =  global_hash_fn name
+                     -- Get it from the REAL interface!!
+                     -- This will trigger when we compile an hsig file
+                     -- and we know a backing impl for it.
+                     -- See Note [Identity versus semantic module]
+                     | semantic_mod /= this_mod
+                     , not (isHoleModule semantic_mod) = global_hash_fn name
+                     | otherwise = return (snd (lookupOccEnv local_env (getOccName name)
                            `orElse` pprPanic "urk! lookup local fingerprint"
-                                       (ppr name)) -- (undefined,fingerprint0))
+                                       (ppr name)))
                 -- This panic indicates that we got the dependency
                 -- analysis wrong, because we needed a fingerprint for
                 -- an entity that wasn't in the environment.  To debug
@@ -445,7 +478,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                 -- pprTraces below, run the compile again, and inspect
                 -- the output and the generated .hi file with
                 -- --show-iface.
-            in put_ bh hash
+            in hash >>= put_ bh
 
         -- take a strongly-connected group of declarations and compute
         -- its fingerprint.
@@ -591,6 +624,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
 
   where
     this_mod = mi_module iface0
+    semantic_mod = mi_semantic_module iface0
     dflags = hsc_dflags hsc_env
     this_pkg = thisPackage dflags
     (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)
@@ -1038,9 +1072,8 @@ checkVersions hsc_env mod_summary iface
 
        ; recomp <- checkFlagHash hsc_env iface
        ; if recompileRequired recomp then return (recomp, Nothing) else do {
-       ; if getSigOf (hsc_dflags hsc_env) (moduleName (mi_module iface))
-                /= mi_sig_of iface
-            then return (RecompBecause "sig-of changed", Nothing) else do {
+       ; recomp <- checkHsig mod_summary iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
        ; recomp <- checkDependencies hsc_env mod_summary iface
        ; if recompileRequired recomp then return (recomp, Just iface) else do {
 
@@ -1067,6 +1100,18 @@ checkVersions hsc_env mod_summary iface
     mod_deps :: DModuleNameEnv (ModuleName, IsBootInterface)
     mod_deps = mkModDeps (dep_mods (mi_deps iface))
 
+-- | Check if an hsig file needs recompilation because its
+-- implementing module has changed.
+checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
+checkHsig mod_summary iface = do
+    dflags <- getDynFlags
+    let outer_mod = ms_mod mod_summary
+        inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)
+    MASSERT( thisPackage dflags == moduleUnitId outer_mod )
+    case inner_mod == mi_semantic_module iface of
+        True -> up_to_date (text "implementing module unchanged")
+        False -> return (RecompBecause "implementing module changed")
+
 -- | Check the flags haven't changed
 checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
 checkFlagHash hsc_env iface = do
@@ -1146,7 +1191,6 @@ needInterface mod continue
                   -- import and it's been deleted
       Succeeded iface -> continue iface
 
-
 -- | Given the usage information extracted from the old
 -- M.hi file for the module being compiled, figure out
 -- whether M needs to be recompiled.
@@ -1162,6 +1206,11 @@ checkModUsage _this_pkg UsagePackageModule{
         -- recompile.  This is safe but may entail more recompilation when
         -- a dependent package has changed.
 
+checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }
+  = needInterface mod $ \iface -> do
+    let reason = moduleNameString (moduleName mod) ++ " changed (raw)"
+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)
+
 checkModUsage this_pkg UsageHomeModule{
                                 usg_mod_name = mod_name,
                                 usg_mod_hash = old_mod_hash,
index 5b31b7a..024cd7b 100644 (file)
@@ -11,6 +11,8 @@ Type checking of type signatures in interface files
 module TcIface (
         tcLookupImported_maybe,
         importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
+        typecheckIfacesForMerging,
+        typecheckIfaceForInstantiate,
         tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
         tcIfaceVectInfo, tcIfaceAnnotations,
         tcIfaceExpr,    -- Desired by HERMIT (Trac #7683)
@@ -68,6 +70,7 @@ import Util
 import FastString
 import BasicTypes hiding ( SuccessFlag(..) )
 import ListSetOps
+import GHC.Fingerprint
 
 import Data.List
 import Control.Monad
@@ -146,7 +149,7 @@ knots are tied through the EPS.  No problem!
 typecheckIface :: ModIface      -- Get the decls from here
                -> IfG ModDetails
 typecheckIface iface
-  = initIfaceLcl (mi_module iface) (text "typecheckIface") (mi_boot iface) $ do
+  = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do
         {       -- Get the right set of decls and rules.  If we are compiling without -O
                 -- we discard pragmas before typechecking, so that we don't "see"
                 -- information that we shouldn't.  From a versioning point of view
@@ -167,7 +170,7 @@ typecheckIface iface
         ; anns      <- tcIfaceAnnotations (mi_anns iface)
 
                 -- Vectorisation information
-        ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env (mi_vect_info iface)
+        ; vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
 
                 -- Exports
         ; exports <- ifaceExportNames (mi_exports iface)
@@ -191,6 +194,151 @@ typecheckIface iface
 {-
 ************************************************************************
 *                                                                      *
+                Typechecking for merging
+*                                                                      *
+************************************************************************
+-}
+
+-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)
+isAbstractIfaceDecl :: IfaceDecl -> Bool
+isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon _ } = True
+isAbstractIfaceDecl _ = False
+
+-- | Merge two 'IfaceDecl's together, preferring a non-abstract one.  If
+-- both are non-abstract we pick one arbitrarily (and check for consistency
+-- later.)
+mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
+mergeIfaceDecl d1 d2
+    | isAbstractIfaceDecl d1 = d2
+    | isAbstractIfaceDecl d2 = d1
+    -- It doesn't matter; we'll check for consistency later when
+    -- we merge, see 'mergeSignatures'
+    | otherwise              = d1
+
+-- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'.
+mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
+mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl
+
+-- | This is a very interesting function.  Like typecheckIface, we want
+-- to type check an interface file into a ModDetails.  However, the use-case
+-- for these ModDetails is different: we want to compare all of the
+-- ModDetails to ensure they define compatible declarations, and then
+-- merge them together.  So in particular, we have to take a different
+-- strategy for knot-tying: we first speculatively merge the declarations
+-- to get the "base" truth for what we believe the types will be
+-- (this is "type computation.")  Then we read everything in and check
+-- for compatibility.
+--
+-- Consider this example:
+--
+--      H :: [ data A;      type B = A              ]
+--      H :: [ type A = C;              data C      ]
+--      H :: [ type A = (); data B;     type C = B; ]
+--
+-- We attempt to make a type synonym cycle, which is solved if we
+-- take the hint that @type A = ()@.  But actually we can and should
+-- reject this: the 'Name's of C and () are different, so the declarations
+-- of A are incompatible. (Thus there's no problem if we pick a
+-- particular declaration of 'A' over another.)
+--
+-- Here's another one:
+--
+--      H :: [ data Int;    type B = Int;           ]
+--      H :: [ type Int=C;              data C      ]
+--      H :: [ export Int;  data B;     type C = B; ]
+--
+-- We'll properly reject this too: a reexport of Int is a data
+-- constructor, whereas type Int=C is a type synonym: incompatible
+-- types.
+--
+-- Perhaps the renamer is too fussy when it comes to ambiguity (requiring
+-- original names to match, rather than just the types after type synonym
+-- expansion) to match, but that's what we have for Haskell today.
+typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])
+typecheckIfacesForMerging mod ifaces tc_env_var =
+  -- cannot be boot (False)
+  initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do
+    ignore_prags <- goptM Opt_IgnoreInterfacePragmas
+    -- Build the initial environment
+    -- NB: Don't include dfuns here, because we don't want to
+    -- serialize them out.  See Note [Bogus DFun renamings]
+    let mk_decl_env decls
+            = mkOccEnv [ (ifName decl, decl)
+                       | decl <- decls
+                       , case decl of
+                            IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns
+                            _ -> True ]
+        decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces
+                        :: [OccEnv IfaceDecl]
+        decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs
+                        ::  OccEnv IfaceDecl
+    -- TODO: change loadDecls to accept w/o Fingerprint
+    names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x))
+                                                  (occEnvElts decl_env))
+    let global_type_env = mkNameEnv names_w_things
+    writeMutVar tc_env_var global_type_env
+
+    -- OK, now typecheck each ModIface using this environment
+    details <- forM ifaces $ \iface -> do
+        -- DO NOT load these decls into the mutable variable: we did
+        -- that already!
+        decls     <- loadDecls ignore_prags (mi_decls iface)
+        let type_env = mkNameEnv decls
+        -- But note that we use this type_env to typecheck references to DFun
+        -- in 'IfaceInst'
+        insts     <- mapM (tcIfaceInstWithDFunTypeEnv type_env) (mi_insts iface)
+        fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+        rules     <- tcIfaceRules ignore_prags (mi_rules iface)
+        anns      <- tcIfaceAnnotations (mi_anns iface)
+        vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
+        exports   <- ifaceExportNames (mi_exports iface)
+        return $ ModDetails { md_types     = type_env
+                            , md_insts     = insts
+                            , md_fam_insts = fam_insts
+                            , md_rules     = rules
+                            , md_anns      = anns
+                            , md_vect_info = vect_info
+                            , md_exports   = exports
+                            }
+    return (global_type_env, details)
+
+-- | Typecheck a signature 'ModIface' under the assumption that we have
+-- instantiated it under some implementation (recorded in 'mi_semantic_module')
+-- and want to check if the implementation fills the signature.
+--
+-- This needs to operate slightly differently than 'typecheckIface'
+-- because (1) we have a 'NameShape', from the exports of the
+-- implementing module, which we will use to give our top-level
+-- declarations the correct 'Name's even when the implementor
+-- provided them with a reexport, and (2) we have to deal with
+-- DFun silliness (see Note [Bogus DFun renamings])
+typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails
+typecheckIfaceForInstantiate nsubst iface =
+  initIfaceLclWithSubst (mi_semantic_module iface)
+                        (text "typecheckIfaceForInstantiate")
+                        (mi_boot iface) nsubst $ do
+    ignore_prags <- goptM Opt_IgnoreInterfacePragmas
+    decls     <- loadDecls ignore_prags (mi_decls iface)
+    let type_env = mkNameEnv decls
+    -- See Note [Bogus DFun renamings]
+    insts     <- mapM (tcIfaceInstWithDFunTypeEnv type_env) (mi_insts iface)
+    fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+    rules     <- tcIfaceRules ignore_prags (mi_rules iface)
+    anns      <- tcIfaceAnnotations (mi_anns iface)
+    vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
+    exports   <- ifaceExportNames (mi_exports iface)
+    return $ ModDetails { md_types     = type_env
+                        , md_insts     = insts
+                        , md_fam_insts = fam_insts
+                        , md_rules     = rules
+                        , md_anns      = anns
+                        , md_vect_info = vect_info
+                        , md_exports   = exports
+                        }
+
+{-
+************************************************************************
+*                                                                      *
                 Type and class declarations
 *                                                                      *
 ************************************************************************
@@ -704,6 +852,24 @@ tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
        ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
        ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }
 
+-- | Typecheck an 'IfaceClsInst', but rather than using 'tcIfaceGlobal',
+-- resolve the 'ifDFun' using a passed in 'TypeEnv'.
+--
+-- Why do we do it this way?  See Note [Bogus DFun renamings]
+tcIfaceInstWithDFunTypeEnv :: TypeEnv -> IfaceClsInst -> IfL ClsInst
+tcIfaceInstWithDFunTypeEnv tenv
+            (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
+                          , ifInstCls = cls, ifInstTys = mb_tcs
+                          , ifInstOrph = orph })
+  = do { dfun <- case lookupTypeEnv tenv dfun_name of
+                    Nothing -> pprPanic "tcIfaceInstWithDFunTypeEnv"
+                        (ppr dfun_name $$ ppr tenv)
+                    Just (AnId dfun) -> return dfun
+                    Just tything -> pprPanic "tcIfaceInstWithDFunTypeEnv"
+                        (ppr dfun_name <+> ppr tything)
+       ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+       ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }
+
 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
 tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
                              , ifFamInstAxiom = axiom_name } )
index 6e61d20..30493f1 100644 (file)
@@ -144,7 +144,8 @@ compileOne' m_tc_result mHscMessage
 
    case (status, hsc_lang) of
         (HscUpToDate, _) ->
-            ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
+            -- TODO recomp014 triggers this assert. What's going on?!
+            -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
             return hmi0 { hm_linkable = maybe_old_linkable }
         (HscNotGeneratingCode, HscNothing) ->
             let mb_linkable = if isHsBootOrSig src_flavour
@@ -989,6 +990,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
                                         ms_location  = location,
                                         ms_hs_date   = src_timestamp,
                                         ms_obj_date  = Nothing,
+                                        ms_parsed_mod   = Nothing,
                                         ms_iface_date   = Nothing,
                                         ms_textual_imps = imps,
                                         ms_srcimps      = src_imps }
index b78d665..69fb8b8 100644 (file)
@@ -53,8 +53,8 @@ module DynFlags (
         wWarningFlags,
         dynFlagDependencies,
         tablesNextToCode, mkTablesNextToCode,
-        SigOf, getSigOf,
         makeDynFlagsConsistent,
+        thisUnitIdComponentId,
 
         Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
         wayGeneralFlags, wayUnsetGeneralFlags,
@@ -97,6 +97,7 @@ module DynFlags (
         setTmpDir,
         setUnitId,
         interpretPackageEnv,
+        canonicalizeHomeModule,
 
         -- ** Parsing DynFlags
         parseDynamicFlagsCmdLine,
@@ -164,7 +165,6 @@ import CmdLineParser
 import Constants
 import Panic
 import Util
-import UniqFM
 import Maybes
 import MonadUtils
 import qualified Pretty
@@ -334,6 +334,7 @@ data DumpFlag
    | Opt_D_dump_occur_anal
    | Opt_D_dump_parsed
    | Opt_D_dump_rn
+   | Opt_D_dump_shape
    | Opt_D_dump_simpl
    | Opt_D_dump_simpl_iterations
    | Opt_D_dump_spec
@@ -642,11 +643,6 @@ instance Show SafeHaskellMode where
 instance Outputable SafeHaskellMode where
     ppr = text . show
 
-type SigOf = ModuleNameEnv Module
-
-getSigOf :: DynFlags -> ModuleName -> Maybe Module
-getSigOf dflags n = lookupUFM (sigOf dflags) n
-
 -- | Contains not only a collection of 'GeneralFlag's but also a plethora of
 -- information relating to the compilation of a single file or GHC session
 data DynFlags = DynFlags {
@@ -654,8 +650,6 @@ data DynFlags = DynFlags {
   ghcLink               :: GhcLink,
   hscTarget             :: HscTarget,
   settings              :: Settings,
-  -- See Note [Signature parameters in TcGblEnv and DynFlags]
-  sigOf                 :: SigOf,       -- ^ Compiling an hs-boot against impl.
   verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]
   optLevel              :: Int,         -- ^ Optimisation level
   debugLevel            :: Int,         -- ^ How much debug information to produce
@@ -694,7 +688,9 @@ data DynFlags = DynFlags {
   solverIterations      :: IntWithInf,   -- ^ Number of iterations in the constraints solver
                                          --   Typically only 1 is needed
 
-  thisPackage           :: UnitId,   -- ^ key of package currently being compiled
+  thisPackage           :: UnitId,   -- ^ unit id of package currently being compiled.
+                                     --   Not properly initialized until initPackages
+  thisUnitIdInsts       :: [(ModuleName, Module)],
 
   -- ways
   ways                  :: [Way],       -- ^ Way flags from the command line
@@ -1159,8 +1155,11 @@ isNoLink _      = False
 -- is used.
 data PackageArg =
       PackageArg String    -- ^ @-package@, by 'PackageName'
-    | UnitIdArg String     -- ^ @-package-id@, by 'UnitId'
+    | UnitIdArg UnitId     -- ^ @-package-id@, by 'UnitId'
   deriving (Eq, Show)
+instance Outputable PackageArg where
+    ppr (PackageArg pn) = text "package" <+> text pn
+    ppr (UnitIdArg uid) = text "unit" <+> ppr uid
 
 -- | Represents the renaming that may be associated with an exposed
 -- package, e.g. the @rns@ part of @-package "foo (rns)"@.
@@ -1178,6 +1177,8 @@ data ModRenaming = ModRenaming {
     modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope
                                                --   under name @n@.
   } deriving (Eq)
+instance Outputable ModRenaming where
+    ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns)
 
 -- | Flags for manipulating the set of non-broken packages.
 newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@
@@ -1197,6 +1198,10 @@ data PackageFlag
 -- NB: equality instance is used by InteractiveUI to test if
 -- package flags have changed.
 
+instance Outputable PackageFlag where
+    ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn)
+    ppr (HidePackage str) = text "-hide-package" <+> text str
+
 defaultHscTarget :: Platform -> HscTarget
 defaultHscTarget = defaultObjectTarget
 
@@ -1452,7 +1457,6 @@ defaultDynFlags mySettings =
         ghcMode                 = CompManager,
         ghcLink                 = LinkBinary,
         hscTarget               = defaultHscTarget (sTargetPlatform mySettings),
-        sigOf                   = emptyUFM,
         verbosity               = 0,
         optLevel                = 0,
         debugLevel              = 0,
@@ -1484,6 +1488,7 @@ defaultDynFlags mySettings =
         solverIterations        = treatZeroAsInf mAX_SOLVER_ITERATIONS,
 
         thisPackage             = mainUnitId,
+        thisUnitIdInsts         = [],
 
         objectDir               = Nothing,
         dylibInstallName        = Nothing,
@@ -1782,6 +1787,7 @@ dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags)
           enableIfVerbose Opt_D_dump_vt_trace               = False
           enableIfVerbose Opt_D_dump_tc                     = False
           enableIfVerbose Opt_D_dump_rn                     = False
+          enableIfVerbose Opt_D_dump_shape                  = False
           enableIfVerbose Opt_D_dump_rn_stats               = False
           enableIfVerbose Opt_D_dump_hi_diffs               = False
           enableIfVerbose Opt_D_verbose_core2core           = False
@@ -1997,26 +2003,29 @@ setOutputFile f d = d { outputFile = f}
 setDynOutputFile f d = d { dynOutputFile = f}
 setOutputHi   f d = d { outputHi   = f}
 
-parseSigOf :: String -> SigOf
-parseSigOf str = case filter ((=="").snd) (readP_to_S parse str) of
+parseUnitIdInsts :: String -> [(ModuleName, Module)]
+parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of
     [(r, "")] -> r
-    _ -> throwGhcException $ CmdLineError ("Can't parse -sig-of: " ++ str)
-  where parse = listToUFM <$> sepBy parseEntry (R.char ',')
+    _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str)
+  where parse = sepBy parseEntry (R.char ',')
         parseEntry = do
-            n <- tok $ parseModuleName
-            -- ToDo: deprecate this 'is' syntax?
-            tok $ ((string "is" >> return ()) +++ (R.char '=' >> return ()))
-            m <- tok $ parseModule
+            n <- parseModuleName
+            _ <- R.char '='
+            m <- parseModuleId
             return (n, m)
-        parseModule = do
-            pk <- munch1 (\c -> isAlphaNum c || c `elem` "-_.")
-            _ <- R.char ':'
-            m <- parseModuleName
-            return (mkModule (stringToUnitId pk) m)
-        tok m = skipSpaces >> m
 
-setSigOf :: String -> DynFlags -> DynFlags
-setSigOf s d = d { sigOf = parseSigOf s }
+setUnitIdInsts :: String -> DynFlags -> DynFlags
+setUnitIdInsts s d = updateWithInsts (parseUnitIdInsts s) d
+
+updateWithInsts :: [(ModuleName, Module)] -> DynFlags -> DynFlags
+updateWithInsts insts d =
+    -- Overwrite the instances, the instances are "indefinite"
+    d { thisPackage     =
+          if not (null insts) && all (\(x,y) -> mkHoleModule x == y) insts
+            then newUnitId (unitIdComponentId (thisPackage d)) insts
+            else thisPackage d
+      , thisUnitIdInsts = insts
+      }
 
 addPluginModuleName :: String -> DynFlags -> DynFlags
 addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }
@@ -2358,7 +2367,7 @@ dynamic_flags_deps = [
                  -- as specifing that the number of
                  -- parallel builds is equal to the
                  -- result of getNumProcessors
-  , make_ord_flag defFlag "sig-of"   (sepArg setSigOf)
+  , make_ord_flag defFlag "instantiated-with"   (sepArg setUnitIdInsts)
 
     -- RTS options -------------------------------------------------------------
   , make_ord_flag defFlag "H"           (HasArg (\s -> upd (\d ->
@@ -2719,6 +2728,8 @@ dynamic_flags_deps = [
         (setDumpFlag Opt_D_dump_worker_wrapper)
   , make_ord_flag defGhcFlag "ddump-rn-trace"
         (setDumpFlag Opt_D_dump_rn_trace)
+  , make_ord_flag defGhcFlag "ddump-shape"
+        (setDumpFlag Opt_D_dump_shape)
   , make_ord_flag defGhcFlag "ddump-if-trace"
         (setDumpFlag Opt_D_dump_if_trace)
   , make_ord_flag defGhcFlag "ddump-cs-trace"
@@ -4280,22 +4291,18 @@ removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extra
 clearPkgConf :: DynP ()
 clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] }
 
-parseModuleName :: ReadP ModuleName
-parseModuleName = fmap mkModuleName
-                $ munch1 (\c -> isAlphaNum c || c `elem` "_.")
-
 parsePackageFlag :: String                 -- the flag
-                 -> (String -> PackageArg) -- type of argument
+                 -> ReadP PackageArg       -- type of argument
                  -> String                 -- string to parse
                  -> PackageFlag
-parsePackageFlag flag constr str
+parsePackageFlag flag arg_parse str
  = case filter ((=="").snd) (readP_to_S parse str) of
     [(r, "")] -> r
     _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str)
   where doc = flag ++ " " ++ str
         parse = do
-            pkg <- tok $ munch1 (\c -> isAlphaNum c || c `elem` ":-_.")
-            let mk_expose = ExposePackage doc (constr pkg)
+            pkg_arg <- tok arg_parse
+            let mk_expose = ExposePackage doc pkg_arg
             ( do _ <- tok $ string "with"
                  fmap (mk_expose . ModRenaming True) parseRns
              <++ fmap (mk_expose . ModRenaming False) parseRns
@@ -4320,13 +4327,13 @@ exposePackage, exposePackageId, hidePackage,
 exposePackage p = upd (exposePackage' p)
 exposePackageId p =
   upd (\s -> s{ packageFlags =
-    parsePackageFlag "-package-id" UnitIdArg p : packageFlags s })
+    parsePackageFlag "-package-id" parseUnitIdArg p : packageFlags s })
 exposePluginPackage p =
   upd (\s -> s{ pluginPackageFlags =
-    parsePackageFlag "-plugin-package" PackageArg p : pluginPackageFlags s })
+    parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s })
 exposePluginPackageId p =
   upd (\s -> s{ pluginPackageFlags =
-    parsePackageFlag "-plugin-package-id" UnitIdArg p : pluginPackageFlags s })
+    parsePackageFlag "-plugin-package-id" parseUnitIdArg p : pluginPackageFlags s })
 hidePackage p =
   upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
 ignorePackage p =
@@ -4340,10 +4347,38 @@ distrustPackage p = exposePackage p >>
 exposePackage' :: String -> DynFlags -> DynFlags
 exposePackage' p dflags
     = dflags { packageFlags =
-            parsePackageFlag "-package" PackageArg p : packageFlags dflags }
+            parsePackageFlag "-package" parsePackageArg p : packageFlags dflags }
+
+parsePackageArg :: ReadP PackageArg
+parsePackageArg =
+    fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_."))
+
+parseUnitIdArg :: ReadP PackageArg
+parseUnitIdArg =
+    fmap UnitIdArg parseUnitId
+
+
+thisUnitIdComponentId :: DynFlags -> ComponentId
+thisUnitIdComponentId = unitIdComponentId . thisPackage
 
 setUnitId :: String -> DynFlags -> DynFlags
-setUnitId p s =  s{ thisPackage = stringToUnitId p }
+setUnitId p d =
+    updateWithInsts (thisUnitIdInsts d) $ d{ thisPackage = uid }
+  where
+    uid =
+        case filter ((=="").snd) (readP_to_S parseUnitId p) of
+            [(r, "")] -> r
+            _ -> throwGhcException $ CmdLineError ("Can't parse component id: " ++ p)
+
+-- | Given a 'ModuleName' of a signature in the home library, find
+-- out how it is instantiated.  E.g., the canonical form of
+-- A in @p[A=q[]:A]@ is @q[]:A@.
+canonicalizeHomeModule :: DynFlags -> ModuleName -> Module
+canonicalizeHomeModule dflags mod_name =
+    case lookup mod_name (thisUnitIdInsts dflags) of
+        Nothing  -> mkModule (thisPackage dflags) mod_name
+        Just mod -> mod
+
 
 -- -----------------------------------------------------------------------------
 -- | Find the package environment (if one exists)
index 446cdf8..e813e9e 100644 (file)
@@ -86,7 +86,7 @@ removeFromFinderCache :: IORef FinderCache -> Module -> IO ()
 removeFromFinderCache ref key =
   atomicModifyIORef' ref $ \c -> (delModuleEnv c key, ())
 
-lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FindResult)
+lookupFinderCache :: IORef FinderCache -> VirginModule -> IO (Maybe FindResult)
 lookupFinderCache ref key = do
    c <- readIORef ref
    return $! lookupModuleEnv c key
@@ -131,7 +131,7 @@ findPluginModule hsc_env mod_name =
 -- reading the interface for a module mentioned by another interface,
 -- for example (a "system import").
 
-findExactModule :: HscEnv -> Module -> IO FindResult
+findExactModule :: HscEnv -> VirginModule -> IO FindResult
 findExactModule hsc_env mod =
     let dflags = hsc_dflags hsc_env
     in if moduleUnitId mod == thisPackage dflags
@@ -205,7 +205,7 @@ findLookupResult hsc_env r = case r of
                        , fr_mods_hidden = []
                        , fr_suggestions = suggest })
 
-modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult
+modLocationCache :: HscEnv -> VirginModule -> IO FindResult -> IO FindResult
 modLocationCache hsc_env mod do_this = do
   m <- lookupFinderCache (hsc_FC hsc_env) mod
   case m of
@@ -281,7 +281,7 @@ findHomeModule hsc_env mod_name =
 
 
 -- | Search for a module in external packages only.
-findPackageModule :: HscEnv -> Module -> IO FindResult
+findPackageModule :: HscEnv -> VirginModule -> IO FindResult
 findPackageModule hsc_env mod = do
   let
         dflags = hsc_dflags hsc_env
@@ -298,7 +298,7 @@ findPackageModule hsc_env mod = do
 -- the 'PackageConfig' must be consistent with the unit id in the 'Module'.
 -- The redundancy is to avoid an extra lookup in the package state
 -- for the appropriate config.
-findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult
+findPackageModule_ :: HscEnv -> VirginModule -> PackageConfig -> IO FindResult
 findPackageModule_ hsc_env mod pkg_conf =
   ASSERT( moduleUnitId mod == packageConfigId pkg_conf )
   modLocationCache hsc_env mod $
index 0adee6e..998d68c 100644 (file)
 -- -----------------------------------------------------------------------------
 module GhcMake(
         depanal,
-        load, LoadHowMuch(..),
+        load, load', LoadHowMuch(..),
 
         topSortModuleGraph,
 
         ms_home_srcimps, ms_home_imps,
 
+        IsBoot(..),
+        summariseModule,
+        hscSourceToIsBoot,
+        findExtraSigImports,
+        implicitRequirements,
+
         noModError, cyclicModuleErr
     ) where
 
@@ -40,6 +46,7 @@ import HscTypes
 import Module
 import TcIface          ( typecheckIface )
 import TcRnMonad        ( initIfaceCheck )
+import HscMain
 
 import Bag              ( listToBag )
 import BasicTypes
@@ -55,9 +62,14 @@ import SrcLoc
 import StringBuffer
 import SysTools
 import UniqFM
+import UniqDSet
+import TcBackpack
+import Packages
+import UniqSet
 import Util
 import qualified GHC.LanguageExtensions as LangExt
 import NameEnv
+import TcRnDriver (findExtraSigImports, implicitRequirements)
 
 import Data.Either ( rights, partitionEithers )
 import qualified Data.Map as Map
@@ -153,6 +165,14 @@ data LoadHowMuch
 load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
 load how_much = do
     mod_graph <- depanal [] False
+    load' how_much (Just batchMsg) mod_graph
+
+-- | Generalized version of 'load' which also supports a custom
+-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
+-- produced by calling 'depanal'.
+load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
+load' how_much mHscMessage mod_graph = do
+    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
     guessOutputFile
     hsc_env <- getSession
 
@@ -297,7 +317,7 @@ load how_much = do
 
     setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
     (upsweep_ok, modsUpswept)
-       <- upsweep_fn pruned_hpt stable_mods cleanup mg
+       <- upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg
 
     -- Make modsDone be the summaries for each home module now
     -- available; this should equal the domain of hpt3.
@@ -741,16 +761,20 @@ parUpsweep
     :: GhcMonad m
     => Int
     -- ^ The number of workers we wish to run in parallel
+    -> Maybe Messager
     -> HomePackageTable
     -> ([ModuleName],[ModuleName])
     -> (HscEnv -> IO ())
     -> [SCC ModSummary]
     -> m (SuccessFlag,
           [ModSummary])
-parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
+parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
     hsc_env <- getSession
     let dflags = hsc_dflags hsc_env
 
+    when (not (null (unitIdsToCheck dflags))) $
+      throwGhcException (ProgramError "Backpack typechecking not supported with -j")
+
     -- The bits of shared state we'll be using:
 
     -- The global HscEnv is updated with the module's HMI when a module
@@ -840,7 +864,7 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
                 -- work to compile the module (see parUpsweep_one).
                 m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $
                         parUpsweep_one mod home_mod_map comp_graph_loops
-                                       lcl_dflags cleanup
+                                       lcl_dflags mHscMessage cleanup
                                        par_sem hsc_env_var old_hpt_var
                                        stable_mods mod_idx (length sccs)
 
@@ -939,6 +963,8 @@ parUpsweep_one
     -- ^ The list of all module loops within the compilation graph.
     -> DynFlags
     -- ^ The thread-local DynFlags
+    -> Maybe Messager
+    -- ^ The messager
     -> (HscEnv -> IO ())
     -- ^ The callback for cleaning up intermediate files
     -> QSem
@@ -955,7 +981,7 @@ parUpsweep_one
     -- ^ The total number of modules
     -> IO SuccessFlag
     -- ^ The result of this compile
-parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem
+parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem
                hsc_env_var old_hpt_var stable_mods mod_index num_mods = do
 
     let this_build_mod = mkBuildModule mod
@@ -1070,7 +1096,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem
                                  map (moduleName . fst) loop
 
                 -- Compile the module.
-                mod_info <- upsweep_mod lcl_hsc_env'' old_hpt stable_mods
+                mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods
                                         lcl_mod mod_index num_mods
                 return (Just mod_info)
 
@@ -1122,7 +1148,8 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem
 -- There better had not be any cyclic groups here -- we check for them.
 upsweep
     :: GhcMonad m
-    => HomePackageTable            -- ^ HPT from last time round (pruned)
+    => Maybe Messager
+    -> HomePackageTable            -- ^ HPT from last time round (pruned)
     -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
     -> (HscEnv -> IO ())           -- ^ How to clean up unwanted tmp files
     -> [SCC ModSummary]            -- ^ Mods to do (the worklist)
@@ -1134,23 +1161,28 @@ upsweep
        --  2. The 'HscEnv' in the monad has an updated HPT
        --  3. A list of modules which succeeded loading.
 
-upsweep old_hpt stable_mods cleanup sccs = do
+upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
+   dflags <- getSessionDynFlags
    (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
+                           (unitIdsToCheck dflags) done_holes
    return (res, reverse done)
  where
+  done_holes = emptyUniqSet
 
   upsweep' _old_hpt done
-     [] _ _
-   = return (Succeeded, done)
+     [] _ _ uids_to_check _
+   = do hsc_env <- getSession
+        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check
+        return (Succeeded, done)
 
   upsweep' _old_hpt done
-     (CyclicSCC ms:_) _ _
+     (CyclicSCC ms:_) _ _ _ _
    = do dflags <- getSessionDynFlags
         liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
         return (Failed, done)
 
   upsweep' old_hpt done
-     (AcyclicSCC mod:mods) mod_index nmods
+     (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes
    = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
         --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
         --                     (moduleEnvElts (hsc_HPT hsc_env)))
@@ -1158,6 +1190,18 @@ upsweep old_hpt stable_mods cleanup sccs = do
 
         hsc_env <- getSession
 
+        -- TODO: Cache this, so that we don't repeatedly re-check
+        -- our imports when you run --make.
+        let (ready_uids, uids_to_check')
+                = partition (\uid -> isEmptyUniqDSet
+                    (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes))
+                     uids_to_check
+            done_holes'
+                | ms_hsc_src mod == HsigFile
+                = addOneToUniqSet done_holes (ms_mod_name mod)
+                | otherwise = done_holes
+        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids
+
         -- Remove unwanted tmp files between compilations
         liftIO (cleanup hsc_env)
 
@@ -1178,7 +1222,7 @@ upsweep old_hpt stable_mods cleanup sccs = do
         mb_mod_info
             <- handleSourceError
                    (\err -> do logger mod (Just err); return Nothing) $ do
-                 mod_info <- liftIO $ upsweep_mod hsc_env2 old_hpt stable_mods
+                 mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods
                                                   mod mod_index nmods
                  logger mod Nothing -- log warnings
                  return (Just mod_info)
@@ -1212,7 +1256,16 @@ upsweep old_hpt stable_mods cleanup sccs = do
                 hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'
                 setSession hsc_env4
 
-                upsweep' old_hpt1 done' mods (mod_index+1) nmods
+                upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes'
+
+unitIdsToCheck :: DynFlags -> [UnitId]
+unitIdsToCheck dflags =
+  nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags))
+ where
+  goUnitId uid =
+    case splitUnitIdInsts uid of
+      (_, Just insts) -> uid : concatMap (goUnitId . moduleUnitId . snd) insts
+      _ -> []
 
 maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
 maybeGetIfaceDate dflags location
@@ -1226,13 +1279,14 @@ maybeGetIfaceDate dflags location
 -- | Compile a single module.  Always produce a Linkable for it if
 -- successful.  If no compilation happened, return the old Linkable.
 upsweep_mod :: HscEnv
+            -> Maybe Messager
             -> HomePackageTable
             -> ([ModuleName],[ModuleName])
             -> ModSummary
             -> Int  -- index of module
             -> Int  -- total number of modules
             -> IO HomeModInfo
-upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
+upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods
    =    let
             this_mod_name = ms_mod_name summary
             this_mod    = ms_mod summary
@@ -1285,13 +1339,13 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
 
             compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
             compile_it  mb_linkable src_modified =
-                  compileOne hsc_env summary' mod_index nmods
+                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods
                              mb_old_iface mb_linkable src_modified
 
             compile_it_discard_iface :: Maybe Linkable -> SourceModified
                                      -> IO HomeModInfo
             compile_it_discard_iface mb_linkable  src_modified =
-                  compileOne hsc_env summary' mod_index nmods
+                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods
                              Nothing mb_linkable src_modified
 
             -- With the HscNothing target we create empty linkables to avoid
@@ -1510,7 +1564,9 @@ topSortModuleGraph
 topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
   = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
   where
-    (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
+    -- stronglyConnCompG flips the original order, so if we reverse
+    -- the summaries we get a stable topological sort.
+    (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes (reverse summaries)
 
     initial_graph = case mb_root_mod of
         Nothing -> graph
@@ -1662,15 +1718,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
        summs <- loop (concatMap calcDeps rootSummariesOk) root_map
        return summs
      where
-        -- When we're compiling a signature file, we have an implicit
-        -- dependency on what-ever the signature's implementation is.
-        -- (But not when we're type checking!)
-        calcDeps summ
-          | HsigFile <- ms_hsc_src summ
-          , Just m <- getSigOf (hsc_dflags hsc_env) (moduleName (ms_mod summ))
-          , moduleUnitId m == thisPackage (hsc_dflags hsc_env)
-                      = (noLoc (moduleName m), NotBoot) : msDeps summ
-          | otherwise = msDeps summ
+        calcDeps = msDeps
 
         dflags = hsc_dflags hsc_env
         roots = hsc_targets hsc_env
@@ -1691,7 +1739,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
                                            (L rootLoc modl) obj_allowed
                                            maybe_buf excl_mods
                 case maybe_summary of
-                   Nothing -> return $ Left $ packageModErr dflags modl
+                   Nothing -> return $ Left $ moduleNotFoundErr dflags modl
                    Just s  -> return s
 
         rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
@@ -1865,12 +1913,17 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
 
         hi_timestamp <- maybeGetIfaceDate dflags location
 
+        extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
+        required_by_imports <- implicitRequirements hsc_env the_imps
+
         return (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src,
                              ms_location = location,
                              ms_hspp_file = hspp_fn,
                              ms_hspp_opts = dflags',
                              ms_hspp_buf  = Just buf,
-                             ms_srcimps = srcimps, ms_textual_imps = the_imps,
+                             ms_parsed_mod = Nothing,
+                             ms_srcimps = srcimps,
+                             ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
                              ms_hs_date = src_timestamp,
                              ms_iface_date = hi_timestamp,
                              ms_obj_date = obj_timestamp })
@@ -2003,14 +2056,18 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
 
         hi_timestamp <- maybeGetIfaceDate dflags location
 
+        extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
+        required_by_imports <- implicitRequirements hsc_env the_imps
+
         return (Just (Right (ModSummary { ms_mod       = mod,
                               ms_hsc_src   = hsc_src,
                               ms_location  = location,
                               ms_hspp_file = hspp_fn,
                               ms_hspp_opts = dflags',
                               ms_hspp_buf  = Just buf,
+                              ms_parsed_mod = Nothing,
                               ms_srcimps      = srcimps,
-                              ms_textual_imps = the_imps,
+                              ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
                               ms_hs_date   = src_timestamp,
                               ms_iface_date = hi_timestamp,
                               ms_obj_date  = obj_timestamp })))
@@ -2070,10 +2127,10 @@ noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg
 noHsFileErr dflags loc path
   = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path
 
-packageModErr :: DynFlags -> ModuleName -> ErrMsg
-packageModErr dflags mod
+moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg
+moduleNotFoundErr dflags mod
   = mkPlainErrMsg dflags noSrcSpan $
-        text "module" <+> quotes (ppr mod) <+> text "is a package module"
+        text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"
 
 multiRootsErr :: DynFlags -> [ModSummary] -> IO ()
 multiRootsErr _      [] = panic "multiRootsErr"
index 5e14e77..cd8b568 100644 (file)
@@ -79,6 +79,8 @@ module HscMain
     , hscSimpleIface', hscNormalIface'
     , oneShotMsg
     , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats
+    , ioMsgMaybe
+    , showModuleIndex
     ) where
 
 #ifdef GHCI
@@ -135,6 +137,7 @@ import InstEnv
 import FamInstEnv
 import Fingerprint      ( Fingerprint )
 import Hooks
+import TcEnv
 import Maybes
 
 import DynFlags
@@ -342,7 +345,9 @@ hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
 
 -- internal version, that doesn't fail due to -Werror
 hscParse' :: ModSummary -> Hsc HsParsedModule
-hscParse' mod_summary = {-# SCC "Parser" #-}
+hscParse' mod_summary
+ | Just r <- ms_parsed_mod mod_summary = return r
+ | otherwise = {-# SCC "Parser" #-}
     withTiming getDynFlags
                (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
                (const ()) $ do
@@ -359,8 +364,11 @@ hscParse' mod_summary = {-# SCC "Parser" #-}
                Nothing -> liftIO $ hGetStringBuffer src_filename
 
     let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
+    let parseMod | HsigFile == ms_hsc_src mod_summary
+                 = parseSignature
+                 | otherwise = parseModule
 
-    case unP parseModule (mkPState dflags buf loc) of
+    case unP parseMod (mkPState dflags buf loc) of
         PFailed span err ->
             liftIO $ throwOneError (mkPlainErrMsg dflags span err)
 
@@ -417,7 +425,7 @@ type RenamedStuff =
 hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
                    -> IO (TcGblEnv, RenamedStuff)
 hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
-    tc_result <- tcRnModule' hsc_env mod_summary True rdr_module
+    tc_result <- hscTypecheck True mod_summary (Just rdr_module)
 
         -- This 'do' is in the Maybe monad!
     let rn_info = do decl <- tcg_rn_decls tc_result
@@ -428,6 +436,31 @@ hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
 
     return (tc_result, rn_info)
 
+hscTypecheck :: Bool -- ^ Keep renamed source?
+             -> ModSummary -> Maybe HsParsedModule
+             -> Hsc TcGblEnv
+hscTypecheck keep_rn mod_summary mb_rdr_module = do
+    hsc_env <- getHscEnv
+    let hsc_src = ms_hsc_src mod_summary
+        dflags = hsc_dflags hsc_env
+        outer_mod = ms_mod mod_summary
+        inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)
+        src_filename  = ms_hspp_file mod_summary
+        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )
+    if hsc_src == HsigFile && not (isHoleModule inner_mod)
+        then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod real_loc
+        else
+         do hpm <- case mb_rdr_module of
+                    Just hpm -> return hpm
+                    Nothing -> hscParse' mod_summary
+            tc_result0 <- tcRnModule' hsc_env mod_summary keep_rn hpm
+            if hsc_src == HsigFile
+                then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing
+                        ioMsgMaybe $
+                            tcRnMergeSignatures hsc_env (tcg_top_loc tc_result0) iface
+                else return tc_result0
+
 -- wrapper around tcRnModule to handle safe haskell extras
 tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule
             -> Hsc TcGblEnv
@@ -689,11 +722,12 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
         -- to retypecheck but the resulting interface is exactly
         -- the same.)
         Right (FrontendTypecheck tc_result, mb_old_hash) -> do
-            (status, hmi, no_change) <-
-                    if hscTarget dflags /= HscNothing &&
-                       ms_hsc_src mod_summary == HsSrcFile
-                       then finish              hsc_env mod_summary tc_result mb_old_hash
-                       else finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash
+            (status, hmi, no_change)
+                <- case ms_hsc_src mod_summary of
+                        HsSrcFile | hscTarget dflags /= HscNothing ->
+                            finish              hsc_env mod_summary tc_result mb_old_hash
+                        _ ->
+                            finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash
             liftIO $ hscMaybeWriteIface dflags (hm_iface hmi) no_change mod_summary
             return (status, hmi)
 
@@ -803,11 +837,7 @@ batchMsg hsc_env mod_index recomp mod_summary =
 -- | Given a 'ModSummary', parses and typechecks it, returning the
 -- 'TcGblEnv' resulting from type-checking.
 hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
-hscFileFrontEnd mod_summary = do
-    hpm <- hscParse' mod_summary
-    hsc_env <- getHscEnv
-    tcg_env <- tcRnModule' hsc_env mod_summary False hpm
-    return tcg_env
+hscFileFrontEnd mod_summary = hscTypecheck False mod_summary Nothing
 
 --------------------------------------------------------------
 -- Safe Haskell
index 127775e..c2d2938 100644 (file)
@@ -73,6 +73,9 @@ module HscTypes (
         -- * Interfaces
         ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
         emptyIfaceWarnCache, mi_boot, mi_fix,
+        mi_semantic_module,
+        mi_free_holes,
+        renameFreeHoles,
 
         -- * Fixity
         FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
@@ -139,9 +142,9 @@ import ByteCodeTypes
 import InteractiveEvalTypes ( Resume )
 import GHCi.Message         ( Pipe )
 import GHCi.RemoteTypes
-import UniqFM
 #endif
 
+import UniqFM
 import HsSyn
 import RdrName
 import Avail
@@ -191,6 +194,7 @@ import Binary
 import ErrUtils
 import Platform
 import Util
+import UniqDSet
 import GHC.Serialized   ( Serialized )
 
 import Foreign
@@ -770,9 +774,13 @@ prepareAnnotations hsc_env mb_guts = do
 -- Although the @FinderCache@ range is 'FindResult' for convenience,
 -- in fact it will only ever contain 'Found' or 'NotFound' entries.
 --
-type FinderCache = ModuleEnv FindResult
+type FinderCache = VirginModuleEnv FindResult
 
 -- | The result of searching for an imported module.
+--
+-- NB: FindResult manages both user source-import lookups
+-- (which can result in 'Module') as well as direct imports
+-- for interfaces (which always result in 'VirginModule').
 data FindResult
   = Found ModLocation Module
         -- ^ The module was found
@@ -936,6 +944,42 @@ mi_boot iface = mi_hsc_src iface == HsBootFile
 mi_fix :: ModIface -> OccName -> Fixity
 mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity
 
+-- | The semantic module for this interface; e.g., if it's a interface
+-- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module'
+-- will be @<A>@.
+mi_semantic_module :: ModIface -> Module
+mi_semantic_module iface = case mi_sig_of iface of
+                            Nothing -> mi_module iface
+                            Just mod -> mod
+
+-- | The "precise" free holes, e.g., the signatures that this
+-- 'ModIface' depends on.
+mi_free_holes :: ModIface -> UniqDSet ModuleName
+mi_free_holes iface =
+  case splitModuleInsts (mi_module iface) of
+    (_, Just insts)
+        -- A mini-hack: we rely on the fact that 'renameFreeHoles'
+        -- drops things that aren't holes.
+        -> renameFreeHoles (mkUniqDSet cands) insts
+    _   -> emptyUniqDSet
+  where
+    cands = map fst (dep_mods (mi_deps iface))
+
+-- | Given a set of free holes, and a unit identifier, rename
+-- the free holes according to the instantiation of the unit
+-- identifier.  For example, if we have A and B free, and
+-- our unit identity is @p[A=<C>,B=impl:B]@, the renamed free
+-- holes are just C.
+renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName
+renameFreeHoles fhs insts =
+    unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs))
+  where
+    hmap = listToUFM insts
+    lookup_impl mod_name
+        | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod
+        -- It wasn't actually a hole
+        | otherwise                           = emptyUniqDSet
+
 instance Binary ModIface where
    put_ bh (ModIface {
                  mi_module    = mod,
@@ -964,6 +1008,7 @@ instance Binary ModIface where
                  mi_trust     = trust,
                  mi_trust_pkg = trust_pkg }) = do
         put_ bh mod
+        put_ bh sig_of
         put_ bh hsc_src
         put_ bh iface_hash
         put_ bh mod_hash
@@ -987,10 +1032,10 @@ instance Binary ModIface where
         put_ bh hpc_info
         put_ bh trust
         put_ bh trust_pkg
-        put_ bh sig_of
 
    get bh = do
-        mod_name    <- get bh
+        mod         <- get bh
+        sig_of      <- get bh
         hsc_src     <- get bh
         iface_hash  <- get bh
         mod_hash    <- get bh
@@ -1014,9 +1059,8 @@ instance Binary ModIface where
         hpc_info    <- get bh
         trust       <- get bh
         trust_pkg   <- get bh
-        sig_of      <- get bh
         return (ModIface {
-                 mi_module      = mod_name,
+                 mi_module      = mod,
                  mi_sig_of      = sig_of,
                  mi_hsc_src     = hsc_src,
                  mi_iface_hash  = iface_hash,
@@ -1997,7 +2041,10 @@ lookupType dflags hpt pte name
        Just hm -> lookupNameEnv (md_types (hm_details hm)) name
        Nothing -> lookupNameEnv pte name
   where
-    mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+    mod = ASSERT2( isExternalName name, ppr name )
+          if isHoleName name
+            then mkModule (thisPackage dflags) (moduleName (nameModule name))
+            else nameModule name
 
 -- | As 'lookupType', but with a marginally easier-to-use interface
 -- if you have a 'HscEnv'
@@ -2280,6 +2327,11 @@ data Usage
         -- contents don't change.  This previously lead to odd
         -- recompilation behaviors; see #8114
   }
+  -- | A requirement which was merged into this one.
+  | UsageMergedRequirement {
+        usg_mod :: Module,
+        usg_mod_hash :: Fingerprint
+  }
     deriving( Eq )
         -- The export list field is (Just v) if we depend on the export list:
         --      i.e. we imported the module directly, whether or not we
@@ -2314,6 +2366,11 @@ instance Binary Usage where
         put_ bh (usg_file_path usg)
         put_ bh (usg_file_hash usg)
 
+    put_ bh usg@UsageMergedRequirement{} = do
+        putByte bh 3
+        put_ bh (usg_mod      usg)
+        put_ bh (usg_mod_hash usg)
+
     get bh = do
         h <- getByte bh
         case h of
@@ -2334,6 +2391,10 @@ instance Binary Usage where
             fp   <- get bh
             hash <- get bh
             return UsageFile { usg_file_path = fp, usg_file_hash = hash }
+          3 -> do
+            mod <- get bh
+            hash <- get bh
+            return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash }
           i -> error ("Binary.get(Usage): " ++ show i)
 
 {-
@@ -2388,6 +2449,16 @@ data ExternalPackageState
                 --
                 -- * Deprecations and warnings
 
+        eps_free_holes :: ModuleEnv (UniqDSet ModuleName),
+                -- ^ Cache for 'mi_free_holes'.  Ordinarily, we can rely on
+                -- the 'eps_PIT' for this information, EXCEPT that when
+                -- we do dependency analysis, we need to look at the
+                -- 'Dependencies' of our imports to determine what their
+                -- precise free holes are ('moduleFreeHolesPrecise').  We
+                -- don't want to repeatedly reread in the interface
+                -- for every import, so cache it here.  When the PIT
+                -- gets filled in we can drop these entries.
+
         eps_PTE :: !PackageTypeEnv,
                 -- ^ Result of typechecking all the external package
                 -- interface files we have sucked in. The domain of
@@ -2519,6 +2590,9 @@ data ModSummary
           -- ^ Source imports of the module
         ms_textual_imps :: [(Maybe FastString, Located ModuleName)],
           -- ^ Non-source imports of the module from the module *text*
+        ms_parsed_mod   :: Maybe HsParsedModule,
+          -- ^ The parsed, nonrenamed source, if we have it.  This is also
+          -- used to support "inline module syntax" in Backpack files.
         ms_hspp_file    :: FilePath,
           -- ^ Filename of preprocessed source file
         ms_hspp_opts    :: DynFlags,
@@ -2577,24 +2651,12 @@ showModMsg dflags target recomp mod_summary
                   HscInterpreted | recomp
                              -> text "interpreted"
                   HscNothing -> text "nothing"
-                  _ | HsigFile == ms_hsc_src mod_summary -> text "nothing"
-                    | otherwise -> text (normalise $ msObjFilePath mod_summary),
+                  _ -> text (normalise $ msObjFilePath mod_summary),
               char ')']
  where
     mod     = moduleName (ms_mod mod_summary)
     mod_str = showPpr dflags mod
-                ++ hscSourceString' dflags mod (ms_hsc_src mod_summary)
-
--- | Variant of hscSourceString which prints more information for signatures.
--- This can't live in DriverPhases because this would cause a module loop.
-hscSourceString' :: DynFlags -> ModuleName -> HscSource -> String
-hscSourceString' _ _ HsSrcFile   = ""
-hscSourceString' _ _ HsBootFile  = "[boot]"
-hscSourceString' dflags mod HsigFile =
-     "[" ++ (maybe "abstract sig"
-               (("sig of "++).showPpr dflags)
-               (getSigOf dflags mod)) ++ "]"
-    -- NB: -sig-of could be missing if we're just typechecking
+                ++ hscSourceString (ms_hsc_src mod_summary)
 
 {-
 ************************************************************************
index cda8f7f..f16c902 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, RecordWildCards, MultiParamTypeClasses #-}
+{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-}
 
 -- |
 -- Package configuration information: essentially the interface to Cabal, with
@@ -11,6 +11,7 @@ module PackageConfig (
 
         -- * UnitId
         packageConfigId,
+        expandedPackageConfigId,
 
         -- * The PackageConfig type: information about a package
         PackageConfig,
@@ -40,9 +41,11 @@ import Unique
 -- which is similar to a subset of the InstalledPackageInfo type from Cabal.
 
 type PackageConfig = InstalledPackageInfo
+                       ComponentId
                        SourcePackageId
                        PackageName
                        Module.UnitId
+                       Module.UnitId
                        Module.ModuleName
                        Module.Module
 
@@ -50,14 +53,9 @@ type PackageConfig = InstalledPackageInfo
 --       feature, but ghc doesn't currently have convenient support for any
 --       other compact string types, e.g. plain ByteString or Text.
 
-newtype ComponentId = ComponentId FastString deriving (Eq, Ord)
 newtype SourcePackageId    = SourcePackageId    FastString deriving (Eq, Ord)
 newtype PackageName        = PackageName        FastString deriving (Eq, Ord)
 
-instance BinaryStringRep ComponentId where
-  fromStringRep = ComponentId . mkFastStringByteString
-  toStringRep (ComponentId s) = fastStringToByteString s
-
 instance BinaryStringRep SourcePackageId where
   fromStringRep = SourcePackageId . mkFastStringByteString
   toStringRep (SourcePackageId s) = fastStringToByteString s
@@ -66,18 +64,12 @@ instance BinaryStringRep PackageName where
   fromStringRep = PackageName . mkFastStringByteString
   toStringRep (PackageName s) = fastStringToByteString s
 
-instance Uniquable ComponentId where
-  getUnique (ComponentId n) = getUnique n
-
 instance Uniquable SourcePackageId where
   getUnique (SourcePackageId n) = getUnique n
 
 instance Uniquable PackageName where
   getUnique (PackageName n) = getUnique n
 
-instance Outputable ComponentId where
-  ppr (ComponentId str) = ftext str
-
 instance Outputable SourcePackageId where
   ppr (SourcePackageId str) = ftext str
 
@@ -125,7 +117,6 @@ pprPackageConfig InstalledPackageInfo {..} =
   where
     field name body = text name <> colon <+> nest 4 body
 
-
 -- -----------------------------------------------------------------------------
 -- UnitId (package names, versions and dep hash)
 
@@ -140,3 +131,9 @@ pprPackageConfig InstalledPackageInfo {..} =
 -- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig'
 packageConfigId :: PackageConfig -> UnitId
 packageConfigId = unitId
+
+expandedPackageConfigId :: PackageConfig -> UnitId
+expandedPackageConfigId p =
+    case instantiatedWith p of
+        [] -> packageConfigId p
+        _ -> newUnitId (unitIdComponentId (packageConfigId p)) (instantiatedWith p)
diff --git a/compiler/main/PackageConfig.hs-boot b/compiler/main/PackageConfig.hs-boot
new file mode 100644 (file)
index 0000000..c65bf47
--- /dev/null
@@ -0,0 +1,7 @@
+module PackageConfig where
+import FastString
+import {-# SOURCE #-} Module
+import GHC.PackageDb
+newtype PackageName = PackageName FastString
+newtype SourcePackageId = SourcePackageId FastString
+type PackageConfig = InstalledPackageInfo ComponentId SourcePackageId PackageName UnitId ModuleName Module
index 0c91af2..3003e01 100644 (file)
@@ -1,13 +1,14 @@
 -- (c) The University of Glasgow, 2006
 
-{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}
 
 -- | Package manipulation
 module Packages (
         module PackageConfig,
 
         -- * Reading the package config, and processing cmdline args
-        PackageState(preloadPackages, explicitPackages),
+        PackageState(preloadPackages, explicitPackages, requirementContext),
+        PackageConfigMap,
         emptyPackageState,
         initPackages,
         readPackageConfigs,
@@ -18,8 +19,13 @@ module Packages (
 
         -- * Querying the package config
         lookupPackage,
+        lookupPackage',
+        lookupPackageName,
+        lookupComponentId,
+        improveUnitId,
         searchPackageId,
         getPackageDetails,
+        componentIdString,
         listVisibleModuleNames,
         lookupModuleInAllPackages,
         lookupModuleWithSuggestions,
@@ -35,13 +41,14 @@ module Packages (
         getPackageExtraCcOpts,
         getPackageFrameworkPath,
         getPackageFrameworks,
+        getPackageConfigMap,
         getPreloadPackagesAnd,
 
         collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
         packageHsLibs,
 
         -- * Utils
-        unitIdPackageIdString,
+        unwireUnitId,
         pprFlag,
         pprPackages,
         pprPackagesSimple,
@@ -66,9 +73,8 @@ import Maybes
 
 import System.Environment ( getEnv )
 import FastString
-import ErrUtils         ( debugTraceMsg, MsgDoc )
+import ErrUtils         ( debugTraceMsg, MsgDoc, printInfoForUser )
 import Exception
-import Unique
 
 import System.Directory
 import System.FilePath as FilePath
@@ -78,6 +84,8 @@ import Data.Char ( toUpper )
 import Data.List as List
 import Data.Map (Map)
 import Data.Set (Set)
+import Data.Maybe (mapMaybe)
+import Data.Monoid (First(..))
 #if __GLASGOW_HASKELL__ > 710
 import Data.Semigroup   ( Semigroup )
 import qualified Data.Semigroup as Semigroup
@@ -234,14 +242,57 @@ originEmpty _ = False
 type UnitIdMap = UniqDFM
 
 -- | 'UniqFM' map from 'UnitId' to 'PackageConfig'
-type PackageConfigMap = UnitIdMap PackageConfig
+-- (newtyped so we can put it in boot.)
+newtype PackageConfigMap = PackageConfigMap { unPackageConfigMap :: UnitIdMap PackageConfig }
+
+-- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'.
+type VisibilityMap = Map UnitId UnitVisibility
+
+-- | 'UnitVisibility' records the various aspects of visibility of a particular
+-- 'UnitId'.
+data UnitVisibility = UnitVisibility
+    { uv_expose_all :: Bool
+      --  ^ Should all modules in exposed-modules should be dumped into scope?
+    , uv_renamings :: [(ModuleName, ModuleName)]
+      -- ^ Any custom renamings that should bring extra 'ModuleName's into
+      -- scope.
+    , uv_package_name :: First FastString
+      -- ^ The package name is associated with the 'UnitId'.  This is used
+      -- to implement legacy behavior where @-package foo-0.1@ implicitly
+      -- hides any packages named @foo@
+    , uv_requirements :: Map ModuleName (Set HoleModule)
+      -- ^ The signatures which are contributed to the requirements context
+      -- from this unit ID.
+    , uv_explicit :: Bool
+      -- ^ Whether or not this unit was explicitly brought into scope,
+      -- as opposed to implicitly via the 'exposed' fields in the
+      -- package database (when @-hide-all-packages@ is not passed.)
+    }
 
--- | 'UniqFM' map from 'UnitId' to (1) whether or not all modules which
--- are exposed should be dumped into scope, (2) any custom renamings that
--- should also be apply, and (3) what package name is associated with the
--- key, if it might be hidden
-type VisibilityMap =
-    UnitIdMap (Bool, [(ModuleName, ModuleName)], FastString)
+instance Outputable UnitVisibility where
+    ppr (UnitVisibility {
+        uv_expose_all = b,
+        uv_renamings = rns,
+        uv_package_name = First mb_pn,
+        uv_requirements = reqs,
+        uv_explicit = explicit
+    }) = ppr (b, rns, mb_pn, reqs, explicit)
+instance Monoid UnitVisibility where
+    mempty = UnitVisibility
+             { uv_expose_all = False
+             , uv_renamings = []
+             , uv_package_name = First Nothing
+             , uv_requirements = Map.empty
+             , uv_explicit = False
+             }
+    mappend uv1 uv2
+        = UnitVisibility
+          { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
+          , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
+          , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
+          , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)
+          , uv_explicit = uv_explicit uv1 || uv_explicit uv2
+          }
 
 -- | Map from 'ModuleName' to 'Module' to all the origins of the bindings
 -- in scope.  The 'PackageConf' is not cached, mostly for convenience reasons
@@ -257,6 +308,14 @@ data PackageState = PackageState {
   -- may have the 'exposed' flag be 'False'.)
   pkgIdMap              :: PackageConfigMap,
 
+  -- | A mapping of 'PackageName' to 'ComponentId'.  This is used when
+  -- users refer to packages in Backpack includes.
+  packageNameMap            :: Map PackageName ComponentId,
+
+  -- | A mapping from wired in names to the original names from the
+  -- package database.
+  unwireMap :: Map UnitId UnitId,
+
   -- | The packages we're going to link in eagerly.  This list
   -- should be in reverse dependency order; that is, a package
   -- is always mentioned before the packages it depends on.
@@ -272,30 +331,65 @@ data PackageState = PackageState {
   moduleToPkgConfAll    :: !ModuleToPkgConfAll,
 
   -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility.
-  pluginModuleToPkgConfAll    :: !ModuleToPkgConfAll
+  pluginModuleToPkgConfAll    :: !ModuleToPkgConfAll,
+
+  -- | A map saying, for each requirement, what interfaces must be merged
+  -- together when we use them.  For example, if our dependencies
+  -- are @p[A=<A>]@ and @q[A=<A>,B=r[C=<A>]:B]@, then the interfaces
+  -- to merge for A are @p[A=<A>]:A@, @q[A=<A>,B=r[C=<A>]:B]:A@
+  -- and @r[C=<A>]:C@.
+  --
+  -- There's an entry in this map for each hole in our home library.
+  requirementContext :: Map ModuleName [HoleModule]
   }
 
 emptyPackageState :: PackageState
 emptyPackageState = PackageState {
     pkgIdMap = emptyPackageConfigMap,
+    packageNameMap = Map.empty,
+    unwireMap = Map.empty,
     preloadPackages = [],
     explicitPackages = [],
     moduleToPkgConfAll = Map.empty,
-    pluginModuleToPkgConfAll = Map.empty
+    pluginModuleToPkgConfAll = Map.empty,
+    requirementContext = Map.empty
     }
 
 type InstalledPackageIndex = Map UnitId PackageConfig
 
 -- | Empty package configuration map
 emptyPackageConfigMap :: PackageConfigMap
-emptyPackageConfigMap = emptyUDFM
+emptyPackageConfigMap = PackageConfigMap emptyUDFM
 
--- | Find the package we know about with the given key (e.g. @foo_HASH@), if any
+-- | Find the package we know about with the given unit id, if any
 lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
-lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags))
+lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState dflags))
+
+-- | A more specialized interface, which takes a boolean specifying
+-- whether or not to look for on-the-fly renamed interfaces, and
+-- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can
+-- be used while we're initializing 'DynFlags'
+lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
+lookupPackage' False (PackageConfigMap pkg_map) uid = lookupUDFM pkg_map uid
+lookupPackage' True (PackageConfigMap pkg_map) uid =
+    case splitUnitIdInsts uid of
+        (iuid, Just insts) ->
+            fmap (renamePackage (PackageConfigMap pkg_map) insts)
+                 (lookupUDFM pkg_map iuid)
+        (_, Nothing) -> lookupUDFM pkg_map uid
+
+-- | Find the indefinite package for a given 'ComponentId'.
+-- The way this works is just by fiat'ing that every indefinite package's
+-- unit key is precisely its component ID; and that they share uniques.
+lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig
+lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs
+  where
+    PackageConfigMap pkg_map = pkgIdMap (pkgState dflags)
 
-lookupPackage' :: PackageConfigMap -> UnitId -> Maybe PackageConfig
-lookupPackage' = lookupUDFM
+-- | Find the package we know about with the given package name (e.g. @foo@), if any
+-- (NB: there might be a locally defined unit name which overrides this)
+lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId
+lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags))
 
 -- | Search for packages with a given package ID (e.g. \"foo-0.1\")
 searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
@@ -305,9 +399,12 @@ searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
 -- | Extends the package configuration map with a list of package configs.
 extendPackageConfigMap
    :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
-extendPackageConfigMap pkg_map new_pkgs
-  = foldl add pkg_map new_pkgs
-  where add pkg_map p = addToUDFM pkg_map (packageConfigId p) p
+extendPackageConfigMap (PackageConfigMap pkg_map) new_pkgs
+  = PackageConfigMap (foldl add pkg_map new_pkgs)
+    -- We also add the expanded version of the packageConfigId, so that
+    -- 'improveUnitId' can find it.
+  where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p)
+                                  (packageConfigId p) p
 
 -- | Looks up the package with the given id in the package state, panicing if it is
 -- not found
@@ -320,7 +417,9 @@ getPackageDetails dflags pid =
 -- does not imply that the exposed-modules of the package are available
 -- (they may have been thinned or renamed).
 listPackageConfigMap :: DynFlags -> [PackageConfig]
-listPackageConfigMap dflags = eltsUDFM (pkgIdMap (pkgState dflags))
+listPackageConfigMap dflags = eltsUDFM pkg_map
+  where
+    PackageConfigMap pkg_map = pkgIdMap (pkgState dflags)
 
 -- ----------------------------------------------------------------------------
 -- Loading the package db files and building up the package state
@@ -346,11 +445,10 @@ initPackages dflags0 = do
         Nothing -> readPackageConfigs dflags
         Just db -> return $ map (\(p, pkgs)
                                     -> (p, setBatchPackageFlags dflags pkgs)) db
-  (pkg_state, preload, this_pkg)
+  (pkg_state, preload)
         <- mkPackageState dflags pkg_db []
   return (dflags{ pkgDatabase = Just pkg_db,
-                  pkgState = pkg_state,
-                  thisPackage = this_pkg },
+                  pkgState = pkg_state },
           preload)
 
 -- -----------------------------------------------------------------------------
@@ -522,19 +620,25 @@ applyTrustFlag dflags unusable pkgs flag =
     -- we trust all matching packages. Maybe should only trust first one?
     -- and leave others the same or set them untrusted
     TrustPackage str ->
-       case selectPackages (matchingStr str) pkgs unusable of
+       case selectPackages (PackageArg str) pkgs unusable of
          Left ps       -> trustFlagErr dflags flag ps
          Right (ps,qs) -> return (map trust ps ++ qs)
           where trust p = p {trusted=True}
 
     DistrustPackage str ->
-       case selectPackages (matchingStr str) pkgs unusable of
+       case selectPackages (PackageArg str) pkgs unusable of
          Left ps       -> trustFlagErr dflags flag ps
          Right (ps,qs) -> return (map distrust ps ++ qs)
           where distrust p = p {trusted=False}
 
+-- | A little utility to tell if the 'thisPackage' is indefinite
+-- (if it is not, we should never use on-the-fly renaming.)
+isIndefinite :: DynFlags -> Bool
+isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags))
+
 applyPackageFlag
    :: DynFlags
+   -> PackageConfigMap
    -> UnusablePackages
    -> Bool -- if False, if you expose a package, it implicitly hides
            -- any previously exposed packages with the same name
@@ -543,16 +647,46 @@ applyPackageFlag
    -> PackageFlag               -- flag to apply
    -> IO VisibilityMap        -- Now exposed
 
-applyPackageFlag dflags unusable no_hide_others pkgs vm flag =
+applyPackageFlag dflags pkg_db unusable no_hide_others pkgs vm flag =
   case flag of
     ExposePackage _ arg (ModRenaming b rns) ->
-       case selectPackages (matching arg) pkgs unusable of
+       case findPackages pkg_db arg pkgs unusable of
          Left ps         -> packageFlagErr dflags flag ps
-         Right (p:_,_) -> return vm'
+         Right (p:_) -> return vm'
           where
            n = fsPackageName p
-           vm' = addToUDFM_C edit vm_cleared (packageConfigId p) (b, rns, n)
-           edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
+
+           -- If a user says @-unit-id p[A=<A>]@, this imposes
+           -- a requirement on us: whatever our signature A is,
+           -- it must fulfill all of p[A=<A>]:A's requirements.
+           -- This method is responsible for computing what our
+           -- inherited requirements are.
+           reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid
+                | otherwise                 = Map.empty
+
+           collectHoles uid = case splitUnitIdInsts uid of
+                (_, Just insts) ->
+                  let cid = unitIdComponentId uid
+                      local = [ Map.singleton
+                                  (moduleName mod)
+                                  (Set.singleton $ (newIndefUnitId cid insts, mod_name))
+                              | (mod_name, mod) <- insts
+                              , isHoleModule mod ]
+                      recurse = [ collectHoles (moduleUnitId mod)
+                                | (_, mod) <- insts ]
+                  in Map.unionsWith Set.union $ local ++ recurse
+                -- Other types of unit identities don't have holes
+                (_, Nothing) -> Map.empty
+
+
+           uv = UnitVisibility
+                { uv_expose_all = b
+                , uv_renamings = rns
+                , uv_package_name = First (Just n)
+                , uv_requirements = reqs
+                , uv_explicit = True
+                }
+           vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared
            -- In the old days, if you said `ghc -package p-0.1 -package p-0.2`
            -- (or if p-0.1 was registered in the pkgdb as exposed: True),
            -- the second package flag would override the first one and you
@@ -574,29 +708,74 @@ applyPackageFlag dflags unusable no_hide_others pkgs vm flag =
            -- -hide-all-packages/-hide-all-plugin-packages depending on what
            -- flag is in question.
            vm_cleared | no_hide_others = vm
-                      | otherwise = filterUDFM_Directly
-                            (\k (_,_,n') -> k == getUnique (packageConfigId p)
-                                                || n /= n') vm
+                      -- NB: renamings never clear
+                      | (_:_) <- rns = vm
+                      | otherwise = Map.filterWithKey
+                            (\k uv -> k == packageConfigId p
+                                   || First (Just n) /= uv_package_name uv) vm
          _ -> panic "applyPackageFlag"
 
     HidePackage str ->
-       case selectPackages (matchingStr str) pkgs unusable of
-         Left ps       -> packageFlagErr dflags flag ps
-         Right (ps,_) -> return vm'
-          where vm' = delListFromUDFM vm (map packageConfigId ps)
-
-selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
+       case findPackages pkg_db (PackageArg str) pkgs unusable of
+         Left ps  -> packageFlagErr dflags flag ps
+         Right ps -> return vm'
+          where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps)
+
+-- | Like 'selectPackages', but doesn't return a list of unmatched
+-- packages.  Furthermore, any packages it returns are *renamed*
+-- if the 'UnitArg' has a renaming associated with it.
+findPackages :: PackageConfigMap -> PackageArg -> [PackageConfig]
+             -> UnusablePackages
+             -> Either [(PackageConfig, UnusablePackageReason)]
+                [PackageConfig]
+findPackages pkg_db arg pkgs unusable
+  = let ps = mapMaybe (finder arg) pkgs
+    in if null ps
+        then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y))
+                            (Map.elems unusable))
+        else Right (sortByVersion (reverse ps))
+  where
+    finder (PackageArg str) p
+      = if str == sourcePackageIdString p || str == packageNameString p
+          then Just p
+          else Nothing
+    finder (UnitIdArg uid) p
+      = let (iuid, mb_insts) = splitUnitIdInsts uid
+        in if iuid == packageConfigId p
+              then Just (case mb_insts of
+                            Nothing    -> p
+                            Just insts -> renamePackage pkg_db insts p)
+              else Nothing
+
+selectPackages :: PackageArg -> [PackageConfig]
                -> UnusablePackages
                -> Either [(PackageConfig, UnusablePackageReason)]
                   ([PackageConfig], [PackageConfig])
-selectPackages matches pkgs unusable
-  = let (ps,rest) = partition matches pkgs
+selectPackages arg pkgs unusable
+  = let matches = matching arg
+        (ps,rest) = partition matches pkgs
     in if null ps
         then Left (filter (matches.fst) (Map.elems unusable))
         -- NB: packages from later package databases are LATER
         -- in the list.  We want to prefer the latest package.
         else Right (sortByVersion (reverse ps), rest)
 
+-- | Rename a 'PackageConfig' according to some module instantiation.
+renamePackage :: PackageConfigMap -> [(ModuleName, Module)]
+              -> PackageConfig -> PackageConfig
+renamePackage pkg_map insts conf =
+    let hsubst = listToUFM insts
+        smod = renameHoleModule' pkg_map hsubst
+        suid = renameHoleUnitId' pkg_map hsubst
+        new_uid = suid (unitId conf)
+    in conf {
+        unitId = new_uid,
+        depends = map suid (depends conf),
+        exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))
+                             (exposedModules conf)
+    }
+
+
 -- A package named on the command line can either include the
 -- version, or just the name if it is unambiguous.
 matchingStr :: String -> PackageConfig -> Bool
@@ -604,12 +783,12 @@ matchingStr str p
         =  str == sourcePackageIdString p
         || str == packageNameString p
 
-matchingId :: String -> PackageConfig -> Bool
-matchingId str p = str == unitIdString (packageConfigId p)
+matchingId :: UnitId -> PackageConfig -> Bool
+matchingId uid p = uid == packageConfigId p
 
 matching :: PackageArg -> PackageConfig -> Bool
 matching (PackageArg str) = matchingStr str
-matching (UnitIdArg str)  = matchingId str
+matching (UnitIdArg uid)  = matchingId uid
 
 sortByVersion :: [PackageConfig] -> [PackageConfig]
 sortByVersion = sortBy (flip (comparing packageVersion))
@@ -712,7 +891,7 @@ findWiredInPackages dflags pkgs vis_map = do
            let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
                all_exposed_ps =
                     [ p | p <- all_ps
-                        , elemUDFM (packageConfigId p) vis_map ] in
+                        , Map.member (packageConfigId p) vis_map ] in
            case all_exposed_ps of
             [] -> case all_ps of
                        []   -> notfound
@@ -766,7 +945,8 @@ findWiredInPackages dflags pkgs vis_map = do
           where upd_pkg pkg
                   | unitId pkg `elem` wired_in_ids
                   = pkg {
-                      unitId = stringToUnitId (packageNameString pkg)
+                      unitId = let PackageName fs = packageName pkg
+                               in fsToUnitId fs
                     }
                   | otherwise
                   = pkg
@@ -786,9 +966,9 @@ findWiredInPackages dflags pkgs vis_map = do
 
 updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap
 updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
-  where f vm (from, to) = case lookupUDFM vis_map from of
+  where f vm (from, to) = case Map.lookup from vis_map of
                     Nothing -> vm
-                    Just r -> addToUDFM vm to r
+                    Just r -> Map.insert to r (Map.delete from vm)
 
 
 -- ----------------------------------------------------------------------------
@@ -797,6 +977,10 @@ type IsShadowed = Bool
 data UnusablePackageReason
   = IgnoredWithFlag
   | MissingDependencies IsShadowed [UnitId]
+instance Outputable UnusablePackageReason where
+    ppr IgnoredWithFlag = text "[ignored with flag]"
+    ppr (MissingDependencies b uids) =
+        brackets (if b then text "shadowed" else empty <+> ppr uids)
 
 type UnusablePackages = Map UnitId
                             (PackageConfig, UnusablePackageReason)
@@ -876,9 +1060,7 @@ mkPackageState
     -> [(FilePath, [PackageConfig])]     -- initial databases
     -> [UnitId]              -- preloaded packages
     -> IO (PackageState,
-           [UnitId],         -- new packages to preload
-           UnitId) -- this package, might be modified if the current
-                      -- package is a wired-in package.
+           [UnitId])         -- new packages to preload
 
 mkPackageState dflags dbs preload0 = do
   -- Compute the unit id
@@ -938,6 +1120,8 @@ mkPackageState dflags dbs preload0 = do
 
   let other_flags = reverse (packageFlags dflags)
       ignore_flags = reverse (ignorePackageFlags dflags)
+  debugTraceMsg dflags 2 $
+      text "package flags" <+> ppr other_flags
 
   let merge (pkg_map, prev_unusable) (db_path, db) = do
             debugTraceMsg dflags 2 $
@@ -1004,6 +1188,7 @@ mkPackageState dflags dbs preload0 = do
   -- or not packages are visible or not)
   pkgs1 <- foldM (applyTrustFlag dflags unusable)
                  (Map.elems pkg_map1) (reverse (trustFlags dflags))
+  let prelim_pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs1
 
   --
   -- Calculate the initial set of packages, prior to any package flags.
@@ -1019,18 +1204,28 @@ mkPackageState dflags dbs preload0 = do
                     then emptyUDFM
                     else foldl' calcInitial emptyUDFM pkgs1
       vis_map1 = foldUDFM (\p vm ->
-                            if exposed p
-                               then addToUDFM vm (packageConfigId p)
-                                              (True, [], fsPackageName p)
+                            -- Note: we NEVER expose indefinite packages by
+                            -- default, because it's almost assuredly not
+                            -- what you want (no mix-in linking has occurred).
+                            if exposed p && unitIdIsDefinite (packageConfigId p)
+                               then Map.insert (packageConfigId p)
+                                               UnitVisibility {
+                                                 uv_expose_all = True,
+                                                 uv_renamings = [],
+                                                 uv_package_name = First (Just (fsPackageName p)),
+                                                 uv_requirements = Map.empty,
+                                                 uv_explicit = False
+                                               }
+                                               vm
                                else vm)
-                         emptyUDFM initial
+                         Map.empty initial
 
   --
   -- Compute a visibility map according to the command-line flags (-package,
   -- -hide-package).  This needs to know about the unusable packages, since if a
   -- user tries to enable an unusable package, we should let them know.
   --
-  vis_map2 <- foldM (applyPackageFlag dflags unusable
+  vis_map2 <- foldM (applyPackageFlag dflags prelim_pkg_db unusable
                         (gopt Opt_HideAllPackages dflags) pkgs1)
                             vis_map1 other_flags
 
@@ -1040,6 +1235,7 @@ mkPackageState dflags dbs preload0 = do
   -- package arguments we need to key against the old versions.
   --
   (pkgs2, wired_map) <- findWiredInPackages dflags pkgs1 vis_map2
+  let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2
 
   -- Update the visibility map, so we treat wired packages as visible.
   let vis_map = updateVisibilityMap wired_map vis_map2
@@ -1049,15 +1245,15 @@ mkPackageState dflags dbs preload0 = do
     case pluginPackageFlags dflags of
         -- common case; try to share the old vis_map
         [] | not hide_plugin_pkgs -> return vis_map
-           | otherwise -> return emptyUDFM
+           | otherwise -> return Map.empty
         _ -> do let plugin_vis_map1
-                        | hide_plugin_pkgs = emptyUDFM
+                        | hide_plugin_pkgs = Map.empty
                         -- Use the vis_map PRIOR to wired in,
                         -- because otherwise applyPackageFlag
                         -- won't work.
                         | otherwise = vis_map2
                 plugin_vis_map2
-                    <- foldM (applyPackageFlag dflags unusable
+                    <- foldM (applyPackageFlag dflags prelim_pkg_db unusable
                                 (gopt Opt_HideAllPluginPackages dflags) pkgs1)
                              plugin_vis_map1
                              (reverse (pluginPackageFlags dflags))
@@ -1078,16 +1274,24 @@ mkPackageState dflags dbs preload0 = do
   -- should contain at least rts & base, which is why we pretend that
   -- the command line contains -package rts & -package base.
   --
-  let preload1 = [ let key = unitId p
-                   in fromMaybe key (Map.lookup key wired_map)
-                 | f <- other_flags, p <- get_exposed f ]
+  -- NB: preload IS important even for type-checking, because we
+  -- need the correct include path to be set.
+  --
+  let preload1 = Map.keys (Map.filter uv_explicit vis_map)
 
-      get_exposed (ExposePackage _ a _) = take 1 . sortByVersion
-                                      . filter (matching a)
-                                      $ pkgs1
-      get_exposed _                 = []
+  let pkgname_map = foldl add Map.empty pkgs2
+        where add pn_map p
+                = Map.insert (packageName p) (unitIdComponentId (packageConfigId p)) pn_map
+
+  -- The explicitPackages accurately reflects the set of packages we have turned
+  -- on; as such, it also is the only way one can come up with requirements.
+  -- The requirement context is directly based off of this: we simply
+  -- look for nested unit IDs that are directly fed holes: the requirements
+  -- of those units are precisely the ones we need to track
+  let explicit_pkgs = Map.keys vis_map
+      req_ctx = Map.map (Set.toList)
+              $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map))
 
-  let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2
 
   let preload2 = preload1
 
@@ -1095,7 +1299,7 @@ mkPackageState dflags dbs preload0 = do
       -- add base & rts to the preload packages
       basicLinkedPackages
        | gopt Opt_AutoLinkPackages dflags
-          = filter (flip elemUDFM pkg_db)
+          = filter (flip elemUDFM (unPackageConfigMap pkg_db))
                 [baseUnitId, rtsUnitId]
        | otherwise = []
       -- but in any case remove the current package from the set of
@@ -1108,42 +1312,58 @@ mkPackageState dflags dbs preload0 = do
   dep_preload <- closeDeps dflags pkg_db (zip preload3 (repeat Nothing))
   let new_dep_preload = filter (`notElem` preload0) dep_preload
 
+  let mod_map = mkModuleToPkgConfAll dflags pkg_db vis_map
+  when (dopt Opt_D_dump_mod_map dflags) $
+      printInfoForUser (dflags { pprCols = 200 })
+                       alwaysQualify (pprModuleMap mod_map)
+
   -- Force pstate to avoid leaking the dflags0 passed to mkPackageState
   let !pstate = PackageState{
     preloadPackages     = dep_preload,
-    explicitPackages    = foldUDFM (\pkg xs ->
-                            if elemUDFM (packageConfigId pkg) vis_map
-                                then packageConfigId pkg : xs
-                                else xs) [] pkg_db,
+    explicitPackages    = explicit_pkgs,
     pkgIdMap            = pkg_db,
-    moduleToPkgConfAll  = mkModuleToPkgConfAll dflags pkg_db vis_map,
-    pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map
+    moduleToPkgConfAll  = mod_map,
+    pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map,
+    packageNameMap          = pkgname_map,
+    unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ],
+    requirementContext = req_ctx
     }
-  return (pstate, new_dep_preload, this_package)
+  return (pstate, new_dep_preload)
 
+-- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId'
+-- that it was recorded as in the package database.
+unwireUnitId :: DynFlags -> UnitId -> UnitId
+unwireUnitId dflags uid =
+    fromMaybe uid (Map.lookup uid (unwireMap (pkgState dflags)))
 
 -- -----------------------------------------------------------------------------
 -- | Makes the mapping from module to package info
 
+-- Slight irritation: we proceed by leafing through everything
+-- in the installed package database, which makes handling indefinite
+-- packages a bit bothersome.
+
 mkModuleToPkgConfAll
   :: DynFlags
   -> PackageConfigMap
   -> VisibilityMap
   -> ModuleToPkgConfAll
 mkModuleToPkgConfAll dflags pkg_db vis_map =
-    foldl' extend_modmap emptyMap (eltsUDFM pkg_db)
+    Map.foldlWithKey extend_modmap emptyMap vis_map
  where
   emptyMap = Map.empty
   sing pk m _ = Map.singleton (mkModule pk m)
   addListTo = foldl' merge
   merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m
   setOrigins m os = fmap (const os) m
-  extend_modmap modmap pkg = addListTo modmap theBindings
+  extend_modmap modmap uid
+    UnitVisibility { uv_expose_all = b, uv_renamings = rns }
+    = addListTo modmap theBindings
    where
+    pkg = pkg_lookup uid
+
     theBindings :: [(ModuleName, Map Module ModuleOrigin)]
-    theBindings | Just (b,rns,_) <- lookupUDFM vis_map (packageConfigId pkg)
-                              = newBindings b rns
-                | otherwise   = newBindings False []
+    theBindings = newBindings b rns
 
     newBindings :: Bool
                 -> [(ModuleName, ModuleName)]
@@ -1177,7 +1397,8 @@ mkModuleToPkgConfAll dflags pkg_db vis_map =
     hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]
 
     pk = packageConfigId pkg
-    pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db
+    pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid
+                        `orElse` pprPanic "pkg_lookup" (ppr uid)
 
     exposed_mods = exposedModules pkg
     hidden_mods = hiddenModules pkg
@@ -1349,7 +1570,7 @@ lookupModuleWithSuggestions' dflags mod_map m mb_pn
             | originVisible origin   -> (hidden_pkg,   hidden_mod,   x:exposed)
             | otherwise              -> (x:hidden_pkg, hidden_mod,   exposed)
 
-    pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags
+    pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m)
     mod_pkg = pkg_lookup . moduleUnitId
 
     -- Filters out origins which are not associated with the given package
@@ -1403,7 +1624,7 @@ getPreloadPackagesAnd dflags pkgids =
       preload = preloadPackages state
       pairs = zip pkgids (repeat Nothing)
   in do
-  all_pkgs <- throwErr dflags (foldM (add_package pkg_map) preload pairs)
+  all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs)
   return (map (getPackageDetails dflags) all_pkgs)
 
 -- Takes a list of packages, and returns the list with dependencies included,
@@ -1413,7 +1634,7 @@ closeDeps :: DynFlags
           -> [(UnitId, Maybe UnitId)]
           -> IO [UnitId]
 closeDeps dflags pkg_map ps
-    = throwErr dflags (closeDepsErr pkg_map ps)
+    = throwErr dflags (closeDepsErr dflags pkg_map ps)
 
 throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
 throwErr dflags m
@@ -1421,20 +1642,22 @@ throwErr dflags m
                 Failed e    -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))
                 Succeeded r -> return r
 
-closeDepsErr :: PackageConfigMap
+closeDepsErr :: DynFlags
+             -> PackageConfigMap
              -> [(UnitId,Maybe UnitId)]
              -> MaybeErr MsgDoc [UnitId]
-closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps
+closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps
 
 -- internal helper
-add_package :: PackageConfigMap
+add_package :: DynFlags
+            -> PackageConfigMap
             -> [UnitId]
             -> (UnitId,Maybe UnitId)
             -> MaybeErr MsgDoc [UnitId]
-add_package pkg_db ps (p, mb_parent)
+add_package dflags pkg_db ps (p, mb_parent)
   | p `elem` ps = return ps     -- Check if we've already added this package
   | otherwise =
-      case lookupPackage' pkg_db p of
+      case lookupPackage' (isIndefinite dflags) pkg_db p of
         Nothing -> Failed (missingPackageMsg p <>
                            missingDependencyMsg mb_parent)
         Just pkg -> do
@@ -1443,7 +1666,7 @@ add_package pkg_db ps (p, mb_parent)
            return (p : ps')
           where
             add_unit_key ps key
-              = add_package pkg_db ps (key, Just p)
+              = add_package dflags pkg_db ps (key, Just p)
 
 missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
 missingPackageMsg p = text "unknown package:" <+> ppr p
@@ -1455,10 +1678,9 @@ missingDependencyMsg (Just parent)
 
 -- -----------------------------------------------------------------------------
 
-unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String
-unitIdPackageIdString dflags pkg_key
-    | pkg_key == mainUnitId = Just "main"
-    | otherwise = fmap sourcePackageIdString (lookupPackage dflags pkg_key)
+componentIdString :: DynFlags -> ComponentId -> Maybe String
+componentIdString dflags cid =
+    fmap sourcePackageIdString (lookupComponentId dflags cid)
 
 -- | Will the 'Name' come from a dynamically linked library?
 isDllName :: DynFlags -> UnitId -> Module -> Name -> Bool
@@ -1516,14 +1738,29 @@ pprPackagesSimple = pprPackagesWith pprIPI
                        in e <> t <> text "  " <> ftext i
 
 -- | Show the mapping of modules to where they come from.
-pprModuleMap :: DynFlags -> SDoc
-pprModuleMap dflags =
-  vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags))))
+pprModuleMap :: ModuleToPkgConfAll -> SDoc
+pprModuleMap mod_map =
+  vcat (map pprLine (Map.toList mod_map))
     where
       pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
+      pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc
       pprEntry m (m',o)
         | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o)
         | otherwise = ppr m' <+> parens (ppr o)
 
 fsPackageName :: PackageConfig -> FastString
 fsPackageName = mkFastString . packageNameString
+
+-- | Given a fully instantiated 'UnitId', improve it into a
+-- 'HashedUnitId' if we can find it in the package database.
+improveUnitId :: PackageConfigMap -> UnitId -> UnitId
+improveUnitId pkg_map uid =
+    -- Do NOT lookup indefinite ones, they won't be useful!
+    case lookupPackage' False pkg_map uid of
+        Nothing  -> uid
+        Just pkg -> packageConfigId pkg -- use the hashed version!
+
+-- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used
+-- in the @hs-boot@ loop-breaker.
+getPackageConfigMap :: DynFlags -> PackageConfigMap
+getPackageConfigMap = pkgIdMap . pkgState
index 1197fad..c05d392 100644 (file)
@@ -1,7 +1,9 @@
 module Packages where
--- Well, this is kind of stupid...
-import {-# SOURCE #-} Module (UnitId)
-import {-# SOURCE #-} DynFlags (DynFlags)
+import {-# SOURCE #-} DynFlags(DynFlags)
+import {-# SOURCE #-} Module(ComponentId, UnitId)
 data PackageState
-unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String
+data PackageConfigMap
 emptyPackageState :: PackageState
+componentIdString :: DynFlags -> ComponentId -> Maybe String
+improveUnitId :: PackageConfigMap -> UnitId -> UnitId
+getPackageConfigMap :: DynFlags -> PackageConfigMap
index 361fa0b..6800fab 100644 (file)
@@ -615,6 +615,12 @@ data Token
   | ITstock
   | ITanyclass
 
+  -- Backpack tokens
+  | ITunit
+  | ITsignature
+  | ITdependency
+  | ITrequires
+
   -- Pragmas, see  note [Pragma source text] in BasicTypes
   | ITinline_prag       SourceText InlineSpec RuleMatchInfo
   | ITspec_prag         SourceText                -- SPECIALISE
@@ -825,6 +831,10 @@ reservedWordsFM = listToUFM $
          ( "prim",           ITprimcallconv,  xbit FfiBit),
          ( "javascript",     ITjavascriptcallconv, xbit FfiBit),
 
+         ( "unit",           ITunit,          0 ),
+         ( "dependency",     ITdependency,       0 ),
+         ( "signature",      ITsignature,     0 ),
+
          ( "rec",            ITrec,           xbit ArrowsBit .|.
                                               xbit RecursiveDoBit),
          ( "proc",           ITproc,          xbit ArrowsBit)
index 4cab083..d72aabd 100644 (file)
@@ -22,7 +22,7 @@
 --       buffer = stringToStringBuffer str
 --       parseState = mkPState flags buffer location
 -- @
-module Parser (parseModule, parseImport, parseStatement,
+module Parser (parseModule, parseSignature, parseImport, parseStatement, parseBackpack,
                parseDeclaration, parseExpression, parsePattern,
                parseTypeSignature,
                parseStmt, parseIdentifier,
@@ -41,6 +41,8 @@ import HsSyn
 -- compiler/main
 import HscTypes         ( IsBootInterface, WarningTxt(..) )
 import DynFlags
+import BkpSyn
+import PackageConfig
 
 -- compiler/utils
 import OrdList
@@ -371,6 +373,10 @@ output it generates.
  'stock'        { L _ ITstock }    -- for DerivingStrategies extension
  'anyclass'     { L _ ITanyclass } -- for DerivingStrategies extension
 
+ 'unit'         { L _ ITunit }
+ 'signature'    { L _ ITsignature }
+ 'dependency'   { L _ ITdependency }
+
  '{-# INLINE'             { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE
  '{-# SPECIALISE'         { L _ (ITspec_prag _) }
  '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _ _) }
@@ -487,6 +493,7 @@ TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
 
 -- Exported parsers
 %name parseModule module
+%name parseSignature signature
 %name parseImport importdecl
 %name parseStatement stmt
 %name parseDeclaration topdecl
@@ -496,6 +503,7 @@ TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
 %name parseStmt   maybe_stmt
 %name parseIdentifier  identifier
 %name parseType ctype
+%name parseBackpack backpack
 %partial parseHeader header
 %%
 
@@ -510,6 +518,92 @@ identifier :: { Located RdrName }
                                [mj AnnOpenP $1,mu AnnRarrow $2,mj AnnCloseP $3] }
 
 -----------------------------------------------------------------------------
+-- Backpack stuff
+
+backpack :: { [LHsUnit PackageName] }
+         : implicit_top units close { fromOL $2 }
+         | '{' units '}'            { fromOL $2 }
+
+units :: { OrdList (LHsUnit PackageName) }
+         : units ';' unit { $1 `appOL` unitOL $3 }
+         | units ';'      { $1 }
+         | unit           { unitOL $1 }
+
+unit :: { LHsUnit PackageName }
+        : 'unit' pkgname 'where' unitbody
+            { sL1 $1 $ HsUnit { hsunitName = $2
+                              , hsunitBody = fromOL $4 } }
+
+unitid :: { LHsUnitId PackageName }
+        : pkgname                  { sL1 $1 $ HsUnitId $1 [] }
+        | pkgname '[' msubsts ']'  { sLL $1 $> $ HsUnitId $1 (fromOL $3) }
+
+msubsts :: { OrdList (LHsModuleSubst PackageName) }
+        : msubsts ',' msubst { $1 `appOL` unitOL $3 }
+        | msubsts ','        { $1 }
+        | msubst             { unitOL $1 }
+
+msubst :: { LHsModuleSubst PackageName }
+        : modid '=' moduleid { sLL $1 $> $ ($1, $3) }
+        | modid VARSYM modid VARSYM { sLL $1 $> $ ($1, sLL $2 $> $ HsModuleVar $3) }
+
+moduleid :: { LHsModuleId PackageName }
+          : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar $2 }
+          | unitid ':' modid    { sLL $1 $> $ HsModuleId $1 $3 }
+
+pkgname :: { Located PackageName }
+        : STRING     { sL1 $1 $ PackageName (getSTRING $1) }
+        | litpkgname { sL1 $1 $ PackageName (unLoc $1) }
+
+litpkgname_segment :: { Located FastString }
+        : VARID  { sL1 $1 $ getVARID $1 }
+        | CONID  { sL1 $1 $ getCONID $1 }
+        | special_id { $1 }
+
+litpkgname :: { Located FastString }
+        : litpkgname_segment { $1 }
+        -- a bit of a hack, means p - b is parsed same as p-b, enough for now.
+        | litpkgname_segment '-' litpkgname  { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) }
+
+mayberns :: { Maybe [LRenaming] }
+        : {- empty -} { Nothing }
+        | '(' rns ')' { Just (fromOL $2) }
+
+rns :: { OrdList LRenaming }
+        : rns ',' rn { $1 `appOL` unitOL $3 }
+        | rns ','    { $1 }
+        | rn         { unitOL $1 }
+
+rn :: { LRenaming }
+        : modid 'as' modid { sLL $1 $> $ Renaming (unLoc $1) (unLoc $3) }
+        | modid            { sL1 $1    $ Renaming (unLoc $1) (unLoc $1) }
+
+unitbody :: { OrdList (LHsUnitDecl PackageName) }
+        : '{'     unitdecls '}'   { $2 }
+        | vocurly unitdecls close { $2 }
+
+unitdecls :: { OrdList (LHsUnitDecl PackageName) }
+        : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 }
+        | unitdecls ';'         { $1 }
+        | unitdecl              { unitOL $1 }
+
+unitdecl :: { LHsUnitDecl PackageName }
+        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
+             -- XXX not accurate
+             { sL1 $2 $ DeclD ModuleD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) }
+        | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body
+             { sL1 $2 $ DeclD SignatureD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) }
+        -- NB: MUST have maybedocheader here, otherwise shift-reduce conflict
+        -- will prevent us from parsing both forms.
+        | maybedocheader 'module' modid
+             { sL1 $2 $ DeclD ModuleD $3 Nothing }
+        | maybedocheader 'signature' modid
+             { sL1 $2 $ DeclD SignatureD $3 Nothing }
+        | 'dependency' unitid mayberns
+             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2
+                                              , idModRenaming = $3 }) }
+
+-----------------------------------------------------------------------------
 -- Module Header
 
 -- The place for module deprecation is really too restrictive, but if it
@@ -519,6 +613,14 @@ identifier :: { Located RdrName }
 -- either, and DEPRECATED is only expected to be used by people who really
 -- know what they are doing. :-)
 
+signature :: { Located (HsModule RdrName) }
+       : maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body
+             {% fileSrcSpan >>= \ loc ->
+                ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)
+                              (snd $ snd $7) $4 $1)
+                    )
+                    ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) }
+
 module :: { Located (HsModule RdrName) }
        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
              {% fileSrcSpan >>= \ loc ->
@@ -539,6 +641,9 @@ maybedocheader :: { Maybe LHsDocString }
 missing_module_keyword :: { () }
         : {- empty -}                           {% pushModuleContext }
 
+implicit_top :: { () }
+        : {- empty -}                           {% pushModuleContext }
+
 maybemodwarning :: { Maybe (Located WarningTxt) }
     : '{-# DEPRECATED' strings '#-}'
                       {% ajs (Just (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2)))
@@ -585,6 +690,10 @@ header  :: { Located (HsModule RdrName) }
                 {% fileSrcSpan >>= \ loc ->
                    ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
                           )) [mj AnnModule $2,mj AnnWhere $6] }
+        | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body
+                {% fileSrcSpan >>= \ loc ->
+                   ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
+                          )) [mj AnnModule $2,mj AnnWhere $6] }
         | header_body2
                 {% fileSrcSpan >>= \ loc ->
                    return (L loc (HsModule Nothing Nothing $1 [] Nothing
@@ -3093,6 +3202,9 @@ special_id
         | 'group'               { sL1 $1 (fsLit "group") }
         | 'stock'               { sL1 $1 (fsLit "stock") }
         | 'anyclass'            { sL1 $1 (fsLit "anyclass") }
+        | 'unit'                { sL1 $1 (fsLit "unit") }
+        | 'dependency'          { sL1 $1 (fsLit "dependency") }
+        | 'signature'           { sL1 $1 (fsLit "signature") }
 
 special_sym :: { Located FastString }
 special_sym : '!'       {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] }
index b1cb7fe..d41e9ef 100644 (file)
@@ -208,40 +208,16 @@ newTopSrcBinder (L loc rdr_name)
                 -- module name, we we get a confusing "M.T is not in scope" error later
 
         ; stage <- getStage
-        ; env <- getGblEnv
         ; if isBrackStage stage then
                 -- We are inside a TH bracket, so make an *Internal* name
                 -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames
              do { uniq <- newUnique
                 ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
-          else case tcg_impl_rdr_env env of
-            Just gr ->
-                -- We're compiling --sig-of, so resolve with respect to this
-                -- module.
-                -- See Note [Signature parameters in TcGblEnv and DynFlags]
-             do { case lookupGlobalRdrEnv gr (rdrNameOcc rdr_name) of
-                    -- Be sure to override the loc so that we get accurate
-                    -- information later
-                    [GRE{ gre_name = n }] -> do
-                      -- NB: Just adding this line will not work:
-                      --    addUsedGRE True gre
-                      -- see Note [Signature lazy interface loading] for
-                      -- more details.
-                      return (setNameLoc n loc)
-                    _ -> do
-                      { -- NB: cannot use reportUnboundName rdr_name
-                        -- because it looks up in the wrong RdrEnv
-                        -- ToDo: more helpful error messages
-                      ; addErr (unknownNameErr (pprNonVarNameSpace
-                            (occNameSpace (rdrNameOcc rdr_name))) rdr_name)
-                      ; return (mkUnboundNameRdr rdr_name)
-                      }
-                }
-            Nothing ->
-                -- Normal case
+          else
              do { this_mod <- getModule
                 ; traceRn (text "newTopSrcBinder" <+> (ppr this_mod $$ ppr rdr_name $$ ppr loc))
-                ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } }
+                ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }
+        }
 
 {-
 *********************************************************
@@ -1216,6 +1192,14 @@ data HsSigCtxt
   | RoleAnnotCtxt NameSet    -- A role annotation, with the names of all types
                              -- in the group
 
+instance Outputable HsSigCtxt where
+    ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns
+    ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns
+    ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n
+    ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns
+    ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns
+    ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns
+
 lookupSigOccRn :: HsSigCtxt
                -> Sig RdrName
                -> Located RdrName -> RnM (Located Name)
@@ -1398,7 +1382,7 @@ lookupFixity is a bit strange.
 * Nested local fixity decls are put in the local fixity env, which we
   find with getFixtyEnv
 
-* Imported fixities are found in the HIT or PIT
+* Imported fixities are found in the PIT
 
 * Top-level fixity decls in this module may be for Names that are
     either  Global         (constructors, class operations)
index 6b4942f..e1258a3 100644 (file)
@@ -12,6 +12,7 @@ module RnNames (
         gresFromAvails,
         calculateAvails,
         reportUnusedNames,
+        plusAvail,
         checkConName
     ) where
 
@@ -153,7 +154,10 @@ with yes we have gone with no for now.
 rnImports :: [LImportDecl RdrName]
           -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
 rnImports imports = do
-    this_mod <- getModule
+    tcg_env <- getGblEnv
+    -- NB: want an identity module here, because it's OK for a signature
+    -- module to import from its implementor
+    let this_mod = tcg_mod tcg_env
     let (source, ordinary) = partition is_source_import imports
         is_source_import d = ideclSource (unLoc d)
     stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary
@@ -811,7 +815,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
         -- NB: the AvailTC can have fields as well as data constructors (Trac #12127)
         combine (name1, a1@(AvailTC p1 _ _), mp1)
                 (name2, a2@(AvailTC p2 _ _), mp2)
-          = ASSERT( name1 == name2 && isNothing mp1 && isNothing mp2 )
+          = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2
+                   , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 )
             if p1 == name1 then (name1, a1, Just p2)
                            else (name1, a2, Just p1)
         combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)
index 84f1f4b..f2d3ef0 100644 (file)
@@ -65,7 +65,6 @@ import Outputable
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad( unless )
-import Data.Maybe( isJust )
 
 {-
 ************************************************************************
@@ -699,13 +698,7 @@ addLocalInst (home_ie, my_insts) ispec
                  | isGHCi    = deleteFromInstEnv home_ie ispec
                  | otherwise = home_ie
 
-               -- If we're compiling sig-of and there's an external duplicate
-               -- instance, silently ignore it (that's the instance we're
-               -- implementing!)  NB: we still count local duplicate instances
-               -- as errors.
-               -- See Note [Signature files and type class instances]
-               global_ie | isJust (tcg_sig_of tcg_env) = emptyInstEnv
-                         | otherwise = eps_inst_env eps
+               global_ie = eps_inst_env eps
                inst_envs = InstEnvs { ie_global  = global_ie
                                     , ie_local   = home_ie'
                                     , ie_visible = tcVisibleOrphanMods tcg_env }
diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs
new file mode 100644 (file)
index 0000000..be24423
--- /dev/null
@@ -0,0 +1,552 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module TcBackpack (
+    findExtraSigImports',
+    findExtraSigImports,
+    implicitRequirements',
+    implicitRequirements,
+    checkUnitId,
+    tcRnCheckUnitId,
+    tcRnMergeSignatures,
+    mergeSignatures,
+    tcRnInstantiateSignature,
+    instantiateSignature,
+) where
+
+import Packages
+import DynFlags
+import HsSyn
+import RdrName
+import TcRnMonad
+import InstEnv
+import FamInstEnv
+import Inst
+import TcIface
+import TcMType
+import TcType
+import TcSimplify
+import LoadIface
+import RnNames
+import ErrUtils
+import Id
+import Module
+import Name
+import NameEnv
+import NameSet
+import Avail
+import SrcLoc
+import HscTypes
+import Outputable
+import Type
+import FastString
+import Maybes
+import TcEnv
+import Var
+import PrelNames
+import qualified Data.Map as Map
+
+import Finder
+import UniqDSet
+import NameShape
+import TcErrors
+import TcUnify
+import RnModIface
+import Util
+
+import Control.Monad
+import Data.List (find, foldl')
+
+import {-# SOURCE #-} TcRnDriver
+
+#include "HsVersions.h"
+
+-- | Given a 'ModDetails' of an instantiated signature (note that the
+-- 'ModDetails' must be knot-tied consistently with the actual implementation)
+-- and a 'GlobalRdrEnv' constructed from the implementor of this interface,
+-- verify that the actual implementation actually matches the original
+-- interface.
+--
+-- Note that it is already assumed that the implementation *exports*
+-- a sufficient set of entities, since otherwise the renaming and then
+-- typechecking of the signature 'ModIface' would have failed.
+checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModDetails -> TcRn ()
+checkHsigIface tcg_env gr
+  ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
+               md_types = sig_type_env, md_exports = sig_exports   } = do
+    traceTc "checkHsigIface" $ vcat
+        [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
+    mapM_ check_export (map availName sig_exports)
+    unless (null sig_fam_insts) $
+        panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++
+               "instances in hsig files yet...")
+    -- Delete instances so we don't look them up when
+    -- checking instance satisfiability
+    -- TODO: this should not be necessary
+    tcg_env <- getGblEnv
+    setGblEnv tcg_env { tcg_inst_env = emptyInstEnv,
+                        tcg_fam_inst_env = emptyFamInstEnv,
+                        tcg_insts = [],
+                        tcg_fam_insts = [] } $ do
+    mapM_ check_inst sig_insts
+    failIfErrsM
+  where
+    -- NB: the Names in sig_type_env are bogus.  Let's say we have H.hsig
+    -- in package p that defines T; and we implement with himpl:H.  Then the
+    -- Name is p[himpl:H]:H.T, NOT himplH:H.T.  That's OK but we just
+    -- have to look up the right name.
+    sig_type_occ_env = mkOccEnv
+                     . map (\t -> (nameOccName (getName t), t))
+                     $ nameEnvElts sig_type_env
+    dfun_names = map getName sig_insts
+    check_export name
+      -- Skip instances, we'll check them later
+      | name `elem` dfun_names = return ()
+      -- See if we can find the type directly in the hsig ModDetails
+      -- TODO: need to special case wired in names
+      | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do
+        -- NB: We use tcLookupImported_maybe because we want to EXCLUDE
+        -- tcg_env (TODO: but maybe this isn't relevant anymore).
+        r <- tcLookupImported_maybe name
+        case r of
+          Failed err -> addErr err
+          Succeeded real_thing -> checkBootDeclM False sig_thing real_thing
+      -- The hsig did NOT define this function; that means it must
+      -- be a reexport.  In this case, make sure the 'Name' of the
+      -- reexport matches the 'Name exported here.
+      | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) =
+        when (name /= name') $ do
+            -- See Note [Error reporting bad reexport]
+            -- TODO: Actually this error swizzle doesn't work
+            let p (L _ ie) = name `elem` ieNames ie
+                loc = case tcg_rn_exports tcg_env of
+                       Just es | Just e <- find p es
+                         -- TODO: maybe we can be a little more
+                         -- precise here and use the Located
+                         -- info for the *specific* name we matched.
+                         -> getLoc e
+                       _ -> nameSrcSpan name
+            addErrAt loc
+                (badReexportedBootThing False name name')
+      -- This should actually never happen, but whatever...
+      | otherwise =
+        addErrAt (nameSrcSpan name)
+            (missingBootThing False name "exported by")
+
+-- Note [Error reporting bad reexport]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- NB: You want to be a bit careful about what location you report on reexports.
+-- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the
+-- correct source location.  However, if it was *reexported*, obviously the name
+-- is not going to have the right location.  In this case, we need to grovel in
+-- tcg_rn_exports to figure out where the reexport came from.
+
+
+
+-- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't
+-- assume that the implementing file actually implemented the instances (they
+-- may be reexported from elsewhere).  Where should we look for the instances?
+-- We do the same as we would otherwise: consult the EPS.  This isn't perfect
+-- (we might conclude the module exports an instance when it doesn't, see
+-- #9422), but we will never refuse to compile something.
+check_inst :: ClsInst -> TcM ()
+check_inst sig_inst = do
+    -- TODO: This could be very well generalized to support instance
+    -- declarations in boot files.
+    tcg_env <- getGblEnv
+    -- NB: Have to tug on the interface, not necessarily
+    -- tugged... but it didn't work?
+    mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))
+    -- Based off of 'simplifyDeriv'
+    let ty = idType (instanceDFunId sig_inst)
+        skol_info = InstSkol
+        -- Based off of tcSplitDFunTy
+        (tvs, theta, pred) =
+           case tcSplitForAllTys ty of { (tvs, rho)   ->
+           case splitFunTys rho     of { (theta, pred) ->
+           (tvs, theta, pred) }}
+        origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst
+    (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
+    (cts, tclvl) <- pushTcLevelM $ do
+       wanted <- newWanted origin
+                           (Just TypeLevel)
+                           (substTy skol_subst pred)
+       givens <- forM theta $ \given -> do
+           loc <- getCtLocM origin (Just TypeLevel)
+           let given_pred = substTy skol_subst given
+           new_ev <- newEvVar given_pred
+           return CtGiven { ctev_pred = given_pred
+                          -- Doesn't matter, make something up
+                          , ctev_evar = new_ev
+                          , ctev_loc = loc
+                          }
+       return $ wanted : givens
+    unsolved <- simplifyWantedsTcM cts
+
+    (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved
+    reportAllUnsolved (mkImplicWC implic)
+
+-- | Return this list of requirement interfaces that need to be merged
+-- to form @mod_name@, or @[]@ if this is not a requirement.
+requirementMerges :: DynFlags -> ModuleName -> [HoleModule]
+requirementMerges dflags mod_name =
+    fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags)))
+
+-- | For a module @modname@ of type 'HscSource', determine the list
+-- of extra "imports" of other requirements which should be considered part of
+-- the import of the requirement, because it transitively depends on those
+-- requirements by imports of modules from other packages.  The situation
+-- is something like this:
+--
+--      package p where
+--          signature A
+--          signature B
+--              import A
+--
+--      package q where
+--          include p
+--          signature A
+--          signature B
+--
+-- Although q's B does not directly import A, we still have to make sure we
+-- process A first, because the merging process will cause B to indirectly
+-- import A.  This function finds the TRANSITIVE closure of all such imports
+-- we need to make.
+findExtraSigImports' :: HscEnv
+                     -> HscSource
+                     -> ModuleName
+                     -> IO (UniqDSet ModuleName)
+findExtraSigImports' hsc_env HsigFile modname =
+    fmap unionManyUniqDSets (forM reqs $ \(iuid, mod_name) ->
+        (initIfaceLoad hsc_env
+            . withException
+            $ moduleFreeHolesPrecise (text "findExtraSigImports")
+                (mkModule (AnIndefUnitId iuid) mod_name)))
+  where
+    reqs = requirementMerges (hsc_dflags hsc_env) modname
+
+findExtraSigImports' _ _ _ = return emptyUniqDSet
+
+-- | 'findExtraSigImports', but in a convenient form for "GhcMake" and
+-- "TcRnDriver".
+findExtraSigImports :: HscEnv -> HscSource -> ModuleName
+                    -> IO [(Maybe FastString, Located ModuleName)]
+findExtraSigImports hsc_env hsc_src modname = do
+    extra_requirements <- findExtraSigImports' hsc_env hsc_src modname
+    return [ (Nothing, noLoc mod_name)
+           | mod_name <- uniqDSetToList extra_requirements ]
+
+-- A version of 'implicitRequirements'' which is more friendly
+-- for "GhcMake" and "TcRnDriver".
+implicitRequirements :: HscEnv
+                     -> [(Maybe FastString, Located ModuleName)]
+                     -> IO [(Maybe FastString, Located ModuleName)]
+implicitRequirements hsc_env normal_imports
+  = do mns <- implicitRequirements' hsc_env normal_imports
+       return [ (Nothing, noLoc mn) | mn <- mns ]
+
+-- Given a list of 'import M' statements in a module, figure out
+-- any extra implicit requirement imports they may have.  For
+-- example, if they 'import M' and M resolves to p[A=<B>], then
+-- they actually also import the local requirement B.
+implicitRequirements' :: HscEnv
+                     -> [(Maybe FastString, Located ModuleName)]
+                     -> IO [ModuleName]
+implicitRequirements' hsc_env normal_imports
+  = fmap concat $
+    forM normal_imports $ \(mb_pkg, L _ imp) -> do
+        found <- findImportedModule hsc_env imp mb_pkg
+        case found of
+            Found _ mod | thisPackage dflags /= moduleUnitId mod ->
+                return (uniqDSetToList (moduleFreeHoles mod))
+            _ -> return []
+  where dflags = hsc_dflags hsc_env
+
+-- | Given a 'UnitId', make sure it is well typed.  This is because
+-- unit IDs come from Cabal, which does not know if things are well-typed or
+-- not; a component may have been filled with implementations for the holes
+-- that don't actually fulfill the requirements.
+--
+-- INVARIANT: the UnitId is NOT a HashedUnitId
+checkUnitId :: UnitId -> TcM ()
+checkUnitId uid = do
+    case splitUnitIdInsts uid of
+      (_, Just insts) ->
+        forM_ insts $ \(mod_name, mod) ->
+            -- NB: direct hole instantiations are well-typed by construction
+  &nbs