diff options
| -rw-r--r-- | compiler/typecheck/FamInst.hs | 73 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.hs | 4 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnMonad.hs | 1 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 7 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs | 4 | ||||
| -rw-r--r-- | testsuite/driver/extra_files.py | 1 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_compile/T11062.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_compile/T11062.hs-boot | 3 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_compile/T11062a.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_compile/all.T | 2 |
10 files changed, 95 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 diff --git a/testsuite/driver/extra_files.py b/testsuite/driver/extra_files.py index f151d75849..c2cb401d1f 100644 --- a/testsuite/driver/extra_files.py +++ b/testsuite/driver/extra_files.py @@ -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 index 0000000000..d7dbb856d0 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T11062.hs @@ -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 index 0000000000..fb56005fa1 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T11062.hs-boot @@ -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 index 0000000000..7e1a456db1 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T11062a.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} +module T11062a where +import {-# SOURCE #-} T11062 +type instance F Int = Bool diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 999786e1c1..d628366935 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -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, ['']) |