Commit d9965c11 authored by dterei's avatar dterei

SafeHaskell: Move safe haskell flag into Overlap flag

For instance decls we no longer store the SafeHaskell mode
in this data structure but instead store it as a bool field
in the overlap flag structure.
parent 615fa148
......@@ -324,38 +324,43 @@ instance Outputable RecFlag where
\begin{code}
data OverlapFlag
= NoOverlap -- This instance must not overlap another
| OverlapOk -- Silently ignore this instance if you find a
-- more specific one that matches the constraint
-- you are trying to resolve
--
-- Example: constraint (Foo [Int])
-- instances (Foo [Int])
-- (Foo [a]) OverlapOk
-- Since the second instance has the OverlapOk flag,
-- the first instance will be chosen (otherwise
-- its ambiguous which to choose)
| Incoherent -- Like OverlapOk, but also ignore this instance
-- if it doesn't match the constraint you are
-- trying to resolve, but could match if the type variables
-- in the constraint were instantiated
--
-- Example: constraint (Foo [b])
-- instances (Foo [Int]) Incoherent
-- (Foo [a])
-- Without the Incoherent flag, we'd complain that
-- instantiating 'b' would change which instance
-- was chosen
-- | This instance must not overlap another
= NoOverlap { isSafeOverlap :: Bool }
-- | Silently ignore this instance if you find a
-- more specific one that matches the constraint
-- you are trying to resolve
--
-- Example: constraint (Foo [Int])
-- instances (Foo [Int])
-- (Foo [a]) OverlapOk
-- Since the second instance has the OverlapOk flag,
-- the first instance will be chosen (otherwise
-- its ambiguous which to choose)
| OverlapOk { isSafeOverlap :: Bool }
-- | Like OverlapOk, but also ignore this instance
-- if it doesn't match the constraint you are
-- trying to resolve, but could match if the type variables
-- in the constraint were instantiated
--
-- Example: constraint (Foo [b])
-- instances (Foo [Int]) Incoherent
-- (Foo [a])
-- Without the Incoherent flag, we'd complain that
-- instantiating 'b' would change which instance
-- was chosen
| Incoherent { isSafeOverlap :: Bool }
deriving( Eq )
instance Outputable OverlapFlag where
ppr NoOverlap = empty
ppr OverlapOk = ptext (sLit "[overlap ok]")
ppr Incoherent = ptext (sLit "[incoherent]")
ppr (NoOverlap b) = empty <+> pprSafeOverlap b
ppr (OverlapOk b) = ptext (sLit "[overlap ok]") <+> pprSafeOverlap b
ppr (Incoherent b) = ptext (sLit "[incoherent]") <+> pprSafeOverlap b
pprSafeOverlap :: Bool -> SDoc
pprSafeOverlap True = ptext $ sLit "[safe]"
pprSafeOverlap False = empty
\end{code}
%************************************************************************
......
......@@ -1407,14 +1407,15 @@ instance Binary IfaceFamInst where
return (IfaceFamInst fam tys tycon)
instance Binary OverlapFlag where
put_ bh NoOverlap = putByte bh 0
put_ bh OverlapOk = putByte bh 1
put_ bh Incoherent = putByte bh 2
put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b
put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b
put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b
get bh = do h <- getByte bh
b <- get bh
case h of
0 -> return NoOverlap
1 -> return OverlapOk
2 -> return Incoherent
0 -> return $ NoOverlap b
1 -> return $ OverlapOk b
2 -> return $ Incoherent b
_ -> panic ("get OverlapFlag " ++ show h)
instance Binary IfaceConDecls where
......
......@@ -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_trust iface) (mi_insts iface)
; new_eps_insts <- mapM tcIfaceInst (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,7 +265,7 @@ typecheckIface iface
; writeMutVar tc_env_var type_env
-- Now do those rules, instances and annotations
; insts <- mapM (tcIfaceInst $ mi_trust iface) (mi_insts iface)
; insts <- mapM tcIfaceInst (mi_insts iface)
; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; rules <- tcIfaceRules ignore_prags (mi_rules iface)
; anns <- tcIfaceAnnotations (mi_anns iface)
......@@ -588,14 +588,13 @@ look at it.
%************************************************************************
\begin{code}
tcIfaceInst :: IfaceTrustInfo -> IfaceInst -> IfL Instance
tcIfaceInst safe (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
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
; let safe' = getSafeMode safe
; return (mkImportedInstance cls mb_tcs' dfun oflag safe') }
; return (mkImportedInstance cls mb_tcs' dfun oflag) }
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon,
......
......@@ -14,7 +14,7 @@ import Annotations ( Annotation )
tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceInst :: IfaceTrustInfo -> IfaceInst -> IfL Instance
tcIfaceInst :: IfaceInst -> IfL Instance
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
\end{code}
......
......@@ -13,7 +13,7 @@ module Inst (
newOverloadedLit, mkOverLit,
tcGetInstEnvs, getOverlapFlag, getSafeHaskellFlag,
tcGetInstEnvs, getOverlapFlag,
tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
tcSyntaxName,
......@@ -368,19 +368,15 @@ syntaxNameCtxt name orig ty tidy_env = do
\begin{code}
getOverlapFlag :: TcM OverlapFlag
getOverlapFlag
= do { dflags <- getDOpts
; let overlap_ok = xopt Opt_OverlappingInstances dflags
incoherent_ok = xopt Opt_IncoherentInstances dflags
overlap_flag | incoherent_ok = Incoherent
| overlap_ok = OverlapOk
| otherwise = NoOverlap
; return overlap_flag }
getSafeHaskellFlag :: TcM SafeHaskellMode
getSafeHaskellFlag
= do { dflags <- getDOpts
; return $ safeHaskell dflags }
= do { dflags <- getDOpts
; let overlap_ok = xopt Opt_OverlappingInstances dflags
incoherent_ok = xopt Opt_IncoherentInstances dflags
safeOverlap = safeLanguageOn dflags
overlap_flag | incoherent_ok = Incoherent safeOverlap
| overlap_ok = OverlapOk safeOverlap
| otherwise = NoOverlap safeOverlap
; return overlap_flag }
tcGetInstEnvs :: TcM (InstEnv, InstEnv)
-- Gets both the external-package inst-env
......
......@@ -315,14 +315,13 @@ 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 safe overlap_flag) given_specs
; insts1 <- mapM (genInst True overlap_flag) given_specs
; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
inferInstanceContexts safe overlap_flag infer_specs
inferInstanceContexts overlap_flag infer_specs
; insts2 <- mapM (genInst False safe overlap_flag) final_specs
; insts2 <- mapM (genInst False overlap_flag) final_specs
-- We no longer generate the old generic to/from functions
-- from each type declaration, so this is emptyBag
......@@ -1325,11 +1324,11 @@ ordered by sorting on type varible, tv, (major key) and then class, k,
\end{itemize}
\begin{code}
inferInstanceContexts :: SafeHaskellMode -> OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
inferInstanceContexts _ _ [] = return []
inferInstanceContexts _ [] = return []
inferInstanceContexts safe oflag infer_specs
inferInstanceContexts oflag infer_specs
= do { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
; iterate_deriv 1 initial_solutions }
where
......@@ -1355,7 +1354,7 @@ inferInstanceContexts safe 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 safe oflag)
let inst_specs = zipWithEqual "add_solns" (mkInstance oflag)
current_solns infer_specs
; new_solns <- checkNoErrs $
extendLocalInstEnv inst_specs $
......@@ -1401,11 +1400,11 @@ inferInstanceContexts safe oflag infer_specs
the_pred = mkClassPred clas inst_tys
------------------------------------------------------------------
mkInstance :: SafeHaskellMode -> OverlapFlag -> ThetaType -> DerivSpec -> Instance
mkInstance safe overlap_flag theta
mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
mkInstance overlap_flag theta
(DS { ds_name = dfun_name
, ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
= mkLocalInstance dfun overlap_flag safe
= mkLocalInstance dfun overlap_flag
where
dfun = mkDictFunId dfun_name tyvars theta clas tys
......@@ -1492,10 +1491,9 @@ the renamer. What a great hack!
-- case of instances for indexed families.
--
genInst :: Bool -- True <=> standalone deriving
-> SafeHaskellMode
-> OverlapFlag
-> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
genInst standalone_deriv safe oflag
genInst standalone_deriv 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 })
......@@ -1514,7 +1512,7 @@ genInst standalone_deriv safe oflag
, iBinds = VanillaInst meth_binds [] standalone_deriv }
, aux_binds) }
where
inst_spec = mkInstance safe oflag theta spec
inst_spec = mkInstance oflag theta spec
co1 = case tyConFamilyCoercion_maybe rep_tycon of
Just co_con -> mkAxInstCo co_con rep_tc_args
Nothing -> id_co
......
......@@ -450,11 +450,10 @@ 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 safe
ispec = mkLocalInstance dfun overlap_flag
; return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False },
idx_tycons)
......
......@@ -62,8 +62,6 @@ data Instance
, 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}
......@@ -180,22 +178,21 @@ instanceHead ispec
mkLocalInstance :: DFunId
-> OverlapFlag
-> SafeHaskellMode
-> Instance
-- Used for local instances, where we can safely pull on the DFunId
mkLocalInstance dfun oflag sflag
= Instance { is_flag = oflag, is_safe = sflag, is_dfun = dfun,
mkLocalInstance dfun oflag
= Instance { is_flag = oflag, 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 -> SafeHaskellMode -> Instance
-> DFunId -> OverlapFlag -> Instance
-- Used for imported instances, where we get the rough-match stuff
-- from the interface file
mkImportedInstance cls mb_tcs dfun oflag sflag
= Instance { is_flag = oflag, is_safe = sflag, is_dfun = dfun,
mkImportedInstance cls mb_tcs dfun oflag
= Instance { is_flag = oflag, is_dfun = dfun,
is_tvs = mkVarSet tvs, is_tys = tys,
is_cls = cls, is_tcs = mb_tcs }
where
......@@ -482,12 +479,12 @@ lookupInstEnv (pkg_ie, home_ie) cls tys
-- 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
= case isSafeOverlap (is_flag inst) of
-- most specific isn't from a Safe module so OK
sf | sf /= Sf_Safe && sf /= Sf_SafeLanguage -> ([match], True)
False -> ([match], True)
-- otherwise we make sure it only overlaps instances from
-- the same module
_other -> (go [] others, True)
True -> (go [] others, True)
where
go bad [] = match:bad
go bad (i@(x,_):unchecked) =
......@@ -538,7 +535,7 @@ lookupInstEnv (pkg_ie, home_ie) cls tys
-- Does not match, so next check whether the things unify
-- See Note [Overlapping instances] above
| Incoherent <- oflag
| Incoherent _ <- oflag
= find ms us rest
| otherwise
......@@ -581,8 +578,8 @@ insert_overlapping new_item (item:items)
-- This is a change (Trac #3877, Dec 10). It used to
-- require that instB (the less specific one) permitted overlap.
overlap_ok = case (is_flag instA, is_flag instB) of
(NoOverlap, NoOverlap) -> False
_ -> True
(NoOverlap _, NoOverlap _) -> False
_ -> True
\end{code}
......
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