New handling of overlapping inst in Safe Haskell
authorDavid Terei <code@davidterei.com>
Mon, 11 May 2015 23:05:37 +0000 (16:05 -0700)
committerDavid Terei <code@davidterei.com>
Tue, 12 May 2015 01:21:11 +0000 (18:21 -0700)
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.

72 files changed:
compiler/main/DynFlags.hs
compiler/main/HscMain.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcForeign.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcInteract.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSMonad.hs
compiler/typecheck/TcSimplify.hs
compiler/typecheck/TcSplice.hs
compiler/types/InstEnv.hs
testsuite/tests/safeHaskell/ghci/P13_A.hs
testsuite/tests/safeHaskell/ghci/p13.stderr
testsuite/tests/safeHaskell/overlapping/Makefile [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap1.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap1.stderr [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap10.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap10.stderr [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap10_A.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap10_B.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap11.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap11.stderr [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap11_A.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap11_B.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap1_A.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap1_B.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap2.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap2.stderr [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap2_A.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap2_B.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap3.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap3.stderr [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap3_A.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap3_B.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap4.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap4.stderr [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap4_A.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap4_B.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap5.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap5.stderr [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap5_A.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap5_B.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap6.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap6.stderr [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap6_A.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap6_B.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap7.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap7_A.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap7_B.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap8.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap8.stderr [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap8_A.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap9.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap9.stderr [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap9_A.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/SH_Overlap9_B.hs [new file with mode: 0644]
testsuite/tests/safeHaskell/overlapping/all.T [new file with mode: 0644]
testsuite/tests/safeHaskell/safeInfered/SafeInfered05.hs
testsuite/tests/safeHaskell/safeInfered/SafeInfered05.stderr
testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08.stderr
testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08_A.hs
testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.stderr
testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.stderr
testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.stderr
testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.stderr
testsuite/tests/safeHaskell/safeInfered/UnsafeInfered17.stderr
testsuite/tests/safeHaskell/safeInfered/UnsafeInfered18.stderr
testsuite/tests/safeHaskell/safeInfered/UnsafeInfered19.stderr
testsuite/tests/safeHaskell/safeInfered/all.T

index a0bd8a5..6ebd04c 100644 (file)
@@ -1858,15 +1858,7 @@ unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc,
                     xopt Opt_TemplateHaskell,
                     flip xopt_unset Opt_TemplateHaskell)
               ]
                     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
 
 
 -- | 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"]
 
                     "-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
     safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer
-    -- Have we inferred Unsafe?
-    -- See Note [HscMain . Safe Haskell Inference]
 
 
 {- **********************************************************************
 
 
 {- **********************************************************************
index eb772ba..0acbdff 100644 (file)
@@ -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
 
                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
     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
 
         -- 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
             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
 --
 -- 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.
 --
 -- 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))
 
          (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.
     -- 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.
index b82a70c..c1a1c5a 100644 (file)
@@ -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 }
                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
                dups            = filter (identicalClsInstHead ispec) (map fst matches)
 
              -- Check functional dependencies
index 67aed64..88c88bd 100644 (file)
@@ -1,7 +1,7 @@
 {-# LANGUAGE CPP, ScopedTypeVariables #-}
 
 module TcErrors(
 {-# LANGUAGE CPP, ScopedTypeVariables #-}
 
 module TcErrors(
-       reportUnsolved, reportAllUnsolved,
+       reportUnsolved, reportAllUnsolved, warnAllUnsolved,
        warnDefaulting,
 
        solverDepthErrorTcS
        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`.
 -}
 
 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
 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
 
        ; defer_holes <- goptM Opt_DeferTypedHoles
        ; warn_holes  <- woptM Opt_WarnTypedHoles
@@ -112,21 +114,30 @@ reportUnsolved wanted
                         | warn_partial_sigs = HoleWarn
                         | otherwise         = HoleDefer
 
                         | 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 }
 
        ; 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]
 -- See Note [Deferring coercion errors to runtime]
+reportAllUnsolved :: WantedConstraints -> TcM ()
 reportAllUnsolved wanted
 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
 report_unsolved :: Maybe EvBindsVar  -- cec_binds
+                -> Bool              -- Errors as warnings
                 -> Bool              -- cec_defer_type_errors
                 -> HoleChoice        -- Expression holes
                 -> HoleChoice        -- Type holes
                 -> WantedConstraints -> TcM ()
                 -> 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
   | 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
        ; 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]
                             , 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
 
                          --              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
           , 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]
 -- 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 ()
   = 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]
     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)
 
       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)
             -> 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) }
 
   | 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
   = 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
 
     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
                                     , ptext (sLit "when compiling the other instance declarations")]
                         ])]
         where
-            ispecs = [ispec | (ispec, _) <- matches]
-
             givens = getUserGivens ctxt
             matching_givens = mapMaybe matchable givens
 
             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
     -- 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:"),
         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:"
              , 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])
                     ]
              ]
 
                     ]
              ]
 
index 2ce6f86..4e42645 100644 (file)
@@ -452,7 +452,7 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty
 
            -- handle safe infer fail
            _ | check_safe && safeInferOn dflags
 
            -- handle safe infer fail
            _ | check_safe && safeInferOn dflags
-               -> recordUnsafeInfer
+               -> recordUnsafeInfer emptyBag
 
            -- handle safe language typecheck fail
            _ | check_safe && safeLanguageOn dflags
 
            -- handle safe language typecheck fail
            _ | check_safe && safeLanguageOn dflags
index 39ed3b2..ed4fd91 100644 (file)
@@ -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
 
        -- 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
              _ -> 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)
 
     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.") $+$
     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
 
       | 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
                ([(ispec, dfun_inst_tys)], [], _) -- A single match
                  -> do { let dfun_id = instanceDFunId ispec
                        ; (inst_tys, inst_theta) <- instDFunType dfun_id dfun_inst_tys
index a9dcc98..33ff043 100644 (file)
@@ -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
 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 })
                                            , 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
                 -- 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 }
                        , 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
                   -- 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
 
   | 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
    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 {
     -- 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)
 
                          ; 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
 
     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
       | 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.
 -}
 
 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
 data LookupInstResult
   = NoInstance
-  | GenInst [TcPredType] ([EvId] -> EvTerm)
+  | GenInst [TcPredType] ([EvId] -> EvTerm) SafeOverlapping
 
 instance Outputable LookupInstResult where
 
 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
 
 
 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))
     , 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)
 
     | 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
         ; 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 }
 
                 -> 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)
                 | 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
                       ; 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
                                 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]
                 -> 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
 
    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
                   -- 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
        = 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 $
 
      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))
     | 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
 
   -- 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 ]
 
   -- 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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 {- Note [No Typeable for polytype or for constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 5507e60..ea454d5 100644 (file)
@@ -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 ;
         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 {
         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
 -}
 
 -- | 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
 
 -- | 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
     return $ case safeHaskell dflags of
         Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
                 | otherwise                     -> Sf_None
index 422e934..3014755 100644 (file)
@@ -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
         -- 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
 
         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_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],
         tcg_tc_plugins :: [TcPluginSolver],
+        -- ^ A list of user-defined plugins for the constraint solver.
 
         tcg_static_wc :: TcRef WantedConstraints
           -- ^ Wanted constraints of static forms.
 
         tcg_static_wc :: TcRef WantedConstraints
           -- ^ Wanted constraints of static forms.
index e17bc43..39b01e7 100644 (file)
@@ -34,7 +34,7 @@ module TcSMonad (
     getTopEnv, getGblEnv, getTcEvBinds, getTcLevel,
     getTcEvBindsMap,
 
     getTopEnv, getGblEnv, getTcEvBinds, getTcLevel,
     getTcEvBindsMap,
 
-        -- Inerts
+    -- Inerts
     InertSet(..), InertCans(..),
     updInertTcS, updInertCans, updInertDicts, updInertIrreds,
     getNoGivenEqs, setInertCans, getInertEqs, getInertCans, getInertGivens,
     InertSet(..), InertCans(..),
     updInertTcS, updInertCans, updInertDicts, updInertIrreds,
     getNoGivenEqs, setInertCans, getInertEqs, getInertCans, getInertGivens,
@@ -46,6 +46,10 @@ module TcSMonad (
     emitInsoluble, emitWorkNC, emitWorkCt,
     EqualCtList,
 
     emitInsoluble, emitWorkNC, emitWorkCt,
     EqualCtList,
 
+    -- Inert Safe Haskell safe-overlap failures
+    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,
+    getSafeOverlapFailures,
+
     -- Inert CDictCans
     lookupInertDict, findDictsByClass, addDict, addDictsByClass, delDict, partitionDicts,
 
     -- 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.
 
               -- 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
 
        , 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))
                    <+> 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
                  , 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
 emptyInert
   = IS { inert_cans = IC { inert_eqs      = emptyVarEnv
                          , inert_dicts    = emptyDicts
+                         , inert_safehask = emptyDicts
                          , inert_funeqs   = emptyFunEqs
                          , inert_irreds   = emptyCts
                          , inert_insols   = emptyCts
                          , inert_funeqs   = emptyFunEqs
                          , inert_irreds   = emptyCts
                          , inert_insols   = emptyCts
@@ -589,6 +605,24 @@ insertInertItemTcS item
 
        ; traceTcS "insertInertItemTcS }" $ empty }
 
 
        ; 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]
 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) }
 
 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
 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
     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
       = 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
            , 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
 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 ->
            , 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
        ; 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]
        ; 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 }
 
 
        ; return res }
 
index c1535f8..e970579 100644 (file)
@@ -14,39 +14,40 @@ module TcSimplify(
 
 #include "HsVersions.h"
 
 
 #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 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 ListSetOps
-import Util
+import Maybes        ( isNothing )
+import Name
+import Outputable
 import PrelInfo
 import PrelNames
 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
 -- 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 "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) }
 
        ; 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
     -- 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
   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].
      - 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)
 -}
 
 ------------------
 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
        ; 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]
 
               -- 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
        ; 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
          -- 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
        ; zonked_tau_tvs <- TcM.zonkTyVarsAndFV zonked_tau_tvs
               -- decideQuantification turned some meta tyvars into
               -- quantified skolems, so we have to zonk again
index f6b1083..4ecbd50 100644 (file)
@@ -880,7 +880,7 @@ reifyInstances th_nm th_tys
             Just (tc, tys)                 -- See Trac #7910
                | Just cls <- tyConClass_maybe tc
                -> do { inst_envs <- tcGetInstEnvs
             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
                      ; traceTc "reifyInstances1" (ppr matches)
                      ; reifyClassInstances cls (map fst matches ++ unifies) }
                | isOpenFamilyTyCon tc
index 8d1c855..6151f20 100644 (file)
@@ -727,8 +727,9 @@ type InstMatch = (ClsInst, [DFunInstType])
 type ClsInstLookupResult
      = ( [InstMatch]     -- Successful matches
        , [ClsInst]       -- These don't match but do unify
 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]
 
 {-
 Note [DFunInstType: instantiating types]
@@ -753,7 +754,7 @@ lookupUniqueInstEnv :: InstEnvs
                     -> Class -> [Type]
                     -> Either MsgDoc (ClsInst, [Type])
 lookupUniqueInstEnv instEnv cls tys
                     -> 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:") <+>
       ([(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.
 
 ---------------
 -- 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]
               -> 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
   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)
 
         -- 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
 
     -- 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.
     -- 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
         where
-            go bad [] = match:bad
+            go bad [] = bad
             go bad (i@(x,_):unchecked) =
             go bad (i@(x,_):unchecked) =
-                if inSameMod x
+                if inSameMod x || isOverlappable x
                     then go bad unchecked
                     else go (i:bad) unchecked
 
                     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)
 
                     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
 ---------------
 is_incoherent :: InstMatch -> Bool
 is_incoherent (inst, _) = case overlapMode (is_flag inst) of
index 1044c83..cfdb630 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverlappingInstances, FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
 module P13_A where
 
 class Pos a where { res :: a -> Bool }
 module P13_A where
 
 class Pos a where { res :: a -> Bool }
index 7a743f1..f7e8b85 100644 (file)
@@ -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:
     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:
     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]
     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 (file)
index 0000000..9101fbd
--- /dev/null
@@ -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 (file)
index 0000000..beaf388
--- /dev/null
@@ -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 (file)
index 0000000..20349c6
--- /dev/null
@@ -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 (file)
index 0000000..7c5e5a1
--- /dev/null
@@ -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 (file)
index 0000000..c5aee56
--- /dev/null
@@ -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 (file)
index 0000000..76d0b2e
--- /dev/null
@@ -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 (file)
index 0000000..1efb86c
--- /dev/null
@@ -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 (file)
index 0000000..f591c0a
--- /dev/null
@@ -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 (file)
index 0000000..76d7779
--- /dev/null
@@ -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 (file)
index 0000000..100a9f3
--- /dev/null
@@ -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 (file)
index 0000000..63ba1d7
--- /dev/null
@@ -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 (file)
index 0000000..d231bc9
--- /dev/null
@@ -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 (file)
index 0000000..1dbb59b
--- /dev/null
@@ -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 (file)
index 0000000..5df87ab
--- /dev/null
@@ -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 (file)
index 0000000..b4f1551
--- /dev/null
@@ -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 (file)
index 0000000..2510818
--- /dev/null
@@ -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 (file)
index 0000000..fcd8ef8
--- /dev/null
@@ -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 (file)
index 0000000..bbd5350
--- /dev/null
@@ -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 (file)
index 0000000..8a0066f
--- /dev/null
@@ -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 (file)
index 0000000..0a3393e
--- /dev/null
@@ -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 (file)
index 0000000..4908d73
--- /dev/null
@@ -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 (file)
index 0000000..0d9f445
--- /dev/null
@@ -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 (file)
index 0000000..6942269
--- /dev/null
@@ -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 (file)
index 0000000..bb1625e
--- /dev/null
@@ -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 (file)
index 0000000..2a53fff
--- /dev/null
@@ -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 (file)
index 0000000..185946d
--- /dev/null
@@ -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 (file)
index 0000000..8c2bc7d
--- /dev/null
@@ -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 (file)
index 0000000..71c6bac
--- /dev/null
@@ -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 (file)
index 0000000..e7e8102
--- /dev/null
@@ -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 (file)
index 0000000..e38037a
--- /dev/null
@@ -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 (file)
index 0000000..e5b7ac9
--- /dev/null
@@ -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 (file)
index 0000000..788c2f3
--- /dev/null
@@ -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 (file)
index 0000000..5ec4567
--- /dev/null
@@ -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 (file)
index 0000000..e99e73f
--- /dev/null
@@ -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 (file)
index 0000000..088d0f0
--- /dev/null
@@ -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 (file)
index 0000000..972c5ab
--- /dev/null
@@ -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 (file)
index 0000000..382cad0
--- /dev/null
@@ -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 (file)
index 0000000..6523193
--- /dev/null
@@ -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 (file)
index 0000000..f53cd43
--- /dev/null
@@ -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 (file)
index 0000000..8c19b1a
--- /dev/null
@@ -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 (file)
index 0000000..5ae00fa
--- /dev/null
@@ -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 (file)
index 0000000..b94705c
--- /dev/null
@@ -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 (file)
index 0000000..580bbda
--- /dev/null
@@ -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 (file)
index 0000000..4cbf886
--- /dev/null
@@ -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 (file)
index 0000000..c253850
--- /dev/null
@@ -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', ''])
+
index 0b42002..1e933ac 100644 (file)
@@ -2,24 +2,8 @@
 {-# LANGUAGE OverlappingInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
 
 {-# 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
 module SafeInfered05 where
 
 import safe SafeInfered05_A
index 10e70c4..0690054 100644 (file)
@@ -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 )
 
     -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_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])
index 8ff2596..36f4ded 100644 (file)
@@ -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 )
 [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.
index 4cd276f..0449737 100644 (file)
@@ -1,8 +1,6 @@
 {-# LANGUAGE OverlappingInstances #-}
 {-# OPTIONS_GHC -w #-}  -- Turn off deprecation for OverlappingInstances
 {-# 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
 module UnsafeInfered08_A where
 
 g :: Int
index 30be0ec..e69de29 100644 (file)
@@ -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.
index 80d9526..e69de29 100644 (file)
@@ -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.
index 44a0202..e69de29 100644 (file)
@@ -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.
index 5ac27d3..e69de29 100644 (file)
@@ -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.
index aa43fbe..e69de29 100644 (file)
@@ -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.
index 0896ec5..58db37d 100644 (file)
@@ -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
     -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
index 002c950..e69de29 100644 (file)
@@ -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.
index 9fb4b2c..def0250 100644 (file)
@@ -20,11 +20,9 @@ test('SafeInfered03',
 test('SafeInfered04',
      [ extra_clean(['SafeInfered04_A.hi', 'SafeInfered04_A.o']) ],
      multimod_compile, ['SafeInfered04', ''])
 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']) ],
 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',
 
 # 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, ['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']) ],
 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', ''])
 
      [ 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('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('UnsafeInfered18', normal, compile, [''])
-test('UnsafeInfered19', normal, compile_fail, [''])
+test('UnsafeInfered19', normal, compile, [''])
 
 # Mixed tests
 test('Mixed01', normal, compile_fail, [''])
 
 # Mixed tests
 test('Mixed01', normal, compile_fail, [''])