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 ...@@ -324,38 +324,43 @@ instance Outputable RecFlag where
\begin{code} \begin{code}
data OverlapFlag data OverlapFlag
= NoOverlap -- This instance must not overlap another -- | This instance must not overlap another
= NoOverlap { isSafeOverlap :: Bool }
| OverlapOk -- Silently ignore this instance if you find a
-- more specific one that matches the constraint -- | Silently ignore this instance if you find a
-- you are trying to resolve -- more specific one that matches the constraint
-- -- you are trying to resolve
-- Example: constraint (Foo [Int]) --
-- instances (Foo [Int]) -- Example: constraint (Foo [Int])
-- instances (Foo [Int])
-- (Foo [a]) OverlapOk -- (Foo [a]) OverlapOk
-- Since the second instance has the OverlapOk flag, -- Since the second instance has the OverlapOk flag,
-- the first instance will be chosen (otherwise -- the first instance will be chosen (otherwise
-- its ambiguous which to choose) -- its ambiguous which to choose)
| OverlapOk { isSafeOverlap :: Bool }
| Incoherent -- Like OverlapOk, but also ignore this instance
-- if it doesn't match the constraint you are -- | Like OverlapOk, but also ignore this instance
-- trying to resolve, but could match if the type variables -- if it doesn't match the constraint you are
-- in the constraint were instantiated -- trying to resolve, but could match if the type variables
-- -- in the constraint were instantiated
-- Example: constraint (Foo [b]) --
-- instances (Foo [Int]) Incoherent -- Example: constraint (Foo [b])
-- (Foo [a]) -- instances (Foo [Int]) Incoherent
-- Without the Incoherent flag, we'd complain that -- (Foo [a])
-- instantiating 'b' would change which instance -- Without the Incoherent flag, we'd complain that
-- was chosen -- instantiating 'b' would change which instance
-- was chosen
| Incoherent { isSafeOverlap :: Bool }
deriving( Eq ) deriving( Eq )
instance Outputable OverlapFlag where instance Outputable OverlapFlag where
ppr NoOverlap = empty ppr (NoOverlap b) = empty <+> pprSafeOverlap b
ppr OverlapOk = ptext (sLit "[overlap ok]") ppr (OverlapOk b) = ptext (sLit "[overlap ok]") <+> pprSafeOverlap b
ppr Incoherent = ptext (sLit "[incoherent]") ppr (Incoherent b) = ptext (sLit "[incoherent]") <+> pprSafeOverlap b
pprSafeOverlap :: Bool -> SDoc
pprSafeOverlap True = ptext $ sLit "[safe]"
pprSafeOverlap False = empty
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -1407,14 +1407,15 @@ instance Binary IfaceFamInst where ...@@ -1407,14 +1407,15 @@ instance Binary IfaceFamInst where
return (IfaceFamInst fam tys tycon) return (IfaceFamInst fam tys tycon)
instance Binary OverlapFlag where instance Binary OverlapFlag where
put_ bh NoOverlap = putByte bh 0 put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b
put_ bh OverlapOk = putByte bh 1 put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b
put_ bh Incoherent = putByte bh 2 put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b
get bh = do h <- getByte bh get bh = do h <- getByte bh
b <- get bh
case h of case h of
0 -> return NoOverlap 0 -> return $ NoOverlap b
1 -> return OverlapOk 1 -> return $ OverlapOk b
2 -> return Incoherent 2 -> return $ Incoherent b
_ -> panic ("get OverlapFlag " ++ show h) _ -> panic ("get OverlapFlag " ++ show h)
instance Binary IfaceConDecls where instance Binary IfaceConDecls where
......
...@@ -240,7 +240,7 @@ loadInterface doc_str mod from ...@@ -240,7 +240,7 @@ loadInterface doc_str mod from
; ignore_prags <- doptM Opt_IgnoreInterfacePragmas ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas
; new_eps_decls <- loadDecls ignore_prags (mi_decls iface) ; 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_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
; new_eps_anns <- tcIfaceAnnotations (mi_anns iface) ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
......
...@@ -265,7 +265,7 @@ typecheckIface iface ...@@ -265,7 +265,7 @@ typecheckIface iface
; writeMutVar tc_env_var type_env ; writeMutVar tc_env_var type_env
-- Now do those rules, instances and annotations -- 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) ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; rules <- tcIfaceRules ignore_prags (mi_rules iface) ; rules <- tcIfaceRules ignore_prags (mi_rules iface)
; anns <- tcIfaceAnnotations (mi_anns iface) ; anns <- tcIfaceAnnotations (mi_anns iface)
...@@ -588,14 +588,13 @@ look at it. ...@@ -588,14 +588,13 @@ look at it.
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
tcIfaceInst :: IfaceTrustInfo -> IfaceInst -> IfL Instance tcIfaceInst :: IfaceInst -> IfL Instance
tcIfaceInst safe (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
ifInstCls = cls, ifInstTys = mb_tcs }) ifInstCls = cls, ifInstTys = mb_tcs })
= do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $ = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
tcIfaceExtId dfun_occ tcIfaceExtId dfun_occ
; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
; let safe' = getSafeMode safe ; return (mkImportedInstance cls mb_tcs' dfun oflag) }
; return (mkImportedInstance cls mb_tcs' dfun oflag safe') }
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon,
......
...@@ -14,7 +14,7 @@ import Annotations ( Annotation ) ...@@ -14,7 +14,7 @@ import Annotations ( Annotation )
tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceInst :: IfaceTrustInfo -> IfaceInst -> IfL Instance tcIfaceInst :: IfaceInst -> IfL Instance
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
\end{code} \end{code}
......
...@@ -13,7 +13,7 @@ module Inst ( ...@@ -13,7 +13,7 @@ module Inst (
newOverloadedLit, mkOverLit, newOverloadedLit, mkOverLit,
tcGetInstEnvs, getOverlapFlag, getSafeHaskellFlag, tcGetInstEnvs, getOverlapFlag,
tcExtendLocalInstEnv, instCallConstraints, newMethodFromName, tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
tcSyntaxName, tcSyntaxName,
...@@ -368,19 +368,15 @@ syntaxNameCtxt name orig ty tidy_env = do ...@@ -368,19 +368,15 @@ syntaxNameCtxt name orig ty tidy_env = do
\begin{code} \begin{code}
getOverlapFlag :: TcM OverlapFlag getOverlapFlag :: TcM OverlapFlag
getOverlapFlag getOverlapFlag
= do { dflags <- getDOpts = do { dflags <- getDOpts
; let overlap_ok = xopt Opt_OverlappingInstances dflags ; let overlap_ok = xopt Opt_OverlappingInstances dflags
incoherent_ok = xopt Opt_IncoherentInstances dflags incoherent_ok = xopt Opt_IncoherentInstances dflags
overlap_flag | incoherent_ok = Incoherent safeOverlap = safeLanguageOn dflags
| overlap_ok = OverlapOk overlap_flag | incoherent_ok = Incoherent safeOverlap
| otherwise = NoOverlap | overlap_ok = OverlapOk safeOverlap
| otherwise = NoOverlap safeOverlap
; return overlap_flag }
; return overlap_flag }
getSafeHaskellFlag :: TcM SafeHaskellMode
getSafeHaskellFlag
= do { dflags <- getDOpts
; return $ safeHaskell dflags }
tcGetInstEnvs :: TcM (InstEnv, InstEnv) tcGetInstEnvs :: TcM (InstEnv, InstEnv)
-- Gets both the external-package inst-env -- Gets both the external-package inst-env
......
...@@ -315,14 +315,13 @@ tcDeriving tycl_decls inst_decls deriv_decls ...@@ -315,14 +315,13 @@ tcDeriving tycl_decls inst_decls deriv_decls
; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras
; overlap_flag <- getOverlapFlag ; overlap_flag <- getOverlapFlag
; safe <- getSafeHaskellFlag
; let (infer_specs, given_specs) = splitEithers early_specs ; 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) $ ; 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 -- We no longer generate the old generic to/from functions
-- from each type declaration, so this is emptyBag -- 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, ...@@ -1325,11 +1324,11 @@ ordered by sorting on type varible, tv, (major key) and then class, k,
\end{itemize} \end{itemize}
\begin{code} \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) = do { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
; iterate_deriv 1 initial_solutions } ; iterate_deriv 1 initial_solutions }
where where
...@@ -1355,7 +1354,7 @@ inferInstanceContexts safe oflag infer_specs ...@@ -1355,7 +1354,7 @@ inferInstanceContexts safe oflag infer_specs
| otherwise | otherwise
= do { -- Extend the inst info from the explicit instance decls = do { -- Extend the inst info from the explicit instance decls
-- with the current set of solutions, and simplify each RHS -- 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 current_solns infer_specs
; new_solns <- checkNoErrs $ ; new_solns <- checkNoErrs $
extendLocalInstEnv inst_specs $ extendLocalInstEnv inst_specs $
...@@ -1401,11 +1400,11 @@ inferInstanceContexts safe oflag infer_specs ...@@ -1401,11 +1400,11 @@ inferInstanceContexts safe oflag infer_specs
the_pred = mkClassPred clas inst_tys the_pred = mkClassPred clas inst_tys
------------------------------------------------------------------ ------------------------------------------------------------------
mkInstance :: SafeHaskellMode -> OverlapFlag -> ThetaType -> DerivSpec -> Instance mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
mkInstance safe overlap_flag theta mkInstance overlap_flag theta
(DS { ds_name = dfun_name (DS { ds_name = dfun_name
, ds_tvs = tyvars, ds_cls = clas, ds_tys = tys }) , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
= mkLocalInstance dfun overlap_flag safe = mkLocalInstance dfun overlap_flag
where where
dfun = mkDictFunId dfun_name tyvars theta clas tys dfun = mkDictFunId dfun_name tyvars theta clas tys
...@@ -1492,10 +1491,9 @@ the renamer. What a great hack! ...@@ -1492,10 +1491,9 @@ the renamer. What a great hack!
-- case of instances for indexed families. -- case of instances for indexed families.
-- --
genInst :: Bool -- True <=> standalone deriving genInst :: Bool -- True <=> standalone deriving
-> SafeHaskellMode
-> OverlapFlag -> OverlapFlag
-> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds) -> 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 spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args
, ds_theta = theta, ds_newtype = is_newtype , ds_theta = theta, ds_newtype = is_newtype
, ds_name = name, ds_cls = clas }) , ds_name = name, ds_cls = clas })
...@@ -1514,7 +1512,7 @@ genInst standalone_deriv safe oflag ...@@ -1514,7 +1512,7 @@ genInst standalone_deriv safe oflag
, iBinds = VanillaInst meth_binds [] standalone_deriv } , iBinds = VanillaInst meth_binds [] standalone_deriv }
, aux_binds) } , aux_binds) }
where where
inst_spec = mkInstance safe oflag theta spec inst_spec = mkInstance oflag theta spec
co1 = case tyConFamilyCoercion_maybe rep_tycon of co1 = case tyConFamilyCoercion_maybe rep_tycon of
Just co_con -> mkAxInstCo co_con rep_tc_args Just co_con -> mkAxInstCo co_con rep_tc_args
Nothing -> id_co Nothing -> id_co
......
...@@ -450,11 +450,10 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ...@@ -450,11 +450,10 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
-- Dfun location is that of instance *header* -- Dfun location is that of instance *header*
; overlap_flag <- getOverlapFlag ; overlap_flag <- getOverlapFlag
; safe <- getSafeHaskellFlag
; let (eq_theta,dict_theta) = partition isEqPred theta ; let (eq_theta,dict_theta) = partition isEqPred theta
theta' = eq_theta ++ dict_theta theta' = eq_theta ++ dict_theta
dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys 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 }, ; return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False },
idx_tycons) idx_tycons)
......
...@@ -62,8 +62,6 @@ data Instance ...@@ -62,8 +62,6 @@ data Instance
, is_dfun :: DFunId -- See Note [Haddock assumptions] , is_dfun :: DFunId -- See Note [Haddock assumptions]
, is_flag :: OverlapFlag -- See detailed comments with , is_flag :: OverlapFlag -- See detailed comments with
-- the decl of BasicTypes.OverlapFlag -- the decl of BasicTypes.OverlapFlag
, is_safe :: SafeHaskellMode -- SafeHaskell mode of module the
-- instance came from
} }
\end{code} \end{code}
...@@ -180,22 +178,21 @@ instanceHead ispec ...@@ -180,22 +178,21 @@ instanceHead ispec
mkLocalInstance :: DFunId mkLocalInstance :: DFunId
-> OverlapFlag -> OverlapFlag
-> SafeHaskellMode
-> Instance -> Instance
-- Used for local instances, where we can safely pull on the DFunId -- Used for local instances, where we can safely pull on the DFunId
mkLocalInstance dfun oflag sflag mkLocalInstance dfun oflag
= Instance { is_flag = oflag, is_safe = sflag, is_dfun = dfun, = Instance { is_flag = oflag, is_dfun = dfun,
is_tvs = mkVarSet tvs, is_tys = tys, is_tvs = mkVarSet tvs, is_tys = tys,
is_cls = className cls, is_tcs = roughMatchTcs tys } is_cls = className cls, is_tcs = roughMatchTcs tys }
where where
(tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
mkImportedInstance :: Name -> [Maybe Name] mkImportedInstance :: Name -> [Maybe Name]
-> DFunId -> OverlapFlag -> SafeHaskellMode -> Instance -> DFunId -> OverlapFlag -> Instance
-- Used for imported instances, where we get the rough-match stuff -- Used for imported instances, where we get the rough-match stuff
-- from the interface file -- from the interface file
mkImportedInstance cls mb_tcs dfun oflag sflag mkImportedInstance cls mb_tcs dfun oflag
= Instance { is_flag = oflag, is_safe = sflag, is_dfun = dfun, = Instance { is_flag = oflag, is_dfun = dfun,
is_tvs = mkVarSet tvs, is_tys = tys, is_tvs = mkVarSet tvs, is_tys = tys,
is_cls = cls, is_tcs = mb_tcs } is_cls = cls, is_tcs = mb_tcs }
where where
...@@ -482,12 +479,12 @@ lookupInstEnv (pkg_ie, home_ie) cls tys ...@@ -482,12 +479,12 @@ lookupInstEnv (pkg_ie, home_ie) cls tys
-- overlap instances from the same module. A same instance origin -- overlap instances from the same module. A same instance origin
-- policy for safe compiled instances. -- policy for safe compiled instances.
check_safe match@(inst,_) others 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 -- 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 -- otherwise we make sure it only overlaps instances from
-- the same module -- the same module
_other -> (go [] others, True) True -> (go [] others, True)
where where
go bad [] = match:bad go bad [] = match:bad
go bad (i@(x,_):unchecked) = go bad (i@(x,_):unchecked) =
...@@ -538,7 +535,7 @@ lookupInstEnv (pkg_ie, home_ie) cls tys ...@@ -538,7 +535,7 @@ lookupInstEnv (pkg_ie, home_ie) cls tys
-- Does not match, so next check whether the things unify -- Does not match, so next check whether the things unify
-- See Note [Overlapping instances] above -- See Note [Overlapping instances] above
| Incoherent <- oflag | Incoherent _ <- oflag
= find ms us rest = find ms us rest
| otherwise | otherwise
...@@ -581,8 +578,8 @@ insert_overlapping new_item (item:items) ...@@ -581,8 +578,8 @@ insert_overlapping new_item (item:items)
-- This is a change (Trac #3877, Dec 10). It used to -- This is a change (Trac #3877, Dec 10). It used to
-- require that instB (the less specific one) permitted overlap. -- require that instB (the less specific one) permitted overlap.
overlap_ok = case (is_flag instA, is_flag instB) of overlap_ok = case (is_flag instA, is_flag instB) of
(NoOverlap, NoOverlap) -> False (NoOverlap _, NoOverlap _) -> False
_ -> True _ -> True
\end{code} \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