@@ -1,99 +1,194 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Error.Pattern where
3+module Reporting.Error.Pattern
4+ ( P.Error(..)
5+ , toReport
6+ )
7+ where
48
5−import Data.Text (Text)
6−import qualified Data.Text as Text
9+import qualified Data.List as List
710
8−import qualified Nitpick.Pattern as Pattern
9−import qualified Reporting.Render.Type as RenderType
10−import qualified Reporting.Region as Region
11+import qualified Nitpick.PatternMatches as P
1112import qualified Reporting.Report as Report
12−import qualified Reporting.Helpers as Help
13−import Reporting.Helpers ((<>), text)
14−
15−
16−
17−data Error
18− = Incomplete Origin [Pattern.Pattern]
19− | Redundant Region.Region Int
20−
21−
22−data Origin
23− = Arg
24− | LetBound
25− | Case
13+import qualified Reporting.Render.Code as Code
14+import qualified Reporting.Helpers as H
15+import Reporting.Helpers ((<>))
2616
2717
2818
2919-- TO REPORT
3020
3121
32−toReport :: RenderType.Localizer -> Error -> Report.Report
33−toReport _localizer err =
22+toReport :: Code.Source -> P.Error -> Report.Report
23+toReport source err =
3424 case err of
35− Incomplete Arg unhandled ->
36− Report.report
37− "PARTIAL PATTERN"
38− Nothing
39− "This pattern does not cover all possible inputs."
40− (text (unhandledError unhandled toCaseMessage))
41−
42− Incomplete LetBound unhandled ->
43− Report.report
44− "PARTIAL PATTERN"
45− Nothing
46− "The pattern used here does not cover all possible values."
47− (text (unhandledError unhandled toCaseMessage))
48−
49− Incomplete Case unhandled ->
50− Report.report
51− "MISSING PATTERNS"
52− Nothing
53− "This `case` does not have branches for all possibilities."
54− (text (unhandledError unhandled (missingBranchesMessage (length unhandled))))
55−
56− Redundant region index ->
57− Report.report
58− "REDUNDANT PATTERN"
59− (Just region)
60− ("The " <> Help.ordinalize index <> " pattern is redundant. Remove it.")
61− (text "Any value with this shape will be handled by a previous pattern.")
62−
63−
64−unhandledError :: [Pattern.Pattern] -> Text -> Text
65−unhandledError unhandledPatterns relevantMessage =
66− let
67− (visiblePatterns, rest) =
68− splitAt 4 unhandledPatterns
69−
70− patternList =
71− map Pattern.toText visiblePatterns
72− ++ if null rest then [] else ["..."]
73−
74− noun =
75− if length unhandledPatterns == 1 then "pattern" else "patterns"
76− in
77− "You need to account for the following " <> noun <> ":\n"
78− <> Text.concat (map ("\n " <>) patternList) <> "\n"
79− <> "\n"
80− <> relevantMessage <> "\n"
81− <> "\n"
82− <> "If you are seeing this error for the first time, check out these hints:\n"
83− <> Help.hintLink "missing-patterns" <> "\n"
84− <> "The recommendations about wildcard patterns and `Debug.crash` are important!"
85−
86−
87−toCaseMessage :: Text
88−toCaseMessage =
89− "Switch to a `case` expression to handle all possible patterns."
90−
91−
92−missingBranchesMessage :: Int -> Text
93−missingBranchesMessage numUnhandled =
94− if numUnhandled == 1 then
95− "Add a branch to cover this pattern!"
96−
97− else
98− "Add branches to cover each of these patterns!"
25+ P.Redundant caseRegion patternRegion index ->
26+ Report.Report "REDUNDANT PATTERN" patternRegion [] $
27+ Report.toCodeSnippet source caseRegion (Just patternRegion)
28+ (
29+ H.reflow $
30+ "The " <> H.ordinalize index <> " pattern is redundant:"
31+ ,
32+ H.reflow $
33+ "Any value with this shape will be handled by a previous\
34+ \ pattern, so it should be removed."
35+ )
36+
37+ P.Incomplete region context unhandled ->
38+ case context of
39+ P.BadArg ->
40+ Report.Report "UNSAFE PATTERN" region [] $
41+ Report.toCodeSnippet source region Nothing
42+ (
43+ "This pattern does not cover all possiblities:"
44+ ,
45+ H.stack
46+ [ "Other possibilities include:"
47+ , unhandledPatternsToDocBlock unhandled
48+ , H.reflow $
49+ "I would have to crash if I saw one of those! So rather than\
50+ \ pattern matching in function arguments, put a `case` in\
51+ \ the function body to account for all possibilities."
52+ ]
53+ )
54+
55+ P.BadDestruct ->
56+ Report.Report "UNSAFE PATTERN" region [] $
57+ Report.toCodeSnippet source region Nothing
58+ (
59+ "This pattern does not cover all possible values:"
60+ ,
61+ H.stack
62+ [ "Other possibilities include:"
63+ , unhandledPatternsToDocBlock unhandled
64+ , H.reflow $
65+ "I would have to crash if I saw one of those! You can use\
66+ \ `let` to deconstruct values only if there is ONE possiblity.\
67+ \ Switch to a `case` expression to account for all possibilities."
68+ , H.toSimpleHint $
69+ "Are you calling a function that definitely returns values\
70+ \ with a very specific shape? Try making the return type of\
71+ \ that function more specific!"
72+ ]
73+ )
74+
75+ P.BadCase ->
76+ Report.Report "MISSING PATTERNS" region [] $
77+ Report.toCodeSnippet source region Nothing
78+ (
79+ "This `case` does not have branches for all possibilities:"
80+ ,
81+ H.stack
82+ [ "Missing possibilities include:"
83+ , unhandledPatternsToDocBlock unhandled
84+ , H.reflow $
85+ "I would have to crash if I saw one of those. Add branches for them!"
86+ , H.link "Hint"
87+ "If you want to write the code for each branch later, use `Debug.crash` as a placeholder. Read"
88+ "missing-patterns"
89+ "for more guidance on this workflow."
90+ ]
91+ )
92+
93+
94+
95+-- PATTERN TO DOC
96+
97+
98+unhandledPatternsToDocBlock :: [P.Pattern] -> H.Doc
99+unhandledPatternsToDocBlock unhandledPatterns =
100+ H.indent 4 $ H.dullyellow $ H.vcat $
101+ map (patternToDoc Unambiguous) unhandledPatterns
102+
103+
104+data Context
105+ = Arg
106+ | Head
107+ | Unambiguous
108+ deriving (Eq)
109+
110+
111+patternToDoc :: Context -> P.Pattern -> H.Doc
112+patternToDoc context pattern =
113+ case delist pattern [] of
114+ NonList P.Anything ->
115+ "_"
116+
117+ NonList (P.Literal literal) ->
118+ case literal of
119+ P.Chr chr ->
120+ H.textToDoc ("'" <> chr <> "'")
121+
122+ P.Str str ->
123+ H.textToDoc ("\"" <> str <> "\"")
124+
125+ P.Int int ->
126+ H.text (show int)
127+
128+ NonList (P.Ctor _ "#0" []) ->
129+ "()"
130+
131+ NonList (P.Ctor _ "#2" [a,b]) ->
132+ "( " <> patternToDoc Unambiguous a <>
133+ ", " <> patternToDoc Unambiguous b <>
134+ " )"
135+
136+ NonList (P.Ctor _ "#3" [a,b,c]) ->
137+ "( " <> patternToDoc Unambiguous a <>
138+ ", " <> patternToDoc Unambiguous b <>
139+ ", " <> patternToDoc Unambiguous c <>
140+ " )"
141+
142+ NonList (P.Ctor _ name args) ->
143+ let
144+ ctorDoc =
145+ H.hsep (H.nameToDoc name : map (patternToDoc Arg) args)
146+ in
147+ if context == Arg && length args > 0 then
148+ "(" <> ctorDoc <> ")"
149+ else
150+ ctorDoc
151+
152+ FiniteList [] ->
153+ "[]"
154+
155+ FiniteList entries ->
156+ let entryDocs = map (patternToDoc Unambiguous) entries in
157+ "[" <> H.hcat (List.intersperse "," entryDocs) <> "]"
158+
159+ Conses conses finalPattern ->
160+ let
161+ consDoc =
162+ foldr
163+ (\hd tl -> patternToDoc Head hd <> " :: " <> tl)
164+ (patternToDoc Unambiguous finalPattern)
165+ conses
166+ in
167+ if context == Unambiguous then
168+ consDoc
169+ else
170+ "(" <> consDoc <> ")"
171+
172+
173+data Structure
174+ = FiniteList [P.Pattern]
175+ | Conses [P.Pattern] P.Pattern
176+ | NonList P.Pattern
177+
178+
179+delist :: P.Pattern -> [P.Pattern] -> Structure
180+delist pattern revEntries =
181+ case pattern of
182+ P.Ctor _ "[]" [] ->
183+ FiniteList revEntries
184+
185+ P.Ctor _ "::" [hd,tl] ->
186+ delist tl (hd:revEntries)
187+
188+ _ ->
189+ case revEntries of
190+ [] ->
191+ NonList pattern
99192
193+ _ ->
194+ Conses (reverse revEntries) pattern