diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-08-23 17:07:04 +0100 |
|---|---|---|
| committer | Matthew Pickering <matthewtpickering@gmail.com> | 2021-08-23 17:09:56 +0100 |
| commit | 45db66412de602f94c37051111f84af905a03a67 (patch) | |
| tree | e09b9e6a45e7ac56b2cc69f52cd336cfefad7f16 | |
| parent | 6e1056038f23995cae33270fe5634d1248932e20 (diff) | |
| download | haskell-wip/splice-imports.tar.gz | |
Splice imports wipwip/splice-imports
45 files changed, 312 insertions, 63 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 73f3856f82..7259ffcb26 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -1493,7 +1493,7 @@ getNameToInstancesIndex visible_mods mods_to_load = do let doc = text "Need interface for reporting instances in scope" in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods - ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs + ; InstEnvs {ie_global, ie_local_obj, ie_local_tc} <- tcGetInstEnvs ; let visible_mods' = mkModuleSet visible_mods ; (pkg_fie, home_fie) <- tcGetFamInstEnvs -- We use Data.Sequence.Seq because we are creating left associated @@ -1501,7 +1501,7 @@ getNameToInstancesIndex visible_mods mods_to_load = do -- cls_index and fam_index below are adapted from GHC.Tc.Module.lookupInsts ; let cls_index = Map.fromListWith mappend [ (n, Seq.singleton ispec) - | ispec <- instEnvElts ie_local ++ instEnvElts ie_global + | ispec <- instEnvElts ie_local_tc ++ instEnvElts ie_local_obj ++ instEnvElts ie_global , instIsVisible visible_mods' ispec , n <- nameSetElemsStable $ orphNamesOfClsInst ispec ] diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index b5688e3ab2..f66d6929ee 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -53,6 +53,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import GHC.Utils.Trace {- ************************************************************************ @@ -395,7 +396,8 @@ type InstEnv = UniqDFM Class ClsInstEnv -- Maps Class to instances for that -- directly imported) used to test orphan instance visibility. data InstEnvs = InstEnvs { ie_global :: InstEnv, -- External-package instances - ie_local :: InstEnv, -- Home-package instances + ie_local_obj :: InstEnv, -- Home-package instances available in top-level splices + ie_local_tc :: InstEnv, -- Home-package instances available outside top-level splice ie_visible :: VisibleOrphanModules -- Set of all orphan modules transitively -- reachable from the module being compiled -- See Note [Instance lookup and orphan instances] @@ -446,8 +448,8 @@ instIsVisible vis_mods ispec | otherwise -> True classInstances :: InstEnvs -> Class -> [ClsInst] -classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls - = get home_ie ++ get pkg_ie +classInstances (InstEnvs { ie_global = pkg_ie, ie_local_obj = home_obj_ie, ie_local_tc = home_tc_ie, ie_visible = vis_mods }) cls + = get home_tc_ie ++ get home_obj_ie ++ get pkg_ie where get env = case lookupUDFM env cls of Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts @@ -796,11 +798,13 @@ anyone noticing, so it's manifestly not ruining anyone's day.) -- |Look up an instance in the given instance environment. The given class application must match exactly -- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful, -- yield 'Left errorMessage'. + +-- MP: TODO, check callsite lookupUniqueInstEnv :: InstEnvs -> Class -> [Type] -> Either SDoc (ClsInst, [Type]) lookupUniqueInstEnv instEnv cls tys - = case lookupInstEnv False instEnv cls tys of + = case lookupInstEnv False False instEnv cls tys of ([(inst, inst_tys)], _, _) | noFlexiVar -> Right (inst, inst_tys') | otherwise -> Left $ text "flexible type variable:" <+> @@ -879,25 +883,31 @@ lookupInstEnv' ie vis_mods cls tys --------------- -- This is the common way to call this function. lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions + -> Bool -- True iff in top-level splice -> InstEnvs -- External and home package inst-env -> Class -> [Type] -- What we are looking for -> ClsInstLookupResult -- ^ See Note [Rules for instance lookup] -- ^ See Note [Safe Haskell Overlapping Instances] in "GHC.Tc.Solver" -- ^ See Note [Safe Haskell Overlapping Instances Implementation] in "GHC.Tc.Solver" -lookupInstEnv check_overlap_safe +lookupInstEnv check_overlap_safe is_splice_context (InstEnvs { ie_global = pkg_ie - , ie_local = home_ie + , ie_local_obj = home_obj_ie + , ie_local_tc = home_tc_ie , ie_visible = vis_mods }) cls tys = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $ - (final_matches, final_unifs, unsafe_overlapped) + (pprTraceIt "insts" final_matches, final_unifs, unsafe_overlapped) where - (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys + (home_obj_matches, home_unifs) = lookupInstEnv' home_obj_ie vis_mods cls tys + (home_tc_matches, home_tc_unifs) = lookupInstEnv' home_tc_ie vis_mods cls tys + home_matches + | is_splice_context = home_obj_matches + | otherwise = home_tc_matches (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys all_matches = home_matches ++ pkg_matches - all_unifs = home_unifs ++ pkg_unifs + all_unifs = home_tc_unifs ++ home_unifs ++ pkg_unifs final_matches = foldr insert_overlapping [] all_matches -- Even if the unifs is non-empty (an error situation) -- we still prune the matches, so that the error message isn't diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 45fa18e31d..a8df5e1661 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -285,7 +285,7 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps in [ thing | -- Find each non-hi-boot module below me - GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- Set.toList (hptModulesBelow hsc_env deps) + GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- Set.toList (pprTraceIt "modules" $ hptModulesBelow hsc_env deps) , include_hi_boot || (is_boot == NotBoot) -- unsavoury: when compiling the base package with --make, we diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 7a2c04e898..f32d1ad804 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -1715,6 +1715,8 @@ mkRootMap summaries = ModNodeMap $ Map.insertListWith [ (msKey $ emsModSummary s, [Right s]) | s <- summaries ] Map.empty + + -- | Returns the dependencies of the ModSummary s. -- A wrinkle is that for a {-# SOURCE #-} import we return -- *both* the hs-boot file diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 88d1133963..5b00bb1b76 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -115,7 +115,7 @@ deSugar hsc_env tcg_th_splice_used = tc_splice_used, tcg_rdr_env = rdr_env, tcg_fix_env = fix_env, - tcg_inst_env = inst_env, + tcg_obj_inst_env = inst_env, tcg_fam_inst_env = fam_inst_env, tcg_merged = merged, tcg_warns = warns, diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index c9c4214fd0..69d9640514 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -69,9 +69,7 @@ mkDependencies :: HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies mkDependencies home_unit mod imports plugin_mods = let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods plugin_units = map (toUnitId . moduleUnit) external_plugins - all_direct_mods = foldr (\mn m -> addToUFM m mn (GWIB mn NotBoot)) - (imp_direct_dep_mods imports) - (map moduleName home_plugins) + all_direct_mods = imp_direct_dep_mods imports direct_mods = modDepsElts (delFromUFM all_direct_mods (moduleName mod)) -- M.hi-boot can be in the imp_dep_mods, but we must remove @@ -81,6 +79,8 @@ mkDependencies home_unit mod imports plugin_mods = -- on M.hi-boot, and hence that we should do the hi-boot consistency -- check.) + direct_splice_mods = modDepsElts (imp_direct_dep_splice_mods imports) + dep_orphs = filter (/= mod) (imp_orphs imports) -- We must also remove self-references from imp_orphs. See -- Note [Module self-dependency] @@ -98,6 +98,8 @@ mkDependencies home_unit mod imports plugin_mods = sig_mods = filter (/= (moduleName mod)) $ imp_sig_mods imports in Deps { dep_direct_mods = direct_mods + , dep_direct_splice_mods = direct_splice_mods + , dep_plugin_mods = Set.fromList (map moduleName home_plugins) , dep_direct_pkgs = direct_pkgs , dep_sig_mods = sort sig_mods , dep_trusted_pkgs = trust_pkgs diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index dc993aa261..8d5a884642 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -1187,6 +1187,8 @@ pprUsageImport usage usg_mod' -- | Pretty-print unit dependencies pprDeps :: UnitState -> Dependencies -> SDoc pprDeps unit_state (Deps { dep_direct_mods = dmods + , dep_direct_splice_mods = splice_mods + , dep_plugin_mods = plugin_mods , dep_boot_mods = bmods , dep_orphs = orphs , dep_direct_pkgs = pkgs @@ -1195,6 +1197,8 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods }) = pprWithUnitState unit_state $ vcat [text "direct module dependencies:" <+> ppr_set ppr_mod dmods, + text "direct splice module dependencies" <+> ppr_set ppr_mod splice_mods, + text "direct plugin module dependencies" <+> ppr_set ppr plugin_mods, text "boot module dependencies:" <+> ppr_set ppr bmods, text "direct package dependencies:" <+> ppr_set ppr pkgs, if null tps diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 0abee1a5c0..b0dec096a2 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -455,6 +455,7 @@ checkDependencies hsc_env summary iface res <- liftIO $ traverse (\(mb_pkg, L _ mod) -> let reason = moduleNameString mod ++ " changed" in classify reason <$> findImportedModule fc fopts units home_unit mod (mb_pkg)) + -- MP: TODO (ms_imps summary ++ ms_srcimps summary) case sequence (res ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of Left recomp -> return recomp @@ -1196,6 +1197,8 @@ getOrphanHashes hsc_env mods = do sortDependencies :: Dependencies -> Dependencies sortDependencies d = Deps { dep_direct_mods = dep_direct_mods d, + dep_direct_splice_mods = dep_direct_splice_mods d, + dep_plugin_mods = dep_plugin_mods d, dep_direct_pkgs = dep_direct_pkgs d, dep_sig_mods = sort (dep_sig_mods d), dep_trusted_pkgs = dep_trusted_pkgs d, diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index fe8056f6c6..784a5a2054 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index dd857c71d5..6adc4f03f8 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -413,7 +413,7 @@ rnImportDecl this_mod , imv_all_exports = potential_gres , imv_qualified = qual_only } - imports = calculateAvails home_unit iface mod_safe' want_boot (ImportedByUser imv) + imports = calculateAvails home_unit iface mod_safe' want_boot mod_splice (ImportedByUser imv) -- Complain if we import a deprecated module case mi_warns iface of @@ -435,15 +435,18 @@ rnImportDecl this_mod return (new_imp_decl, gbl_env, imports, mi_hpc iface) +type IsSpliceImport = Bool + -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. calculateAvails :: HomeUnit -> ModIface -> IsSafeImport -> IsBootInterface + -> IsSpliceImport -> ImportedBy -> ImportAvails -calculateAvails home_unit iface mod_safe' want_boot imported_by = +calculateAvails home_unit iface mod_safe' want_boot is_splice imported_by = let imp_mod = mi_module iface imp_sem_mod= mi_semantic_module iface orph_iface = mi_orphan (mi_final_exts iface) @@ -506,7 +509,11 @@ calculateAvails home_unit iface mod_safe' want_boot imported_by = then S.empty else S.singleton ipkg - direct_mods = mkModDeps $ if isHomeUnit home_unit pkg + direct_mods = mkModDeps $ if isHomeUnit home_unit pkg && not is_splice + then S.singleton (GWIB (moduleName imp_mod) want_boot) + else S.empty + + direct_splice_mods = mkModDeps $ if isHomeUnit home_unit pkg && is_splice then S.singleton (GWIB (moduleName imp_mod) want_boot) else S.empty @@ -533,6 +540,7 @@ calculateAvails home_unit iface mod_safe' want_boot imported_by = imp_finsts = finsts, imp_sig_mods = sig_mods, imp_direct_dep_mods = direct_mods, + imp_direct_dep_splice_mods = direct_splice_mods, imp_dep_direct_pkgs = dependent_pkgs, imp_boot_mods = boot_mods, diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index e28b2daeba..06ecf36305 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -1073,8 +1073,8 @@ getDictionaryBindings theta = do -- Find instances where the head unifies with the provided type findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])] findMatchingInstances ty = do - ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs - let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local + ies@(InstEnvs {ie_global = ie_global, ie_local_obj = ie_local, ie_local_tc = ie_local_tc }) <- tcGetInstEnvs + let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local ++ instEnvClasses ie_local_tc return $ concatMap (try_cls ies) allClasses where {- Check that a class instance is well-kinded. @@ -1085,7 +1085,8 @@ findMatchingInstances ty = do | Just (_, arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls) , tcIsConstraintKind res_kind , Type.typeKind ty `eqType` arg_kind - , (matches, _, _) <- lookupInstEnv True ies cls [ty] + -- TODO: Check site MP + , (matches, _, _) <- lookupInstEnv True False ies cls [ty] = matches | otherwise = [] diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index 444b372ada..9a7422f28d 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -1036,8 +1036,8 @@ extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a -- for functional dependency errors -- that'll happen in GHC.Tc.TyCl.Instance extendLocalInstEnv dfuns thing_inside = do { env <- getGblEnv - ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns - env' = env { tcg_inst_env = inst_env' } + ; let inst_env' = extendInstEnvList (tcg_tc_inst_env env) dfuns + env' = env { tcg_tc_inst_env = inst_env' } ; setGblEnv env' thing_inside } {- diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 51ab0fca2a..bb7a033848 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -74,7 +74,7 @@ import GHC.Utils.FV ( fvVarList, unionFV ) import GHC.Data.Bag import GHC.Data.FastString -import GHC.Utils.Trace (pprTraceUserWarning) +import GHC.Utils.Trace (pprTraceUserWarning, pprTraceM) import GHC.Data.List.SetOps ( equivClasses ) import GHC.Data.Maybe import qualified GHC.Data.Strict as Strict @@ -2400,8 +2400,13 @@ mkDictErr :: ReportErrCtxt -> [Ct] -> TcM Report mkDictErr ctxt cts = assert (not (null cts)) $ do { inst_envs <- tcGetInstEnvs + ; st <- getStage + ; pprTraceM "mkDictErr" (ppr st) + ; let in_splice = case st of + Splice{} -> True + _ -> False ; let min_cts = elim_superclasses cts - lookups = map (lookup_cls_inst inst_envs) min_cts + lookups = map (lookup_cls_inst inst_envs in_splice) min_cts (no_inst_cts, overlap_cts) = partition is_no_inst lookups -- Report definite no-instance errors, @@ -2419,9 +2424,10 @@ mkDictErr ctxt cts && null matches && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) - lookup_cls_inst inst_envs ct + lookup_cls_inst inst_envs in_splice ct -- Note [Flattening in error message generation] - = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys)) + -- TODO: MP check callsite + = (ct, lookupInstEnv True in_splice inst_envs clas (flattenTys emptyInScopeSet tys)) where (clas, tys) = getClassPredTys (ctPred ct) diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 13cd3e71c9..e8d28a624b 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1711,7 +1711,8 @@ reifyInstances' th_nm th_tys Just (tc, tys) -- See #7910 | Just cls <- tyConClass_maybe tc -> do { inst_envs <- tcGetInstEnvs - ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys + -- MP: Check call site + ; let (matches, unifies, _) = lookupInstEnv False False inst_envs cls tys ; traceTc "reifyInstances'1" (ppr matches) ; return $ Left (cls, map fst matches ++ unifies) } | isOpenFamilyTyCon tc diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index f80d3eaf93..3cebb86390 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -47,6 +47,7 @@ import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 ) import Data.Maybe +import GHC.Utils.Trace {- ******************************************************************* * * @@ -162,10 +163,16 @@ matchGlobalInst dflags short_cut clas tys matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult matchInstEnv dflags short_cut_solver clas tys = do { instEnvs <- tcGetInstEnvs + ; st <- getStage + ; let in_splice = case st of + Splice {} -> True + _ -> False + ; pprTraceM "matchInstEnv" (ppr st) ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy] - (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys + -- MP: TODO check callsite, probably needs to change + (matches, unify, unsafeOverlaps) = lookupInstEnv True in_splice instEnvs clas tys safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps) - ; traceTc "matchInstEnv" $ + ; pprTraceM "matchInstEnv" $ vcat [ text "goal:" <+> ppr clas <+> ppr tys , text "matches:" <+> ppr matches , text "unify:" <+> ppr unify ] diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index dee799f78f..1c15267199 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -181,6 +181,7 @@ import Data.Data ( Data ) import qualified Data.Set as S import Control.DeepSeq import Control.Monad +import GHC.Utils.Trace {- ************************************************************************ @@ -371,9 +372,12 @@ tcRnImports hsc_env import_decls = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; ; this_mod <- getModule - ; let { dep_mods :: ModuleNameEnv ModuleNameWithIsBoot + ; let { splice_imports = xopt LangExt.SpliceImports (hsc_dflags hsc_env) + ; dep_mods, dep_splice_mods :: ModuleNameEnv ModuleNameWithIsBoot ; dep_mods = imp_direct_dep_mods imports + ; dep_splice_mods = imp_direct_dep_splice_mods imports + -- We want instance declarations from all home-package -- modules below this one, including boot modules, except -- ourselves. The 'except ourselves' is so that we don't @@ -381,10 +385,22 @@ tcRnImports hsc_env import_decls -- filtering also ensures that we don't see instances from -- modules batch (@--make@) compiled before this one, but -- which are not below this one. - ; (home_insts, home_fam_insts) = hptInstancesBelow hsc_env (moduleName this_mod) + ; (home_tc_insts, home_tc_fam_insts) = hptInstancesBelow hsc_env (moduleName this_mod) (S.fromList (eltsUFM dep_mods)) + + ; (home_obj_insts, home_obj_fam_insts) + | splice_imports = hptInstancesBelow hsc_env (moduleName this_mod) + (S.fromList (eltsUFM dep_splice_mods)) + | otherwise = assert (isNullUFM dep_splice_mods) (home_tc_insts, []) + + + ; home_fam_insts = home_obj_fam_insts ++ home_tc_fam_insts } ; + ; pprTraceM "home_insts" (ppr dep_mods $$ ppr dep_splice_mods) + ; pprTraceM "home_insts" (ppr home_obj_insts $$ ppr home_tc_insts) + + -- Record boot-file info in the EPS, so that it's -- visible to loadHiBootInterface in tcRnSrcDecls, -- and any other incrementally-performed imports @@ -398,7 +414,8 @@ tcRnImports hsc_env import_decls tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, tcg_imports = tcg_imports gbl `plusImportAvails` imports, tcg_rn_imports = rn_imports, - tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_obj_inst_env = extendInstEnvList (tcg_obj_inst_env gbl) home_obj_insts, + tcg_tc_inst_env = extendInstEnvList (tcg_tc_inst_env gbl) home_tc_insts, tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) home_fam_insts, tcg_hpc = hpc_info @@ -1705,7 +1722,8 @@ tcMissingParentClassWarn warnFlag isName shouldName checkShouldInst isClass shouldClass isInst = do { instEnv <- tcGetInstEnvs ; let (instanceMatches, shouldInsts, _) - = lookupInstEnv False instEnv shouldClass (is_tys isInst) + -- MP: Check call site + = lookupInstEnv False False instEnv shouldClass (is_tys isInst) ; traceTc "tcMissingParentClassWarn/checkShouldInst" (hang (ppr isInst) 4 @@ -2060,8 +2078,8 @@ runTcInteractive hsc_env thing_inside ; let gbl_env' = gbl_env { tcg_rdr_env = ic_rn_gbl_env icxt , tcg_type_env = type_env - , tcg_inst_env = extendInstEnvList - (extendInstEnvList (tcg_inst_env gbl_env) ic_insts) + , tcg_obj_inst_env = extendInstEnvList + (extendInstEnvList (tcg_obj_inst_env gbl_env) ic_insts) home_insts , tcg_fam_inst_env = extendFamInstEnvList (extendFamInstEnvList (tcg_fam_inst_env gbl_env) @@ -2871,7 +2889,7 @@ tcRnGetInfo hsc_env name -- could be changed to consult that index. lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) lookupInsts (ATyCon tc) - = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs + = do { InstEnvs { ie_global = pkg_ie, ie_local_obj = home_ie, ie_local_tc = home_ie_tc, ie_visible = vis_mods } <- tcGetInstEnvs ; (pkg_fie, home_fie) <- tcGetFamInstEnvs -- Load all instances for all classes that are -- in the type environment (which are all the ones @@ -2881,7 +2899,7 @@ lookupInsts (ATyCon tc) -- the instances whose head contains the thing's name. ; let cls_insts = [ ispec -- Search all - | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie + | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie ++ instEnvElts home_ie_tc , instIsVisible vis_mods ispec , tc_name `elemNameSet` orphNamesOfClsInst ispec ] ; let fam_insts = diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 2894321546..13cc64cc93 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -450,7 +450,8 @@ data TcGblEnv -- bound in this module when dealing with hi-boot recursions -- Updated at intervals (e.g. after dealing with types and classes) - tcg_inst_env :: !InstEnv, + tcg_obj_inst_env :: !InstEnv, + tcg_tc_inst_env :: !InstEnv, -- ^ Instance envt for all /home-package/ modules; -- Includes the dfuns in tcg_insts -- NB. BangPattern is to fix a leak, see #15111 @@ -1390,6 +1391,9 @@ data ImportAvails imp_direct_dep_mods :: ModuleNameEnv ModuleNameWithIsBoot, -- ^ Home-package modules directly imported by the module being compiled. + imp_direct_dep_splice_mods :: ModuleNameEnv ModuleNameWithIsBoot, + -- ^ Home-package modules directly splice imported by the module being compiled. + imp_dep_direct_pkgs :: Set UnitId, -- ^ Packages directly needed by the module being compiled @@ -1456,6 +1460,7 @@ modDepsElts = S.fromList . nonDetEltsUFM emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, imp_direct_dep_mods = emptyUFM, + imp_direct_dep_splice_mods = emptyUFM, imp_dep_direct_pkgs = S.empty, imp_sig_mods = [], imp_trust_pkgs = S.empty, @@ -1473,6 +1478,7 @@ plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails plusImportAvails (ImportAvails { imp_mods = mods1, imp_direct_dep_mods = ddmods1, + imp_direct_dep_splice_mods = ddsplicemods1, imp_dep_direct_pkgs = ddpkgs1, imp_boot_mods = srs1, imp_sig_mods = sig_mods1, @@ -1480,6 +1486,7 @@ plusImportAvails imp_orphs = orphs1, imp_finsts = finsts1 }) (ImportAvails { imp_mods = mods2, imp_direct_dep_mods = ddmods2, + imp_direct_dep_splice_mods = ddsplicemods2, imp_dep_direct_pkgs = ddpkgs2, imp_boot_mods = srcs2, imp_sig_mods = sig_mods2, @@ -1487,6 +1494,7 @@ plusImportAvails imp_orphs = orphs2, imp_finsts = finsts2 }) = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, imp_direct_dep_mods = ddmods1 `plusModDeps` ddmods2, + imp_direct_dep_splice_mods = ddsplicemods1 `plusModDeps` ddsplicemods2, imp_dep_direct_pkgs = ddpkgs1 `S.union` ddpkgs2, imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, imp_trust_own_pkg = tself1 || tself2, diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index d5ada1f85c..db3f6a65f2 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -144,7 +144,8 @@ checkHsigIface tcg_env gr sig_iface -- checking instance satisfiability -- TODO: this should not be necessary tcg_env <- getGblEnv - setGblEnv tcg_env { tcg_inst_env = emptyInstEnv, + setGblEnv tcg_env { tcg_tc_inst_env = emptyInstEnv, + tcg_obj_inst_env = emptyInstEnv, tcg_fam_inst_env = emptyFamInstEnv, tcg_insts = [], tcg_fam_insts = [] } $ do @@ -895,7 +896,7 @@ mergeSignatures -- see Note [Signature merging DFuns] = (inst:insts, extendInstEnv inst_env inst) (insts, inst_env) = foldl' merge_inst - (tcg_insts tcg_env, tcg_inst_env tcg_env) + (tcg_insts tcg_env, tcg_tc_inst_env tcg_env) (md_insts details) -- This is a HACK to prevent calculateAvails from including imp_mod -- in the listing. We don't want it because a module is NOT @@ -903,9 +904,9 @@ mergeSignatures iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } } home_unit = hsc_home_unit hsc_env avails = plusImportAvails (tcg_imports tcg_env) $ - calculateAvails home_unit iface' False NotBoot ImportedBySystem + calculateAvails home_unit iface' False NotBoot False ImportedBySystem return tcg_env { - tcg_inst_env = inst_env, + tcg_tc_inst_env = inst_env, tcg_insts = insts, tcg_imports = avails, tcg_merged = @@ -993,7 +994,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do (dep_orphs (mi_deps impl_iface)) let avails = calculateAvails home_unit - impl_iface False{- safe -} NotBoot ImportedBySystem + impl_iface False{- safe -} NotBoot False ImportedBySystem fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f) | (occ, f) <- mi_fixities impl_iface , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ] diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 65785fc822..c4119e5999 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -346,7 +346,8 @@ tcGetInstEnvs :: TcM InstEnvs tcGetInstEnvs = do { eps <- getEps ; env <- getGblEnv ; return (InstEnvs { ie_global = eps_inst_env eps - , ie_local = tcg_inst_env env + , ie_local_obj = tcg_obj_inst_env env + , ie_local_tc = tcg_tc_inst_env env , ie_visible = tcVisibleOrphanMods env }) } instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index 73c62839e3..0100769734 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -851,20 +851,22 @@ tcExtendLocalInstEnv dfuns thing_inside -- there are a very small number of TcGblEnv. Keeping a TcGblEnv -- alive is quite dangerous because it contains reference to many -- large data structures. - ; let !init_inst_env = tcg_inst_env env + ; let !init_obj_inst_env = tcg_obj_inst_env env + !init_tc_inst_env = tcg_tc_inst_env env + !init_insts = tcg_insts env - ; (inst_env', cls_insts') <- foldlM addLocalInst - (init_inst_env, init_insts) + ; (inst_env', cls_insts') <- foldlM (addLocalInst init_obj_inst_env) + (init_tc_inst_env, init_insts) dfuns ; let env' = env { tcg_insts = cls_insts' - , tcg_inst_env = inst_env' } + , tcg_tc_inst_env = inst_env' } ; setGblEnv env' thing_inside } -addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst]) +addLocalInst :: InstEnv -> (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst]) -- Check that the proposed new instance is OK, -- and then add it to the home inst env -- If overwrite_inst, then we can overwrite a direct match -addLocalInst (home_ie, my_insts) ispec +addLocalInst home_obj_ie (home_tc_ie, my_insts) ispec = do { -- Load imported instances, so that we report -- duplicates correctly @@ -879,13 +881,17 @@ addLocalInst (home_ie, my_insts) ispec -- In GHCi, we *override* any identical instances -- that are also defined in the interactive context -- See Note [Override identical instances in GHCi] - ; let home_ie' - | isGHCi = deleteFromInstEnv home_ie ispec - | otherwise = home_ie + ; let home_obj_ie' + | isGHCi = deleteFromInstEnv home_obj_ie ispec + | otherwise = home_obj_ie + home_tc_ie' + | isGHCi = deleteFromInstEnv home_tc_ie ispec + | otherwise = home_tc_ie global_ie = eps_inst_env eps inst_envs = InstEnvs { ie_global = global_ie - , ie_local = home_ie' + , ie_local_obj = home_obj_ie' + , ie_local_tc = home_tc_ie' , ie_visible = tcVisibleOrphanMods tcg_env } -- Check for inconsistent functional dependencies @@ -895,12 +901,13 @@ addLocalInst (home_ie, my_insts) ispec -- Check for duplicate instance decls. ; let (_tvs, cls, tys) = instanceHead ispec - (matches, _, _) = lookupInstEnv False inst_envs cls tys + -- TODO: MP check callsite + (matches, _, _) = lookupInstEnv False False inst_envs cls tys dups = filter (identicalClsInstHead ispec) (map fst matches) ; unless (null dups) $ dupInstErr ispec (head dups) - ; return (extendInstEnv home_ie' ispec, ispec : my_insts) } + ; return (extendInstEnv home_tc_ie' ispec, ispec : my_insts) } {- Note [Signature files and type class instances] diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 1c5e79013d..08d75b69d4 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -307,7 +307,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this else Nothing, tcg_type_env = emptyNameEnv, tcg_type_env_var = type_env_var, - tcg_inst_env = emptyInstEnv, + tcg_obj_inst_env = emptyInstEnv, + tcg_tc_inst_env = emptyInstEnv, tcg_fam_inst_env = emptyFamInstEnv, tcg_ann_env = emptyAnnEnv, tcg_th_used = th_var, diff --git a/compiler/GHC/Unit/Module/Deps.hs b/compiler/GHC/Unit/Module/Deps.hs index ebdd4b351f..559ac14bd9 100644 --- a/compiler/GHC/Unit/Module/Deps.hs +++ b/compiler/GHC/Unit/Module/Deps.hs @@ -31,6 +31,12 @@ data Dependencies = Deps { dep_direct_mods :: Set ModuleNameWithIsBoot -- ^ All home-package modules which are directly imported by this one. + , dep_direct_splice_mods :: Set ModuleNameWithIsBoot + -- ^ All home-package modules which are splice imported by this one + + , dep_plugin_mods :: Set ModuleName + -- ^ All home-package plugins which are imported by this one + , dep_direct_pkgs :: Set UnitId -- ^ All packages directly imported by this module -- I.e. packages to which this module's direct imports belong. @@ -76,6 +82,8 @@ data Dependencies = Deps instance Binary Dependencies where put_ bh deps = do put_ bh (dep_direct_mods deps) + put_ bh (dep_direct_splice_mods deps) + put_ bh (dep_plugin_mods deps) put_ bh (dep_direct_pkgs deps) put_ bh (dep_trusted_pkgs deps) put_ bh (dep_sig_mods deps) @@ -84,6 +92,8 @@ instance Binary Dependencies where put_ bh (dep_finsts deps) get bh = do dms <- get bh + spms <- get bh + plugins <- get bh dps <- get bh tps <- get bh hsigms <- get bh @@ -91,6 +101,8 @@ instance Binary Dependencies where os <- get bh fis <- get bh return (Deps { dep_direct_mods = dms + , dep_direct_splice_mods = spms + , dep_plugin_mods = plugins , dep_direct_pkgs = dps , dep_sig_mods = hsigms , dep_boot_mods = sms @@ -101,6 +113,8 @@ instance Binary Dependencies where noDependencies :: Dependencies noDependencies = Deps { dep_direct_mods = Set.empty + , dep_direct_splice_mods = Set.empty + , dep_plugin_mods = Set.empty , dep_direct_pkgs = Set.empty , dep_sig_mods = [] , dep_boot_mods = Set.empty diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py index d776c12bb3..853ea11624 100644 --- a/testsuite/driver/testlib.py +++ b/testsuite/driver/testlib.py @@ -748,7 +748,7 @@ def no_check_hp(name, opts): def filter_stdout_lines( regex ): """ Filter lines of stdout with the given regular expression """ def f( name, opts ): - _normalise_fun(name, opts, lambda s: '\n'.join(re.findall(regex, s))) + _normalise_fun(name, opts, lambda s: print(s)) # '\n'.join(re.findall(regex, s))) return f def normalise_slashes( name, opts ): diff --git a/testsuite/tests/splice-imports/ClassA.hs b/testsuite/tests/splice-imports/ClassA.hs new file mode 100644 index 0000000000..1d847c5b18 --- /dev/null +++ b/testsuite/tests/splice-imports/ClassA.hs @@ -0,0 +1,8 @@ +module ClassA where + +data X = X + +vx = X + +class C a where + x :: a -> a diff --git a/testsuite/tests/splice-imports/InstanceA.hs b/testsuite/tests/splice-imports/InstanceA.hs new file mode 100644 index 0000000000..1ec2383e1f --- /dev/null +++ b/testsuite/tests/splice-imports/InstanceA.hs @@ -0,0 +1,6 @@ +module InstanceA where + +import ClassA + +instance C X where + x = id diff --git a/testsuite/tests/splice-imports/Makefile b/testsuite/tests/splice-imports/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/splice-imports/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/splice-imports/SI01.hs b/testsuite/tests/splice-imports/SI01.hs new file mode 100644 index 0000000000..6e2bf2b09e --- /dev/null +++ b/testsuite/tests/splice-imports/SI01.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE SpliceImports #-} +{-# LANGUAGE TemplateHaskell #-} +module SI01 where + +import splice SI01A + +main :: IO () +main = $( sid [| pure () |]) >> $$( sid [|| pure () ||]) diff --git a/testsuite/tests/splice-imports/SI01A.hs b/testsuite/tests/splice-imports/SI01A.hs new file mode 100644 index 0000000000..a1cf7bfd9f --- /dev/null +++ b/testsuite/tests/splice-imports/SI01A.hs @@ -0,0 +1,3 @@ +module SI01A where + +sid = id diff --git a/testsuite/tests/splice-imports/SI02.hs b/testsuite/tests/splice-imports/SI02.hs new file mode 100644 index 0000000000..e924d438c1 --- /dev/null +++ b/testsuite/tests/splice-imports/SI02.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE SpliceImports #-} +{-# LANGUAGE TemplateHaskell #-} +module SI02 where + +import splice Prelude + +main :: IO () +main = $(id [| pure () |]) diff --git a/testsuite/tests/splice-imports/SI03.hs b/testsuite/tests/splice-imports/SI03.hs new file mode 100644 index 0000000000..7fe6ed8ef2 --- /dev/null +++ b/testsuite/tests/splice-imports/SI03.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE SpliceImports #-} +{-# LANGUAGE TemplateHaskell #-} +module SI03 where + +import SI01A + +main :: IO () +main = $( sid [| pure () |]) >> $$( sid [|| pure () ||]) diff --git a/testsuite/tests/splice-imports/SI03.stderr b/testsuite/tests/splice-imports/SI03.stderr new file mode 100644 index 0000000000..deac1f4809 --- /dev/null +++ b/testsuite/tests/splice-imports/SI03.stderr @@ -0,0 +1,7 @@ + +SI03.hs:8:11: error: + • Splice import + sid + imported from ‘SI01A’ at SI03.hs:5:1-12 + (and originally defined at SI01A.hs:3:1-3) + • In the untyped splice: $(sid [| pure () |]) diff --git a/testsuite/tests/splice-imports/SI04.hs b/testsuite/tests/splice-imports/SI04.hs new file mode 100644 index 0000000000..597827e3de --- /dev/null +++ b/testsuite/tests/splice-imports/SI04.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE SpliceImports #-} +{-# LANGUAGE TemplateHaskell #-} +module SI04 where + +import SI01A +import splice SI01A + +main :: IO () +main = $( sid [| pure () |]) >> $$( sid [|| pure () ||]) diff --git a/testsuite/tests/splice-imports/SI05.hs b/testsuite/tests/splice-imports/SI05.hs new file mode 100644 index 0000000000..2c35211c98 --- /dev/null +++ b/testsuite/tests/splice-imports/SI05.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE SpliceImports #-} +{-# LANGUAGE TemplateHaskell #-} +module SI04 where + +import SI01A +import splice SI05A + +main :: IO () +main = $( sid [| pure () |]) >> $$( sid [|| pure () ||]) diff --git a/testsuite/tests/splice-imports/SI05.stderr b/testsuite/tests/splice-imports/SI05.stderr new file mode 100644 index 0000000000..6bd4eebcaa --- /dev/null +++ b/testsuite/tests/splice-imports/SI05.stderr @@ -0,0 +1,11 @@ + +SI05.hs:9:11: error: + • Ambiguous occurrence ‘sid’ + It could refer to + either ‘SI01A.sid’, + imported from ‘SI01A’ at SI05.hs:5:1-12 + (and originally defined at SI01A.hs:3:1-3) + or ‘SI05A.sid’, + imported from ‘SI05A’ at SI05.hs:6:1-19 + (and originally defined at SI05A.hs:3:1-3) + • In the untyped splice: $(sid [| pure () |]) diff --git a/testsuite/tests/splice-imports/SI05A.hs b/testsuite/tests/splice-imports/SI05A.hs new file mode 100644 index 0000000000..5f5c4a3ba6 --- /dev/null +++ b/testsuite/tests/splice-imports/SI05A.hs @@ -0,0 +1,3 @@ +module SI05A where + +sid = id diff --git a/testsuite/tests/splice-imports/SI06.hs b/testsuite/tests/splice-imports/SI06.hs new file mode 100644 index 0000000000..f7f0d64296 --- /dev/null +++ b/testsuite/tests/splice-imports/SI06.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE SpliceImports #-} +module SI06 where + +import splice SI01A + +x = 5 diff --git a/testsuite/tests/splice-imports/SI07.hs b/testsuite/tests/splice-imports/SI07.hs new file mode 100644 index 0000000000..2c69b62091 --- /dev/null +++ b/testsuite/tests/splice-imports/SI07.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE SpliceImports #-} +{-# LANGUAGE TemplateHaskell #-} +module SI07 where + +import SI07A +import splice SI05A + +main :: IO () +main = $( sid [| pure () |]) >> $$( sid [|| pure () ||]) diff --git a/testsuite/tests/splice-imports/SI07.stderr b/testsuite/tests/splice-imports/SI07.stderr new file mode 100644 index 0000000000..2eb886b2ef --- /dev/null +++ b/testsuite/tests/splice-imports/SI07.stderr @@ -0,0 +1,3 @@ +[1 of 3] Compiling SI05A ( SI05A.hs, SI05A.o, SI05A.dyn_o ) +[2 of 3] Compiling SI07A ( SI07A.hs, nothing, SI07A.dyn_o ) +[3 of 3] Compiling SI07 ( SI07.hs, SI07.o, SI07.dyn_o ) diff --git a/testsuite/tests/splice-imports/SI07A.hs b/testsuite/tests/splice-imports/SI07A.hs new file mode 100644 index 0000000000..6b93bac022 --- /dev/null +++ b/testsuite/tests/splice-imports/SI07A.hs @@ -0,0 +1 @@ +module SI07A where diff --git a/testsuite/tests/splice-imports/SI08.hs b/testsuite/tests/splice-imports/SI08.hs new file mode 100644 index 0000000000..75cdcef7ad --- /dev/null +++ b/testsuite/tests/splice-imports/SI08.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE SpliceImports #-} +{-# LANGUAGE TemplateHaskell #-} +module SI08 where + +import InstanceA () +import splice ClassA + +e :: X +-- Uses a non-splice imported instance +e = $(const [| x vx |] (x vx)) diff --git a/testsuite/tests/splice-imports/SI08.stderr b/testsuite/tests/splice-imports/SI08.stderr new file mode 100644 index 0000000000..aa8469aad4 --- /dev/null +++ b/testsuite/tests/splice-imports/SI08.stderr @@ -0,0 +1,6 @@ + +SI08.hs:10:25: error: + • No instance for (C X) arising from a use of ‘x’ + • In the second argument of ‘const’, namely ‘(x vx)’ + In the expression: const [| x vx |] (x vx) + In the untyped splice: $(const [| x vx |] (x vx)) diff --git a/testsuite/tests/splice-imports/SI09.hs b/testsuite/tests/splice-imports/SI09.hs new file mode 100644 index 0000000000..08a0a97826 --- /dev/null +++ b/testsuite/tests/splice-imports/SI09.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE SpliceImports #-} +{-# LANGUAGE TemplateHaskell #-} +module SI09 where + +import splice InstanceA () +import splice ClassA + +e :: IO () +-- Uses a non-splice imported instance +e = $(const [| pure () |] (x vx)) diff --git a/testsuite/tests/splice-imports/SI10.hs b/testsuite/tests/splice-imports/SI10.hs new file mode 100644 index 0000000000..d160e4f79f --- /dev/null +++ b/testsuite/tests/splice-imports/SI10.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE SpliceImports #-} +{-# LANGUAGE TemplateHaskell #-} +module SI09 where + +import InstanceA () +import splice ClassA + +e :: X +-- Uses a non-splice imported instance +e = $(const [| x vx |] ()) diff --git a/testsuite/tests/splice-imports/all.T b/testsuite/tests/splice-imports/all.T new file mode 100644 index 0000000000..26e99225f5 --- /dev/null +++ b/testsuite/tests/splice-imports/all.T @@ -0,0 +1,17 @@ +def check_nothing(actual_file, normaliser): + actual_raw = read_no_crs(actual_file) + return ("Nothing" in actual_raw) + + +test('SI01', normal, multimod_compile, ['SI01', '-v0']) +test('SI02', normal, compile, ['']) +test('SI03', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI03', '-v0']) +test('SI04', [extra_files(["SI01A.hs"])], multimod_compile, ['SI04', '-v0']) +test('SI05', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI05', '-v0']) +test('SI06', [extra_files(["SI01A.hs"])], multimod_compile, ['SI06', '-v0']) +test('SI07', [extra_files(["SI05A.hs"])], multimod_compile, ['SI07', '-fwrite-interface -fno-code']) +# Instance tests +test('SI08', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile_fail, ['SI08', '-v0']) +test('SI09', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile, ['SI09', '-v0']) +test('SI10', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile, ['SI10', '-v0']) + diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 74135cb9f6..9797b69689 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -723,8 +723,8 @@ instance ExactPrint (LocatedP WarningTxt) where instance ExactPrint (ImportDecl GhcPs) where getAnnotationEntry idecl = fromAnn (ideclExt idecl) - exact x@(ImportDecl EpAnnNotUsed _ _ _ _ _ _ _ _ _) = withPpr x - exact (ImportDecl ann@(EpAnn _ an _) msrc (L lm modname) mpkg _src safeflag qualFlag _impl mAs hiding) = do + exact x@(ImportDecl EpAnnNotUsed _ _ _ _ _ _ _ _ _ _) = withPpr x + exact (ImportDecl ann@(EpAnn _ an _) msrc (L lm modname) mpkg _src _splice safeflag qualFlag _impl mAs hiding) = do markAnnKw ann importDeclAnnImport AnnImport |