git.iko.soy/elk
on 2297bbf help sign in
elk/src/Nitpick/PatternMatches.hs
362 lines 8.5 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 ()
185-- CHECK PATTERNS
187checkPatterns
188 :: TagDict
189 -> Region.Region
190 -> [Pattern.CanonicalPattern]
191 -> Result.Result Warning.Warning e ()
192checkPatterns tagDict region patterns =
193 checkPatternsHelp tagDict region [Anything] patterns
196checkPatternsHelp
197 :: TagDict
198 -> Region.Region
199 -> [Pattern]
200 -> [Pattern.CanonicalPattern]
201 -> Result.Result Warning.Warning e ()
202checkPatternsHelp tagDict region unhandled patterns =
203 case (unhandled, patterns) of
204 ([], []) ->
205 return ()
207 (_:_, []) ->
208 Result.warn region (Warning.InexhaustivePatternMatch unhandled)
210 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
211 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
212 checkPatternsHelp tagDict region newUnhandled remainingPatterns
215filterPatterns
216 :: TagDict
217 -> Region.Region
218 -> Pattern.CanonicalPattern
219 -> [Pattern]
220 -> Result.Result Warning.Warning e [Pattern]
221filterPatterns tagDict region pattern unhandled =
222 let
223 nitPattern =
224 fromCanonicalPattern pattern
226 noIntersection pat =
227 intersection pat nitPattern == Nothing
228 in
229 if all noIntersection unhandled then
230 do Result.warn region Warning.RedundantPatternMatch
231 return unhandled
232 else
233 do let complementPatterns = complement tagDict nitPattern
234 return $
235 concatMap
236 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
237 unhandled
240-- PATTERN INTERSECTION
242intersection :: Pattern -> Pattern -> Maybe Pattern
243intersection pattern1 pattern2 =
244 case (pattern1, pattern2) of
245 (Alias _ pattern1', _) ->
246 intersection pattern1' pattern2
248 (_, Alias _ pattern2') ->
249 intersection pattern1 pattern2'
251 (Anything, _) ->
252 Just pattern2
254 (Var _, _) ->
255 Just pattern2
257 (_, Anything) ->
258 Just pattern1
260 (_, Var _) ->
261 Just pattern1
263 (Data ctor1 args1, Data ctor2 args2) ->
264 if ctor1 /= ctor2 then
265 Nothing
266 else
267 Data ctor1 <$> sequence (zipWith intersection args1 args2)
269 (Record _, Record _) ->
270 Just pattern1
272 (Literal lit1, Literal lit2) ->
273 if lit1 == lit2 then
274 Just pattern1
275 else
276 Nothing
278 (AnythingBut literals, Literal lit) ->
279 if Set.member lit literals then
280 Nothing
281 else
282 Just pattern2
284 (Literal lit, AnythingBut literals) ->
285 if Set.member lit literals then
286 Nothing
287 else
288 Just pattern1
290 (AnythingBut literals1, AnythingBut literals2) ->
291 Just (AnythingBut (Set.union literals1 literals2))
293 _ ->
294 Nothing
297-- PATTERN COMPLEMENT
299complement :: TagDict -> Pattern -> [Pattern]
300complement tagDict nitPattern =
301 case nitPattern of
302 Record _fields ->
303 []
305 Alias _name pattern ->
306 complement tagDict pattern
308 Var _name ->
309 []
311 Anything ->
312 []
314 Literal lit ->
315 [AnythingBut (Set.singleton lit)]
317 AnythingBut literals ->
318 map Literal (Set.toList literals)
320 Data ctor patterns ->
321 complementData tagDict ctor patterns
324complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
325complementData tagDict tag patterns =
326 let
327 otherTags =
328 lookupOtherTags tag tagDict
330 tagComplements =
331 Maybe.mapMaybe (tagToPattern tag) otherTags
333 arity =
334 length patterns
336 argComplements =
337 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
338 in
339 tagComplements ++ argComplements
342tagToPattern :: Var.Canonical -> (Tag, Int) -> Maybe Pattern
343tagToPattern (Var.Canonical home rootTag) (tag, arity) =
344 if rootTag == tag then
345 Nothing
346 else
347 Just (Data (Var.Canonical home tag) (replicate arity Anything))
350makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
351makeArgComplements tagDict tag arity index argPattern =
352 let
353 complementList =
354 complement tagDict argPattern
356 padArgs pattern =
357 replicate index Anything
358 ++ pattern
359 : replicate (arity - index - 1) Anything
360 in
361 map (Data tag . padArgs) complementList