git.iko.soy/elk
on cc76ccb help sign in
elk/compiler/src/Reporting/Error/Pattern.hs
195 lines 5.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Error.Pattern
4 ( P.Error(..)
5 , toReport
6 )
7 where
9import qualified Data.List as List
11import qualified Elm.String as ES
12import qualified Nitpick.PatternMatches as P
13import Reporting.Doc ((<>))
14import qualified Reporting.Doc as D
15import qualified Reporting.Report as Report
16import qualified Reporting.Render.Code as Code
20-- TO REPORT
23toReport :: Code.Source -> P.Error -> Report.Report
24toReport source err =
25 case err of
26 P.Redundant caseRegion patternRegion index ->
27 Report.Report "REDUNDANT PATTERN" patternRegion [] $
28 Code.toSnippet source caseRegion (Just patternRegion)
29 (
30 D.reflow $
31 "The " <> D.intToOrdinal index <> " pattern is redundant:"
32 ,
33 D.reflow $
34 "Any value with this shape will be handled by a previous\
35 \ pattern, so it should be removed."
36 )
38 P.Incomplete region context unhandled ->
39 case context of
40 P.BadArg ->
41 Report.Report "UNSAFE PATTERN" region [] $
42 Code.toSnippet source region Nothing
43 (
44 "This pattern does not cover all possiblities:"
45 ,
46 D.stack
47 [ "Other possibilities include:"
48 , unhandledPatternsToDocBlock unhandled
49 , D.reflow $
50 "I would have to crash if I saw one of those! So rather than\
51 \ pattern matching in function arguments, put a `case` in\
52 \ the function body to account for all possibilities."
53 ]
54 )
56 P.BadDestruct ->
57 Report.Report "UNSAFE PATTERN" region [] $
58 Code.toSnippet source region Nothing
59 (
60 "This pattern does not cover all possible values:"
61 ,
62 D.stack
63 [ "Other possibilities include:"
64 , unhandledPatternsToDocBlock unhandled
65 , D.reflow $
66 "I would have to crash if I saw one of those! You can use\
67 \ `let` to deconstruct values only if there is ONE possiblity.\
68 \ Switch to a `case` expression to account for all possibilities."
69 , D.toSimpleHint $
70 "Are you calling a function that definitely returns values\
71 \ with a very specific shape? Try making the return type of\
72 \ that function more specific!"
73 ]
74 )
76 P.BadCase ->
77 Report.Report "MISSING PATTERNS" region [] $
78 Code.toSnippet source region Nothing
79 (
80 "This `case` does not have branches for all possibilities:"
81 ,
82 D.stack
83 [ "Missing possibilities include:"
84 , unhandledPatternsToDocBlock unhandled
85 , D.reflow $
86 "I would have to crash if I saw one of those. Add branches for them!"
87 , D.link "Hint"
88 "If you want to write the code for each branch later, use `Debug.todo` as a placeholder. Read"
89 "missing-patterns"
90 "for more guidance on this workflow."
91 ]
92 )
96-- PATTERN TO DOC
99unhandledPatternsToDocBlock :: [P.Pattern] -> D.Doc
100unhandledPatternsToDocBlock unhandledPatterns =
101 D.indent 4 $ D.dullyellow $ D.vcat $
102 map (patternToDoc Unambiguous) unhandledPatterns
105data Context
106 = Arg
107 | Head
108 | Unambiguous
109 deriving (Eq)
112patternToDoc :: Context -> P.Pattern -> D.Doc
113patternToDoc context pattern =
114 case delist pattern [] of
115 NonList P.Anything ->
116 "_"
118 NonList (P.Literal literal) ->
119 case literal of
120 P.Chr chr ->
121 "'" <> D.fromChars (ES.toChars chr) <> "'"
123 P.Str str ->
124 "\"" <> D.fromChars (ES.toChars str) <> "\""
126 P.Int int ->
127 D.fromInt int
129 NonList (P.Ctor _ "#0" []) ->
130 "()"
132 NonList (P.Ctor _ "#2" [a,b]) ->
133 "( " <> patternToDoc Unambiguous a <>
134 ", " <> patternToDoc Unambiguous b <>
135 " )"
137 NonList (P.Ctor _ "#3" [a,b,c]) ->
138 "( " <> patternToDoc Unambiguous a <>
139 ", " <> patternToDoc Unambiguous b <>
140 ", " <> patternToDoc Unambiguous c <>
141 " )"
143 NonList (P.Ctor _ name args) ->
144 let
145 ctorDoc =
146 D.hsep (D.fromName name : map (patternToDoc Arg) args)
147 in
148 if context == Arg && length args > 0 then
149 "(" <> ctorDoc <> ")"
150 else
151 ctorDoc
153 FiniteList [] ->
154 "[]"
156 FiniteList entries ->
157 let entryDocs = map (patternToDoc Unambiguous) entries in
158 "[" <> D.hcat (List.intersperse "," entryDocs) <> "]"
160 Conses conses finalPattern ->
161 let
162 consDoc =
163 foldr
164 (\hd tl -> patternToDoc Head hd <> " :: " <> tl)
165 (patternToDoc Unambiguous finalPattern)
166 conses
167 in
168 if context == Unambiguous then
169 consDoc
170 else
171 "(" <> consDoc <> ")"
174data Structure
175 = FiniteList [P.Pattern]
176 | Conses [P.Pattern] P.Pattern
177 | NonList P.Pattern
180delist :: P.Pattern -> [P.Pattern] -> Structure
181delist pattern revEntries =
182 case pattern of
183 P.Ctor _ "[]" [] ->
184 FiniteList revEntries
186 P.Ctor _ "::" [hd,tl] ->
187 delist tl (hd:revEntries)
189 _ ->
190 case revEntries of
191 [] ->
192 NonList pattern
194 _ ->
195 Conses (reverse revEntries) pattern