diff options
| -rw-r--r-- | compiler/GHC/Tc/Errors.hs | 41 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 6 |
3 files changed, 23 insertions, 34 deletions
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 7734a135f5..3a3e474b80 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -83,6 +83,7 @@ import Data.Foldable ( toList ) import Data.Function ( on ) import Data.List ( partition, sort, sortBy ) import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE import Data.Ord ( comparing ) import qualified Data.Semigroup as S @@ -2205,24 +2206,24 @@ mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupR -> TcM TcSolverReportMsg -- Report an overlap error if this class constraint results -- from an overlap (returning Left clas), otherwise return (Right pred) -mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) - | null matches -- No matches but perhaps several unifiers - = do { (_, rel_binds, item) <- relevantBindings True ctxt item - ; candidate_insts <- get_candidate_instances - ; (imp_errs, field_suggestions) <- record_field_suggestions - ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) } - - | null unsafe_overlapped -- Some matches => overlap errors - = return $ overlap_msg - - | otherwise - = return $ safe_haskell_msg +mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) = case (NE.nonEmpty matches, NE.nonEmpty unsafe_overlapped) of + (Nothing, _) -> do -- No matches but perhaps several unifiers + { (_, rel_binds, item) <- relevantBindings True ctxt item + ; candidate_insts <- get_candidate_instances + ; (imp_errs, field_suggestions) <- record_field_suggestions + ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) } + + -- Some matches => overlap errors + (Just matchesNE, Nothing) -> return $ + OverlappingInstances item (NE.map fst matchesNE) (getPotentialUnifiers unifiers) + + (Just (match :| []), Just unsafe_overlappedNE) -> return $ + UnsafeOverlap item (fst match) (NE.map fst unsafe_overlappedNE) + (Just (_ :| rest), Just{}) -> pprPanic "should be empty" (ppr rest) where orig = errorItemOrigin item pred = errorItemPred item (clas, tys) = getClassPredTys pred - ispecs = [ispec | (ispec, _) <- matches] - unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] get_candidate_instances :: TcM [ClsInst] -- See Note [Report candidate instances] @@ -2271,18 +2272,6 @@ mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) cannot_resolve_msg item candidate_insts binds imp_errs field_suggestions = CannotResolveInstance item (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds - -- Overlap errors. - overlap_msg, safe_haskell_msg :: TcSolverReportMsg - -- Normal overlap error - overlap_msg - = assert (not (null matches)) $ OverlappingInstances item ispecs (getPotentialUnifiers unifiers) - - -- Overlap error because of Safe Haskell (first - -- match should be the most specific match) - safe_haskell_msg - = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $ - UnsafeOverlap item ispecs unsafe_ispecs - {- Note [Report candidate instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have an unsolved (Num Int), where `Int` is not the Prelude Int, diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 2842362a8f..ac01c9e8e7 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -2377,8 +2377,8 @@ pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item match sep [text "Matching givens (or their superclasses):" , nest 2 (vcat matching_givens)] , potentialInstancesErrMsg - (PotentialInstances { matches, unifiers }) - , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ + (PotentialInstances { matches = NE.toList matches, unifiers }) + , ppWhen (null matching_givens && null (NE.tail matches) && null unifiers) $ -- Intuitively, some given matched the wanted in their -- flattened or rewritten (from given equalities) form -- but the matcher can't figure that out because the @@ -2388,7 +2388,7 @@ pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item match sep [ text "There exists a (perhaps superclass) match:" , nest 2 (vcat (pp_givens useful_givens))] - , ppWhen (isSingleton matches) $ + , ppWhen (null $ NE.tail matches) $ parens (vcat [ ppUnless (null tyCoVars) $ text "The choice depends on the instantiation of" <+> quotes (pprWithCommas ppr tyCoVars) @@ -2433,12 +2433,12 @@ pprTcSolverReportMsg _ (UnsafeOverlap item matches unsafe_overlapped) = vcat [ addArising ct_loc (text "Unsafe overlapping instances for" <+> pprType (mkClassPred clas tys)) , sep [text "The matching instance is:", - nest 2 (pprInstance $ head matches)] + nest 2 (pprInstance matches)] , vcat [ text "It is compiled in a Safe module and as such can only" , text "overlap instances from the same module, however it" , text "overlaps the following instances from different" <+> text "modules:" - , nest 2 (vcat [pprInstances $ unsafe_overlapped]) + , nest 2 (vcat [pprInstances $ NE.toList unsafe_overlapped]) ] ] where diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index d0d40366d9..bd9851f475 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -3028,7 +3028,7 @@ data TcSolverReportMsg -- Test cases: tcfail118, tcfail121, tcfail218. | OverlappingInstances { overlappingInstances_item :: ErrorItem - , overlappingInstances_matches :: [ClsInst] + , overlappingInstances_matches :: NE.NonEmpty ClsInst , overlappingInstances_unifiers :: [ClsInst] } -- | Could not solve a constraint from instances because @@ -3038,8 +3038,8 @@ data TcSolverReportMsg -- Test cases: SH_Overlap{1,2,5,6,7,11}. | UnsafeOverlap { unsafeOverlap_item :: ErrorItem - , unsafeOverlap_matches :: [ClsInst] - , unsafeOverlapped :: [ClsInst] } + , unsafeOverlap_matches :: ClsInst + , unsafeOverlapped :: NE.NonEmpty ClsInst } deriving Generic |