git.iko.soy/elk
on b0beee4 help sign in
elk/src/Nitpick/PatternMatches.hs
364 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.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.If 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.Update record fields ->
163 go record
164 <* F.traverse_ (go . snd) fields
166 E.Record fields ->
167 F.traverse_ (go . snd) fields
169 E.Port impl ->
170 case impl of
171 E.In _ _ ->
172 Result.ok ()
174 E.Out _ expr _ ->
175 go expr
177 E.Task _ expr _ ->
178 go expr
180 E.GLShader _ _ _ ->
181 Result.ok ()
183 E.Crash _ ->
184 Result.ok ()
187-- CHECK PATTERNS
189checkPatterns
190 :: TagDict
191 -> Region.Region
192 -> [Pattern.CanonicalPattern]
193 -> Result.Result Warning.Warning e ()
194checkPatterns tagDict region patterns =
195 checkPatternsHelp tagDict region [Anything] patterns
198checkPatternsHelp
199 :: TagDict
200 -> Region.Region
201 -> [Pattern]
202 -> [Pattern.CanonicalPattern]
203 -> Result.Result Warning.Warning e ()
204checkPatternsHelp tagDict region unhandled patterns =
205 case (unhandled, patterns) of
206 ([], []) ->
207 return ()
209 (_:_, []) ->
210 Result.warn region (Warning.InexhaustivePatternMatch unhandled)
212 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
213 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
214 checkPatternsHelp tagDict region newUnhandled remainingPatterns
217filterPatterns
218 :: TagDict
219 -> Region.Region
220 -> Pattern.CanonicalPattern
221 -> [Pattern]
222 -> Result.Result Warning.Warning e [Pattern]
223filterPatterns tagDict region pattern unhandled =
224 let
225 nitPattern =
226 fromCanonicalPattern pattern
228 noIntersection pat =
229 intersection pat nitPattern == Nothing
230 in
231 if all noIntersection unhandled then
232 do Result.warn region Warning.RedundantPatternMatch
233 return unhandled
234 else
235 do let complementPatterns = complement tagDict nitPattern
236 return $
237 concatMap
238 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
239 unhandled
242-- PATTERN INTERSECTION
244intersection :: Pattern -> Pattern -> Maybe Pattern
245intersection pattern1 pattern2 =
246 case (pattern1, pattern2) of
247 (Alias _ pattern1', _) ->
248 intersection pattern1' pattern2
250 (_, Alias _ pattern2') ->
251 intersection pattern1 pattern2'
253 (Anything, _) ->
254 Just pattern2
256 (Var _, _) ->
257 Just pattern2
259 (_, Anything) ->
260 Just pattern1
262 (_, Var _) ->
263 Just pattern1
265 (Data ctor1 args1, Data ctor2 args2) ->
266 if ctor1 /= ctor2 then
267 Nothing
268 else
269 Data ctor1 <$> sequence (zipWith intersection args1 args2)
271 (Record _, Record _) ->
272 Just pattern1
274 (Literal lit1, Literal lit2) ->
275 if lit1 == lit2 then
276 Just pattern1
277 else
278 Nothing
280 (AnythingBut literals, Literal lit) ->
281 if Set.member lit literals then
282 Nothing
283 else
284 Just pattern2
286 (Literal lit, AnythingBut literals) ->
287 if Set.member lit literals then
288 Nothing
289 else
290 Just pattern1
292 (AnythingBut literals1, AnythingBut literals2) ->
293 Just (AnythingBut (Set.union literals1 literals2))
295 _ ->
296 Nothing
299-- PATTERN COMPLEMENT
301complement :: TagDict -> Pattern -> [Pattern]
302complement tagDict nitPattern =
303 case nitPattern of
304 Record _fields ->
305 []
307 Alias _name pattern ->
308 complement tagDict pattern
310 Var _name ->
311 []
313 Anything ->
314 []
316 Literal lit ->
317 [AnythingBut (Set.singleton lit)]
319 AnythingBut literals ->
320 map Literal (Set.toList literals)
322 Data ctor patterns ->
323 complementData tagDict ctor patterns
326complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
327complementData tagDict tag patterns =
328 let
329 otherTags =
330 lookupOtherTags tag tagDict
332 tagComplements =
333 Maybe.mapMaybe (tagToPattern tag) otherTags
335 arity =
336 length patterns
338 argComplements =
339 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
340 in
341 tagComplements ++ argComplements
344tagToPattern :: Var.Canonical -> (Tag, Int) -> Maybe Pattern
345tagToPattern (Var.Canonical home rootTag) (tag, arity) =
346 if rootTag == tag then
347 Nothing
348 else
349 Just (Data (Var.Canonical home tag) (replicate arity Anything))
352makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
353makeArgComplements tagDict tag arity index argPattern =
354 let
355 complementList =
356 complement tagDict argPattern
358 padArgs pattern =
359 replicate index Anything
360 ++ pattern
361 : replicate (arity - index - 1) Anything
362 in
363 map (Data tag . padArgs) complementList