Splice imports wipwip/splice-imports

10 files changed, 87 insertions, 37 deletions

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,