Support for using only partial pieces of included signatures.

Summary:
Generally speaking, it's not possible to "hide" a requirement from a
package you include, because if there is some module relying on that
requirement, well, you can't just wish it out of existence.

However, some packages don't have any modules.  For these, we can
validly thin out requirements; indeed, this is very convenient if
someone has published a large signature package but you only want
some of the definitions.

This patchset tweaks the interpretation of export lists in
signatures: in particular, they no longer need to refer to
entities that are defined locally; they range over both the current
signature as well as any signatures that were inherited from
signature packages (defined by having zero exposed modules.)

In the process of doing this, I cleaned up a number of other
things:

* rnModIface and rnModExports now report errors that occurred
  during renaming and can propagate these to the TcM monad.
  This is important because in the current semantics, you can
  thin out a type which is referenced by a value you keep;
  in this situation, we need to error (to ensure that all
  types in signatures are rooted, so that we can determine
  their identities).

* I ended up introducing a new construct 'dependency signature;
  to bkp files, to make it easier to tell if we were depending
  on a signature package.  It's not difficult for Cabal to
  figure this out (I already have a patch for it.)

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

Test Plan: validate

Reviewers: simonpj, austin, bgamari

Subscribers: thomie, mpickering

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

GHC Trac Issues: #12994

4 files changed, 129 insertions, 31 deletions

diff --git a/compiler/backpack/BkpSyn.hs b/compiler/backpack/BkpSyn.hs
index e019d03b24..a7e4db30dd 100644
--- a/compiler/backpack/BkpSyn.hs
+++ b/compiler/backpack/BkpSyn.hs
@@ -68,7 +68,12 @@ type LHsUnitDecl n = Located (HsUnitDecl n)
 -- | An include of another unit
 data IncludeDecl n = IncludeDecl {
         idUnitId :: LHsUnitId n,
-        idModRenaming :: Maybe [ LRenaming ]
+        idModRenaming :: Maybe [ LRenaming ],
+        -- | Is this a @dependency signature@ include?  If so,
+        -- we don't compile this include when we instantiate this
+        -- unit (as there should not be any modules brought into
+        -- scope.)
+        idSignatureInclude :: Bool
     }
 
 -- | Rename a module from one name to another.  The identity renaming
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
index fc46ce1752..595cb25174 100644
--- a/compiler/backpack/DriverBkp.hs
+++ b/compiler/backpack/DriverBkp.hs
@@ -104,11 +104,20 @@ computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
     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) _)) =
+    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
+data SessionType
+    -- | A compilation operation which will result in a
+    -- runnable executable being produced.
+    = ExeSession
+    -- | A type-checking operation which produces only
+    -- interface files, no object files.
+    | TcSession
+    -- | A compilation operation which produces both
+    -- interface files and object files.
+    | CompSession
     deriving (Eq)
 
 -- | Create a temporary Session to do some sort of type checking or
@@ -208,11 +217,19 @@ compileUnit cid insts = do
     lunit <- getSource cid
     buildUnit CompSession cid insts lunit
 
--- Invariant: this NEVER returns InstalledUnitId
-hsunitDeps :: HsUnit HsComponentId -> [(UnitId, ModRenaming)]
-hsunitDeps unit = concatMap get_dep (hsunitBody unit)
+-- | Compute the dependencies with instantiations of a syntactic
+-- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a
+-- unit file, return the 'UnitId' corresponding to @p[A=<A>]@.
+-- The @include_sigs@ parameter controls whether or not we also
+-- include @dependency signature@ declarations in this calculation.
+--
+-- Invariant: this NEVER returns InstalledUnitId.
+hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)]
+hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)
   where
-    get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn))) = [(convertHsUnitId hsuid, go mb_lrn)]
+    get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))
+        | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)]
+        | otherwise = []
       where
         go Nothing = ModRenaming True []
         go (Just lrns) = ModRenaming False (map convRn lrns)
@@ -223,7 +240,11 @@ hsunitDeps unit = concatMap get_dep (hsunitBody unit)
 
 buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
 buildUnit session cid insts lunit = do
-    let deps_w_rns = hsunitDeps (unLoc lunit)
+    -- NB: include signature dependencies ONLY when typechecking.
+    -- If we're compiling, it's not necessary to recursively
+    -- compile a signature since it isn't going to produce
+    -- any object files.
+    let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)
         raw_deps = map fst deps_w_rns
     dflags <- getDynFlags
     -- The compilation dependencies are just the appropriately filled
@@ -273,11 +294,7 @@ buildUnit session cid insts lunit = do
             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
+            compat_pn = PackageName compat_fs
 
         return InstalledPackageInfo {
             -- Stub data
@@ -336,7 +353,7 @@ buildUnit session cid insts lunit = do
 compileExe :: LHsUnit HsComponentId -> BkpM ()
 compileExe lunit = do
     msgUnitId mainUnitId
-    let deps_w_rns = hsunitDeps (unLoc lunit)
+    let deps_w_rns = hsunitDeps False (unLoc lunit)
         deps = map fst deps_w_rns
         -- no renaming necessary
     forM_ (zip [1..] deps) $ \(i, dep) ->
@@ -562,7 +579,8 @@ renameHsUnits dflags m units = map (fmap renameHsUnit) units
     renameHsUnitDecl (IncludeD idecl) =
         IncludeD IncludeDecl {
             idUnitId = fmap renameHsUnitId (idUnitId idecl),
-            idModRenaming = idModRenaming idecl
+            idModRenaming = idModRenaming idecl,
+            idSignatureInclude = idSignatureInclude idecl
         }
 
     renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
@@ -713,7 +731,9 @@ hsModuleToModSummary :: PackageName
                      -> Located (HsModule RdrName)
                      -> BkpM ModSummary
 hsModuleToModSummary pn hsc_src modname
-                     hsmod@(L loc (HsModule _ _ imps _ _ _)) = do
+                     hsmod = do
+    let imps = hsmodImports (unLoc hsmod)
+        loc  = getLoc hsmod
     hsc_env <- getSession
     -- Sort of the same deal as in DriverPipeline's getLocation
     -- Use the PACKAGE NAME to find the location
diff --git a/compiler/backpack/NameShape.hs b/compiler/backpack/NameShape.hs
index ea6e193629..0804d71ebb 100644
--- a/compiler/backpack/NameShape.hs
+++ b/compiler/backpack/NameShape.hs
@@ -7,6 +7,7 @@ module NameShape(
     extendNameShape,
     nameShapeExports,
     substNameShape,
+    maybeSubstNameShape,
     ) where
 
 #include "HsVersions.h"
@@ -134,6 +135,15 @@ substNameShape ns n | nameModule n == ns_module ns
                     | otherwise
                     = n
 
+-- | Like 'substNameShape', but returns @Nothing@ if no substitution
+-- works.
+maybeSubstNameShape :: NameShape -> Name -> Maybe Name
+maybeSubstNameShape ns n
+    | nameModule n == ns_module ns
+    = lookupOccEnv (ns_map ns) (occName n)
+    | otherwise
+    = Nothing
+
 -- | The 'Module' of any 'Name's a 'NameShape' has action over.
 ns_module :: NameShape -> Module
 ns_module = mkHoleModule . ns_mod_name
diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs
index 4861628764..0a95849646 100644
--- a/compiler/backpack/RnModIface.hs
+++ b/compiler/backpack/RnModIface.hs
@@ -9,10 +9,13 @@
 module RnModIface(
     rnModIface,
     rnModExports,
+    tcRnModIface,
+    tcRnModExports,
     ) where
 
 #include "HsVersions.h"
 
+import SrcLoc
 import Outputable
 import HscTypes
 import Module
@@ -21,6 +24,7 @@ import Avail
 import IfaceSyn
 import FieldLabel
 import Var
+import ErrUtils
 
 import Name
 import TcRnMonad
@@ -34,9 +38,39 @@ import DynFlags
 
 import qualified Data.Traversable as T
 
+import Bag
+import Data.IORef
 import NameShape
 import IfaceEnv
 
+tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a
+tcRnMsgMaybe do_this = do
+    r <- liftIO $ do_this
+    case r of
+        Left errs -> do
+            addMessages (emptyBag, errs)
+            failM
+        Right x -> return x
+
+tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface
+tcRnModIface x y z = do
+    hsc_env <- getTopEnv
+    tcRnMsgMaybe $ rnModIface hsc_env x y z
+
+tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo]
+tcRnModExports x y = do
+    hsc_env <- getTopEnv
+    tcRnMsgMaybe $ rnModExports hsc_env x y
+
+failWithRn :: SDoc -> ShIfM a
+failWithRn doc = do
+    errs_var <- fmap sh_if_errs getGblEnv
+    dflags <- getDynFlags
+    errs <- readTcRef errs_var
+    -- TODO: maybe associate this with a source location?
+    writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc)
+    failM
+
 -- | 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
@@ -58,7 +92,7 @@ import IfaceEnv
 -- 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
+           -> ModIface -> IO (Either ErrorMessages ModIface)
 rnModIface hsc_env insts nsubst iface = do
     initRnIface hsc_env iface insts nsubst $ do
         mod <- rnModule (mi_module iface)
@@ -81,7 +115,7 @@ rnModIface hsc_env insts nsubst iface = do
 
 -- | 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 :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo])
 rnModExports hsc_env insts iface
     = initRnIface hsc_env iface insts Nothing
     $ mapM rnAvailInfo (mi_exports iface)
@@ -94,19 +128,28 @@ rnModExports hsc_env insts iface
 ************************************************************************
 -}
 
--- | Initialize the 'ShIfM' monad.
+-- | Run a computation in 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
+            -> ShIfM a -> IO (Either ErrorMessages a)
+initRnIface hsc_env iface insts nsubst do_this = do
+    errs_var <- newIORef emptyBag
+    let dflags = hsc_dflags hsc_env
+        hsubst = listToUFM insts
+        rn_mod = renameHoleModule dflags 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
+            sh_if_shape = nsubst,
+            sh_if_errs = errs_var
         }
-    in initTcRnIf 'c' hsc_env env () do_this
+    -- Modeled off of 'initTc'
+    res <- initTcRnIf 'c' hsc_env env () $ tryM do_this
+    msgs <- readIORef errs_var
+    case res of
+        Left _                          -> return (Left msgs)
+        Right r | not (isEmptyBag msgs) -> return (Left msgs)
+                | otherwise             -> return (Right r)
 
 -- | Environment for 'ShIfM' monads.
 data ShIfEnv = ShIfEnv {
@@ -123,7 +166,9 @@ data ShIfEnv = ShIfEnv {
         -- 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
+        sh_if_shape :: Maybe NameShape,
+        -- Mutable reference to keep track of errors (similar to 'tcl_errs')
+        sh_if_errs :: IORef ErrorMessages
     }
 
 getHoleSubst :: ShIfM ShHoleSubst
@@ -215,10 +260,21 @@ rnIfaceGlobal n = do
        , 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
+      -> do n' <- setNameModule (Just m') n
+            case mb_nsubst of
+                Nothing -> return n'
+                Just nsubst ->
+                    case maybeSubstNameShape nsubst n' of
+                        -- TODO: would love to have context
+                        -- TODO: This will give an unpleasant message if n'
+                        -- is a constructor; then we'll suggest adding T
+                        -- but it won't work.
+                        Nothing -> failWithRn $ vcat [
+                            text "The identifier" <+> ppr (occName n') <+>
+                                text "does not exist in the local signature.",
+                            parens (text "Try adding it to the export list of the hsig file.")
+                            ]
+                        Just n'' -> return n''
        -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the
        -- export list is irrelevant.
        | not (isHoleModule m)
@@ -239,7 +295,14 @@ rnIfaceGlobal n = do
             iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env
                             $ loadSysInterface (text "rnIfaceGlobal") m''
             let nsubst = mkNameShape (moduleName m) (mi_exports iface)
-            return (substNameShape nsubst n)
+            case maybeSubstNameShape nsubst n of
+                Nothing -> failWithRn $ vcat [
+                    text "The identifier" <+> ppr (occName n) <+>
+                        -- NB: report m' because it's more user-friendly
+                        text "does not exist in the signature for" <+> ppr m',
+                    parens (text "Try adding it to the export list in that hsig file.")
+                    ]
+                Just n' -> return n'
 
 -- | Rename a DFun name. Here is where we ensure that DFuns have the correct
 -- module as described in Note [Bogus DFun renamings].