git.iko.soy/elk
on c61d87f help sign in
elk/src/Nitpick/PatternMatches.hs
407 lines 9.3 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.Literal as L
14import qualified AST.Module as Module
15import qualified AST.Pattern as P
16import qualified AST.Variable as Var
17import Elm.Utils ((|>))
18import qualified Reporting.Annotation as A
19import qualified Reporting.Region as Region
20import qualified Reporting.Result as Result
21import qualified Reporting.Warning as Warning
24patternMatches
25 :: Module.Interfaces
26 -> Module.CanonicalModule
27 -> Result.Result Warning.Warning e ()
28patternMatches interfaces modul =
29 let
30 name = Module.names modul
31 body = Module.body modul
32 in
33 checkExpression
34 (toTagDict interfaces name (Module.datatypes body))
35 (Module.program body)
38-- PATTERN MATCH DATA STRUCTURE
40data Pattern
41 = Data Var.Canonical [Pattern]
42 | Record [String]
43 | Alias String Pattern
44 | Var String
45 | Anything
46 | Literal L.Literal
47 | AnythingBut (Set.Set L.Literal)
48 deriving (Show, Eq)
51fromCanonicalPattern :: P.CanonicalPattern -> Pattern
52fromCanonicalPattern (A.A _ pattern) =
53 case pattern of
54 P.Data ctor patterns ->
55 Data ctor (map fromCanonicalPattern patterns)
57 P.Record fields ->
58 Record fields
60 P.Alias name pattern ->
61 Alias name (fromCanonicalPattern pattern)
63 P.Var name ->
64 Var name
66 P.Anything ->
67 Anything
69 P.Literal literal ->
70 Literal literal
74-- TAG DICT
76type TagDict =
77 Map.Map Var.Home (Map.Map Tag [(Tag, Int)])
80type Tag = String
83toTagDict :: Module.Interfaces -> Module.Name -> Module.ADTs -> TagDict
84toTagDict interfaces localName localAdts =
85 let
86 listTags =
87 [ ("::", 2), ("[]", 0) ]
89 builtinDict =
90 Map.singleton Var.BuiltIn $
91 Map.fromList
92 [ ("::", listTags)
93 , ("[]", listTags)
94 ]
96 interfaceDict =
97 interfaces
98 |> Map.map (toTagMapping . Module.iAdts)
99 |> Map.mapKeysMonotonic Var.Module
100 |> Map.insert (Var.Module localName) (toTagMapping localAdts)
101 in
102 Map.union builtinDict interfaceDict
105toTagMapping :: Module.ADTs -> Map.Map Tag ([(Tag,Int)])
106toTagMapping adts =
107 let
108 toTagAndArity (_tvars, tagInfoList) =
109 let
110 info = map (\(tag, args) -> (tag, length args)) tagInfoList
111 in
112 map (second (const info)) tagInfoList
113 in
114 Map.elems adts
115 |> concatMap toTagAndArity
116 |> Map.fromList
119lookupOtherCtors :: Var.Canonical -> TagDict -> [(Tag, Int)]
120lookupOtherCtors (Var.Canonical home name) tagDict =
121 case Map.lookup name =<< Map.lookup home tagDict of
122 Just otherTags ->
123 otherTags
125 Nothing ->
126 if Help.isTuple name then
127 [(name, read (drop 6 name))]
128 else
129 error
130 "Since the Nitpick phase happens after canonicalization and type \
131 \inference, it is impossible that a pattern in a case cannot be \
132 \found."
135-- CHECK EXPRESSIONS
137checkExpression
138 :: TagDict
139 -> Canonical.Expr
140 -> Result.Result Warning.Warning e ()
141checkExpression tagDict (A.A region expression) =
142 let
143 go =
144 checkExpression tagDict
146 go2 a b =
147 F.traverse_ go [a,b]
149 goPattern =
150 checkPatterns tagDict region
151 in
152 case expression of
153 E.Literal _ ->
154 Result.ok ()
156 E.Var _ ->
157 Result.ok ()
159 E.Range low high ->
160 go low
161 <* go high
163 E.ExplicitList listExprs ->
164 F.traverse_ go listExprs
166 E.Binop _ leftExpr rightExpr ->
167 go2 leftExpr rightExpr
169 E.Lambda pattern body ->
170 goPattern [pattern]
171 <* go body
173 E.App func arg ->
174 go2 func arg
176 E.MultiIf branches finally ->
177 F.traverse_ (uncurry go2) branches
178 <* go finally
180 E.Let defs body ->
181 go body
182 <* F.traverse_ goDef defs
183 where
184 goDef (Canonical.Definition pattern expr _) =
185 goPattern [pattern]
186 <* go expr
188 E.Case expr branches ->
189 go expr
190 <* goPattern (map fst branches)
191 <* F.traverse_ (go . snd) branches
193 E.Data _ctor exprs ->
194 F.traverse_ go exprs
196 E.Access record _field ->
197 go record
199 E.Remove record _field ->
200 go record
202 E.Insert record _field value ->
203 go2 record value
205 E.Modify record fields ->
206 go record
207 <* F.traverse_ (go . snd) fields
209 E.Record fields ->
210 F.traverse_ (go . snd) fields
212 E.Port impl ->
213 case impl of
214 E.In _ _ ->
215 Result.ok ()
217 E.Out _ expr _ ->
218 go expr
220 E.Task _ expr _ ->
221 go expr
223 E.GLShader _ _ _ ->
224 Result.ok ()
226 E.Crash _ ->
227 Result.ok ()
230-- CHECK PATTERNS
232checkPatterns
233 :: TagDict
234 -> Region.Region
235 -> [P.CanonicalPattern]
236 -> Result.Result Warning.Warning e ()
237checkPatterns tagDict region patterns =
238 checkPatternsHelp tagDict region [Anything] patterns
241checkPatternsHelp
242 :: TagDict
243 -> Region.Region
244 -> [Pattern]
245 -> [P.CanonicalPattern]
246 -> Result.Result Warning.Warning e ()
247checkPatternsHelp tagDict region unhandled patterns =
248 case (unhandled, patterns) of
249 ([], []) ->
250 return ()
252 (_:_, []) ->
253 Result.warn region Warning.InexhaustivePatternMatch
255 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
256 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
257 checkPatternsHelp tagDict region newUnhandled remainingPatterns
260filterPatterns
261 :: TagDict
262 -> Region.Region
263 -> P.CanonicalPattern
264 -> [Pattern]
265 -> Result.Result Warning.Warning e [Pattern]
266filterPatterns tagDict region pattern unhandled =
267 let
268 nitPattern =
269 fromCanonicalPattern pattern
271 noIntersection pat =
272 intersection pat nitPattern == Nothing
273 in
274 if all noIntersection unhandled then
275 do Result.warn region Warning.RedundantPatternMatch
276 return unhandled
277 else
278 do let complementPatterns = complement tagDict nitPattern
279 return $
280 concatMap
281 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
282 unhandled
285-- PATTERN INTERSECTION
287intersection :: Pattern -> Pattern -> Maybe Pattern
288intersection pattern1 pattern2 =
289 case (pattern1, pattern2) of
290 (Alias _ pattern1', _) ->
291 intersection pattern1' pattern2
293 (_, Alias _ pattern2') ->
294 intersection pattern1 pattern2'
296 (Anything, _) ->
297 Just pattern2
299 (Var _, _) ->
300 Just pattern2
302 (_, Anything) ->
303 Just pattern1
305 (_, Var _) ->
306 Just pattern1
308 (Data ctor1 args1, Data ctor2 args2) ->
309 if ctor1 /= ctor2 then
310 Nothing
311 else
312 Data ctor1 <$> sequence (zipWith intersection args1 args2)
314 (Record _, Record _) ->
315 Just pattern1
317 (Literal lit1, Literal lit2) ->
318 if lit1 == lit2 then
319 Just pattern1
320 else
321 Nothing
323 (AnythingBut literals, Literal lit) ->
324 if Set.member lit literals then
325 Nothing
326 else
327 Just pattern2
329 (Literal lit, AnythingBut literals) ->
330 if Set.member lit literals then
331 Nothing
332 else
333 Just pattern1
335 (AnythingBut literals1, AnythingBut literals2) ->
336 Just (AnythingBut (Set.union literals1 literals2))
338 _ ->
339 Nothing
342-- PATTERN COMPLEMENT
344complement :: TagDict -> Pattern -> [Pattern]
345complement tagDict nitPattern =
346 case nitPattern of
347 Record _fields ->
348 []
350 Alias _name pattern ->
351 complement tagDict pattern
353 Var _name ->
354 []
356 Anything ->
357 []
359 Literal lit ->
360 [AnythingBut (Set.singleton lit)]
362 AnythingBut literals ->
363 map Literal (Set.toList literals)
365 Data ctor patterns ->
366 complementData tagDict ctor patterns
369complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
370complementData tagDict tag patterns =
371 let
372 otherTags =
373 lookupOtherCtors tag tagDict
375 tagComplements =
376 Maybe.mapMaybe (tagToPattern tag) otherTags
378 arity =
379 length patterns
381 argComplements =
382 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
383 in
384 tagComplements ++ argComplements
387tagToPattern :: Var.Canonical -> (Tag, Int) -> Maybe Pattern
388tagToPattern (Var.Canonical home rootTag) (tag, arity) =
389 if rootTag == tag then
390 Nothing
391 else
392 Just (Data (Var.Canonical home tag) (replicate arity Anything))
395makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
396makeArgComplements tagDict tag arity index argPattern =
397 let
398 complementList =
399 complement tagDict argPattern
401 padArgs pattern =
402 replicate index Anything
403 ++ pattern
404 : replicate (arity - index - 1) Anything
405 in
406 map (Data tag . padArgs) complementList