Fix #13214 by correctly setting up dep_orphs for signatures.

Prior to this, I hadn't thought about orphan handling at all.
This commit implements the semantics that if a signature
(transitively) imports an orphan instance, that instance
is considered in scope no matter what the implementing module
is.  (As it turns out, this is the semantics that falls out
when orphans are recorded transitively.)

This patch fixes a few bugs:

1. Put semantic modules in dep_orphs rather than identity
   modules.
2. Don't put the implementing module in dep_orphs when
   merging signatures (this is a silly bug that happened
   because we were reusing calculateAvails, which is
   designed for imports. It mostly works for signature
   merging, except this case.)
3. When renaming a signature, blast in the orphans of the
   implementing module inside Dependencies.

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

Test Plan: validate

Reviewers: bgamari, austin

Reviewed By: bgamari

Subscribers: thomie

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

12 files changed, 181 insertions, 6 deletions

diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs
index e32bb74e48..d77d061fb9 100644
--- a/compiler/backpack/RnModIface.hs
+++ b/compiler/backpack/RnModIface.hs
@@ -103,6 +103,7 @@ rnModIface hsc_env insts nsubst iface = do
         decls <- mapM rnIfaceDecl' (mi_decls iface)
         insts <- mapM rnIfaceClsInst (mi_insts iface)
         fams <- mapM rnIfaceFamInst (mi_fam_insts iface)
+        deps <- rnDependencies (mi_deps iface)
         -- TODO:
         -- mi_rules
         -- mi_vect_info (LOW PRIORITY)
@@ -111,7 +112,8 @@ rnModIface hsc_env insts nsubst iface = do
                      , mi_insts = insts
                      , mi_fam_insts = fams
                      , mi_exports = exports
-                     , mi_decls = decls }
+                     , mi_decls = decls
+                     , mi_deps = deps }
 
 -- | Rename just the exports of a 'ModIface'.  Useful when we're doing
 -- shaping prior to signature merging.
@@ -120,6 +122,26 @@ rnModExports hsc_env insts iface
     = initRnIface hsc_env iface insts Nothing
     $ mapM rnAvailInfo (mi_exports iface)
 
+rnDependencies :: Rename Dependencies
+rnDependencies deps = do
+    orphs  <- rnDepModules dep_orphs deps
+    finsts <- rnDepModules dep_finsts deps
+    return deps { dep_orphs = orphs, dep_finsts = finsts }
+
+rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module]
+rnDepModules sel deps = do
+    hsc_env <- getTopEnv
+    hmap <- getHoleSubst
+    -- NB: It's not necessary to test if we're doing signature renaming,
+    -- because ModIface will never contain module reference for itself
+    -- in these dependencies.
+    fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do
+        dflags <- getDynFlags
+        let mod' = renameHoleModule dflags hmap mod
+        iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env
+                        $ loadSysInterface (text "rnDepModule") mod'
+        return (mod' : sel (mi_deps iface))
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 2cde294678..dc9cdd9063 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -321,6 +321,7 @@ calculateAvails :: DynFlags
                 -> ImportAvails
 calculateAvails dflags iface mod_safe' want_boot =
   let imp_mod    = mi_module iface
+      imp_sem_mod= mi_semantic_module iface
       orph_iface = mi_orphan iface
       has_finsts = mi_finsts iface
       deps       = mi_deps iface
@@ -353,12 +354,12 @@ calculateAvails dflags iface mod_safe' want_boot =
       -- 'imp_finsts' if it defines an orphan or instance family; thus the
       -- orph_iface/has_iface tests.
 
-      orphans | orph_iface = ASSERT( not (imp_mod `elem` dep_orphs deps) )
-                             imp_mod : dep_orphs deps
+      orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )
+                             imp_sem_mod : dep_orphs deps
               | otherwise  = dep_orphs deps
 
-      finsts | has_finsts = ASSERT( not (imp_mod `elem` dep_finsts deps) )
-                            imp_mod : dep_finsts deps
+      finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )
+                            imp_sem_mod : dep_finsts deps
              | otherwise  = dep_finsts deps
 
       pkg = moduleUnitId (mi_module iface)
diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs
index ce8ab7a970..fef586f69c 100644
--- a/compiler/typecheck/TcBackpack.hs
+++ b/compiler/typecheck/TcBackpack.hs
@@ -689,8 +689,12 @@ mergeSignatures hsmod lcl_iface0 = do
             (insts, inst_env) = foldl' merge_inst
                                     (tcg_insts tcg_env, tcg_inst_env tcg_env)
                                     (md_insts details)
+            -- This is a HACK to prevent calculateAvails from including imp_mod
+            -- in the listing.  We don't want it because a module is NOT
+            -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214
+            iface' = iface { mi_orphan = False, mi_finsts = False }
             avails = plusImportAvails (tcg_imports tcg_env)
-                                      (calculateAvails dflags iface False False)
+                                      (calculateAvails dflags iface' False False)
         return tcg_env {
             tcg_inst_env = inst_env,
             tcg_insts    = insts,
diff --git a/docs/users_guide/separate_compilation.rst b/docs/users_guide/separate_compilation.rst
index 4f862e5e2c..9693cea8fd 100644
--- a/docs/users_guide/separate_compilation.rst
+++ b/docs/users_guide/separate_compilation.rst
@@ -954,6 +954,11 @@ to ``hs-boot`` files, but with some slight changes:
   they are implemented in a non-overlapping way.  If this is
   giving you problems give us a shout.
 
+- Any orphan instances which are brought into scope by an import
+  from a signature are unconditionally considered in scope, even
+  if the eventual implementing module doesn't actually import the
+  same orphans.
+
 Known limitations:
 
 - Algebraic data types specified in a signature cannot be implemented using
diff --git a/testsuite/tests/backpack/should_compile/T13214.bkp b/testsuite/tests/backpack/should_compile/T13214.bkp
new file mode 100644
index 0000000000..833cc1b953
--- /dev/null
+++ b/testsuite/tests/backpack/should_compile/T13214.bkp
@@ -0,0 +1,33 @@
+unit p where
+    signature A where
+        instance Show (a -> b)
+        a :: Bool
+    module B where
+        import A
+        f = show (\x -> x)
+    signature H where
+        import A
+unit q where
+    module A where
+        instance Show (a -> b) where
+            show _ = "<function>"
+        a = True
+    module A2 where
+        import A
+        a = False
+unit r1 where
+    dependency p[A=q:A,H=<H>]
+    module C where
+        import B
+        g = show (\x -> x)
+unit r2 where
+    dependency p[A=q:A2,H=<H>]
+    module C where
+        import B
+        g = show (\x -> x)
+unit r3 where
+    dependency p[A=<X>,H=<H>]
+    module D where
+        import X
+        import B
+        g = show (\x -> x)
diff --git a/testsuite/tests/backpack/should_compile/T13214.stderr b/testsuite/tests/backpack/should_compile/T13214.stderr
new file mode 100644
index 0000000000..dea6d06ff4
--- /dev/null
+++ b/testsuite/tests/backpack/should_compile/T13214.stderr
@@ -0,0 +1,18 @@
+[1 of 5] Processing p
+  [1 of 3] Compiling A[sig]           ( p/A.hsig, nothing )
+  [2 of 3] Compiling B                ( p/B.hs, nothing )
+  [3 of 3] Compiling H[sig]           ( p/H.hsig, nothing )
+[2 of 5] Processing q
+  Instantiating q
+  [1 of 2] Compiling A                ( q/A.hs, T13214.out/q/A.o )
+  [2 of 2] Compiling A2               ( q/A2.hs, T13214.out/q/A2.o )
+[3 of 5] Processing r1
+  [1 of 2] Compiling H[sig]           ( r1/H.hsig, nothing )
+  [2 of 2] Compiling C                ( r1/C.hs, nothing )
+[4 of 5] Processing r2
+  [1 of 2] Compiling H[sig]           ( r2/H.hsig, nothing )
+  [2 of 2] Compiling C                ( r2/C.hs, nothing )
+[5 of 5] Processing r3
+  [1 of 3] Compiling X[sig]           ( r3/X.hsig, nothing )
+  [2 of 3] Compiling H[sig]           ( r3/H.hsig, nothing )
+  [3 of 3] Compiling D                ( r3/D.hs, nothing )
diff --git a/testsuite/tests/backpack/should_compile/all.T b/testsuite/tests/backpack/should_compile/all.T
index e7834df464..31bbfcf019 100644
--- a/testsuite/tests/backpack/should_compile/all.T
+++ b/testsuite/tests/backpack/should_compile/all.T
@@ -42,5 +42,7 @@ test('bkp47', normal, backpack_compile, [''])
 test('bkp48', normal, backpack_compile, [''])
 test('bkp49', normal, backpack_compile, [''])
 test('bkp50', normal, backpack_compile, [''])
+test('bkp51', normal, backpack_compile, [''])
 
 test('T13149', expect_broken(13149), backpack_compile, [''])
+test('T13214', normal, backpack_compile, [''])
diff --git a/testsuite/tests/backpack/should_compile/bkp51.bkp b/testsuite/tests/backpack/should_compile/bkp51.bkp
new file mode 100644
index 0000000000..af0a422464
--- /dev/null
+++ b/testsuite/tests/backpack/should_compile/bkp51.bkp
@@ -0,0 +1,35 @@
+unit p where
+    module A0 where
+        instance Show (a -> b) where
+            show _ = "<function>"
+    module A where
+        import A0
+    module AA where
+unit q where
+    dependency p
+    signature B where
+        import A
+    signature H where
+    module C where
+        import B
+        x = show id
+unit r where
+    dependency q[B=<B>,H=<H>]
+    module D where
+        import B
+        y = show id
+unit s where
+    dependency r[B=p:A,H=<H>]
+    module E where
+        import D
+        z = show id
+unit t where
+    dependency r[B=s:E,H=<H>]
+    module F where
+        import D
+        a = show id
+unit u where
+    dependency q[B=p:AA,H=<H>]
+    module G where
+        import C
+        b = show id
diff --git a/testsuite/tests/backpack/should_compile/bkp51.stderr b/testsuite/tests/backpack/should_compile/bkp51.stderr
new file mode 100644
index 0000000000..652f309735
--- /dev/null
+++ b/testsuite/tests/backpack/should_compile/bkp51.stderr
@@ -0,0 +1,22 @@
+[1 of 6] Processing p
+  Instantiating p
+  [1 of 3] Compiling A0               ( p/A0.hs, bkp51.out/p/A0.o )
+  [2 of 3] Compiling A                ( p/A.hs, bkp51.out/p/A.o )
+  [3 of 3] Compiling AA               ( p/AA.hs, bkp51.out/p/AA.o )
+[2 of 6] Processing q
+  [1 of 3] Compiling B[sig]           ( q/B.hsig, nothing )
+  [2 of 3] Compiling H[sig]           ( q/H.hsig, nothing )
+  [3 of 3] Compiling C                ( q/C.hs, nothing )
+[3 of 6] Processing r
+  [1 of 3] Compiling H[sig]           ( r/H.hsig, nothing )
+  [2 of 3] Compiling B[sig]           ( r/B.hsig, nothing )
+  [3 of 3] Compiling D                ( r/D.hs, nothing )
+[4 of 6] Processing s
+  [1 of 2] Compiling H[sig]           ( s/H.hsig, nothing )
+  [2 of 2] Compiling E                ( s/E.hs, nothing )
+[5 of 6] Processing t
+  [1 of 2] Compiling H[sig]           ( t/H.hsig, nothing )
+  [2 of 2] Compiling F                ( t/F.hs, nothing )
+[6 of 6] Processing u
+  [1 of 2] Compiling H[sig]           ( u/H.hsig, nothing )
+  [2 of 2] Compiling G                ( u/G.hs, nothing )
diff --git a/testsuite/tests/backpack/should_fail/all.T b/testsuite/tests/backpack/should_fail/all.T
index ff171d38f6..9878c79464 100644
--- a/testsuite/tests/backpack/should_fail/all.T
+++ b/testsuite/tests/backpack/should_fail/all.T
@@ -38,3 +38,4 @@ test('bkpfail39', expect_broken(13068), backpack_compile_fail, [''])
 test('bkpfail40', normal, backpack_compile_fail, [''])
 test('bkpfail41', normal, backpack_compile_fail, [''])
 test('bkpfail42', normal, backpack_compile_fail, [''])
+test('bkpfail43', normal, backpack_compile_fail, [''])
diff --git a/testsuite/tests/backpack/should_fail/bkpfail43.bkp b/testsuite/tests/backpack/should_fail/bkpfail43.bkp
new file mode 100644
index 0000000000..c00781d692
--- /dev/null
+++ b/testsuite/tests/backpack/should_fail/bkpfail43.bkp
@@ -0,0 +1,13 @@
+unit p where
+    signature A where
+        instance Show (a -> b)
+    module B where
+        import A
+        f = show (\x -> x)
+unit q where
+    module A where
+unit r where
+    dependency p[A=q:A]
+    module C where
+        import B
+        g = show (\x -> x)
diff --git a/testsuite/tests/backpack/should_fail/bkpfail43.stderr b/testsuite/tests/backpack/should_fail/bkpfail43.stderr
new file mode 100644
index 0000000000..91c010d2f7
--- /dev/null
+++ b/testsuite/tests/backpack/should_fail/bkpfail43.stderr
@@ -0,0 +1,19 @@
+[1 of 3] Processing p
+  [1 of 2] Compiling A[sig]           ( p/A.hsig, nothing )
+  [2 of 2] Compiling B                ( p/B.hs, nothing )
+[2 of 3] Processing q
+  Instantiating q
+  [1 of 1] Compiling A                ( q/A.hs, bkpfail43.out/q/A.o )
+[3 of 3] Processing r
+  Instantiating r
+  [1 of 1] Including p[A=q:A]
+    Instantiating p[A=q:A]
+    [1 of 2] Compiling A[sig]           ( p/A.hsig, bkpfail43.out/p/p-HVmFlcYSefiK5n1aDP1v7x/A.o )
+
+bkpfail43.out/p/p-HVmFlcYSefiK5n1aDP1v7x/../A.hi:1:1: error:
+    No instance for (GHC.Show.Show (a -> b))
+      arising when attempting to show that
+      instance [safe] GHC.Show.Show (a -> b)
+        -- Defined at bkpfail43.bkp:3:18
+      is provided by ‘q:A’
+      (maybe you haven't applied a function to enough arguments?)