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