Commit 3a8df611 authored by dterei's avatar dterei

SafeHaskell: Restrict OverlappingInstances.

OverlappingInstances in Safe modules can only overlap instances
defined in the same module.
parent 0f13e110
......@@ -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)
......
......@@ -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,
......
\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}
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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,
......
......@@ -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")
......
......@@ -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
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment