Check family instance consistency of hs-boot families later, fixes #11062.

Summary:
With hs-boot files, some type families may be defined in the
module we are typechecking.  In this case, we are not allowed
to poke these families until after we typecheck our local
declarations.  So we first check everything involving non-recursive
families, and then check the recursive families as we finish
kind-checking them.

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

Test Plan: validate

Reviewers: goldfire, austin, simonpj, bgamari

Subscribers: thomie

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

GHC Trac Issues: #11062

5 files changed, 81 insertions, 8 deletions

diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs
index 8fe043112f..747100fb49 100644
--- a/compiler/typecheck/FamInst.hs
+++ b/compiler/typecheck/FamInst.hs
@@ -7,6 +7,7 @@ module FamInst (
         checkFamInstConsistency, tcExtendLocalFamInstEnv,
         tcLookupDataFamInst, tcLookupDataFamInst_maybe,
         tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,
+        checkRecFamInstConsistency,
         newFamInst,
 
         -- * Injectivity
@@ -41,8 +42,10 @@ import VarSet
 import Bag( Bag, unionBags, unitBag )
 import Control.Monad
 import Unique
+import NameEnv
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.List
 
 #include "HsVersions.h"
 
@@ -116,6 +119,9 @@ modules where both modules occur in the `HscTypes.dep_finsts' set (of the
 `HscTypes.Dependencies') of one of our directly imported modules must have
 already been checked.  Everything else, we check now.  (So that we can be
 certain that the modules in our `HscTypes.dep_finsts' are consistent.)
+
+There is some fancy footwork regarding hs-boot module loops, see
+Note [Don't check hs-boot type family instances too early]
 -}
 
 -- The optimisation of overlap tests is based on determining pairs of modules
@@ -181,7 +187,14 @@ listToSet l = Set.fromList l
 --
 -- See Note [Checking family instance consistency] for more
 -- details.
-checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
+--
+-- This function doesn't check ALL instances for consistency,
+-- only ones that aren't involved in recursive knot-tying
+-- loops; see Note [Don't check hs-boot type family instances too early].
+-- It returns a modified 'TcGblEnv' that has saved the
+-- instances that need to be checked later; use 'checkRecFamInstConsistency'
+-- to check those.
+checkFamInstConsistency :: [Module] -> [Module] -> TcM TcGblEnv
 checkFamInstConsistency famInstMods directlyImpMods
   = do { dflags     <- getDynFlags
        ; (eps, hpt) <- getEpsAndHpt
@@ -210,7 +223,10 @@ checkFamInstConsistency famInstMods directlyImpMods
                  -- See Note [ModulePairSet determinism and performance]
              }
 
-       ; mapM_ (check hpt_fam_insts) toCheckPairs
+       ; pending_checks <- mapM (check hpt_fam_insts) toCheckPairs
+       ; tcg_env <- getGblEnv
+       ; return tcg_env { tcg_pending_fam_checks
+                           = foldl' (plusNameEnv_C (++)) emptyNameEnv pending_checks }
        }
   where
     allPairs []     = []
@@ -219,12 +235,57 @@ checkFamInstConsistency famInstMods directlyImpMods
     check hpt_fam_insts (ModulePair m1 m2)
       = do { env1 <- getFamInsts hpt_fam_insts m1
            ; env2 <- getFamInsts hpt_fam_insts m2
-           ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))
-                   (famInstEnvElts env1)
-           ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2))
-                   (famInstEnvElts env1)
+           -- Note [Don't check hs-boot type family instances too early]
+           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+           -- Family instance consistency checking involves checking that
+           -- the family instances of our imported modules are consistent with
+           -- one another; this might lead you to think that this process
+           -- has nothing to do with the module we are about to typecheck.
+           -- Not so!  If a type family was defined in the hs-boot file
+           -- of the current module, we are NOT allowed to poke the TyThing
+           -- for this family: since we haven't typechecked the definition
+           -- yet (checkFamInstConsistency is called during renaming),
+           -- we won't be able to find our local copy in if_rec_types.
+           -- Failing to do this lead to #11062.
+           --
+           -- So, we have to defer the checks for family instances that
+           -- refer to families that are locally defined.
+           --
+           -- See also Note [Tying the knot] and Note [Type-checking inside the knot]
+           -- for why we are doing this at all.
+           ; this_mod <- getModule
+           ; let (check_now, check_later)
+                    -- NB: == this_mod only holds if there's an hs-boot file;
+                    -- otherwise we cannot possible see instances for families
+                    -- *defined by the module we are compiling* in imports.
+                    = partition ((/= this_mod) . nameModule . fi_fam)
+                                (famInstEnvElts env1)
+           ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))           check_now
+           ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now
+           ; let check_later_map =
+                    extendNameEnvList_C (++) emptyNameEnv
+                        [(fi_fam finst, [finst]) | finst <- check_later]
+           ; return (mapNameEnv (\xs -> [(xs, env2)]) check_later_map)
  }
 
+-- | Given a 'TyCon' that has been incorporated into the type
+-- environment (the knot is tied), if it is a type family, check
+-- that all deferred instances for it are consistent.
+-- See Note [Don't check hs-boot type family instances too early]
+checkRecFamInstConsistency :: TyCon -> TcM ()
+checkRecFamInstConsistency tc = do
+   tcg_env <- getGblEnv
+   let checkConsistency tc
+        | isFamilyTyCon tc
+        , Just pairs <- lookupNameEnv (tcg_pending_fam_checks tcg_env)
+                                      (tyConName tc)
+        = forM_ pairs $ \(check_now, env2) -> do
+            mapM_ (checkForConflicts (emptyFamInstEnv, env2))           check_now
+            mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now
+        | otherwise
+        = return ()
+   checkConsistency tc
+
 
 getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
 getFamInsts hpt_fam_insts mod
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index ce18a2d72d..ad49ca0601 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -347,9 +347,9 @@ tcRnImports hsc_env import_decls
         ; let { dir_imp_mods = moduleEnvKeys
                              . imp_mods
                              $ imports }
-        ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
+        ; tcg_env <- checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
 
-        ; getGblEnv } }
+        ; return tcg_env } }
 
 {-
 ************************************************************************
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 7aabfdf6ca..8c117f0936 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -252,6 +252,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_type_env_var   = type_env_var,
                 tcg_inst_env       = emptyInstEnv,
                 tcg_fam_inst_env   = emptyFamInstEnv,
+                tcg_pending_fam_checks = emptyNameEnv,
                 tcg_ann_env        = emptyAnnEnv,
                 tcg_th_used        = th_var,
                 tcg_th_splice_used = th_splice_var,
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index a163aab34d..6d902b32e0 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -501,6 +501,13 @@ data TcGblEnv
         tcg_fam_inst_env :: FamInstEnv, -- ^ Ditto for family instances
         tcg_ann_env      :: AnnEnv,     -- ^ And for annotations
 
+        -- | Family instances we have to check for consistency.
+        -- Invariant: each FamInst in the list's fi_fam matches the
+        -- key of the entry in the 'NameEnv'.  This gets consumed
+        -- by 'checkRecFamInstConsistency'.
+        -- See Note [Don't check hs-boot type family instances too early]
+        tcg_pending_fam_checks :: NameEnv [([FamInst], FamInstEnv)],
+
                 -- Now a bunch of things about this module that are simply
                 -- accumulated, but never consulted until the end.
                 -- Nevertheless, it's convenient to accumulate them along
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 381aa4dfcd..34ce53f04b 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -155,6 +155,10 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
        ; checkSynCycles this_uid tyclss tyclds
        ; traceTc "Done synonym cycle check" (ppr tyclss)
 
+       ; traceTc "Starting family consistency check" (ppr tyclss)
+       ; forM_ tyclss checkRecFamInstConsistency
+       ; traceTc "Done family consistency" (ppr tyclss)
+
            -- Step 2: Perform the validity check on those types/classes
            -- We can do this now because we are done with the recursive knot
            -- Do it before Step 3 (adding implicit things) because the latter