SafeHaskell: Restrict OverlappingInstances.
authorDavid Terei <davidterei@gmail.com>
Sat, 30 Apr 2011 02:16:31 +0000 (19:16 -0700)
committerDavid Terei <davidterei@gmail.com>
Sat, 18 Jun 2011 01:39:28 +0000 (18:39 -0700)
OverlappingInstances in Safe modules can only overlap instances
defined in the same module.

compiler/iface/LoadIface.lhs
compiler/iface/TcIface.lhs
compiler/iface/TcIface.lhs-boot
compiler/typecheck/Inst.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcSMonad.lhs
compiler/typecheck/TcSplice.lhs
compiler/types/InstEnv.lhs
compiler/vectorise/Vectorise/Monad/InstEnv.hs

index 219ab6a..b73c186 100644 (file)
@@ -240,7 +240,7 @@ loadInterface doc_str mod from
 
        ; ignore_prags      <- doptM Opt_IgnoreInterfacePragmas
        ; new_eps_decls     <- loadDecls ignore_prags (mi_decls iface)
-       ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)
+       ; new_eps_insts     <- mapM (tcIfaceInst $ mi_trust iface) (mi_insts iface)
        ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
        ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)
        ; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)
index 5bfb406..ac5794a 100644 (file)
@@ -265,10 +265,10 @@ typecheckIface iface
        ; writeMutVar tc_env_var type_env
 
                -- Now do those rules, instances and annotations
-       ; insts     <- mapM tcIfaceInst    (mi_insts     iface)
+       ; insts     <- mapM (tcIfaceInst $ mi_trust iface) (mi_insts iface)
        ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
        ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)
-       ; anns      <- tcIfaceAnnotations  (mi_anns iface)
+       ; anns      <- tcIfaceAnnotations (mi_anns iface)
 
                 -- Vectorisation information
         ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env 
@@ -588,13 +588,14 @@ look at it.
 %************************************************************************
 
 \begin{code}
-tcIfaceInst :: IfaceInst -> IfL Instance
-tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
-                        ifInstCls = cls, ifInstTys = mb_tcs })
-  = do { dfun    <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
-                    tcIfaceExtId dfun_occ
-        ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
-       ; return (mkImportedInstance cls mb_tcs' dfun oflag) }
+tcIfaceInst :: IfaceTrustInfo -> IfaceInst -> IfL Instance
+tcIfaceInst safe (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
+                              ifInstCls = cls, ifInstTys = mb_tcs })
+  = do { dfun    <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
+                     tcIfaceExtId dfun_occ
+       ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+       ; let safe' = getSafeMode safe
+       ; return (mkImportedInstance cls mb_tcs' dfun oflag safe') }
 
 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
 tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, 
index c8ad717..e6f3b7b 100644 (file)
@@ -1,20 +1,21 @@
 \begin{code}
 module TcIface where
-import IfaceSyn          ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule, IfaceAnnotation )
-import TypeRep   ( TyThing )
-import TcRnTypes  ( IfL )
-import InstEnv   ( Instance )
-import FamInstEnv ( FamInst )
-import CoreSyn   ( CoreRule )
-import HscTypes   ( TypeEnv, VectInfo, IfaceVectInfo )
-import Module     ( Module )
+
+import IfaceSyn    ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule, IfaceAnnotation )
+import TypeRep     ( TyThing )
+import TcRnTypes   ( IfL )
+import InstEnv     ( Instance )
+import FamInstEnv  ( FamInst )
+import CoreSyn     ( CoreRule )
+import HscTypes    ( TypeEnv, VectInfo, IfaceVectInfo, IfaceTrustInfo )
+import Module      ( Module )
 import Annotations ( Annotation )
 
-tcIfaceDecl    :: Bool -> IfaceDecl -> IfL TyThing
-tcIfaceRules   :: Bool -> [IfaceRule] -> IfL [CoreRule]
-tcIfaceVectInfo:: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
-tcIfaceInst    :: IfaceInst -> IfL Instance
-tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
+tcIfaceDecl        :: Bool -> IfaceDecl -> IfL TyThing
+tcIfaceRules       :: Bool -> [IfaceRule] -> IfL [CoreRule]
+tcIfaceVectInfo    :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
+tcIfaceInst        :: IfaceTrustInfo -> IfaceInst -> IfL Instance
+tcIfaceFamInst     :: IfaceFamInst -> IfL FamInst
 tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
 \end{code}
 
index 378bbd6..a3caea6 100644 (file)
@@ -13,8 +13,8 @@ module Inst (
 
        newOverloadedLit, mkOverLit, 
      
-       tcGetInstEnvs, getOverlapFlag, tcExtendLocalInstEnv,
-       instCallConstraints, newMethodFromName,
+       tcGetInstEnvs, getOverlapFlag, getSafeHaskellFlag,
+       tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
        tcSyntaxName,
 
        -- Simple functions over evidence variables
@@ -377,6 +377,11 @@ getOverlapFlag
                           
        ; return overlap_flag }
 
+getSafeHaskellFlag :: TcM SafeHaskellMode
+getSafeHaskellFlag
+  = do { dflags <- getDOpts
+       ; return $ safeHaskell dflags }
+
 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 -- Gets both the external-package inst-env
 -- and the home-pkg inst env (includes module being compiled)
@@ -429,7 +434,7 @@ addLocalInst home_ie ispec
                Nothing    -> return ()
 
                -- Check for duplicate instance decls
-       ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
+       ; let { (matches, _, _) = lookupInstEnv inst_envs cls tys'
              ; dup_ispecs = [ dup_ispec 
                             | (dup_ispec, _) <- matches
                             , let (_,_,_,dup_tys) = instanceHead dup_ispec
index 995affd..7499cd9 100644 (file)
@@ -315,13 +315,14 @@ tcDeriving tycl_decls inst_decls deriv_decls
         ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras
 
        ; overlap_flag <- getOverlapFlag
+       ; safe <- getSafeHaskellFlag
        ; let (infer_specs, given_specs) = splitEithers early_specs
-       ; insts1 <- mapM (genInst True overlap_flag) given_specs
+       ; insts1 <- mapM (genInst True safe overlap_flag) given_specs
 
        ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
-                        inferInstanceContexts overlap_flag infer_specs
+                        inferInstanceContexts safe overlap_flag infer_specs
 
-       ; insts2 <- mapM (genInst False overlap_flag) final_specs
+       ; insts2 <- mapM (genInst False safe overlap_flag) final_specs
 
        -- We no longer generate the old generic to/from functions
         -- from each type declaration, so this is emptyBag
@@ -1324,11 +1325,11 @@ ordered by sorting on type varible, tv, (major key) and then class, k,
 \end{itemize}
 
 \begin{code}
-inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
+inferInstanceContexts :: SafeHaskellMode -> OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
 
-inferInstanceContexts _ [] = return []
+inferInstanceContexts _ [] = return []
 
-inferInstanceContexts oflag infer_specs
+inferInstanceContexts safe oflag infer_specs
   = do { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
        ; iterate_deriv 1 initial_solutions }
   where
@@ -1354,7 +1355,7 @@ inferInstanceContexts oflag infer_specs
       | otherwise
       =        do {      -- Extend the inst info from the explicit instance decls
                  -- with the current set of solutions, and simplify each RHS
-            let inst_specs = zipWithEqual "add_solns" (mkInstance oflag)
+            let inst_specs = zipWithEqual "add_solns" (mkInstance safe oflag)
                                           current_solns infer_specs
           ; new_solns <- checkNoErrs $
                          extendLocalInstEnv inst_specs $
@@ -1400,11 +1401,11 @@ inferInstanceContexts oflag infer_specs
         the_pred = mkClassPred clas inst_tys
 
 ------------------------------------------------------------------
-mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
-mkInstance overlap_flag theta
+mkInstance :: SafeHaskellMode -> OverlapFlag -> ThetaType -> DerivSpec -> Instance
+mkInstance safe overlap_flag theta
            (DS { ds_name = dfun_name
                , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
-  = mkLocalInstance dfun overlap_flag
+  = mkLocalInstance dfun overlap_flag safe
   where
     dfun = mkDictFunId dfun_name tyvars theta clas tys
 
@@ -1490,10 +1491,11 @@ the renamer.  What a great hack!
 -- Representation tycons differ from the tycon in the instance signature in
 -- case of instances for indexed families.
 --
-genInst :: Bool        -- True <=> standalone deriving
-       -> OverlapFlag
+genInst :: Bool             -- True <=> standalone deriving
+        -> SafeHaskellMode
+        -> OverlapFlag
         -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
-genInst standalone_deriv oflag
+genInst standalone_deriv safe oflag
         spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args
                  , ds_theta = theta, ds_newtype = is_newtype
                  , ds_name = name, ds_cls = clas })
@@ -1512,7 +1514,7 @@ genInst standalone_deriv oflag
                            , iBinds  = VanillaInst meth_binds [] standalone_deriv }
                  , aux_binds) }
   where
-    inst_spec = mkInstance oflag theta spec
+    inst_spec = mkInstance safe oflag theta spec
     co1 = case tyConFamilyCoercion_maybe rep_tycon of
               Just co_con -> mkAxInstCo co_con rep_tc_args
              Nothing     -> id_co
index b199053..29a98ac 100644 (file)
@@ -562,16 +562,17 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
            -- Note [Flattening in error message generation]
 
        ; case lookupInstEnv inst_envs clas tys_flat of
-                ([], _) -> return (Just pred)               -- No match
+                ([], _, _) -> return (Just pred)            -- No match
                -- The case of exactly one match and no unifiers means a
                -- successful lookup.  That can't happen here, because dicts
                -- only end up here if they didn't match in Inst.lookupInst
-               ([_],[])
+               ([_],[], _)
                 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
                 res          -> do { addErrorReport ctxt (mk_overlap_msg res)
                                    ; return Nothing } }
   where
-    mk_overlap_msg (matches, unifiers)
+    -- Normal overlap error
+    mk_overlap_msg (matches, unifiers, False)
       = ASSERT( not (null matches) )
         vcat [ addArising orig (ptext (sLit "Overlapping instances for") 
                                <+> pprPredTy pred)
@@ -600,33 +601,50 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
                                    vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
                                          ptext (sLit "when compiling the other instance declarations")]
                               else empty])]
-      where
-       ispecs = [ispec | (ispec, _) <- matches]
-
-        givens = getUserGivens ctxt
-        overlapping_givens = unifiable_givens givens
-
-        unifiable_givens [] = [] 
-        unifiable_givens (gg:ggs) 
-          | Just ggdoc <- matchable gg 
-          = ggdoc : unifiable_givens ggs 
-          | otherwise 
-          = unifiable_givens ggs 
-
-        matchable (evvars,gloc) 
-          = case ev_vars_matching of
-                 [] -> Nothing
-                 _  -> Just $ hang (pprTheta ev_vars_matching)
-                                2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
-                                       , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
-            where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
-                  ev_var_matches (ClassP clas' tys')
-                    | clas' == clas
-                    , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
-                    = True 
-                  ev_var_matches (ClassP clas' tys') =
-                    any ev_var_matches (immSuperClasses clas' tys')
-                  ev_var_matches _ = False
+        where
+            ispecs = [ispec | (ispec, _) <- matches]
+
+            givens = getUserGivens ctxt
+            overlapping_givens = unifiable_givens givens
+    
+            unifiable_givens [] = [] 
+            unifiable_givens (gg:ggs) 
+              | Just ggdoc <- matchable gg 
+              = ggdoc : unifiable_givens ggs 
+              | otherwise 
+              = unifiable_givens ggs 
+    
+            matchable (evvars,gloc) 
+              = case ev_vars_matching of
+                     [] -> Nothing
+                     _  -> Just $ hang (pprTheta ev_vars_matching)
+                                    2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
+                                           , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
+                where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
+                      ev_var_matches (ClassP clas' tys')
+                        | clas' == clas
+                        , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
+                        = True 
+                      ev_var_matches (ClassP clas' tys') =
+                        any ev_var_matches (immSuperClasses clas' tys')
+                      ev_var_matches _ = False
+
+    -- Overlap error because of SafeHaskell (first match should be the most
+    -- specific match)
+    mk_overlap_msg (matches, unifiers, True)
+      = ASSERT( length matches > 1 )
+        vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") 
+                        <+> pprPred pred)
+             , sep [ptext (sLit "The matching instance is") <> colon,
+                    nest 2 (pprInstance $ head ispecs)]
+             , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only"
+                    , ptext $ sLit "overlap instances from the same module, however it"
+                    , ptext $ sLit "overlaps the following instances from different modules:"
+                    , nest 2 (vcat [pprInstances $ tail ispecs])
+                    ]
+             ]
+        where
+            ispecs = [ispec | (ispec, _) <- matches]
 
 
 reportOverlap _ _ _ _ = panic "reportOverlap"    -- Not a ClassP
index d4d8d2f..7ca7a32 100644 (file)
@@ -450,10 +450,11 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
         ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
                -- Dfun location is that of instance *header*
         ; overlap_flag <- getOverlapFlag
+        ; safe <- getSafeHaskellFlag
         ; let (eq_theta,dict_theta) = partition isEqPred theta
               theta'         = eq_theta ++ dict_theta
               dfun           = mkDictFunId dfun_name tyvars theta' clas inst_tys
-              ispec          = mkLocalInstance dfun overlap_flag
+              ispec          = mkLocalInstance dfun overlap_flag safe
 
         ; return (InstInfo { iSpec  = ispec, iBinds = VanillaInst binds uprags False },
                   idx_tycons)
index 0992fb9..39f3c4b 100644 (file)
@@ -916,13 +916,13 @@ matchClass clas tys
   = do { let pred = mkClassPred clas tys 
         ; instEnvs <- getInstEnvs
         ; case lookupInstEnv instEnvs clas tys of {
-            ([], unifs)               -- Nothing matches  
+            ([], unifs, _)               -- Nothing matches  
                 -> do { traceTcS "matchClass not matching"
                                  (vcat [ text "dict" <+> ppr pred, 
                                          text "unifs" <+> ppr unifs ]) 
                       ; return MatchInstNo  
                       } ;  
-           ([(ispec, inst_tys)], []) -- A single match 
+           ([(ispec, inst_tys)], [], _) -- A single match 
                -> do   { let dfun_id = is_dfun ispec
                        ; traceTcS "matchClass success"
                                   (vcat [text "dict" <+> ppr pred, 
@@ -931,7 +931,7 @@ matchClass clas tys
                                  -- Record that this dfun is needed
                         ; return $ MatchInstSingle (dfun_id, inst_tys)
                         } ;
-           (matches, unifs)          -- More than one matches 
+           (matches, unifs, _)          -- More than one matches 
                -> do   { traceTcS "matchClass multiple matches, deferring choice"
                                   (vcat [text "dict" <+> ppr pred,
                                          text "matches" <+> ppr matches,
index 6da5741..97ad485 100644 (file)
@@ -970,7 +970,7 @@ lookupClassInstances c ts
 
        -- Now look up instances
         ; inst_envs <- tcGetInstEnvs
-        ; let (matches, unifies) = lookupInstEnv inst_envs cls tys
+        ; let (matches, unifies, _) = lookupInstEnv inst_envs cls tys
         ; mapM reifyClassInstance (map fst matches ++ unifies) } } }
   where
     doc = ptext (sLit "TcSplice.classInstances")
index 7a2a65e..4fb64fb 100644 (file)
@@ -21,6 +21,7 @@ module InstEnv (
 
 #include "HsVersions.h"
 
+import DynFlags
 import Class
 import Var
 import VarSet
@@ -46,21 +47,23 @@ import Data.Maybe   ( isJust, isNothing )
 
 \begin{code}
 data Instance 
-  = Instance { is_cls  :: Name         -- Class name
-       
-               -- Used for "rough matching"; see Note [Rough-match field]
-               -- INVARIANT: is_tcs = roughMatchTcs is_tys
-            , is_tcs  :: [Maybe Name]  -- Top of type args
-
-               -- Used for "proper matching"; see Note [Proper-match fields]
-            , is_tvs  :: TyVarSet      -- Template tyvars for full match
-            , is_tys  :: [Type]        -- Full arg types
-               -- INVARIANT: is_dfun Id has type 
-               --      forall is_tvs. (...) => is_cls is_tys
-
-            , is_dfun :: DFunId -- See Note [Haddock assumptions]
-            , is_flag :: OverlapFlag   -- See detailed comments with
-                                       -- the decl of BasicTypes.OverlapFlag
+  = Instance { is_cls  :: Name  -- Class name
+
+                -- Used for "rough matching"; see Note [Rough-match field]
+                -- INVARIANT: is_tcs = roughMatchTcs is_tys
+             , is_tcs  :: [Maybe Name]  -- Top of type args
+
+                -- Used for "proper matching"; see Note [Proper-match fields]
+             , is_tvs  :: TyVarSet      -- Template tyvars for full match
+             , is_tys  :: [Type]        -- Full arg types
+                -- INVARIANT: is_dfun Id has type 
+                --      forall is_tvs. (...) => is_cls is_tys
+
+             , is_dfun :: DFunId -- See Note [Haddock assumptions]
+             , is_flag :: OverlapFlag   -- See detailed comments with
+                                        -- the decl of BasicTypes.OverlapFlag
+             , is_safe :: SafeHaskellMode -- SafeHaskell mode of module the
+                                          -- instance came from
     }
 \end{code}
 
@@ -177,21 +180,22 @@ instanceHead ispec
 
 mkLocalInstance :: DFunId
                 -> OverlapFlag
+                -> SafeHaskellMode
                 -> Instance
 -- Used for local instances, where we can safely pull on the DFunId
-mkLocalInstance dfun oflag
-  = Instance { is_flag = oflag, is_dfun = dfun,
+mkLocalInstance dfun oflag sflag
+  = Instance { is_flag = oflag, is_safe = sflag, is_dfun = dfun,
                is_tvs = mkVarSet tvs, is_tys = tys,
                 is_cls = className cls, is_tcs = roughMatchTcs tys }
   where
     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
 
 mkImportedInstance :: Name -> [Maybe Name]
-                  -> DFunId -> OverlapFlag -> Instance
+                  -> DFunId -> OverlapFlag -> SafeHaskellMode -> Instance
 -- Used for imported instances, where we get the rough-match stuff
 -- from the interface file
-mkImportedInstance cls mb_tcs dfun oflag
-  = Instance { is_flag = oflag, is_dfun = dfun,
+mkImportedInstance cls mb_tcs dfun oflag sflag
+  = Instance { is_flag = oflag, is_safe = sflag, is_dfun = dfun,
                is_tvs = mkVarSet tvs, is_tys = tys,
                is_cls = cls, is_tcs = mb_tcs }
   where
@@ -437,7 +441,9 @@ where the Nothing indicates that 'b' can be freely instantiated.
 lookupInstEnv :: (InstEnv, InstEnv)    -- External and home package inst-env
              -> Class -> [Type]        -- What we are looking for
              -> ([InstMatch],          -- Successful matches
-                 [Instance])           -- These don't match but do unify
+                 [Instance],           -- These don't match but do unify
+                  Bool)                 -- True if error condition caused by
+                                        -- SafeHaskell condition.
 
 -- The second component of the result pair happens when we look up
 --     Foo [a]
@@ -450,7 +456,7 @@ lookupInstEnv :: (InstEnv, InstEnv)         -- External and home package inst-env
 -- giving a suitable error messagen
 
 lookupInstEnv (pkg_ie, home_ie) cls tys
-  = (pruned_matches, all_unifs)
+  = (safe_matches, all_unifs, safe_fail)
   where
     rough_tcs  = roughMatchTcs tys
     all_tvs    = all isNothing rough_tcs
@@ -459,11 +465,43 @@ lookupInstEnv (pkg_ie, home_ie) cls tys
     all_matches = home_matches ++ pkg_matches
     all_unifs   = home_unifs   ++ pkg_unifs
     pruned_matches = foldr insert_overlapping [] all_matches
+    (safe_matches, safe_fail) = if length pruned_matches /= 1 
+                        then (pruned_matches, False)
+                        else check_safe (head pruned_matches) all_matches
        -- Even if the unifs is non-empty (an error situation)
        -- we still prune the matches, so that the error message isn't
        -- misleading (complaining of multiple matches when some should be
        -- overlapped away)
 
+    -- SafeHaskell: We restrict code compiled in 'Safe' mode from 
+    -- overriding code compiled in any other mode. The rational is
+    -- that code compiled in 'Safe' mode is code that is untrusted
+    -- by the ghc user. So we shouldn't let that code change the
+    -- behaviour of code the user didn't compile in 'Safe' mode
+    -- since thats the code they trust. So 'Safe' instances can only
+    -- overlap instances from the same module. A same instance origin
+    -- policy for safe compiled instances.
+    check_safe match@(inst,_) others
+        = case is_safe inst of
+                -- most specific isn't from a Safe module so OK
+                sf | sf /= Sf_Safe && sf /= Sf_SafeLanguage -> ([match], True)
+                -- otherwise we make sure it only overlaps instances from
+                -- the same module
+                _other -> (go [] others, True)
+        where
+            go bad [] = match:bad
+            go bad (i@(x,_):unchecked) =
+                if inSameMod x
+                    then go bad unchecked
+                    else go (i:bad) unchecked
+            
+            inSameMod b =
+                let na = getName $ getName inst
+                    la = isInternalName na
+                    nb = getName $ getName b
+                    lb = isInternalName nb
+                in (la && lb) || (nameModule na == nameModule nb)
+
     --------------
     lookup env = case lookupUFM env cls of
                   Nothing -> ([],[])   -- No instances for this class
index 2fc94d8..9492f10 100644 (file)
@@ -38,7 +38,7 @@ lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
 lookupInst cls tys
   = do { instEnv <- getInstEnv
        ; case lookupInstEnv instEnv cls tys of
-          ([(inst, inst_tys)], _) 
+          ([(inst, inst_tys)], _, _
              | noFlexiVar -> return (instanceDFunId inst, inst_tys')
              | otherwise  -> pprPanic "VectMonad.lookupInst: flexi var: " 
                                       (ppr $ mkTyConApp (classTyCon cls) tys)