Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
11 changed files:
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Home/PackageTable.hs
- + testsuite/tests/typecheck/should_compile/T26154.hs
- + testsuite/tests/typecheck/should_compile/T26154_A.hs
- + testsuite/tests/typecheck/should_compile/T26154_B.hs
- + testsuite/tests/typecheck/should_compile/T26154_B.hs-boot
- + testsuite/tests/typecheck/should_compile/T26154_Other.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
| ... | ... | @@ -246,7 +246,7 @@ hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$> |
| 246 | 246 | hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn
|
| 247 | 247 | |
| 248 | 248 | -- | Find instances visible from the given set of imports
|
| 249 | -hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [(Module, FamInstEnv)])
|
|
| 249 | +hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst])
|
|
| 250 | 250 | hugInstancesBelow hsc_env uid mnwib = do
|
| 251 | 251 | let mn = gwib_mod mnwib
|
| 252 | 252 | (insts, famInsts) <-
|
| ... | ... | @@ -256,7 +256,7 @@ hugInstancesBelow hsc_env uid mnwib = do |
| 256 | 256 | -- Don't include instances for the current module
|
| 257 | 257 | in if moduleName (mi_module (hm_iface mod_info)) == mn
|
| 258 | 258 | then []
|
| 259 | - else [(md_insts details, [(mi_module $ hm_iface mod_info, extendFamInstEnvList emptyFamInstEnv $ md_fam_insts details)])])
|
|
| 259 | + else [(md_insts details, md_fam_insts details)])
|
|
| 260 | 260 | True -- Include -hi-boot
|
| 261 | 261 | hsc_env
|
| 262 | 262 | uid
|
| ... | ... | @@ -286,8 +286,8 @@ why we still do redundant checks. |
| 286 | 286 | -- We don't need to check the current module, this is done in
|
| 287 | 287 | -- tcExtendLocalFamInstEnv.
|
| 288 | 288 | -- See Note [The type family instance consistency story].
|
| 289 | -checkFamInstConsistency :: ModuleEnv FamInstEnv -> [Module] -> TcM ()
|
|
| 290 | -checkFamInstConsistency hpt_fam_insts directlyImpMods
|
|
| 289 | +checkFamInstConsistency :: [Module] -> TcM ()
|
|
| 290 | +checkFamInstConsistency directlyImpMods
|
|
| 291 | 291 | = do { (eps, hug) <- getEpsAndHug
|
| 292 | 292 | ; traceTc "checkFamInstConsistency" (ppr directlyImpMods)
|
| 293 | 293 | ; let { -- Fetch the iface of a given module. Must succeed as
|
| ... | ... | @@ -317,6 +317,7 @@ checkFamInstConsistency hpt_fam_insts directlyImpMods |
| 317 | 317 | -- See Note [Order of type family consistency checks]
|
| 318 | 318 | }
|
| 319 | 319 | |
| 320 | + ; hpt_fam_insts <- liftIO $ HUG.allFamInstances hug
|
|
| 320 | 321 | ; debug_consistent_set <- mapM (\x -> (\y -> (x, length y)) <$> modConsistent x) directlyImpMods
|
| 321 | 322 | ; traceTc "init_consistent_set" (ppr debug_consistent_set)
|
| 322 | 323 | ; let init_consistent_set = map fst (reverse (sortOn snd debug_consistent_set))
|
| ... | ... | @@ -119,7 +119,7 @@ import GHC.Core.TyCo.Ppr( debugPprType ) |
| 119 | 119 | import GHC.Core.TyCo.Tidy( tidyTopType )
|
| 120 | 120 | import GHC.Core.FamInstEnv
|
| 121 | 121 | ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst
|
| 122 | - , famInstEnvElts, extendFamInstEnvList, normaliseType, emptyFamInstEnv, unionFamInstEnv )
|
|
| 122 | + , famInstEnvElts, extendFamInstEnvList, normaliseType )
|
|
| 123 | 123 | |
| 124 | 124 | import GHC.Parser.Header ( mkPrelImports )
|
| 125 | 125 | |
| ... | ... | @@ -464,8 +464,8 @@ tcRnImports hsc_env import_decls |
| 464 | 464 | = do { (rn_imports, imp_user_spec, rdr_env, imports) <- rnImports import_decls
|
| 465 | 465 | -- Get the default declarations for the classes imported by this module
|
| 466 | 466 | -- and group them by class.
|
| 467 | - ; tc_defaults <- NE.groupBy ((==) `on` cd_class) . (concatMap defaultList)
|
|
| 468 | - <$> tcGetClsDefaults (M.keys $ imp_mods imports)
|
|
| 467 | + ; tc_defaults <-(NE.groupBy ((==) `on` cd_class) . (concatMap defaultList))
|
|
| 468 | + <$> tcGetClsDefaults (M.keys $ imp_mods imports)
|
|
| 469 | 469 | ; this_mod <- getModule
|
| 470 | 470 | ; gbl_env <- getGblEnv
|
| 471 | 471 | ; let unitId = homeUnitId $ hsc_home_unit hsc_env
|
| ... | ... | @@ -477,10 +477,8 @@ tcRnImports hsc_env import_decls |
| 477 | 477 | -- filtering also ensures that we don't see instances from
|
| 478 | 478 | -- modules batch (@--make@) compiled before this one, but
|
| 479 | 479 | -- which are not below this one.
|
| 480 | - ; (home_insts, home_mod_fam_inst_env) <- liftIO $
|
|
| 480 | + ; (home_insts, home_fam_insts) <- liftIO $
|
|
| 481 | 481 | hugInstancesBelow hsc_env unitId mnwib
|
| 482 | - ; let home_fam_inst_env = foldl' unionFamInstEnv emptyFamInstEnv $ snd <$> home_mod_fam_inst_env
|
|
| 483 | - ; let hpt_fam_insts = mkModuleEnv home_mod_fam_inst_env
|
|
| 484 | 482 | |
| 485 | 483 | -- We use 'unsafeInterleaveIO' to avoid redundant memory allocations
|
| 486 | 484 | -- See Note [Lazily loading COMPLETE pragmas] from GHC.HsToCore.Monad
|
| ... | ... | @@ -506,7 +504,8 @@ tcRnImports hsc_env import_decls |
| 506 | 504 | tcg_rn_imports = rn_imports,
|
| 507 | 505 | tcg_default = foldMap subsume tc_defaults,
|
| 508 | 506 | tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts,
|
| 509 | - tcg_fam_inst_env = unionFamInstEnv (tcg_fam_inst_env gbl) home_fam_inst_env
|
|
| 507 | + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
|
|
| 508 | + home_fam_insts
|
|
| 510 | 509 | }) $ do {
|
| 511 | 510 | |
| 512 | 511 | ; traceRn "rn1" (ppr (imp_direct_dep_mods imports))
|
| ... | ... | @@ -536,7 +535,7 @@ tcRnImports hsc_env import_decls |
| 536 | 535 | $ imports }
|
| 537 | 536 | ; logger <- getLogger
|
| 538 | 537 | ; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ())
|
| 539 | - $ checkFamInstConsistency hpt_fam_insts dir_imp_mods
|
|
| 538 | + $ checkFamInstConsistency dir_imp_mods
|
|
| 540 | 539 | ; traceRn "rn1: } checking family instance consistency" empty
|
| 541 | 540 | |
| 542 | 541 | ; gbl_env <- getGblEnv
|
| ... | ... | @@ -43,6 +43,7 @@ module GHC.Unit.Home.Graph |
| 43 | 43 | |
| 44 | 44 | -- * Very important queries
|
| 45 | 45 | , allInstances
|
| 46 | + , allFamInstances
|
|
| 46 | 47 | , allAnns
|
| 47 | 48 | , allCompleteSigs
|
| 48 | 49 | |
| ... | ... | @@ -109,6 +110,10 @@ allInstances hug = foldr go (pure (emptyInstEnv, [])) hug where |
| 109 | 110 | go hue = liftA2 (\(a,b) (a',b') -> (a `unionInstEnv` a', b ++ b'))
|
| 110 | 111 | (hptAllInstances (homeUnitEnv_hpt hue))
|
| 111 | 112 | |
| 113 | +allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv)
|
|
| 114 | +allFamInstances hug = foldr go (pure emptyModuleEnv) hug where
|
|
| 115 | + go hue = liftA2 plusModuleEnv (hptAllFamInstances (homeUnitEnv_hpt hue))
|
|
| 116 | + |
|
| 112 | 117 | allAnns :: HomeUnitGraph -> IO AnnEnv
|
| 113 | 118 | allAnns hug = foldr go (pure emptyAnnEnv) hug where
|
| 114 | 119 | go hue = liftA2 plusAnnEnv (hptAllAnnotations (homeUnitEnv_hpt hue))
|
| ... | ... | @@ -41,6 +41,7 @@ module GHC.Unit.Home.PackageTable |
| 41 | 41 | -- * Queries about home modules
|
| 42 | 42 | , hptCompleteSigs
|
| 43 | 43 | , hptAllInstances
|
| 44 | + , hptAllFamInstances
|
|
| 44 | 45 | , hptAllAnnotations
|
| 45 | 46 | |
| 46 | 47 | -- ** More Traversal-based queries
|
| ... | ... | @@ -207,6 +208,14 @@ hptAllInstances hpt = do |
| 207 | 208 | let (insts, famInsts) = unzip hits
|
| 208 | 209 | return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts)
|
| 209 | 210 | |
| 211 | +-- | Find all the family instance declarations from the HPT
|
|
| 212 | +hptAllFamInstances :: HomePackageTable -> IO (ModuleEnv FamInstEnv)
|
|
| 213 | +hptAllFamInstances = fmap mkModuleEnv . concatHpt (\hmi -> [(hmiModule hmi, hmiFamInstEnv hmi)])
|
|
| 214 | + where
|
|
| 215 | + hmiModule = mi_module . hm_iface
|
|
| 216 | + hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv
|
|
| 217 | + . md_fam_insts . hm_details
|
|
| 218 | + |
|
| 210 | 219 | -- | All annotations from the HPT
|
| 211 | 220 | hptAllAnnotations :: HomePackageTable -> IO AnnEnv
|
| 212 | 221 | hptAllAnnotations = fmap mkAnnEnv . concatHpt (md_anns . hm_details)
|
| 1 | + |
|
| 2 | +module T26154 where
|
|
| 3 | + |
|
| 4 | +import {-# SOURCE #-} T26154_B
|
|
| 5 | +import T26154_Other |
| 1 | + |
|
| 2 | +{-# LANGUAGE TypeFamilies #-}
|
|
| 3 | + |
|
| 4 | +module T26154_A where
|
|
| 5 | + |
|
| 6 | +import {-# SOURCE #-} T26154_B
|
|
| 7 | + |
|
| 8 | +type family F a b
|
|
| 9 | +type instance F a b = b |
| 1 | +{-# LANGUAGE TypeFamilies #-}
|
|
| 2 | + |
|
| 3 | +module T26154_B where
|
|
| 4 | + |
|
| 5 | +import T26154_A
|
|
| 6 | + |
|
| 7 | +type family FAA a b
|
|
| 8 | + |
|
| 9 | +type instance FAA a b = b |
|
| \ No newline at end of file |
| 1 | +{-# LANGUAGE TypeFamilies #-}
|
|
| 2 | + |
|
| 3 | +module T26154_B where |
| 1 | +{-# LANGUAGE TypeFamilies #-}
|
|
| 2 | + |
|
| 3 | +module T26154_Other where
|
|
| 4 | + |
|
| 5 | +type family OtherF a b
|
|
| 6 | + |
|
| 7 | +type instance OtherF a b = b |
|
| \ No newline at end of file |
| ... | ... | @@ -947,6 +947,7 @@ test('T25992', normal, compile, ['']) |
| 947 | 947 | test('T14010', normal, compile, [''])
|
| 948 | 948 | test('T26256a', normal, compile, [''])
|
| 949 | 949 | test('T25992a', normal, compile, [''])
|
| 950 | +test('T26154', [extra_files(['T26154_A.hs', 'T26154_B.hs', 'T26154_B.hs-boot', 'T26154_Other.hs'])], multimod_compile, ['T26154', '-v0'])
|
|
| 950 | 951 | test('T26346', normal, compile, [''])
|
| 951 | 952 | test('T26358', expect_broken(26358), compile, [''])
|
| 952 | 953 | test('T26345', normal, compile, [''])
|