diff options
72 files changed, 995 insertions, 279 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index a0bd8a56dd..6ebd04cca8 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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] {- ********************************************************************** diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index eb772bae27..0acbdff8a5 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -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. diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index b82a70c642..c1a1c5a98b 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -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 diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 67aed6498b..88c88bdc53 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -1,7 +1,7 @@ {-# 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]) ] ] diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs index 2ce6f8630e..4e426453a7 100644 --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -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 diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 39ed3b29a1..ed4fd913bf 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -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 diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index a9dcc98f2a..33ff043a64 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 5507e60e51..ea454d5d60 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -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 diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 422e9344b9..3014755858 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -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. diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index e17bc4308e..39b01e7d69 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -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) + +getSafeOverlapFailures :: TcS Cts +getSafeOverlapFailures + = do { IC { inert_safehask = safehask } <- getInertCans + ; return $ foldDicts consCts safehask emptyCts } + +-------------- addSolvedDict :: CtEvidence -> Class -> [Type] -> TcS () -- Add a new item in the solved set of the monad -- See Note [Solved dictionaries] @@ -633,6 +667,11 @@ updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS () updInertDicts upd_fn = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) } +updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS () +-- Modify the inert set with the supplied function +updInertSafehask upd_fn + = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) } + updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS () -- Modify the inert set with the supplied function updInertFunEqs upd_fn @@ -653,11 +692,13 @@ prepareInertsForImplications is@(IS { inert_cans = cans }) getGivens (IC { inert_eqs = eqs , inert_irreds = irreds , inert_funeqs = funeqs - , inert_dicts = dicts }) + , inert_dicts = dicts + , inert_safehask = safehask }) = IC { inert_eqs = filterVarEnv is_given_ecl eqs , inert_funeqs = filterFunEqs isGivenCt funeqs , inert_irreds = Bag.filterBag isGivenCt irreds , inert_dicts = filterDicts isGivenCt dicts + , inert_safehask = filterDicts isGivenCt safehask , inert_insols = emptyCts } is_given_ecl :: EqualCtList -> Bool @@ -723,7 +764,8 @@ getUnsolvedInerts :: TcS ( Bag Implication getUnsolvedInerts = do { IC { inert_eqs = tv_eqs , inert_funeqs = fun_eqs - , inert_irreds = irreds, inert_dicts = idicts + , inert_irreds = irreds + , inert_dicts = idicts , inert_insols = insols } <- getInertCans ; let unsolved_tv_eqs = foldVarEnv (\cts rest -> @@ -1343,8 +1385,15 @@ nestTcS (TcS thing_inside) ; res <- thing_inside nest_env ; new_inerts <- TcM.readTcRef new_inert_var + + -- we want to propogate the safe haskell failures + ; let old_ic = inert_cans inerts + new_ic = inert_cans new_inerts + nxt_ic = old_ic { inert_safehask = inert_safehask new_ic } + ; TcM.writeTcRef inerts_var -- See Note [Propagate the solved dictionaries] - (inerts { inert_solved_dicts = inert_solved_dicts new_inerts }) + (inerts { inert_solved_dicts = inert_solved_dicts new_inerts + , inert_cans = nxt_ic }) ; return res } diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index c1535f8733..e9705790ed 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -14,39 +14,40 @@ module TcSimplify( #include "HsVersions.h" -import TcRnTypes -import TcRnMonad -import TcErrors -import TcMType as TcM -import TcType -import TcSMonad as TcS -import TcInteract -import Kind ( isKind, defaultKind_maybe ) -import Inst -import Unify ( tcMatchTy ) -import Type ( classifyPredType, isIPClass, PredTree(..) - , getClassPredTys_maybe, EqRel(..) ) -import TyCon ( isTypeFamilyTyCon ) -import Class ( Class ) -import Id ( idType ) -import Var -import Unique -import VarSet -import TcEvidence -import Name import Bag +import Class ( classKey ) +import Class ( Class ) +import DynFlags ( ExtensionFlag( Opt_AllowAmbiguousTypes + , Opt_FlexibleContexts ) ) +import ErrUtils ( emptyMessages ) +import FastString +import Id ( idType ) +import Inst +import Kind ( isKind, defaultKind_maybe ) import ListSetOps -import Util +import Maybes ( isNothing ) +import Name +import Outputable import PrelInfo import PrelNames -import Control.Monad ( unless ) -import DynFlags ( ExtensionFlag( Opt_AllowAmbiguousTypes, Opt_FlexibleContexts ) ) -import Class ( classKey ) -import Maybes ( isNothing ) -import Outputable -import FastString -import TrieMap () -- DV: for now -import Data.List( partition ) +import TcErrors +import TcEvidence +import TcInteract +import TcMType as TcM +import TcRnMonad as TcRn +import TcSMonad as TcS +import TcType +import TrieMap () -- DV: for now +import TyCon ( isTypeFamilyTyCon ) +import Type ( classifyPredType, isIPClass, PredTree(..) + , getClassPredTys_maybe, EqRel(..) ) +import Unify ( tcMatchTy ) +import Util +import Var +import VarSet + +import Control.Monad ( unless ) +import Data.List ( partition ) {- ********************************************************************************* @@ -63,21 +64,47 @@ simplifyTop :: WantedConstraints -> TcM (Bag EvBind) -- in a degenerate implication, so we do that here instead simplifyTop wanteds = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds - ; (final_wc, binds1) <- runTcS (simpl_top wanteds) + ; ((final_wc, unsafe_ol), binds1) <- runTcS $ simpl_top wanteds ; traceTc "End simplifyTop }" empty ; traceTc "reportUnsolved {" empty ; binds2 <- reportUnsolved final_wc ; traceTc "reportUnsolved }" empty + ; traceTc "reportUnsolved (unsafe overlapping) {" empty + ; unless (isEmptyCts unsafe_ol) $ do { + -- grab current error messages and clear, warnAllUnsolved will + -- update error messages which we'll grab and then restore saved + -- messges. + ; errs_var <- getErrsVar + ; saved_msg <- TcRn.readTcRef errs_var + ; TcRn.writeTcRef errs_var emptyMessages + + ; warnAllUnsolved $ WC { wc_simple = unsafe_ol + , wc_insol = emptyCts + , wc_impl = emptyBag } + + ; whyUnsafe <- fst <$> TcRn.readTcRef errs_var + ; TcRn.writeTcRef errs_var saved_msg + ; recordUnsafeInfer whyUnsafe + } + ; traceTc "reportUnsolved (unsafe overlapping) }" empty + ; return (binds1 `unionBags` binds2) } -simpl_top :: WantedConstraints -> TcS WantedConstraints +type SafeOverlapFailures = Cts +-- ^ See Note [Safe Haskell Overlapping Instances Implementation] + +type FinalConstraints = (WantedConstraints, SafeOverlapFailures) + +simpl_top :: WantedConstraints -> TcS FinalConstraints -- See Note [Top-level Defaulting Plan] simpl_top wanteds = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds) -- This is where the main work happens - ; try_tyvar_defaulting wc_first_go } + ; wc_final <- try_tyvar_defaulting wc_first_go + ; unsafe_ol <- getSafeOverlapFailures + ; return (wc_final, unsafe_ol) } where try_tyvar_defaulting :: WantedConstraints -> TcS WantedConstraints try_tyvar_defaulting wc @@ -186,13 +213,114 @@ defaulting. Again this is done at the top-level and the plan is: - Apply defaulting to their kinds More details in Note [DefaultTyVar]. + +Note [Safe Haskell Overlapping Instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Safe Haskell, we apply an extra restriction to overlapping instances. The +motive is to prevent untrusted code provided by a third-party, changing the +behavior of trusted code through type-classes. This is due to the global and +implicit nature of type-classes that can hide the source of the dictionary. + +Another way to state this is: if a module M compiles without importing another +module N, changing M to import N shouldn't change the behavior of M. + +Overlapping instances with type-classes can violate this principle. However, +overlapping instances aren't always unsafe. They are just unsafe when the most +selected dictionary comes from untrusted code (code compiled with -XSafe) and +overlaps instances provided by other modules. + +In particular, in Safe Haskell at a call site with overlapping instances, we +apply the following rule to determine if it is a 'unsafe' overlap: + + 1) Most specific instance, I1, defined in an `-XSafe` compiled module. + 2) I1 is an orphan instance or a MPTC. + 3) At least one overlapped instance, Ix, is both: + A) from a different module than I1 + B) Ix is not marked `OVERLAPPABLE` + +This is a slightly involved heuristic, but captures the situation of an +imported module N changing the behavior of existing code. For example, if +condition (2) isn't violated, then the module author M must depend either on a +type-class or type defined in N. + +Secondly, when should these heuristics be enforced? We enforced them when the +type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`. +This allows `-XUnsafe` modules to operate without restriction, and for Safe +Haskell inferrence to infer modules with unsafe overlaps as unsafe. + +One alternative design would be to also consider if an instance was imported as +a `safe` import or not and only apply the restriction to instances imported +safely. However, since instances are global and can be imported through more +than one path, this alternative doesn't work. + +Note [Safe Haskell Overlapping Instances Implementation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +How is this implemented? It's compilcated! So we'll step through it all: + + 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where + we check if a particular type-class method call is safe or unsafe. We do this + through the return type, `ClsInstLookupResult`, where the last parameter is a + list of instances that are unsafe to overlap. When the method call is safe, + the list is null. + + 2) `TcInteract.matchClassInst` -- This module drives the instance resolution / + dictionary generation. The return type is `LookupInstResult`, which either + says no instance matched, or one found and if it was a safe or unsafe overlap. + + 3) `TcInteract.doTopReactDict` -- Takes a dictionary / class constraint and + tries to resolve it by calling (in part) `matchClassInst`. The resolving + mechanism has a work list (of constraints) that it process one at a time. If + the constraint can't be resolved, it's added to an inert set. When compiling + an `-XSafe` or `-XTrustworthy` module we follow this approach as we know + compilation should fail. These are handled as normal constraint resolution + failures from here-on (see step 6). + + Otherwise, we may be inferring safety (or using `-fwarn-unsafe`) and + compilation should succeed, but print warnings and/or mark the compiled module + as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds + the unsafe (but resolved!) constraint to the `inert_safehask` field of + `InertCans`. + + 4) `TcSimplify.simpl_top` -- Top-level function for driving the simplifier for + constraint resolution. Once finished, we call `getSafeOverlapFailures` to + retrieve the list of overlapping instances that were successfully resolved, + but unsafe. Remember, this is only applicable for generating warnings + (`-fwarn-unsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy` + cause compilation failure by not resolving the unsafe constraint at all. + `simpl_top` returns a list of unresolved constraints (all types), and resolved + (but unsafe) resolved dictionary constraints. + + 5) `TcSimplify.simplifyTop` -- Is the caller of `simpl_top`. For unresolved + constraints, it calls `TcErrors.reportUnsolved`, while for unsafe overlapping + instance constraints, it calls `TcErrors.warnAllUnsolved`. Both functions + convert constraints into a warning message for the user. + + 6) `TcErrors.*Unsolved` -- Generates error messages for conastraints by + actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we + know is the constraint that is unresolved or unsafe. For dictionary, this is + know we need a dictionary of type C, but not what instances are available and + how they overlap. So we once again call `lookupInstEnv` to figure that out so + we can generate a helpful error message. + + 7) `TcSimplify.simplifyTop` -- In the case of `warnAllUnsolved` for resolved, + but unsafe dictionary constraints, we collect the generated warning message + (pop it) and call `TcRnMonad.recordUnsafeInfer` to mark the module we are + compiling as unsafe, passing the warning message along as the reason. + + 8) `TcRnMonad.recordUnsafeInfer` -- Save the unsafe result and reason in an + IORef called `tcg_safeInfer`. + + 9) `HscMain.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling + `HscMain.markUnsafeInfer` (passing the reason along) when safe-inferrence + failed. -} ------------------ simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () simplifyAmbiguityCheck ty wanteds = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds) - ; (final_wc, _binds) <- runTcS (simpl_top wanteds) + ; ((final_wc, _), _binds) <- runTcS $ simpl_top wanteds ; traceTc "End simplifyAmbiguityCheck }" empty -- Normally report all errors; but with -XAllowAmbiguousTypes @@ -305,7 +433,7 @@ simplifyInfer rhs_tclvl apply_mr name_taus wanteds -- NB: We do not do any defaulting when inferring a type, this can lead -- to less polymorphic types, see Note [Default while Inferring] - ; tc_lcl_env <- TcRnMonad.getLclEnv + ; tc_lcl_env <- TcRn.getLclEnv ; null_ev_binds_var <- TcM.newTcEvBinds ; let wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs ; quant_pred_candidates -- Fully zonked @@ -376,7 +504,7 @@ simplifyInfer rhs_tclvl apply_mr name_taus wanteds -- we don't quantify over beta (since it is fixed by envt) -- so we must promote it! The inferred type is just -- f :: beta -> beta - ; outer_tclvl <- TcRnMonad.getTcLevel + ; outer_tclvl <- TcRn.getTcLevel ; zonked_tau_tvs <- TcM.zonkTyVarsAndFV zonked_tau_tvs -- decideQuantification turned some meta tyvars into -- quantified skolems, so we have to zonk again diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index f6b10838b8..4ecbd5053c 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -880,7 +880,7 @@ reifyInstances th_nm th_tys Just (tc, tys) -- See Trac #7910 | Just cls <- tyConClass_maybe tc -> do { inst_envs <- tcGetInstEnvs - ; let (matches, unifies, _) = lookupInstEnv inst_envs cls tys + ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys ; traceTc "reifyInstances1" (ppr matches) ; reifyClassInstances cls (map fst matches ++ unifies) } | isOpenFamilyTyCon tc diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index 8d1c855b16..6151f20599 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -727,8 +727,9 @@ type InstMatch = (ClsInst, [DFunInstType]) type ClsInstLookupResult = ( [InstMatch] -- Successful matches , [ClsInst] -- These don't match but do unify - , Bool) -- True if error condition caused by - -- SafeHaskell condition. + , [InstMatch] ) -- Unsafe overlapped instances under Safe Haskell + -- (see Note [Safe Haskell Overlapping Instances] in + -- TcSimplify). {- Note [DFunInstType: instantiating types] @@ -753,7 +754,7 @@ lookupUniqueInstEnv :: InstEnvs -> Class -> [Type] -> Either MsgDoc (ClsInst, [Type]) lookupUniqueInstEnv instEnv cls tys - = case lookupInstEnv instEnv cls tys of + = case lookupInstEnv False instEnv cls tys of ([(inst, inst_tys)], _, _) | noFlexiVar -> Right (inst, inst_tys') | otherwise -> Left $ ptext (sLit "flexible type variable:") <+> @@ -830,27 +831,35 @@ lookupInstEnv' ie vis_mods cls tys --------------- -- This is the common way to call this function. -lookupInstEnv :: InstEnvs -- External and home package inst-env +lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions + -> InstEnvs -- External and home package inst-env -> Class -> [Type] -- What we are looking for -> ClsInstLookupResult -- ^ See Note [Rules for instance lookup] -lookupInstEnv (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls tys - = (final_matches, final_unifs, safe_fail) +-- ^ See Note [Safe Haskell Overlapping Instances] in TcSimplify +-- ^ See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify +lookupInstEnv check_overlap_safe + (InstEnvs { ie_global = pkg_ie + , ie_local = home_ie + , ie_visible = vis_mods }) + cls + tys + = (final_matches, final_unifs, unsafe_overlapped) where (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys all_matches = home_matches ++ pkg_matches all_unifs = home_unifs ++ pkg_unifs - pruned_matches = foldr insert_overlapping [] all_matches + final_matches = foldr insert_overlapping [] 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) - (final_matches, safe_fail) - = case pruned_matches of - [match] -> check_safe match all_matches - _ -> (pruned_matches, False) + unsafe_overlapped + = case final_matches of + [match] -> check_safe match + _ -> [] -- If the selected match is incoherent, discard all unifiers final_unifs = case final_matches of @@ -867,17 +876,16 @@ lookupInstEnv (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = v -- 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 isSafeOverlap (is_flag inst) of - -- most specific isn't from a Safe module so OK - False -> ([match], False) - -- otherwise we make sure it only overlaps instances from - -- the same module - True -> (go [] others, True) + check_safe (inst,_) + = case check_overlap_safe && unsafeTopInstance inst of + -- make sure it only overlaps instances from the same module + True -> go [] all_matches + -- most specific is from a trusted location. + False -> [] where - go bad [] = match:bad + go bad [] = bad go bad (i@(x,_):unchecked) = - if inSameMod x + if inSameMod x || isOverlappable x then go bad unchecked else go (i:bad) unchecked @@ -888,6 +896,14 @@ lookupInstEnv (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = v lb = isInternalName nb in (la && lb) || (nameModule na == nameModule nb) + isOverlappable i = hasOverlappableFlag $ overlapMode $ is_flag i + + -- We consider the most specific instance unsafe when it both: + -- (1) Comes from a module compiled as `Safe` + -- (2) Is an orphan instance, OR, an instance for a MPTC + unsafeTopInstance inst = isSafeOverlap (is_flag inst) && + (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1) + --------------- is_incoherent :: InstMatch -> Bool is_incoherent (inst, _) = case overlapMode (is_flag inst) of diff --git a/testsuite/tests/safeHaskell/ghci/P13_A.hs b/testsuite/tests/safeHaskell/ghci/P13_A.hs index 1044c83545..cfdb630464 100644 --- a/testsuite/tests/safeHaskell/ghci/P13_A.hs +++ b/testsuite/tests/safeHaskell/ghci/P13_A.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverlappingInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} module P13_A where class Pos a where { res :: a -> Bool } diff --git a/testsuite/tests/safeHaskell/ghci/p13.stderr b/testsuite/tests/safeHaskell/ghci/p13.stderr index 7a743f18eb..f7e8b8524b 100644 --- a/testsuite/tests/safeHaskell/ghci/p13.stderr +++ b/testsuite/tests/safeHaskell/ghci/p13.stderr @@ -1,8 +1,5 @@ -P13_A.hs:1:14: Warning: - -XOverlappingInstances is deprecated: instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS - -<interactive>:11:1: +<interactive>:11:1: error: Unsafe overlapping instances for Pos [Int] arising from a use of ‘res’ The matching instance is: @@ -11,6 +8,6 @@ P13_A.hs:1:14: Warning: It is compiled in a Safe module and as such can only overlap instances from the same module, however it overlaps the following instances from different modules: - instance [overlap ok] [safe] Pos [a] -- Defined at P13_A.hs:6:10 + instance [safe] Pos [a] -- Defined at P13_A.hs:6:10 In the expression: res [1 :: Int, 2 :: Int] In an equation for ‘it’: it = res [1 :: Int, 2 :: Int] diff --git a/testsuite/tests/safeHaskell/overlapping/Makefile b/testsuite/tests/safeHaskell/overlapping/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap1.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap1.hs new file mode 100644 index 0000000000..beaf3881f5 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap1.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Compilation should fail as we have overlapping instances that don't obey +-- our heuristics. +module SH_Overlap1 where + +import safe SH_Overlap1_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap1.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap1.stderr new file mode 100644 index 0000000000..20349c6024 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap1.stderr @@ -0,0 +1,15 @@ +[1 of 3] Compiling SH_Overlap1_B ( SH_Overlap1_B.hs, SH_Overlap1_B.o ) +[2 of 3] Compiling SH_Overlap1_A ( SH_Overlap1_A.hs, SH_Overlap1_A.o ) +[3 of 3] Compiling SH_Overlap1 ( SH_Overlap1.hs, SH_Overlap1.o ) + +SH_Overlap1.hs:15:8: error: + Unsafe overlapping instances for C [Int] arising from a use of ‘f’ + The matching instance is: + instance [overlap ok] [safe] C [Int] + -- Defined at SH_Overlap1_A.hs:11:3 + It is compiled in a Safe module and as such can only + overlap instances from the same module, however it + overlaps the following instances from different modules: + instance C [a] -- Defined at SH_Overlap1.hs:11:3 + In the expression: f ([1, 2, 3, 4] :: [Int]) + In an equation for ‘test’: test = f ([1, 2, 3, 4] :: [Int]) diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap10.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap10.hs new file mode 100644 index 0000000000..7c5e5a1929 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap10.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as `SH_Overlap6`, but now we are inferring safety. Safe since +-- overlapped instance declares itself overlappable. +module SH_Overlap10 where + +import SH_Overlap10_A + +instance + {-# OVERLAPS #-} + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap10.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap10.stderr new file mode 100644 index 0000000000..c5aee56283 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap10.stderr @@ -0,0 +1,3 @@ +[1 of 3] Compiling SH_Overlap10_B ( SH_Overlap10_B.hs, SH_Overlap10_B.o ) +[2 of 3] Compiling SH_Overlap10_A ( SH_Overlap10_A.hs, SH_Overlap10_A.o ) +[3 of 3] Compiling SH_Overlap10 ( SH_Overlap10.hs, SH_Overlap10.o ) diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap10_A.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap10_A.hs new file mode 100644 index 0000000000..76d0b2ea9e --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap10_A.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap10_A ( + C(..) + ) where + +import SH_Overlap10_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap10_B.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap10_B.hs new file mode 100644 index 0000000000..1efb86c064 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap10_B.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +module SH_Overlap10_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap11.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap11.hs new file mode 100644 index 0000000000..f591c0a188 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap11.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred +-- unsafe due to overlapping instances at call site `f`. +-- +-- Testing that we are given correct reason. +module SH_Overlap11 where + +import SH_Overlap11_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap11.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap11.stderr new file mode 100644 index 0000000000..76d7779631 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap11.stderr @@ -0,0 +1,18 @@ +[1 of 3] Compiling SH_Overlap11_B ( SH_Overlap11_B.hs, SH_Overlap11_B.o ) +[2 of 3] Compiling SH_Overlap11_A ( SH_Overlap11_A.hs, SH_Overlap11_A.o ) +[3 of 3] Compiling SH_Overlap11 ( SH_Overlap11.hs, SH_Overlap11.o ) + +SH_Overlap11.hs:1:16: warning: + ‘SH_Overlap11’ has been inferred as unsafe! + Reason: + SH_Overlap11.hs:17:8: warning: + Unsafe overlapping instances for C [Int] arising from a use of ‘f’ + The matching instance is: + instance [overlap ok] [safe] C [Int] + -- Defined at SH_Overlap11_A.hs:11:3 + It is compiled in a Safe module and as such can only + overlap instances from the same module, however it + overlaps the following instances from different modules: + instance C [a] -- Defined at SH_Overlap11.hs:13:3 + In the expression: f ([1, 2, 3, 4] :: [Int]) + In an equation for ‘test’: test = f ([1, 2, 3, 4] :: [Int]) diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap11_A.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap11_A.hs new file mode 100644 index 0000000000..100a9f30db --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap11_A.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap11_A ( + C(..) + ) where + +import SH_Overlap11_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap11_B.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap11_B.hs new file mode 100644 index 0000000000..63ba1d7c6f --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap11_B.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +module SH_Overlap11_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap1_A.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap1_A.hs new file mode 100644 index 0000000000..d231bc9365 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap1_A.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap1_A ( + C(..) + ) where + +import SH_Overlap1_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap1_B.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap1_B.hs new file mode 100644 index 0000000000..1dbb59b6b4 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap1_B.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe #-} +module SH_Overlap1_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap2.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap2.hs new file mode 100644 index 0000000000..5df87abcab --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap2.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as SH_Overlap1, but SH_Overlap2_A is not imported as 'safe'. +-- +-- Question: Should the OI-check be enforced? Y, see reasoning in +-- `SH_Overlap4.hs` for why the Safe Haskell overlapping instance check should +-- be tied to Safe Haskell mode only, and not to safe imports. +module SH_Overlap2 where + +import SH_Overlap2_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap2.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap2.stderr new file mode 100644 index 0000000000..b4f15515b0 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap2.stderr @@ -0,0 +1,15 @@ +[1 of 3] Compiling SH_Overlap2_B ( SH_Overlap2_B.hs, SH_Overlap2_B.o ) +[2 of 3] Compiling SH_Overlap2_A ( SH_Overlap2_A.hs, SH_Overlap2_A.o ) +[3 of 3] Compiling SH_Overlap2 ( SH_Overlap2.hs, SH_Overlap2.o ) + +SH_Overlap2.hs:18:8: error: + Unsafe overlapping instances for C [Int] arising from a use of ‘f’ + The matching instance is: + instance [overlap ok] [safe] C [Int] + -- Defined at SH_Overlap2_A.hs:11:3 + It is compiled in a Safe module and as such can only + overlap instances from the same module, however it + overlaps the following instances from different modules: + instance C [a] -- Defined at SH_Overlap2.hs:14:3 + In the expression: f ([1, 2, 3, 4] :: [Int]) + In an equation for ‘test’: test = f ([1, 2, 3, 4] :: [Int]) diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap2_A.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap2_A.hs new file mode 100644 index 0000000000..2510818e06 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap2_A.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap2_A ( + C(..) + ) where + +import SH_Overlap2_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap2_B.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap2_B.hs new file mode 100644 index 0000000000..fcd8ef8f56 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap2_B.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe #-} +module SH_Overlap2_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap3.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap3.hs new file mode 100644 index 0000000000..bbd5350b2d --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap3.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as SH_Overlap1, but module where overlap occurs (SH_Overlap3) is +-- marked `Unsafe`. Compilation should succeed (symetry with inferring safety). +module SH_Overlap3 where + +import SH_Overlap3_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap3.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap3.stderr new file mode 100644 index 0000000000..8a0066f55e --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap3.stderr @@ -0,0 +1,3 @@ +[1 of 3] Compiling SH_Overlap3_B ( SH_Overlap3_B.hs, SH_Overlap3_B.o ) +[2 of 3] Compiling SH_Overlap3_A ( SH_Overlap3_A.hs, SH_Overlap3_A.o ) +[3 of 3] Compiling SH_Overlap3 ( SH_Overlap3.hs, SH_Overlap3.o ) diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap3_A.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap3_A.hs new file mode 100644 index 0000000000..0a3393ef4d --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap3_A.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap3_A ( + C(..) + ) where + +import SH_Overlap3_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap3_B.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap3_B.hs new file mode 100644 index 0000000000..4908d73427 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap3_B.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe #-} +module SH_Overlap3_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap4.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap4.hs new file mode 100644 index 0000000000..0d9f445080 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap4.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as SH_Overlap3, however, SH_Overlap4_A is imported as `safe`. +-- +-- Question: Should compilation now fail? N. At first it seems a nice idea to +-- tie the overlap check to safe imports. However, instances are a global +-- entity and can be imported by multiple import paths. How should safe imports +-- interact with this? Especially when considering transitive situations... +-- +-- Simplest is to just enforce the overlap check in Safe and Trustworthy +-- modules, but not in Unsafe ones. +module SH_Overlap4 where + +import safe SH_Overlap4_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap4.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap4.stderr new file mode 100644 index 0000000000..6942269b85 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap4.stderr @@ -0,0 +1,3 @@ +[1 of 3] Compiling SH_Overlap4_B ( SH_Overlap4_B.hs, SH_Overlap4_B.o ) +[2 of 3] Compiling SH_Overlap4_A ( SH_Overlap4_A.hs, SH_Overlap4_A.o ) +[3 of 3] Compiling SH_Overlap4 ( SH_Overlap4.hs, SH_Overlap4.o ) diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap4_A.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap4_A.hs new file mode 100644 index 0000000000..bb1625e222 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap4_A.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap4_A ( + C(..) + ) where + +import SH_Overlap4_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap4_B.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap4_B.hs new file mode 100644 index 0000000000..2a53fff8c6 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap4_B.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe #-} +module SH_Overlap4_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap5.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap5.hs new file mode 100644 index 0000000000..185946d56f --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap5.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Compilation should fail as we have overlapping instances that don't obey +-- our heuristics. +module SH_Overlap5 where + +import safe SH_Overlap5_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap5.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap5.stderr new file mode 100644 index 0000000000..8c2bc7df9d --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap5.stderr @@ -0,0 +1,15 @@ +[1 of 3] Compiling SH_Overlap5_B ( SH_Overlap5_B.hs, SH_Overlap5_B.o ) +[2 of 3] Compiling SH_Overlap5_A ( SH_Overlap5_A.hs, SH_Overlap5_A.o ) +[3 of 3] Compiling SH_Overlap5 ( SH_Overlap5.hs, SH_Overlap5.o ) + +SH_Overlap5.hs:15:8: error: + Unsafe overlapping instances for C [Int] arising from a use of ‘f’ + The matching instance is: + instance [overlap ok] [safe] C [Int] + -- Defined at SH_Overlap5_A.hs:11:3 + It is compiled in a Safe module and as such can only + overlap instances from the same module, however it + overlaps the following instances from different modules: + instance [safe] C [a] -- Defined at SH_Overlap5.hs:11:3 + In the expression: f ([1, 2, 3, 4] :: [Int]) + In an equation for ‘test’: test = f ([1, 2, 3, 4] :: [Int]) diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap5_A.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap5_A.hs new file mode 100644 index 0000000000..71c6bac0f0 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap5_A.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap5_A ( + C(..) + ) where + +import SH_Overlap5_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap5_B.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap5_B.hs new file mode 100644 index 0000000000..e7e8102b98 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap5_B.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe #-} +module SH_Overlap5_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap6.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap6.hs new file mode 100644 index 0000000000..e38037ab8b --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap6.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as `SH_Overlap5` but dependencies are now inferred-safe, not +-- explicitly marked. Compilation should still fail. +module SH_Overlap6 where + +import safe SH_Overlap6_A + +instance C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap6.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap6.stderr new file mode 100644 index 0000000000..e5b7ac95d6 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap6.stderr @@ -0,0 +1,15 @@ +[1 of 3] Compiling SH_Overlap6_B ( SH_Overlap6_B.hs, SH_Overlap6_B.o ) +[2 of 3] Compiling SH_Overlap6_A ( SH_Overlap6_A.hs, SH_Overlap6_A.o ) +[3 of 3] Compiling SH_Overlap6 ( SH_Overlap6.hs, SH_Overlap6.o ) + +SH_Overlap6.hs:14:8: error: + Unsafe overlapping instances for C [Int] arising from a use of ‘f’ + The matching instance is: + instance [overlap ok] [safe] C [Int] + -- Defined at SH_Overlap6_A.hs:11:3 + It is compiled in a Safe module and as such can only + overlap instances from the same module, however it + overlaps the following instances from different modules: + instance [safe] C [a] -- Defined at SH_Overlap6.hs:10:10 + In the expression: f ([1, 2, 3, 4] :: [Int]) + In an equation for ‘test’: test = f ([1, 2, 3, 4] :: [Int]) diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap6_A.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap6_A.hs new file mode 100644 index 0000000000..788c2f384b --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap6_A.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap6_A ( + C(..) + ) where + +import SH_Overlap6_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap6_B.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap6_B.hs new file mode 100644 index 0000000000..5ec45676e9 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap6_B.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +module SH_Overlap6_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.hs new file mode 100644 index 0000000000..e99e73fd41 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred +-- unsafe due to overlapping instances at call site `f`. +module SH_Overlap7 where + +import SH_Overlap7_A + +instance C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr new file mode 100644 index 0000000000..088d0f06b3 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr @@ -0,0 +1,21 @@ +[1 of 3] Compiling SH_Overlap7_B ( SH_Overlap7_B.hs, SH_Overlap7_B.o ) +[2 of 3] Compiling SH_Overlap7_A ( SH_Overlap7_A.hs, SH_Overlap7_A.o ) +[3 of 3] Compiling SH_Overlap7 ( SH_Overlap7.hs, SH_Overlap7.o ) + +SH_Overlap7.hs:1:16: warning: + ‘SH_Overlap7’ has been inferred as unsafe! + Reason: + SH_Overlap7.hs:14:8: warning: + Unsafe overlapping instances for C [Int] arising from a use of ‘f’ + The matching instance is: + instance [overlap ok] [safe] C [Int] + -- Defined at SH_Overlap7_A.hs:12:3 + It is compiled in a Safe module and as such can only + overlap instances from the same module, however it + overlaps the following instances from different modules: + instance C [a] -- Defined at SH_Overlap7.hs:10:10 + In the expression: f ([1, 2, 3, 4] :: [Int]) + In an equation for ‘test’: test = f ([1, 2, 3, 4] :: [Int]) + +<no location info>: error: +Failing due to -Werror. diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap7_A.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7_A.hs new file mode 100644 index 0000000000..972c5abf4e --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7_A.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} +module SH_Overlap7_A ( + C(..) + ) where + +import SH_Overlap7_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap7_B.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7_B.hs new file mode 100644 index 0000000000..382cad01c8 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7_B.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE Safe #-} +module SH_Overlap7_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap8.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap8.hs new file mode 100644 index 0000000000..6523193db3 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap8.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Overlapping instances, but with a single parameter type-class and no +-- orphans. So `SH_Overlap8` decided to explictly depend on `SH_Overlap8_A` +-- since that's where the type-class `C` with function `f` is defined. +-- +-- Question: Safe or Unsafe? Safe +module SH_Overlap8 where + +import safe SH_Overlap8_A + +instance C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap8.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap8.stderr new file mode 100644 index 0000000000..f53cd439bb --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap8.stderr @@ -0,0 +1,2 @@ +[1 of 2] Compiling SH_Overlap8_A ( SH_Overlap8_A.hs, SH_Overlap8_A.o ) +[2 of 2] Compiling SH_Overlap8 ( SH_Overlap8.hs, SH_Overlap8.o ) diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap8_A.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap8_A.hs new file mode 100644 index 0000000000..8c19b1acbd --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap8_A.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap8_A ( + C(..) + ) where + +class C a where + f :: a -> String + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap9.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap9.hs new file mode 100644 index 0000000000..5ae00fa101 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap9.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -fwarn-safe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred +-- unsafe due to overlapping instances at call site `f`. +module SH_Overlap9 where + +import SH_Overlap9_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap9.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap9.stderr new file mode 100644 index 0000000000..b94705c654 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap9.stderr @@ -0,0 +1,3 @@ +[1 of 3] Compiling SH_Overlap9_B ( SH_Overlap9_B.hs, SH_Overlap9_B.o ) +[2 of 3] Compiling SH_Overlap9_A ( SH_Overlap9_A.hs, SH_Overlap9_A.o ) +[3 of 3] Compiling SH_Overlap9 ( SH_Overlap9.hs, SH_Overlap9.o ) diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap9_A.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap9_A.hs new file mode 100644 index 0000000000..580bbda17b --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap9_A.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap9_A ( + C(..) + ) where + +import SH_Overlap9_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap9_B.hs b/testsuite/tests/safeHaskell/overlapping/SH_Overlap9_B.hs new file mode 100644 index 0000000000..4cbf88692c --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap9_B.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +module SH_Overlap9_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/testsuite/tests/safeHaskell/overlapping/all.T b/testsuite/tests/safeHaskell/overlapping/all.T new file mode 100644 index 0000000000..c253850ac1 --- /dev/null +++ b/testsuite/tests/safeHaskell/overlapping/all.T @@ -0,0 +1,62 @@ +# overlapping tests Safe Haskell's handling of overlapping instances. + +# Just do the normal way, SafeHaskell is all in the frontend +def f( name, opts ): + opts.only_ways = ['normal'] + +setTestOpts(f) + +test('SH_Overlap1', + [ extra_clean(['SH_Overlap1_A.hi', 'SH_Overlap1_A.o', + 'SH_Overlap1_B.hi', 'SH_Overlap1_B.o']) ], + multimod_compile_fail, ['SH_Overlap1', '']) + +test('SH_Overlap2', + [ extra_clean(['SH_Overlap2_A.hi', 'SH_Overlap2_A.o', + 'SH_Overlap2_B.hi', 'SH_Overlap2_B.o']) ], + multimod_compile_fail, ['SH_Overlap2', '']) + +test('SH_Overlap3', + [ extra_clean(['SH_Overlap3_A.hi', 'SH_Overlap3_A.o', + 'SH_Overlap3_B.hi', 'SH_Overlap3_B.o']) ], + multimod_compile, ['SH_Overlap3', '']) + +test('SH_Overlap4', + [ extra_clean(['SH_Overlap4_A.hi', 'SH_Overlap4_A.o', + 'SH_Overlap4_B.hi', 'SH_Overlap4_B.o']) ], + multimod_compile, ['SH_Overlap4', '']) + +test('SH_Overlap5', + [ extra_clean(['SH_Overlap5_A.hi', 'SH_Overlap5_A.o', + 'SH_Overlap5_B.hi', 'SH_Overlap5_B.o']) ], + multimod_compile_fail, ['SH_Overlap5', '']) + +test('SH_Overlap6', + [ extra_clean(['SH_Overlap6_A.hi', 'SH_Overlap6_A.o', + 'SH_Overlap6_B.hi', 'SH_Overlap6_B.o']) ], + multimod_compile_fail, ['SH_Overlap6', '']) + +test('SH_Overlap7', + [ extra_clean(['SH_Overlap7_A.hi', 'SH_Overlap7_A.o', + 'SH_Overlap7_B.hi', 'SH_Overlap7_B.o']) ], + multimod_compile_fail, ['SH_Overlap7', '-Werror']) + +test('SH_Overlap8', + [ extra_clean(['SH_Overlap8_A.hi', 'SH_Overlap8_A.o']) ], + multimod_compile, ['SH_Overlap8', '']) + +test('SH_Overlap9', + [ extra_clean(['SH_Overlap9_A.hi', 'SH_Overlap9_A.o', + 'SH_Overlap9_B.hi', 'SH_Overlap9_B.o']) ], + multimod_compile, ['SH_Overlap9', '-Werror']) + +test('SH_Overlap10', + [ extra_clean(['SH_Overlap10_A.hi', 'SH_Overlap10_A.o', + 'SH_Overlap10_B.hi', 'SH_Overlap10_B.o']) ], + multimod_compile, ['SH_Overlap10', '-Werror']) + +test('SH_Overlap11', + [ extra_clean(['SH_Overlap11_A.hi', 'SH_Overlap11_A.o', + 'SH_Overlap11_B.hi', 'SH_Overlap11_B.o']) ], + multimod_compile, ['SH_Overlap11', '']) + diff --git a/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.hs b/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.hs index 0b42002b25..1e933ac3b0 100644 --- a/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.hs +++ b/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.hs @@ -2,24 +2,8 @@ {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE FlexibleInstances #-} --- | --- This module should actually fail to compile since we have the instances C --- [Int] from the -XSafe module SafeInfered05_A overlapping as the most --- specific instance the other instance C [a] from this module. This is in --- violation of our single-origin-policy. --- --- Right now though, the above actually compiles fine but *this is a bug*. --- Compiling module SafeInfered05_A with -XSafe has the right affect of causing --- the compilation of module SafeInfered05 to then subsequently fail. So we --- have a discrepancy between a safe-inferred module and a -XSafe module, which --- there should not be. --- --- It does raise a question of if this bug should be fixed. Right now we've --- designed Safe Haskell to be completely opt-in, even with safe-inference. --- Fixing this of course changes this, causing safe-inference to alter the --- compilation success of some cases. How common it is to have overlapping --- declarations without -XOverlappingInstances specified needs to be tested. --- +-- | We allow this overlap to succeed since the module is regarded as +-- `-XUnsafe`. module SafeInfered05 where import safe SafeInfered05_A diff --git a/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.stderr b/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.stderr index 10e70c409c..0690054ae7 100644 --- a/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.stderr @@ -1,19 +1,8 @@ -SafeInfered05.hs:2:14: Warning: +SafeInfered05.hs:2:14: warning: -XOverlappingInstances is deprecated: instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS [1 of 2] Compiling SafeInfered05_A ( SafeInfered05_A.hs, SafeInfered05_A.o ) -SafeInfered05_A.hs:2:16: Warning: +SafeInfered05_A.hs:2:16: warning: ‘SafeInfered05_A’ has been inferred as safe! [2 of 2] Compiling SafeInfered05 ( SafeInfered05.hs, SafeInfered05.o ) - -SafeInfered05.hs:31:9: - Unsafe overlapping instances for C [Int] arising from a use of ‘f’ - The matching instance is: - instance [safe] C [Int] -- Defined at SafeInfered05_A.hs:8:10 - It is compiled in a Safe module and as such can only - overlap instances from the same module, however it - overlaps the following instances from different modules: - instance [overlap ok] C [a] -- Defined at SafeInfered05.hs:27:10 - In the expression: f ([1, 2, 3, 4] :: [Int]) - In an equation for ‘test2’: test2 = f ([1, 2, 3, 4] :: [Int]) diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08.stderr index 8ff259633a..36f4ded2d5 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08.stderr @@ -1,6 +1,2 @@ [1 of 2] Compiling UnsafeInfered08_A ( UnsafeInfered08_A.hs, UnsafeInfered08_A.o ) [2 of 2] Compiling UnsafeInfered08 ( UnsafeInfered08.hs, UnsafeInfered08.o ) - -UnsafeInfered08.hs:4:1: - UnsafeInfered08_A: Can't be safely imported! - The module itself isn't safe. diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08_A.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08_A.hs index 4cd276fafd..0449737041 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08_A.hs +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08_A.hs @@ -1,8 +1,6 @@ {-# LANGUAGE OverlappingInstances #-} {-# OPTIONS_GHC -w #-} -- Turn off deprecation for OverlappingInstances --- | Unsafe as uses overlapping instances --- Although it isn't defining any so can we mark safe --- still? +-- | Safe, as we now check at overlap occurence, not defenition. module UnsafeInfered08_A where g :: Int diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.stderr index 30be0ec32c..e69de29bb2 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.stderr @@ -1,9 +0,0 @@ - -UnsafeInfered13.hs:1:16: Warning: - ‘UnsafeInfered13’ has been inferred as unsafe! - Reason: - UnsafeInfered13.hs:8:27: - [overlap ok] overlap mode isn't allowed in Safe Haskell - -<no location info>: -Failing due to -Werror. diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.stderr index 80d9526194..e69de29bb2 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.stderr @@ -1,9 +0,0 @@ - -UnsafeInfered14.hs:1:16: Warning: - ‘UnsafeInfered14’ has been inferred as unsafe! - Reason: - UnsafeInfered14.hs:8:31: - [overlappable] overlap mode isn't allowed in Safe Haskell - -<no location info>: -Failing due to -Werror. diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.stderr index 44a0202687..e69de29bb2 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.stderr @@ -1,9 +0,0 @@ - -UnsafeInfered15.hs:1:16: Warning: - ‘UnsafeInfered15’ has been inferred as unsafe! - Reason: - UnsafeInfered15.hs:8:30: - [overlapping] overlap mode isn't allowed in Safe Haskell - -<no location info>: -Failing due to -Werror. diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.stderr index 5ac27d3d82..e69de29bb2 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.stderr @@ -1,13 +0,0 @@ - -UnsafeInfered16.hs:1:16: Warning: - ‘UnsafeInfered16’ has been inferred as unsafe! - Reason: - UnsafeInfered16.hs:8:30: - [overlapping] overlap mode isn't allowed in Safe Haskell - UnsafeInfered16.hs:11:27: - [overlap ok] overlap mode isn't allowed in Safe Haskell - UnsafeInfered16.hs:14:31: - [overlappable] overlap mode isn't allowed in Safe Haskell - -<no location info>: -Failing due to -Werror. diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered17.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered17.stderr index aa43fbeeed..e69de29bb2 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered17.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered17.stderr @@ -1,9 +0,0 @@ - -UnsafeInfered17.hs:1:16: Warning: - ‘UnsafeInfered17’ has been inferred as unsafe! - Reason: - UnsafeInfered17.hs:8:29: - [incoherent] overlap mode isn't allowed in Safe Haskell - -<no location info>: -Failing due to -Werror. diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered18.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered18.stderr index 0896ec500f..58db37d3f0 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered18.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered18.stderr @@ -1,11 +1,3 @@ -UnsafeInfered18.hs:3:14: Warning: +UnsafeInfered18.hs:3:14: warning: -XOverlappingInstances is deprecated: instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS - -UnsafeInfered18.hs:1:16: Warning: - ‘UnsafeInfered18’ has been inferred as unsafe! - Reason: - UnsafeInfered18.hs:3:14: - -XOverlappingInstances is not allowed in Safe Haskell - UnsafeInfered18.hs:9:10: - [overlap ok] overlap mode isn't allowed in Safe Haskell diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered19.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered19.stderr index 002c950930..e69de29bb2 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered19.stderr +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered19.stderr @@ -1,11 +0,0 @@ - -UnsafeInfered19.hs:1:16: Warning: - ‘UnsafeInfered19’ has been inferred as unsafe! - Reason: - UnsafeInfered19.hs:3:14: - -XIncoherentInstances is not allowed in Safe Haskell - UnsafeInfered19.hs:9:10: - [incoherent] overlap mode isn't allowed in Safe Haskell - -<no location info>: -Failing due to -Werror. diff --git a/testsuite/tests/safeHaskell/safeInfered/all.T b/testsuite/tests/safeHaskell/safeInfered/all.T index 9fb4b2c4ea..def025049e 100644 --- a/testsuite/tests/safeHaskell/safeInfered/all.T +++ b/testsuite/tests/safeHaskell/safeInfered/all.T @@ -20,11 +20,9 @@ test('SafeInfered03', test('SafeInfered04', [ extra_clean(['SafeInfered04_A.hi', 'SafeInfered04_A.o']) ], multimod_compile, ['SafeInfered04', '']) - -# Test should fail, tests an earlier bug in 7.8 test('SafeInfered05', [ extra_clean(['SafeInfered05_A.hi', 'SafeInfered05_A.o']) ], - multimod_compile_fail, ['SafeInfered05', '']) + multimod_compile, ['SafeInfered05', '']) # Tests that should fail to compile as they should be infered unsafe test('UnsafeInfered01', @@ -44,7 +42,7 @@ test('UnsafeInfered06', multimod_compile_fail, ['UnsafeInfered06', '']) test('UnsafeInfered08', [ extra_clean(['UnsafeInfered08_A.hi', 'UnsafeInfered08_A.o']) ], - multimod_compile_fail, ['UnsafeInfered08', '']) + multimod_compile, ['UnsafeInfered08', '']) test('UnsafeInfered09', [ extra_clean(['UnsafeInfered09_A.hi', 'UnsafeInfered09_A.o', 'UnsafeInfered09_B.hi', 'UnsafeInfered09_B.o']) ], @@ -58,15 +56,19 @@ test('UnsafeInfered11', [ extra_clean(['UnsafeInfered11_A.hi', 'UnsafeInfered11_A.o']) ], multimod_compile_fail, ['UnsafeInfered11', '']) -# Test should fail as unsafe and we made warn unsafe + -Werror +# Test TH is unsafe test('UnsafeInfered12', normal, compile_fail, ['']) -test('UnsafeInfered13', normal, compile_fail, ['']) -test('UnsafeInfered14', normal, compile_fail, ['']) -test('UnsafeInfered15', normal, compile_fail, ['']) -test('UnsafeInfered16', normal, compile_fail, ['']) -test('UnsafeInfered17', normal, compile_fail, ['']) + +# Test various overlapping instance flags +# GHC 7.10 and earlier we regarded them as unsafe, but we now take an approach +# based on looking only at sites of actual overlaps +test('UnsafeInfered13', normal, compile, ['']) +test('UnsafeInfered14', normal, compile, ['']) +test('UnsafeInfered15', normal, compile, ['']) +test('UnsafeInfered16', normal, compile, ['']) +test('UnsafeInfered17', normal, compile, ['']) test('UnsafeInfered18', normal, compile, ['']) -test('UnsafeInfered19', normal, compile_fail, ['']) +test('UnsafeInfered19', normal, compile, ['']) # Mixed tests test('Mixed01', normal, compile_fail, ['']) |