git.iko.soy/elk
on bb7eb96 help sign in
elk/src/Nitpick/PatternMatches.hs
365 lines 8.6 kB history raw
1module Nitpick.PatternMatches (patternMatches) where
3import Control.Applicative ((<$>), (<*))
4import Control.Arrow (second)
5import qualified Data.Foldable as F
6import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
8import qualified Data.Set as Set
10import qualified AST.Expression.General as E
11import qualified AST.Expression.Canonical as Canonical
12import qualified AST.Helpers as Help
13import qualified AST.Module as Module
14import qualified AST.Module.Name as ModuleName
15import qualified AST.Pattern as Pattern
16import qualified AST.Variable as Var
17import Elm.Utils ((|>))
18import Nitpick.Pattern (Pattern(..), fromCanonicalPattern)
19import qualified Reporting.Annotation as A
20import qualified Reporting.Region as Region
21import qualified Reporting.Result as Result
22import qualified Reporting.Warning as Warning
25patternMatches
26 :: Module.Interfaces
27 -> Module.CanonicalModule
28 -> Result.Result Warning.Warning e ()
29patternMatches interfaces modul =
30 let
31 name = Module.name modul
32 body = Module.body modul
33 in
34 checkExpression
35 (toTagDict interfaces name (Module.datatypes body))
36 (Module.program body)
39-- TAG DICT
41type TagDict =
42 Map.Map Var.Home (Map.Map Tag [(Tag, Int)])
45type Tag = String
48toTagDict :: Module.Interfaces -> ModuleName.Canonical -> Module.ADTs -> TagDict
49toTagDict interfaces localName localAdts =
50 let
51 listTags =
52 [ ("::", 2), ("[]", 0) ]
54 builtinDict =
55 Map.singleton Var.BuiltIn $
56 Map.fromList
57 [ ("::", listTags)
58 , ("[]", listTags)
59 ]
61 interfaceDict =
62 interfaces
63 |> Map.map (toTagMapping . Module.iAdts)
64 |> Map.mapKeysMonotonic Var.Module
65 |> Map.insert (Var.Module localName) (toTagMapping localAdts)
66 in
67 Map.union builtinDict interfaceDict
70toTagMapping :: Module.ADTs -> Map.Map Tag ([(Tag,Int)])
71toTagMapping adts =
72 let
73 toTagAndArity (_tvars, tagInfoList) =
74 let
75 info = map (\(tag, args) -> (tag, length args)) tagInfoList
76 in
77 map (second (const info)) tagInfoList
78 in
79 Map.elems adts
80 |> concatMap toTagAndArity
81 |> Map.fromList
84lookupOtherTags :: Var.Canonical -> TagDict -> [(Tag, Int)]
85lookupOtherTags (Var.Canonical home name) tagDict =
86 case Map.lookup name =<< Map.lookup home tagDict of
87 Just otherTags ->
88 otherTags
90 Nothing ->
91 if Help.isTuple name then
92 [(name, read (drop 6 name))]
93 else
94 error
95 "Since the Nitpick phase happens after canonicalization and type \
96 \inference, it is impossible that a pattern in a case cannot be \
97 \found."
100-- CHECK EXPRESSIONS
102checkExpression
103 :: TagDict
104 -> Canonical.Expr
105 -> Result.Result Warning.Warning e ()
106checkExpression tagDict (A.A region expression) =
107 let
108 go =
109 checkExpression tagDict
111 go2 a b =
112 go a <* go b
114 goPattern =
115 checkPatterns tagDict region
116 in
117 case expression of
118 E.Literal _ ->
119 Result.ok ()
121 E.Var _ ->
122 Result.ok ()
124 E.Range low high ->
125 go2 low high
127 E.ExplicitList listExprs ->
128 F.traverse_ go listExprs
130 E.Binop _ leftExpr rightExpr ->
131 go2 leftExpr rightExpr
133 E.Lambda pattern body ->
134 goPattern [pattern]
135 <* go body
137 E.App func arg ->
138 go2 func arg
140 E.If branches finally ->
141 F.traverse_ (uncurry go2) branches
142 <* go finally
144 E.Let defs body ->
145 go body
146 <* F.traverse_ goDef defs
147 where
148 goDef (Canonical.Definition _ pattern expr _) =
149 goPattern [pattern]
150 <* go expr
152 E.Case expr branches ->
153 go expr
154 <* goPattern (map fst branches)
155 <* F.traverse_ (go . snd) branches
157 E.Data _ctor exprs ->
158 F.traverse_ go exprs
160 E.Access record _field ->
161 go record
163 E.Update record fields ->
164 go record
165 <* F.traverse_ (go . snd) fields
167 E.Record fields ->
168 F.traverse_ (go . snd) fields
170 E.Port impl ->
171 case impl of
172 E.In _ _ ->
173 Result.ok ()
175 E.Out _ expr _ ->
176 go expr
178 E.Task _ expr _ ->
179 go expr
181 E.GLShader _ _ _ ->
182 Result.ok ()
184 E.Crash _ ->
185 Result.ok ()
188-- CHECK PATTERNS
190checkPatterns
191 :: TagDict
192 -> Region.Region
193 -> [Pattern.CanonicalPattern]
194 -> Result.Result Warning.Warning e ()
195checkPatterns tagDict region patterns =
196 checkPatternsHelp tagDict region [Anything] patterns
199checkPatternsHelp
200 :: TagDict
201 -> Region.Region
202 -> [Pattern]
203 -> [Pattern.CanonicalPattern]
204 -> Result.Result Warning.Warning e ()
205checkPatternsHelp tagDict region unhandled patterns =
206 case (unhandled, patterns) of
207 ([], []) ->
208 return ()
210 (_:_, []) ->
211 Result.warn region (Warning.InexhaustivePatternMatch unhandled)
213 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
214 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
215 checkPatternsHelp tagDict region newUnhandled remainingPatterns
218filterPatterns
219 :: TagDict
220 -> Region.Region
221 -> Pattern.CanonicalPattern
222 -> [Pattern]
223 -> Result.Result Warning.Warning e [Pattern]
224filterPatterns tagDict region pattern unhandled =
225 let
226 nitPattern =
227 fromCanonicalPattern pattern
229 noIntersection pat =
230 intersection pat nitPattern == Nothing
231 in
232 if all noIntersection unhandled then
233 do Result.warn region Warning.RedundantPatternMatch
234 return unhandled
235 else
236 do let complementPatterns = complement tagDict nitPattern
237 return $
238 concatMap
239 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
240 unhandled
243-- PATTERN INTERSECTION
245intersection :: Pattern -> Pattern -> Maybe Pattern
246intersection pattern1 pattern2 =
247 case (pattern1, pattern2) of
248 (Alias _ pattern1', _) ->
249 intersection pattern1' pattern2
251 (_, Alias _ pattern2') ->
252 intersection pattern1 pattern2'
254 (Anything, _) ->
255 Just pattern2
257 (Var _, _) ->
258 Just pattern2
260 (_, Anything) ->
261 Just pattern1
263 (_, Var _) ->
264 Just pattern1
266 (Data ctor1 args1, Data ctor2 args2) ->
267 if ctor1 /= ctor2 then
268 Nothing
269 else
270 Data ctor1 <$> sequence (zipWith intersection args1 args2)
272 (Record _, Record _) ->
273 Just pattern1
275 (Literal lit1, Literal lit2) ->
276 if lit1 == lit2 then
277 Just pattern1
278 else
279 Nothing
281 (AnythingBut literals, Literal lit) ->
282 if Set.member lit literals then
283 Nothing
284 else
285 Just pattern2
287 (Literal lit, AnythingBut literals) ->
288 if Set.member lit literals then
289 Nothing
290 else
291 Just pattern1
293 (AnythingBut literals1, AnythingBut literals2) ->
294 Just (AnythingBut (Set.union literals1 literals2))
296 _ ->
297 Nothing
300-- PATTERN COMPLEMENT
302complement :: TagDict -> Pattern -> [Pattern]
303complement tagDict nitPattern =
304 case nitPattern of
305 Record _fields ->
306 []
308 Alias _name pattern ->
309 complement tagDict pattern
311 Var _name ->
312 []
314 Anything ->
315 []
317 Literal lit ->
318 [AnythingBut (Set.singleton lit)]
320 AnythingBut literals ->
321 map Literal (Set.toList literals)
323 Data ctor patterns ->
324 complementData tagDict ctor patterns
327complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
328complementData tagDict tag patterns =
329 let
330 otherTags =
331 lookupOtherTags tag tagDict
333 tagComplements =
334 Maybe.mapMaybe (tagToPattern tag) otherTags
336 arity =
337 length patterns
339 argComplements =
340 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
341 in
342 tagComplements ++ argComplements
345tagToPattern :: Var.Canonical -> (Tag, Int) -> Maybe Pattern
346tagToPattern (Var.Canonical home rootTag) (tag, arity) =
347 if rootTag == tag then
348 Nothing
349 else
350 Just (Data (Var.Canonical home tag) (replicate arity Anything))
353makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
354makeArgComplements tagDict tag arity index argPattern =
355 let
356 complementList =
357 complement tagDict argPattern
359 padArgs pattern =
360 replicate index Anything
361 ++ pattern
362 : replicate (arity - index - 1) Anything
363 in
364 map (Data tag . padArgs) complementList