diff options
author | Sebastian Graf <sgraf1337@gmail.com> | 2019-09-25 16:16:53 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-09-27 22:14:44 -0400 |
commit | 1582dafa319fe3142844847e581d50cf3326e5e0 (patch) | |
tree | e9ff9af68006e71720aa848228bf3c79f6d6e73e | |
parent | 444e554f6d034642f3f2a7c077cca412a6c22c5d (diff) | |
download | haskell-1582dafa319fe3142844847e581d50cf3326e5e0.tar.gz |
PmCheck: Look at precendence to give type signatures to some wildcards
Basically do what we currently only do for -XEmptyCase in other cases
where adding the type signature won't distract from pattern
matches in other positions.
We use the precedence to guide us, equating "need to parenthesise" with
"too much noise".
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 () |