More precise types for fields of OverlappingInstances and UnsafeOverlap in TcSolverReportMsg

It's clear from asserts in `GHC.Tc.Errors` that `overlappingInstances_matches`
and `unsafeOverlapped` are supposed to be non-empty, and `unsafeOverlap_matches`
contains a single instance, but these invariants are immediately lost afterwards
and not encoded in types. This patch enforces the invariants by pattern matching
and makes types more precise, avoiding asserts and partial functions such as `head`.

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