git.iko.soy/elk
on 7b60982 help sign in
elk/compiler/src/Reporting/Error/Pattern.hs
194 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 Nitpick.PatternMatches as P
12import Reporting.Doc ((<>))
13import qualified Reporting.Doc as D
14import qualified Reporting.Report as Report
15import qualified Reporting.Render.Code as Code
19-- TO REPORT
22toReport :: Code.Source -> P.Error -> Report.Report
23toReport source err =
24 case err of
25 P.Redundant caseRegion patternRegion index ->
26 Report.Report "REDUNDANT PATTERN" patternRegion [] $
27 Report.toCodeSnippet source caseRegion (Just patternRegion)
28 (
29 D.reflow $
30 "The " <> D.intToOrdinal index <> " pattern is redundant:"
31 ,
32 D.reflow $
33 "Any value with this shape will be handled by a previous\
34 \ pattern, so it should be removed."
35 )
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 D.stack
46 [ "Other possibilities include:"
47 , unhandledPatternsToDocBlock unhandled
48 , D.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 )
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 D.stack
62 [ "Other possibilities include:"
63 , unhandledPatternsToDocBlock unhandled
64 , D.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 , D.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 )
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 D.stack
82 [ "Missing possibilities include:"
83 , unhandledPatternsToDocBlock unhandled
84 , D.reflow $
85 "I would have to crash if I saw one of those. Add branches for them!"
86 , D.link "Hint"
87 "If you want to write the code for each branch later, use `Debug.todo` as a placeholder. Read"
88 "missing-patterns"
89 "for more guidance on this workflow."
90 ]
91 )
95-- PATTERN TO DOC
98unhandledPatternsToDocBlock :: [P.Pattern] -> D.Doc
99unhandledPatternsToDocBlock unhandledPatterns =
100 D.indent 4 $ D.dullyellow $ D.vcat $
101 map (patternToDoc Unambiguous) unhandledPatterns
104data Context
105 = Arg
106 | Head
107 | Unambiguous
108 deriving (Eq)
111patternToDoc :: Context -> P.Pattern -> D.Doc
112patternToDoc context pattern =
113 case delist pattern [] of
114 NonList P.Anything ->
115 "_"
117 NonList (P.Literal literal) ->
118 case literal of
119 P.Chr chr ->
120 "'" <> D.fromUtf8 chr <> "'"
122 P.Str str ->
123 "\"" <> D.fromUtf8 str <> "\""
125 P.Int int ->
126 D.fromInt int
128 NonList (P.Ctor _ "#0" []) ->
129 "()"
131 NonList (P.Ctor _ "#2" [a,b]) ->
132 "( " <> patternToDoc Unambiguous a <>
133 ", " <> patternToDoc Unambiguous b <>
134 " )"
136 NonList (P.Ctor _ "#3" [a,b,c]) ->
137 "( " <> patternToDoc Unambiguous a <>
138 ", " <> patternToDoc Unambiguous b <>
139 ", " <> patternToDoc Unambiguous c <>
140 " )"
142 NonList (P.Ctor _ name args) ->
143 let
144 ctorDoc =
145 D.hsep (D.fromName name : map (patternToDoc Arg) args)
146 in
147 if context == Arg && length args > 0 then
148 "(" <> ctorDoc <> ")"
149 else
150 ctorDoc
152 FiniteList [] ->
153 "[]"
155 FiniteList entries ->
156 let entryDocs = map (patternToDoc Unambiguous) entries in
157 "[" <> D.hcat (List.intersperse "," entryDocs) <> "]"
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 <> ")"
173data Structure
174 = FiniteList [P.Pattern]
175 | Conses [P.Pattern] P.Pattern
176 | NonList P.Pattern
179delist :: P.Pattern -> [P.Pattern] -> Structure
180delist pattern revEntries =
181 case pattern of
182 P.Ctor _ "[]" [] ->
183 FiniteList revEntries
185 P.Ctor _ "::" [hd,tl] ->
186 delist tl (hd:revEntries)
188 _ ->
189 case revEntries of
190 [] ->
191 NonList pattern
193 _ ->
194 Conses (reverse revEntries) pattern