git.iko.soy/elk
on 2cd0692 help sign in
elk/src/Nitpick/PatternMatches.hs
370 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.Pattern as Pattern
15import qualified AST.Variable as Var
16import Elm.Utils ((|>))
17import Nitpick.Pattern (Pattern(..), fromCanonicalPattern)
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-- TAG DICT
40type TagDict =
41 Map.Map Var.Home (Map.Map Tag [(Tag, Int)])
44type Tag = String
47toTagDict :: Module.Interfaces -> Module.Name -> Module.ADTs -> TagDict
48toTagDict interfaces localName localAdts =
49 let
50 listTags =
51 [ ("::", 2), ("[]", 0) ]
53 builtinDict =
54 Map.singleton Var.BuiltIn $
55 Map.fromList
56 [ ("::", listTags)
57 , ("[]", listTags)
58 ]
60 interfaceDict =
61 interfaces
62 |> Map.map (toTagMapping . Module.iAdts)
63 |> Map.mapKeysMonotonic Var.Module
64 |> Map.insert (Var.Module localName) (toTagMapping localAdts)
65 in
66 Map.union builtinDict interfaceDict
69toTagMapping :: Module.ADTs -> Map.Map Tag ([(Tag,Int)])
70toTagMapping adts =
71 let
72 toTagAndArity (_tvars, tagInfoList) =
73 let
74 info = map (\(tag, args) -> (tag, length args)) tagInfoList
75 in
76 map (second (const info)) tagInfoList
77 in
78 Map.elems adts
79 |> concatMap toTagAndArity
80 |> Map.fromList
83lookupOtherTags :: Var.Canonical -> TagDict -> [(Tag, Int)]
84lookupOtherTags (Var.Canonical home name) tagDict =
85 case Map.lookup name =<< Map.lookup home tagDict of
86 Just otherTags ->
87 otherTags
89 Nothing ->
90 if Help.isTuple name then
91 [(name, read (drop 6 name))]
92 else
93 error
94 "Since the Nitpick phase happens after canonicalization and type \
95 \inference, it is impossible that a pattern in a case cannot be \
96 \found."
99-- CHECK EXPRESSIONS
101checkExpression
102 :: TagDict
103 -> Canonical.Expr
104 -> Result.Result Warning.Warning e ()
105checkExpression tagDict (A.A region expression) =
106 let
107 go =
108 checkExpression tagDict
110 go2 a b =
111 go a <* go b
113 goPattern =
114 checkPatterns tagDict region
115 in
116 case expression of
117 E.Literal _ ->
118 Result.ok ()
120 E.Var _ ->
121 Result.ok ()
123 E.Range low high ->
124 go2 low high
126 E.ExplicitList listExprs ->
127 F.traverse_ go listExprs
129 E.Binop _ leftExpr rightExpr ->
130 go2 leftExpr rightExpr
132 E.Lambda pattern body ->
133 goPattern [pattern]
134 <* go body
136 E.App func arg ->
137 go2 func arg
139 E.MultiIf branches finally ->
140 F.traverse_ (uncurry go2) branches
141 <* go finally
143 E.Let defs body ->
144 go body
145 <* F.traverse_ goDef defs
146 where
147 goDef (Canonical.Definition pattern expr _) =
148 goPattern [pattern]
149 <* go expr
151 E.Case expr branches ->
152 go expr
153 <* goPattern (map fst branches)
154 <* F.traverse_ (go . snd) branches
156 E.Data _ctor exprs ->
157 F.traverse_ go exprs
159 E.Access record _field ->
160 go record
162 E.Remove record _field ->
163 go record
165 E.Insert record _field value ->
166 go2 record value
168 E.Modify record fields ->
169 go record
170 <* F.traverse_ (go . snd) fields
172 E.Record fields ->
173 F.traverse_ (go . snd) fields
175 E.Port impl ->
176 case impl of
177 E.In _ _ ->
178 Result.ok ()
180 E.Out _ expr _ ->
181 go expr
183 E.Task _ expr _ ->
184 go expr
186 E.GLShader _ _ _ ->
187 Result.ok ()
189 E.Crash _ ->
190 Result.ok ()
193-- CHECK PATTERNS
195checkPatterns
196 :: TagDict
197 -> Region.Region
198 -> [Pattern.CanonicalPattern]
199 -> Result.Result Warning.Warning e ()
200checkPatterns tagDict region patterns =
201 checkPatternsHelp tagDict region [Anything] patterns
204checkPatternsHelp
205 :: TagDict
206 -> Region.Region
207 -> [Pattern]
208 -> [Pattern.CanonicalPattern]
209 -> Result.Result Warning.Warning e ()
210checkPatternsHelp tagDict region unhandled patterns =
211 case (unhandled, patterns) of
212 ([], []) ->
213 return ()
215 (_:_, []) ->
216 Result.warn region (Warning.InexhaustivePatternMatch unhandled)
218 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
219 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
220 checkPatternsHelp tagDict region newUnhandled remainingPatterns
223filterPatterns
224 :: TagDict
225 -> Region.Region
226 -> Pattern.CanonicalPattern
227 -> [Pattern]
228 -> Result.Result Warning.Warning e [Pattern]
229filterPatterns tagDict region pattern unhandled =
230 let
231 nitPattern =
232 fromCanonicalPattern pattern
234 noIntersection pat =
235 intersection pat nitPattern == Nothing
236 in
237 if all noIntersection unhandled then
238 do Result.warn region Warning.RedundantPatternMatch
239 return unhandled
240 else
241 do let complementPatterns = complement tagDict nitPattern
242 return $
243 concatMap
244 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
245 unhandled
248-- PATTERN INTERSECTION
250intersection :: Pattern -> Pattern -> Maybe Pattern
251intersection pattern1 pattern2 =
252 case (pattern1, pattern2) of
253 (Alias _ pattern1', _) ->
254 intersection pattern1' pattern2
256 (_, Alias _ pattern2') ->
257 intersection pattern1 pattern2'
259 (Anything, _) ->
260 Just pattern2
262 (Var _, _) ->
263 Just pattern2
265 (_, Anything) ->
266 Just pattern1
268 (_, Var _) ->
269 Just pattern1
271 (Data ctor1 args1, Data ctor2 args2) ->
272 if ctor1 /= ctor2 then
273 Nothing
274 else
275 Data ctor1 <$> sequence (zipWith intersection args1 args2)
277 (Record _, Record _) ->
278 Just pattern1
280 (Literal lit1, Literal lit2) ->
281 if lit1 == lit2 then
282 Just pattern1
283 else
284 Nothing
286 (AnythingBut literals, Literal lit) ->
287 if Set.member lit literals then
288 Nothing
289 else
290 Just pattern2
292 (Literal lit, AnythingBut literals) ->
293 if Set.member lit literals then
294 Nothing
295 else
296 Just pattern1
298 (AnythingBut literals1, AnythingBut literals2) ->
299 Just (AnythingBut (Set.union literals1 literals2))
301 _ ->
302 Nothing
305-- PATTERN COMPLEMENT
307complement :: TagDict -> Pattern -> [Pattern]
308complement tagDict nitPattern =
309 case nitPattern of
310 Record _fields ->
311 []
313 Alias _name pattern ->
314 complement tagDict pattern
316 Var _name ->
317 []
319 Anything ->
320 []
322 Literal lit ->
323 [AnythingBut (Set.singleton lit)]
325 AnythingBut literals ->
326 map Literal (Set.toList literals)
328 Data ctor patterns ->
329 complementData tagDict ctor patterns
332complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
333complementData tagDict tag patterns =
334 let
335 otherTags =
336 lookupOtherTags tag tagDict
338 tagComplements =
339 Maybe.mapMaybe (tagToPattern tag) otherTags
341 arity =
342 length patterns
344 argComplements =
345 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
346 in
347 tagComplements ++ argComplements
350tagToPattern :: Var.Canonical -> (Tag, Int) -> Maybe Pattern
351tagToPattern (Var.Canonical home rootTag) (tag, arity) =
352 if rootTag == tag then
353 Nothing
354 else
355 Just (Data (Var.Canonical home tag) (replicate arity Anything))
358makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
359makeArgComplements tagDict tag arity index argPattern =
360 let
361 complementList =
362 complement tagDict argPattern
364 padArgs pattern =
365 replicate index Anything
366 ++ pattern
367 : replicate (arity - index - 1) Anything
368 in
369 map (Data tag . padArgs) complementList