diff options
18 files changed, 85 insertions, 65 deletions
diff --git a/compiler/deSugar/PmPpr.hs b/compiler/deSugar/PmPpr.hs index 82e6d0f0a0..5b49b2de55 100644 --- a/compiler/deSugar/PmPpr.hs +++ b/compiler/deSugar/PmPpr.hs @@ -10,6 +10,7 @@ module PmPpr ( import GhcPrelude +import BasicTypes import Id import VarEnv import UniqDFM @@ -44,7 +45,12 @@ pprUncovered delta vas | otherwise = hang (fsep vec) 4 $ text "where" <+> vcat (map (pprRefutableShapes . snd) (udfmToList refuts)) where - ppr_action = mapM (pprPmVar 2) vas + init_prec + -- No outer parentheses when it's a unary pattern by assuming lowest + -- precedence + | [_] <- vas = topPrec + | otherwise = appPrec + ppr_action = mapM (pprPmVar init_prec) vas (vec, renamings) = runPmPpr delta ppr_action refuts = prettifyRefuts delta renamings @@ -127,44 +133,57 @@ checkRefuts x = do -- | Pretty print a variable, but remember to prettify the names of the variables -- that refer to neg-literals. The ones that cannot be shown are printed as --- underscores. -pprPmVar :: Int -> Id -> PmPprM SDoc +-- underscores. Even with a type signature, if it's not too noisy. +pprPmVar :: PprPrec -> Id -> PmPprM SDoc +-- Type signature is "too noisy" by my definition if it needs to parenthesize. +-- I like "not matched: _ :: Proxy (DIdEnv SDoc)", +-- but I don't like "not matched: (_ :: stuff) (_:_) (_ :: Proxy (DIdEnv SDoc))" +-- The useful information in the latter case is the constructor that we missed, +-- not the types of the wildcards in the places that aren't matched as a result. pprPmVar prec x = do delta <- ask case lookupSolution delta x of Just (alt, args) -> pprPmAltCon prec alt args - Nothing -> fromMaybe underscore <$> checkRefuts x - -pprPmAltCon :: Int -> PmAltCon -> [Id] -> PmPprM SDoc + Nothing -> fromMaybe typed_wildcard <$> checkRefuts x + where + -- if we have no info about the parameter and would just print a + -- wildcard, also show its type. + typed_wildcard + | prec <= sigPrec + = underscore <+> text "::" <+> ppr (idType x) + | otherwise + = underscore + +pprPmAltCon :: PprPrec -> PmAltCon -> [Id] -> PmPprM SDoc pprPmAltCon _prec (PmAltLit l) _ = pure (ppr l) pprPmAltCon prec (PmAltConLike cl) args = do delta <- ask pprConLike delta prec cl args -pprConLike :: Delta -> Int -> ConLike -> [Id] -> PmPprM SDoc +pprConLike :: Delta -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc pprConLike delta _prec cl args | Just pm_expr_list <- pmExprAsList delta (PmAltConLike cl) args = case pm_expr_list of NilTerminated list -> - brackets . fsep . punctuate comma <$> mapM (pprPmVar 0) list + brackets . fsep . punctuate comma <$> mapM (pprPmVar appPrec) list WcVarTerminated pref x -> - parens . fcat . punctuate colon <$> mapM (pprPmVar 0) (toList pref ++ [x]) + parens . fcat . punctuate colon <$> mapM (pprPmVar appPrec) (toList pref ++ [x]) pprConLike _delta _prec (RealDataCon con) args | isUnboxedTupleCon con , let hash_parens doc = text "(#" <+> doc <+> text "#)" - = hash_parens . fsep . punctuate comma <$> mapM (pprPmVar 0) args + = hash_parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args | isTupleDataCon con - = parens . fsep . punctuate comma <$> mapM (pprPmVar 0) args + = parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args pprConLike _delta prec cl args | conLikeIsInfix cl = case args of - [x, y] -> do x' <- pprPmVar 1 x - y' <- pprPmVar 1 y - return (cparen (prec > 0) (x' <+> ppr cl <+> y')) + [x, y] -> do x' <- pprPmVar funPrec x + y' <- pprPmVar funPrec y + return (cparen (prec > opPrec) (x' <+> ppr cl <+> y')) -- can it be infix but have more than two arguments? list -> pprPanic "pprConLike:" (ppr list) | null args = return (ppr cl) - | otherwise = do args' <- mapM (pprPmVar 2) args - return (cparen (prec > 1) (fsep (ppr cl : args'))) + | otherwise = do args' <- mapM (pprPmVar appPrec) args + return (cparen (prec > funPrec) (fsep (ppr cl : args'))) -- | The result of 'pmExprAsList'. data PmExprList diff --git a/testsuite/tests/deSugar/should_compile/T14135.stderr b/testsuite/tests/deSugar/should_compile/T14135.stderr index 23a3e90aaf..ec0a340bcc 100644 --- a/testsuite/tests/deSugar/should_compile/T14135.stderr +++ b/testsuite/tests/deSugar/should_compile/T14135.stderr @@ -1,4 +1,4 @@ T14135.hs:16:1: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In an equation for ‘f’: Patterns not matched: (Foo2 _) + In an equation for ‘f’: Patterns not matched: Foo2 _ diff --git a/testsuite/tests/dependent/should_compile/KindEqualities.stderr b/testsuite/tests/dependent/should_compile/KindEqualities.stderr index 684c1380aa..81bbc539cf 100644 --- a/testsuite/tests/dependent/should_compile/KindEqualities.stderr +++ b/testsuite/tests/dependent/should_compile/KindEqualities.stderr @@ -3,4 +3,4 @@ KindEqualities.hs:25:1: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In an equation for ‘zero’: Patterns not matched: - (TyApp (TyApp p _) _) where p is not one of {TyInt} + TyApp (TyApp p _) _ where p is not one of {TyInt} diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase001.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase001.stderr index ba9e61fc51..c3c294b4e7 100644 --- a/testsuite/tests/pmcheck/should_compile/EmptyCase001.stderr +++ b/testsuite/tests/pmcheck/should_compile/EmptyCase001.stderr @@ -1,3 +1,4 @@ + EmptyCase001.hs:9:6: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In a case alternative: Patterns not matched: _ :: Int diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase002.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase002.stderr index cbb79efd59..d6c39ec4f7 100644 --- a/testsuite/tests/pmcheck/should_compile/EmptyCase002.stderr +++ b/testsuite/tests/pmcheck/should_compile/EmptyCase002.stderr @@ -1,23 +1,22 @@ EmptyCase002.hs:16:6: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (MkT _) + In a case alternative: Patterns not matched: MkT _ EmptyCase002.hs:43:6: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In a case alternative: Patterns not matched: - (MkT1 B1) - (MkT1 B2) + MkT1 B1 + MkT1 B2 EmptyCase002.hs:47:6: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In a case alternative: Patterns not matched: - (MkT1 False) - (MkT1 True) + MkT1 False + MkT1 True EmptyCase002.hs:51:6: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: - Patterns not matched: (MkT1 (MkT2 (MkT1 D2))) + In a case alternative: Patterns not matched: MkT1 (MkT2 (MkT1 D2)) diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase004.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase004.stderr index ba36499285..d807b51789 100644 --- a/testsuite/tests/pmcheck/should_compile/EmptyCase004.stderr +++ b/testsuite/tests/pmcheck/should_compile/EmptyCase004.stderr @@ -12,13 +12,13 @@ EmptyCase004.hs:19:6: warning: [-Wincomplete-patterns (in -Wextra)] EmptyCase004.hs:31:8: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (B1 _) + In a case alternative: Patterns not matched: B1 _ EmptyCase004.hs:35:6: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In a case alternative: Patterns not matched: - (B1 _) + B1 _ B2 EmptyCase004.hs:47:6: warning: [-Wincomplete-patterns (in -Wextra)] @@ -34,4 +34,4 @@ EmptyCase004.hs:50:9: warning: [-Wincomplete-patterns (in -Wextra)] EmptyCase004.hs:51:9: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (B1 _) + In a case alternative: Patterns not matched: B1 _ diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase005.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase005.stderr index 8cedcddaf5..1d185cc8bb 100644 --- a/testsuite/tests/pmcheck/should_compile/EmptyCase005.stderr +++ b/testsuite/tests/pmcheck/should_compile/EmptyCase005.stderr @@ -1,7 +1,7 @@ EmptyCase005.hs:24:8: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (Void3 _) + In a case alternative: Patterns not matched: Void3 _ EmptyCase005.hs:67:8: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive @@ -14,19 +14,19 @@ EmptyCase005.hs:73:8: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In a case alternative: Patterns not matched: - (MkTBool False) - (MkTBool True) + MkTBool False + MkTBool True EmptyCase005.hs:79:8: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (MkTInt _) + In a case alternative: Patterns not matched: MkTInt _ EmptyCase005.hs:91:8: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In a case alternative: Patterns not matched: - (MkV False) - (MkV True) + MkV False + MkV True EmptyCase005.hs:101:8: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase006.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase006.stderr index f63a438a11..e47e1eea47 100644 --- a/testsuite/tests/pmcheck/should_compile/EmptyCase006.stderr +++ b/testsuite/tests/pmcheck/should_compile/EmptyCase006.stderr @@ -1,12 +1,12 @@ EmptyCase006.hs:18:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (Foo1 MkGA1) + In a case alternative: Patterns not matched: Foo1 MkGA1 EmptyCase006.hs:26:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In a case alternative: Patterns not matched: - (Foo1 MkGA1) - (Foo1 (MkGA2 _)) - (Foo1 MkGA3) + Foo1 MkGA1 + Foo1 (MkGA2 _) + Foo1 MkGA3 diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase007.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase007.stderr index f0c36b9a6f..42cbcf380d 100644 --- a/testsuite/tests/pmcheck/should_compile/EmptyCase007.stderr +++ b/testsuite/tests/pmcheck/should_compile/EmptyCase007.stderr @@ -9,11 +9,11 @@ EmptyCase007.hs:25:7: warning: [-Wincomplete-patterns (in -Wextra)] EmptyCase007.hs:33:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (Foo2 (_, _)) + In a case alternative: Patterns not matched: Foo2 (_, _) EmptyCase007.hs:37:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (Foo2 _) + In a case alternative: Patterns not matched: Foo2 _ EmptyCase007.hs:44:17: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive @@ -23,5 +23,5 @@ EmptyCase007.hs:48:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In a case alternative: Patterns not matched: - (Foo2 []) - (Foo2 (_:_)) + Foo2 [] + Foo2 (_:_) diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase008.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase008.stderr index 99991937d0..b33e8ebb40 100644 --- a/testsuite/tests/pmcheck/should_compile/EmptyCase008.stderr +++ b/testsuite/tests/pmcheck/should_compile/EmptyCase008.stderr @@ -3,8 +3,8 @@ EmptyCase008.hs:17:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In a case alternative: Patterns not matched: - (Foo3 (MkDA1 _)) - (Foo3 MkDA2) + Foo3 (MkDA1 _) + Foo3 MkDA2 EmptyCase008.hs:21:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive @@ -12,7 +12,7 @@ EmptyCase008.hs:21:7: warning: [-Wincomplete-patterns (in -Wextra)] EmptyCase008.hs:40:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (Foo4 MkDB1) + In a case alternative: Patterns not matched: Foo4 MkDB1 EmptyCase008.hs:48:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase009.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase009.stderr index 7d2e84cb6c..e5ea398a60 100644 --- a/testsuite/tests/pmcheck/should_compile/EmptyCase009.stderr +++ b/testsuite/tests/pmcheck/should_compile/EmptyCase009.stderr @@ -5,8 +5,8 @@ EmptyCase009.hs:21:9: warning: [-Wincomplete-patterns (in -Wextra)] EmptyCase009.hs:33:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (Bar MkDB2_u) + In a case alternative: Patterns not matched: Bar MkDB2_u EmptyCase009.hs:42:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (Bar MkGB3) + In a case alternative: Patterns not matched: Bar MkGB3 diff --git a/testsuite/tests/pmcheck/should_compile/EmptyCase010.stderr b/testsuite/tests/pmcheck/should_compile/EmptyCase010.stderr index d4caf6466c..bfff6c7abe 100644 --- a/testsuite/tests/pmcheck/should_compile/EmptyCase010.stderr +++ b/testsuite/tests/pmcheck/should_compile/EmptyCase010.stderr @@ -3,31 +3,31 @@ EmptyCase010.hs:24:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In a case alternative: Patterns not matched: - (Baz MkGC1) - (Baz (MkGC2 _)) + Baz MkGC1 + Baz (MkGC2 _) EmptyCase010.hs:28:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (Baz MkGC1) + In a case alternative: Patterns not matched: Baz MkGC1 EmptyCase010.hs:37:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In a case alternative: Patterns not matched: - (Baz MkGD1) - (Baz MkGD3) + Baz MkGD1 + Baz MkGD3 EmptyCase010.hs:41:9: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (Baz MkGD3) + In a case alternative: Patterns not matched: Baz MkGD3 EmptyCase010.hs:45:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In a case alternative: Patterns not matched: - (Baz MkGD1) - (Baz MkGD2) - (Baz MkGD3) + Baz MkGD1 + Baz MkGD2 + Baz MkGD3 EmptyCase010.hs:57:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive @@ -35,7 +35,7 @@ EmptyCase010.hs:57:7: warning: [-Wincomplete-patterns (in -Wextra)] EmptyCase010.hs:69:7: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (Baz MkDC2) + In a case alternative: Patterns not matched: Baz MkDC2 EmptyCase010.hs:73:9: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive diff --git a/testsuite/tests/pmcheck/should_compile/T11336b.stderr b/testsuite/tests/pmcheck/should_compile/T11336b.stderr index 5d479c3756..d824b8314f 100644 --- a/testsuite/tests/pmcheck/should_compile/T11336b.stderr +++ b/testsuite/tests/pmcheck/should_compile/T11336b.stderr @@ -1,4 +1,4 @@ T11336b.hs:25:1: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In an equation for ‘fun’: Patterns not matched: _ + In an equation for ‘fun’: Patterns not matched: _ :: Proxy a diff --git a/testsuite/tests/pmcheck/should_compile/T11822.stderr b/testsuite/tests/pmcheck/should_compile/T11822.stderr index 7198efc588..4cefed97cb 100644 --- a/testsuite/tests/pmcheck/should_compile/T11822.stderr +++ b/testsuite/tests/pmcheck/should_compile/T11822.stderr @@ -1,9 +1,9 @@ T11822.hs:33:1: warning: Pattern match checker ran into -fmax-pmcheck-models=100 limit, so - Redundant clauses might not be reported at all - Redundant clauses might be reported as inaccessible - Patterns reported as unmatched might actually be matched + • Redundant clauses might not be reported at all + • Redundant clauses might be reported as inaccessible + • Patterns reported as unmatched might actually be matched Increase the limit or resolve the warnings to suppress this message. T11822.hs:33:1: warning: [-Wincomplete-patterns (in -Wextra)] diff --git a/testsuite/tests/pmcheck/should_compile/T15305.stderr b/testsuite/tests/pmcheck/should_compile/T15305.stderr index 54cb90af5e..e760a2c884 100644 --- a/testsuite/tests/pmcheck/should_compile/T15305.stderr +++ b/testsuite/tests/pmcheck/should_compile/T15305.stderr @@ -1,4 +1,4 @@ T15305.hs:48:23: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (MkAbyss _) + In a case alternative: Patterns not matched: MkAbyss _ diff --git a/testsuite/tests/pmcheck/should_compile/pmc009.stderr b/testsuite/tests/pmcheck/should_compile/pmc009.stderr index 8eaa4ab61a..84c360b6ff 100644 --- a/testsuite/tests/pmcheck/should_compile/pmc009.stderr +++ b/testsuite/tests/pmcheck/should_compile/pmc009.stderr @@ -1,4 +1,5 @@ pmc009.hs:10:1: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive - In an equation for ‘addPatSynSelector’: Patterns not matched: _ + In an equation for ‘addPatSynSelector’: + Patterns not matched: _ :: LHsBind p diff --git a/testsuite/tests/warnings/should_fail/WerrorFail.stderr b/testsuite/tests/warnings/should_fail/WerrorFail.stderr index 00272ef2fe..8b96c483f7 100644 --- a/testsuite/tests/warnings/should_fail/WerrorFail.stderr +++ b/testsuite/tests/warnings/should_fail/WerrorFail.stderr @@ -1,4 +1,4 @@ WerrorFail.hs:6:1: error: [-Wincomplete-patterns (in -Wextra), -Werror=incomplete-patterns] Pattern match(es) are non-exhaustive - In an equation for ‘foo’: Patterns not matched: (Just _) + In an equation for ‘foo’: Patterns not matched: Just _ diff --git a/testsuite/tests/warnings/should_fail/WerrorFail2.stderr b/testsuite/tests/warnings/should_fail/WerrorFail2.stderr index f6105d1bfb..afbcd61374 100644 --- a/testsuite/tests/warnings/should_fail/WerrorFail2.stderr +++ b/testsuite/tests/warnings/should_fail/WerrorFail2.stderr @@ -4,7 +4,7 @@ WerrorFail2.hs:15:1: warning: [-Wmissing-signatures (in -Wall)] WerrorFail2.hs:15:10: error: [-Wincomplete-patterns (in -Wextra), -Werror=incomplete-patterns] Pattern match(es) are non-exhaustive - In a case alternative: Patterns not matched: (C2 _) + In a case alternative: Patterns not matched: C2 _ WerrorFail2.hs:19:1: warning: [-Wmissing-signatures (in -Wall)] Top-level binding with no type signature: printRec :: IO () |