Commit 4fffbc34 authored by David Terei's avatar David Terei

New handling of overlapping inst in Safe Haskell

We do much better now due to the newish per-instance flags. Rather than
mark any module that uses `-XOverlappingInstances`,
`-XIncoherentInstances` or the new `OVERLAP*` pragmas as unsafe, we
regard them all as safe and defer the check until an overlap occurs.

An type-class method call that involves overlapping instances is
considered _unsafe_ when:

1) The most specific instance, Ix, is from a module marked `-XSafe`
2) Ix is an orphan instance or a MPTC
3) At least one instance that Ix overlaps, Iy, is:
   a) from a different module than Ix
   AND
   b) Iy is not marked `OVERLAPPABLE`

This check is only enforced in modules compiled with `-XSafe` or
`-XTrustworthy`.

This fixes Safe Haskell to work with the latest overlapping instance
pragmas, and also brings consistent behavior. Previously, Safe Inferred
modules behaved differently than `-XSafe` modules.
parent eecef173
......@@ -1858,15 +1858,7 @@ unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc,
xopt Opt_TemplateHaskell,
flip xopt_unset Opt_TemplateHaskell)
]
unsafeFlagsForInfer = unsafeFlags ++
-- TODO: Can we do better than this for inference?
[ ("-XOverlappingInstances", overlapInstLoc,
xopt Opt_OverlappingInstances,
flip xopt_unset Opt_OverlappingInstances)
, ("-XIncoherentInstances", incoherentOnLoc,
xopt Opt_IncoherentInstances,
flip xopt_unset Opt_IncoherentInstances)
]
unsafeFlagsForInfer = unsafeFlags
-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
......@@ -2183,9 +2175,8 @@ safeFlagCheck cmdl dflags =
"-fpackage-trust ignored;" ++
" must be specified with a Safe Haskell flag"]
-- Have we inferred Unsafe? See Note [HscMain . Safe Haskell Inference]
safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer
-- Have we inferred Unsafe?
-- See Note [HscMain . Safe Haskell Inference]
{- **********************************************************************
......
......@@ -407,19 +407,21 @@ tcRnModule' hsc_env sum save_rn_syntax mod = do
ioMsgMaybe $
tcRnModule hsc_env (ms_hsc_src sum) save_rn_syntax mod
tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_res)
-- See Note [Safe Haskell Overlapping Instances Implementation]
-- although this is used for more than just that failure case.
(tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)
dflags <- getDynFlags
let allSafeOK = safeInferred dflags && tcSafeOK
-- end of the safe haskell line, how to respond to user?
if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK)
-- if safe Haskell off or safe infer failed, mark unsafe
then markUnsafeInfer tcg_res emptyBag
then markUnsafeInfer tcg_res whyUnsafe
-- module (could be) safe, throw warning if needed
else do
tcg_res' <- hscCheckSafeImports tcg_res
safe <- liftIO $ readIORef (tcg_safeInfer tcg_res')
safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
when safe $ do
case wopt Opt_WarnSafe dflags of
True -> (logWarnings $ unitBag $ mkPlainWarnMsg dflags
......@@ -778,8 +780,8 @@ hscFileFrontEnd mod_summary = do
--
-- It used to be that we only did safe inference on modules that had no Safe
-- Haskell flags, but now we perform safe inference on all modules as we want
-- to allow users to set the `--fwarn-safe`, `--fwarn-unsafe` and
-- `--fwarn-trustworthy-safe` flags on Trustworthy and Unsafe modules so that a
-- to allow users to set the `-fwarn-safe`, `-fwarn-unsafe` and
-- `-fwarn-trustworthy-safe` flags on Trustworthy and Unsafe modules so that a
-- user can ensure their assumptions are correct and see reasons for why a
-- module is safe or unsafe.
--
......@@ -1057,7 +1059,7 @@ markUnsafeInfer tcg_env whyUnsafe = do
(logWarnings $ unitBag $
mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
liftIO $ writeIORef (tcg_safeInfer tcg_env) False
liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)
-- NOTE: Only wipe trust when not in an explicity safe haskell mode. Other
-- times inference may be on but we are in Trustworthy mode -- so we want
-- to record safe-inference failed but not wipe the trust dependencies.
......
......@@ -515,7 +515,7 @@ addLocalInst (home_ie, my_insts) ispec
inst_envs = InstEnvs { ie_global = global_ie
, ie_local = home_ie'
, ie_visible = tcg_visible_orphan_mods tcg_env }
(matches, _, _) = lookupInstEnv inst_envs cls tys
(matches, _, _) = lookupInstEnv False inst_envs cls tys
dups = filter (identicalClsInstHead ispec) (map fst matches)
-- Check functional dependencies
......
{-# LANGUAGE CPP, ScopedTypeVariables #-}
module TcErrors(
reportUnsolved, reportAllUnsolved,
reportUnsolved, reportAllUnsolved, warnAllUnsolved,
warnDefaulting,
solverDepthErrorTcS
......@@ -95,10 +95,12 @@ and does not fail if -fdefer-type-errors is on, so that we can continue
compilation. The errors are turned into warnings in `reportUnsolved`.
-}
-- | Report unsolved goals as errors or warnings. We may also turn some into
-- deferred run-time errors if `-fdefer-type-errors` is on.
reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
reportUnsolved wanted
= do { binds_var <- newTcEvBinds
; defer_errors <- goptM Opt_DeferTypeErrors
= do { binds_var <- newTcEvBinds
; defer_errs <- goptM Opt_DeferTypeErrors
; defer_holes <- goptM Opt_DeferTypedHoles
; warn_holes <- woptM Opt_WarnTypedHoles
......@@ -112,21 +114,30 @@ reportUnsolved wanted
| warn_partial_sigs = HoleWarn
| otherwise = HoleDefer
; report_unsolved (Just binds_var) defer_errors expr_holes type_holes wanted
; report_unsolved (Just binds_var) False defer_errs expr_holes type_holes wanted
; getTcEvBinds binds_var }
reportAllUnsolved :: WantedConstraints -> TcM ()
-- Report *all* unsolved goals as errors, even if -fdefer-type-errors is on
-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on
-- See Note [Deferring coercion errors to runtime]
reportAllUnsolved :: WantedConstraints -> TcM ()
reportAllUnsolved wanted
= report_unsolved Nothing False HoleError HoleError wanted
= report_unsolved Nothing False False HoleError HoleError wanted
-- | Report all unsolved goals as warnings (but without deferring any errors to
-- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in
-- TcSimplify
warnAllUnsolved :: WantedConstraints -> TcM ()
warnAllUnsolved wanted
= report_unsolved Nothing True False HoleWarn HoleWarn wanted
-- | Report unsolved goals as errors or warnings.
report_unsolved :: Maybe EvBindsVar -- cec_binds
-> Bool -- Errors as warnings
-> Bool -- cec_defer_type_errors
-> HoleChoice -- Expression holes
-> HoleChoice -- Type holes
-> WantedConstraints -> TcM ()
report_unsolved mb_binds_var defer_errors expr_holes type_holes wanted
report_unsolved mb_binds_var err_as_warn defer_errs expr_holes type_holes wanted
| isEmptyWC wanted
= return ()
| otherwise
......@@ -146,7 +157,8 @@ report_unsolved mb_binds_var defer_errors expr_holes type_holes wanted
; warn_redundant <- woptM Opt_WarnRedundantConstraints
; let err_ctxt = CEC { cec_encl = []
, cec_tidy = tidy_env
, cec_defer_type_errors = defer_errors
, cec_defer_type_errors = defer_errs
, cec_errors_as_warns = err_as_warn
, cec_expr_holes = expr_holes
, cec_type_holes = type_holes
, cec_suppress = False -- See Note [Suppressing error messages]
......@@ -175,6 +187,10 @@ data ReportErrCtxt
-- into warnings, and emit evidence bindings
-- into 'ev' for unsolved constraints
, cec_errors_as_warns :: Bool -- Turn all errors into warnings
-- (except for Holes, which are
-- controlled by cec_type_holes and
-- cec_expr_holes)
, cec_defer_type_errors :: Bool -- True <=> -fdefer-type-errors
-- Defer type errors until runtime
-- Irrelevant if cec_binds = Nothing
......@@ -463,7 +479,7 @@ maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
-- Report the error and/or make a deferred binding for it
maybeReportError ctxt err
-- See Note [Always warn with -fdefer-type-errors]
| cec_defer_type_errors ctxt
| cec_defer_type_errors ctxt || cec_errors_as_warns ctxt
= reportWarning err
| cec_suppress ctxt
= return ()
......@@ -1254,7 +1270,7 @@ mkDictErr ctxt cts
lookup_cls_inst inst_envs ct
= do { tys_flat <- mapM quickFlattenTy tys
-- Note [Flattening in error message generation]
; return (ct, lookupInstEnv inst_envs clas tys_flat) }
; return (ct, lookupInstEnv True inst_envs clas tys_flat) }
where
(clas, tys) = getClassPredTys (ctPred ct)
......@@ -1271,25 +1287,26 @@ mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
-> TcM (ReportErrCtxt, SDoc)
-- Report an overlap error if this class constraint results
-- from an overlap (returning Left clas), otherwise return (Right pred)
mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped))
| null matches -- No matches but perhaps several unifiers
= do { let (is_ambig, ambig_msg) = mkAmbigMsg ct
; (ctxt, binds_msg, _) <- relevantBindings True ctxt ct
; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg)
; return (ctxt, cannot_resolve_msg is_ambig binds_msg ambig_msg) }
| not safe_haskell -- Some matches => overlap errors
| null unsafe_overlapped -- Some matches => overlap errors
= return (ctxt, overlap_msg)
| otherwise
= return (ctxt, safe_haskell_msg)
where
orig = ctLocOrigin (ctLoc ct)
pred = ctPred ct
(clas, tys) = getClassPredTys pred
ispecs = [ispec | (ispec, _) <- matches]
givens = getUserGivens ctxt
all_tyvars = all isTyVarTy tys
orig = ctLocOrigin (ctLoc ct)
pred = ctPred ct
(clas, tys) = getClassPredTys pred
ispecs = [ispec | (ispec, _) <- matches]
unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]
givens = getUserGivens ctxt
all_tyvars = all isTyVarTy tys
cannot_resolve_msg has_ambig_tvs binds_msg ambig_msg
= vcat [ addArising orig no_inst_msg
......@@ -1381,8 +1398,6 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
, ptext (sLit "when compiling the other instance declarations")]
])]
where
ispecs = [ispec | (ispec, _) <- matches]
givens = getUserGivens ctxt
matching_givens = mapMaybe matchable givens
......@@ -1405,7 +1420,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
-- Overlap error because of Safe Haskell (first
-- match should be the most specific match)
safe_haskell_msg
= ASSERT( length matches > 1 )
= ASSERT( length matches == 1 && not (null unsafe_ispecs) )
vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for")
<+> pprType (mkClassPred clas tys))
, sep [ptext (sLit "The matching instance is:"),
......@@ -1413,7 +1428,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
, 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])
, nest 2 (vcat [pprInstances $ unsafe_ispecs])
]
]
......
......@@ -452,7 +452,7 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty
-- handle safe infer fail
_ | check_safe && safeInferOn dflags
-> recordUnsafeInfer
-> recordUnsafeInfer emptyBag
-- handle safe language typecheck fail
_ | check_safe && safeLanguageOn dflags
......
......@@ -413,8 +413,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
-- As above but for Safe Inference mode.
; when (safeInferOn dflags) $ forM_ local_infos $ \x -> case x of
_ | genInstCheck x -> recordUnsafeInfer
_ | overlapCheck x -> recordUnsafeInfer
_ | genInstCheck x -> recordUnsafeInfer emptyBag
_ -> return ()
; return ( gbl_env
......@@ -426,10 +425,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
bad_typeable_instance i
= typeableClassName == is_cls_nm (iSpec i)
overlapCheck ty = case overlapMode (is_flag $ iSpec ty) of
NoOverlap _ -> False
_ -> True
-- Check for hand-written Generic instances (disallowed in Safe Haskell)
genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames
genInstErr i = hang (ptext (sLit $ "Generic instances can only be "
++ "derived in Safe Haskell.") $+$
......@@ -1094,7 +1090,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds fam_envs sc_th
| otherwise
= do { inst_envs <- tcGetInstEnvs
; case lookupInstEnv inst_envs cls tys of
; case lookupInstEnv False inst_envs cls tys of
([(ispec, dfun_inst_tys)], [], _) -- A single match
-> do { let dfun_id = instanceDFunId ispec
; (inst_tys, inst_theta) <- instDFunType dfun_id dfun_inst_tys
......
......@@ -1343,6 +1343,7 @@ kickOutRewritable new_flavour new_eq_rel new_tv
kick_out :: CtFlavour -> EqRel -> TcTyVar -> InertCans -> (WorkList, InertCans)
kick_out new_flavour new_eq_rel new_tv (IC { inert_eqs = tv_eqs
, inert_dicts = dictmap
, inert_safehask = safehask
, inert_funeqs = funeqmap
, inert_irreds = irreds
, inert_insols = insols })
......@@ -1354,6 +1355,7 @@ kick_out new_flavour new_eq_rel new_tv (IC { inert_eqs = tv_eqs
-- take the substitution into account
inert_cans_in = IC { inert_eqs = tv_eqs_in
, inert_dicts = dicts_in
, inert_safehask = safehask
, inert_funeqs = feqs_in
, inert_irreds = irs_in
, inert_insols = insols_in }
......@@ -1569,19 +1571,23 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls
-- It's easy because no evidence is involved
= do { lkup_inst_res <- matchClassInst inerts cls xis dict_loc
; case lkup_inst_res of
GenInst preds _ -> do { mapM_ (emitNewDerived dict_loc) preds
; stopWith fl "Dict/Top (solved)" }
GenInst preds _ s -> do { mapM_ (emitNewDerived dict_loc) preds
; unless s $
insertSafeOverlapFailureTcS work_item
; stopWith fl "Dict/Top (solved)" }
NoInstance -> do { -- If there is no instance, try improvement
try_fundep_improvement
; continueWith work_item } }
NoInstance -> do { -- If there is no instance, try improvement
try_fundep_improvement
; continueWith work_item } }
| otherwise -- Wanted, but not cached
= do { lkup_inst_res <- matchClassInst inerts cls xis dict_loc
; case lkup_inst_res of
NoInstance -> continueWith work_item
GenInst theta mk_ev -> do { addSolvedDict fl cls xis
; solve_from_instance theta mk_ev } }
GenInst theta mk_ev s -> do { addSolvedDict fl cls xis
; unless s $
insertSafeOverlapFailureTcS work_item
; solve_from_instance theta mk_ev }
NoInstance -> continueWith work_item }
where
dict_pred = mkClassPred cls xis
dict_loc = ctEvLoc fl
......@@ -1632,7 +1638,7 @@ doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc
-- Look up in top-level instances, or built-in axiom
do { match_res <- matchFam fam_tc args -- See Note [MATCHING-SYNONYMS]
; case match_res of {
Nothing -> do { try_improvement
Nothing -> do { try_improve
; continueWith work_item } ;
Just (ax_co, rhs_ty)
......@@ -1680,7 +1686,7 @@ doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc
loc = ctEvLoc old_ev
deeper_loc = bumpCtLocDepth loc
try_improvement
try_improve
| not (isWanted old_ev) -- Try improvement only for Given/Derived constraints
-- See Note [When improvement happens during solving]
, Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
......@@ -1961,13 +1967,21 @@ So the inner binding for ?x::Bool *overrides* the outer one.
Hence a work-item Given overrides an inert-item Given.
-}
-- | Indicates if Instance met the Safe Haskell overlapping instances safety
-- check.
--
-- See Note [Safe Haskell Overlapping Instances] in TcSimplify
-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify
type SafeOverlapping = Bool
data LookupInstResult
= NoInstance
| GenInst [TcPredType] ([EvId] -> EvTerm)
| GenInst [TcPredType] ([EvId] -> EvTerm) SafeOverlapping
instance Outputable LookupInstResult where
ppr NoInstance = text "NoInstance"
ppr (GenInst ev _) = text "GenInst" <+> ppr ev
ppr NoInstance = text "NoInstance"
ppr (GenInst ev _ s) = text "GenInst" <+> ppr ev <+> ss
where ss = text $ if s then "[safe]" else "[unsafe]"
matchClassInst :: InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
......@@ -2002,7 +2016,7 @@ matchClassInst _ clas [ ty ] _
, Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
-- SNat n ~ Integer
, let ev_tm = mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep))
= return (GenInst [] $ (\_ -> ev_tm))
= return $ GenInst [] (\_ -> ev_tm) True
| otherwise
= panicTcS (text "Unexpected evidence for" <+> ppr (className clas)
......@@ -2016,19 +2030,27 @@ matchClassInst inerts clas tys loc
; traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr pred
, text "inerts=" <+> ppr inerts ]
; instEnvs <- getInstEnvs
; case lookupInstEnv instEnvs clas tys of
([], _, _) -- Nothing matches
; safeOverlapCheck <- (`elem` [Sf_Safe, Sf_Trustworthy])
<$> safeHaskell <$> getDynFlags
; let (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys
safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)
; case (matches, unify, safeHaskFail) of
-- Nothing matches
([], _, _)
-> do { traceTcS "matchClass not matching" $
vcat [ text "dict" <+> ppr pred ]
; return NoInstance }
([(ispec, inst_tys)], [], _) -- A single match
-- A single match (& no safe haskell failure)
([(ispec, inst_tys)], [], False)
| not (xopt Opt_IncoherentInstances dflags)
, not (isEmptyBag unifiable_givens)
-> -- See Note [Instance and Given overlap]
do { traceTcS "Delaying instance application" $
vcat [ text "Work item=" <+> pprType (mkClassPred clas tys)
, text "Relevant given dictionaries=" <+> ppr unifiable_givens ]
, text "Relevant given dictionaries="
<+> ppr unifiable_givens ]
; return NoInstance }
| otherwise
......@@ -2038,11 +2060,11 @@ matchClassInst inerts clas tys loc
text "witness" <+> ppr dfun_id
<+> ppr (idType dfun_id) ]
-- Record that this dfun is needed
; match_one dfun_id inst_tys }
; match_one (null unsafeOverlaps) dfun_id inst_tys }
(matches, _, _) -- More than one matches
-- Defer any reactions of a multitude
-- until we learn more about the reagent
-- More than one matches (or Safe Haskell fail!). Defer any
-- reactions of a multitude until we learn more about the reagent
(matches, _, _)
-> do { traceTcS "matchClass multiple matches, deferring choice" $
vcat [text "dict" <+> ppr pred,
text "matches" <+> ppr matches]
......@@ -2050,12 +2072,12 @@ matchClassInst inerts clas tys loc
where
pred = mkClassPred clas tys
match_one :: DFunId -> [DFunInstType] -> TcS LookupInstResult
match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcS LookupInstResult
-- See Note [DFunInstType: instantiating types] in InstEnv
match_one dfun_id mb_inst_tys
match_one so dfun_id mb_inst_tys
= do { checkWellStagedDFun pred dfun_id loc
; (tys, theta) <- instDFunType dfun_id mb_inst_tys
; return $ GenInst theta (EvDFunApp dfun_id tys) }
; return $ GenInst theta (EvDFunApp dfun_id tys) so }
unifiable_givens :: Cts
unifiable_givens = filterBag matchable $
......@@ -2196,6 +2218,7 @@ matchTypeableClass clas _k t
| otherwise
= return $ GenInst [mk_typeable_pred f, mk_typeable_pred tk]
(\[t1,t2] -> EvTypeable $ EvTypeableTyApp (EvId t1,f) (EvId t2,tk))
True
-- Representation for concrete kinds. We just use the kind itself,
-- but first check to make sure that it is "simple" (i.e., made entirely
......@@ -2207,7 +2230,7 @@ matchTypeableClass clas _k t
-- Emit a `Typeable` constraint for the given type.
mk_typeable_pred ty = mkClassPred clas [ typeKind ty, ty ]
mkSimpEv ev = return (GenInst [] (\_ -> EvTypeable ev))
mkSimpEv ev = return $ GenInst [] (\_ -> EvTypeable ev) True
{- Note [No Typeable for polytype or for constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -86,7 +86,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
used_rdr_var <- newIORef Set.empty ;
th_var <- newIORef False ;
th_splice_var<- newIORef False ;
infer_var <- newIORef True ;
infer_var <- newIORef (True, emptyBag) ;
lie_var <- newIORef emptyWC ;
dfun_n_var <- newIORef emptyOccSet ;
type_env_var <- case hsc_type_env_var hsc_env of {
......@@ -1292,13 +1292,16 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
-}
-- | Mark that safe inference has failed
recordUnsafeInfer :: TcM ()
recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False
-- See Note [Safe Haskell Overlapping Instances Implementation]
-- although this is used for more than just that failure case.
recordUnsafeInfer :: WarningMessages -> TcM ()
recordUnsafeInfer warns =
getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
-- | Figure out the final correct safe haskell mode
finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode dflags tcg_env = do
safeInf <- readIORef (tcg_safeInfer tcg_env)
safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
return $ case safeHaskell dflags of
Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
| otherwise -> Sf_None
......
......@@ -463,18 +463,18 @@ data TcGblEnv
-- Things defined in this module, or (in GHCi)
-- in the declarations for a single GHCi command.
-- For the latter, see Note [The interactive package] in HscTypes
tcg_binds :: LHsBinds Id, -- Value bindings in this module
tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature
tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids
tcg_warns :: Warnings, -- ...Warnings and deprecations
tcg_anns :: [Annotation], -- ...Annotations
tcg_tcs :: [TyCon], -- ...TyCons and Classes
tcg_insts :: [ClsInst], -- ...Instances
tcg_fam_insts :: [FamInst], -- ...Family instances
tcg_rules :: [LRuleDecl Id], -- ...Rules
tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports
tcg_vects :: [LVectDecl Id], -- ...Vectorisation declarations
tcg_patsyns :: [PatSyn], -- ...Pattern synonyms
tcg_binds :: LHsBinds Id, -- Value bindings in this module
tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature
tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids
tcg_warns :: Warnings, -- ...Warnings and deprecations
tcg_anns :: [Annotation], -- ...Annotations
tcg_tcs :: [TyCon], -- ...TyCons and Classes
tcg_insts :: [ClsInst], -- ...Instances
tcg_fam_insts :: [FamInst], -- ...Family instances
tcg_rules :: [LRuleDecl Id], -- ...Rules
tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports
tcg_vects :: [LVectDecl Id], -- ...Vectorisation declarations
tcg_patsyns :: [PatSyn], -- ...Pattern synonyms
tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs
tcg_hpc :: AnyHpcUsage, -- ^ @True@ if any part of the
......@@ -483,12 +483,14 @@ data TcGblEnv
tcg_main :: Maybe Name, -- ^ The Name of the main
-- function, if this module is
-- the main module.
tcg_safeInfer :: TcRef Bool, -- Has the typechecker
-- inferred this module
-- as -XSafe (Safe Haskell)
-- | A list of user-defined plugins for the constraint solver.
tcg_safeInfer :: TcRef (Bool, WarningMessages),
-- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell)
-- See Note [Safe Haskell Overlapping Instances Implementation],
-- although this is used for more than just that failure case.
tcg_tc_plugins :: [TcPluginSolver],
-- ^ A list of user-defined plugins for the constraint solver.
tcg_static_wc :: TcRef WantedConstraints
-- ^ Wanted constraints of static forms.
......
......@@ -34,7 +34,7 @@ module TcSMonad (
getTopEnv, getGblEnv, getTcEvBinds, getTcLevel,
getTcEvBindsMap,
-- Inerts
-- Inerts
InertSet(..), InertCans(..),
updInertTcS, updInertCans, updInertDicts, updInertIrreds,
getNoGivenEqs, setInertCans, getInertEqs, getInertCans, getInertGivens,
......@@ -46,6 +46,10 @@ module TcSMonad (
emitInsoluble, emitWorkNC, emitWorkCt,
EqualCtList,
-- Inert Safe Haskell safe-overlap failures
addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,
getSafeOverlapFailures,
-- Inert CDictCans
lookupInertDict, findDictsByClass, addDict, addDictsByClass, delDict, partitionDicts,
......@@ -474,6 +478,15 @@ data InertCans
-- NB: index is /not/ the whole type because FD reactions
-- need to match the class but not necessarily the whole type.
, inert_safehask :: DictMap Ct
-- Failed dictionary resolution due to Safe Haskell overlapping
-- instances restriction. We keep this seperate from inert_dicts
-- as it doesn't cause compilation failure, just safe inference
-- failure.
--
-- ^ See Note [Safe Haskell Overlapping Instances Implementation]
-- in TcSimplify
, inert_irreds :: Cts
-- Irreducible predicates
......@@ -527,6 +540,8 @@ instance Outputable InertCans where
<+> pprCts (funEqsToBag (inert_funeqs ics))
, ptext (sLit "Dictionaries:")
<+> pprCts (dictsToBag (inert_dicts ics))
, ptext (sLit "Safe Haskell unsafe overlap:")
<+> pprCts (dictsToBag (inert_safehask ics))
, ptext (sLit "Irreds:")
<+> pprCts (inert_irreds ics)
, text "Insolubles =" <+> -- Clearly print frozen errors
......@@ -541,6 +556,7 @@ emptyInert :: InertSet
emptyInert
= IS { inert_cans = IC { inert_eqs = emptyVarEnv
, inert_dicts = emptyDicts
, inert_safehask = emptyDicts
, inert_funeqs = emptyFunEqs
, inert_irreds = emptyCts
, inert_insols = emptyCts
......@@ -589,6 +605,24 @@ insertInertItemTcS item
; traceTcS "insertInertItemTcS }" $ empty }
--------------
addInertSafehask :: InertCans -> Ct -> InertCans
addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })
= ics { inert_safehask = addDict (inert_dicts ics) cls tys item }
addInertSafehask _ item
= pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item
insertSafeOverlapFailureTcS :: Ct -> TcS ()
insertSafeOverlapFailureTcS item
= updInertCans (\ics -> addInertSafehask ics item)