Exhaustive check does not show enough pattern information for view patterns

Summary

Exhaustive check suppressed too much information when reporting incomplete patterns for view patterns.

/tmp/example.hs:(61,1)-(64,38): warning: [-Wincomplete-patterns] …
    Pattern match(es) are non-exhaustive
    In an equation for ‘normalize’:
        Patterns not matched:
            Fix (Typed _ _)
            Fix (Typed _ _)

This report is unhelpful. The warning is informative when I removed the use of view patterns:

/tmp/example.hs:(61,1)-(64,38): warning: [-Wincomplete-patterns] …
    Pattern match(es) are non-exhaustive
    In an equation for ‘normalize’:
        Patterns not matched:
            Fix (Typed TBool (AddF _ _))
            Fix (Typed TBool (AndF _ _))
            Fix (Typed TBool (IntF _))
            Fix (Typed TBool (BoolF _))
            ...

Steps to reproduce

A small example:

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternSynonyms #-}
{-# options_ghc -Wall #-}
newtype Fix f = Fix { unFix :: f (Fix f) }

rewrite :: (Functor f, Functor g) =>  (forall a. f a -> g a) -> Fix f -> Fix g
rewrite f = Fix . f . fmap (rewrite f) . unFix

data ExpF a
  = AddF a a
  | AndF a a
  | IntF Int
  | BoolF Bool
  deriving (Functor)

pattern Add :: Exp -> Exp -> Exp
pattern Add a b = Fix (AddF a b)
pattern And :: Exp -> Exp -> Exp
pattern And a b = Fix (AndF a b)
pattern Int :: Int -> Exp
pattern Int x = Fix (IntF x)
pattern Bool :: Bool -> Exp
pattern Bool x = Fix (BoolF x)

data Type = TInt | TBool
  deriving Eq

data TypedExpF a = Typed { getType :: Type, getExp :: ExpF a }
  deriving (Functor)

type Exp = Fix ExpF
type TypedExp = Fix TypedExpF

view1 :: TypedExp -> (Type, ExpF (Fix TypedExpF))
view1 (Fix (Typed x y)) = (x, y)

view2 :: TypedExp -> (Type, Exp)
view2 te@(Fix (Typed x _)) = (x, dropType te)

dropType :: TypedExp -> Exp
dropType = rewrite getExp

typecheck :: Exp -> Maybe TypedExp
typecheck (Fix (BoolF x)) = Just . Fix $ Typed TBool (BoolF x)
typecheck (Fix (IntF x))  = Just . Fix $ Typed TInt  (IntF  x)
typecheck (Fix (AndF x y)) = do
  x'@(view1 -> (tx, _)) <- typecheck x
  y'@(view1 -> (ty, _)) <- typecheck y
  if tx == ty && tx == TBool
    then Just . Fix $ Typed TBool (AndF x' y')
    else Nothing
typecheck (Fix (AddF x y)) = do
  x'@(view1 -> (tx, _)) <- typecheck x
  y'@(view1 -> (ty, _)) <- typecheck y
  if tx == ty && tx == TBool
    then Just . Fix $ Typed TBool (AndF x' y')
    else Nothing

normalize :: TypedExp -> TypedExp
-- normalize (Fix (Typed TInt (AddF x y))) =    -- works as expected
normalize (view1 -> (TInt, AddF x y)) =
  let (view2 -> (_, Int x')) = normalize x
      (view2 -> (_, Int y')) = normalize y
  in Fix $ Typed TInt (IntF (x' + y'))

Expected behavior

The compiler should print informative warnings, just like when it does not have view patterns.

Environment

• GHC version used: 9.0.1

Optional:

• Operating System: MacOS 12
• System Architecture: Intel x86_64