Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

11 changed files:

Changes:

  • compiler/GHC/Driver/Env.hs
    ... ... @@ -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
    

  • compiler/GHC/Tc/Instance/Family.hs
    ... ... @@ -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))
    

  • compiler/GHC/Tc/Module.hs
    ... ... @@ -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
    

  • compiler/GHC/Unit/Home/Graph.hs
    ... ... @@ -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))
    

  • compiler/GHC/Unit/Home/PackageTable.hs
    ... ... @@ -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)
    

  • testsuite/tests/typecheck/should_compile/T26154.hs
    1
    +
    
    2
    +module T26154 where
    
    3
    +
    
    4
    +import {-# SOURCE #-} T26154_B
    
    5
    +import T26154_Other

  • testsuite/tests/typecheck/should_compile/T26154_A.hs
    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

  • testsuite/tests/typecheck/should_compile/T26154_B.hs
    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

  • testsuite/tests/typecheck/should_compile/T26154_B.hs-boot
    1
    +{-# LANGUAGE TypeFamilies #-}
    
    2
    +
    
    3
    +module T26154_B where

  • testsuite/tests/typecheck/should_compile/T26154_Other.hs
    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

  • testsuite/tests/typecheck/should_compile/all.T
    ... ... @@ -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, [''])