Check family instance consistency of hs-boot families later, fixes #11062.
authorEdward Z. Yang <ezyang@cs.stanford.edu>
Fri, 16 Dec 2016 02:05:33 +0000 (18:05 -0800)
committerEdward Z. Yang <ezyang@cs.stanford.edu>
Sun, 18 Dec 2016 03:39:55 +0000 (19:39 -0800)
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

compiler/typecheck/FamInst.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcTyClsDecls.hs
testsuite/driver/extra_files.py
testsuite/tests/typecheck/should_compile/T11062.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T11062.hs-boot [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T11062a.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T

index 8fe0431..747100f 100644 (file)
@@ -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
index ce18a2d..ad49ca0 100644 (file)
@@ -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 } }
 
 {-
 ************************************************************************
index 7aabfdf..8c117f0 100644 (file)
@@ -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,
index a163aab..6d902b3 100644 (file)
@@ -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
index 381aa4d..34ce53f 100644 (file)
@@ -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
index f151d75..c2cb401 100644 (file)
@@ -60,6 +60,7 @@ extra_src_files = {
   'T10955dyn': ['A.c', 'B.c'],
   'T10971d': ['T10971c.hs'],
   'T11018': ['Test11018.hs'],
+  'T11062': ['T11062.hs','T11062.hs-boot','T11062a.hs'],
   'T11072gcc': ['A.c', 'T11072.hs'],
   'T11072msvc': ['A.c', 'T11072.hs', 'libAS.def', 'i686/', 'x86_64/'],
   'T11223_link_order_a_b_2_fail': ['bar.c', 'foo.c', 'foo3.hs'],
diff --git a/testsuite/tests/typecheck/should_compile/T11062.hs b/testsuite/tests/typecheck/should_compile/T11062.hs
new file mode 100644 (file)
index 0000000..d7dbb85
--- /dev/null
@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
+module T11062 where
+import T11062a
+type family F a
diff --git a/testsuite/tests/typecheck/should_compile/T11062.hs-boot b/testsuite/tests/typecheck/should_compile/T11062.hs-boot
new file mode 100644 (file)
index 0000000..fb56005
--- /dev/null
@@ -0,0 +1,3 @@
+{-# LANGUAGE TypeFamilies #-}
+module T11062 where
+type family F a
diff --git a/testsuite/tests/typecheck/should_compile/T11062a.hs b/testsuite/tests/typecheck/should_compile/T11062a.hs
new file mode 100644 (file)
index 0000000..7e1a456
--- /dev/null
@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
+module T11062a where
+import {-# SOURCE #-} T11062
+type instance F Int = Bool
index 999786e..d628366 100644 (file)
@@ -497,6 +497,8 @@ test('T10770a', expect_broken(10770), compile, [''])
 test('T10770b', expect_broken(10770), compile, [''])
 test('T10935', normal, compile, [''])
 test('T10971a', normal, compile, [''])
+test('T11062', extra_clean(['T11062.hi-boot', 'T11062.o-boot', 'T11062a.hi', 'T11062a.o']),
+     multimod_compile, ['T11062', '-v0'])
 test('T11237', normal, compile, [''])
 test('T10592', normal, compile, [''])
 test('T11305', normal, compile, [''])