@@ -1,7 +1,7 @@
11module Nitpick.PatternMatches (patternMatches) where
22
33import Control.Applicative ((<$>), (<*))
4−import Control.Monad.Except (forM, liftM)
4+import Control.Arrow (second)
55import qualified Data.Foldable as F
66import qualified Data.Map as Map
77import qualified Data.Maybe as Maybe
@@ -9,79 +9,146 @@ import qualified Data.Set as Set
99
1010import qualified AST.Expression.General as E
1111import qualified AST.Expression.Canonical as Canonical
12+import qualified AST.Literal as L
1213import qualified AST.Module as Module
13−import qualified AST.Pattern as Pattern
14+import qualified AST.Pattern as P
1415import qualified AST.Variable as Var
1516import Elm.Utils ((|>))
16−import qualified Nitpick.Pattern as P
1717import qualified Reporting.Annotation as A
18−import qualified Reporting.Error.Nitpick as Error
1918import qualified Reporting.Region as Region
2019import qualified Reporting.Result as Result
21−import qualified Reporting.Warning.Nitpick as Warning
20+import qualified Reporting.Warning as Warning
2221
2322
2423patternMatches
2524 :: Module.Interfaces
26− -> Module.CanonicalBody
25+ -> Module.Body Canonical.Expr
2726 -> Result.Result Warning.Warning e ()
2827patternMatches interfaces body =
29− checkExpression (toAdtDict interfaces) (Module.program body)
28+ checkExpression (toTagDict interfaces) (Module.program body)
3029
3130
32−-- ADT DICT
31+-- PATTERN MATCH DATA STRUCTURE
3332
34−type AdtDict =
35− Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
33+data Pattern
34+ = Data Var.Canonical [Pattern]
35+ | Record [String]
36+ | Alias String Pattern
37+ | Var String
38+ | Anything
39+ | Literal L.Literal
40+ | AnythingBut (Set.Set L.Literal)
41+ deriving (Show, Eq)
3642
3743
38−toAdtDict :: Module.Interfaces -> AdtDict
39−toAdtDict =
44+fromCanonicalPattern :: P.CanonicalPattern -> Pattern
45+fromCanonicalPattern (A.A _ pattern) =
46+ case pattern of
47+ P.Data ctor patterns ->
48+ Data ctor (map fromCanonicalPattern patterns)
49+
50+ P.Record fields ->
51+ Record fields
52+
53+ P.Alias name pattern ->
54+ Alias name (fromCanonicalPattern pattern)
55+
56+ P.Var name ->
57+ Var name
58+
59+ P.Anything ->
60+ Anything
61+
62+ P.Literal literal ->
63+ Literal literal
64+
65+
66+
67+-- TAG DICT
68+
69+type TagDict =
70+ Map.Map Var.Home (Map.Map Tag [(Tag, Int)])
71+
72+
73+type Tag = String
74+
75+
76+toTagDict :: Module.Interfaces -> TagDict
77+toTagDict interfaces =
4078 let
41− -- TODO
79+ listTags =
80+ [ ("::", 2), ("[]", 0) ]
81+
4282 builtinDict =
43− Map.empty
83+ Map.singleton Var.BuiltIn $
84+ Map.fromList
85+ [ ("::", listTags)
86+ , ("[]", listTags)
87+ ]
4488
4589 interfaceDict =
4690 interfaces
47− |> Map.map Module.iAdts
91+ |> Map.map (toTagMapping . Module.iAdts)
4892 |> Map.mapKeysMonotonic Var.Module
4993 in
5094 Map.union builtinDict interfaceDict
5195
5296
53−-- TODO this is wrong
54−lookupOtherCtors
55− :: Var.Canonical
56− -> AdtDict
57− -> [(Var.Canonical, [Type.Canonical])]
58−lookupOtherCtors (Var.Canonical home name) adtDict =
59− case Map.lookup name =<< Map.lookup home adtDict of
60− Nothing ->
61− error "TODO"
97+toTagMapping :: Module.ADTs -> Map.Map Tag ([(Tag,Int)])
98+toTagMapping adts =
99+ let
100+ toTagAndArity (_tvars, tagInfoList) =
101+ let
102+ info = map (\(tag, args) -> (tag, length args)) tagInfoList
103+ in
104+ map (second (const info)) tagInfoList
105+ in
106+ Map.elems adts
107+ |> concatMap toTagAndArity
108+ |> Map.fromList
62109
63− Just (_tvars, ctors) ->
64− ctors
110+
111+lookupOtherCtors :: Var.Canonical -> TagDict -> [(Tag, Int)]
112+lookupOtherCtors (Var.Canonical home name) tagDict =
113+ case Map.lookup name =<< Map.lookup home tagDict of
114+ Just otherTags ->
115+ otherTags
116+
117+ Nothing ->
118+ error
119+ "Since the Nitpick phase happens after canonicalization and type \
120+ \inference, it is impossible that a pattern in a case cannot be \
121+ \found."
65122
66123
67124-- CHECK EXPRESSIONS
68125
69126checkExpression
70− :: AdtDict
127+ :: TagDict
71128 -> Canonical.Expr
72129 -> Result.Result Warning.Warning e ()
73−checkExpression adtDict (A.A region expression) =
130+checkExpression tagDict (A.A region expression) =
74131 let
75132 go =
76− checkExpression adtDict
133+ checkExpression tagDict
77134
78135 go2 a b =
79136 F.traverse_ go [a,b]
80137
81138 goPattern =
82− checkPatterns adtDict region
139+ checkPatterns tagDict region
83140 in
84141 case expression of
142+ E.Literal _ ->
143+ Result.ok ()
144+
145+ E.Var _ ->
146+ Result.ok ()
147+
148+ E.Range low high ->
149+ go low
150+ <* go high
151+
85152 E.ExplicitList listExprs ->
86153 F.traverse_ go listExprs
87154
@@ -95,15 +162,16 @@ checkExpression adtDict (A.A region expression) =
95162 E.App func arg ->
96163 go2 func arg
97164
98− E.MultiIf branches ->
165+ E.MultiIf branches finally ->
99166 F.traverse_ (uncurry go2) branches
167+ <* go finally
100168
101169 E.Let defs body ->
102170 go body
103171 <* F.traverse_ goDef defs
104172 where
105173 goDef (Canonical.Definition pattern expr _) =
106− goPattern [p]
174+ goPattern [pattern]
107175 <* go expr
108176
109177 E.Case expr branches ->
@@ -130,109 +198,130 @@ checkExpression adtDict (A.A region expression) =
130198 E.Record fields ->
131199 F.traverse_ (go . snd) fields
132200
201+ E.Port impl ->
202+ case impl of
203+ E.In _ _ ->
204+ Result.ok ()
205+
206+ E.Out _ expr _ ->
207+ go expr
208+
209+ E.Task _ expr _ ->
210+ go expr
211+
212+ E.GLShader _ _ _ ->
213+ Result.ok ()
214+
215+ E.Crash _ ->
216+ Result.ok ()
217+
133218
134219-- CHECK PATTERNS
135220
136221checkPatterns
137− :: AdtDict
222+ :: TagDict
138223 -> Region.Region
139− -> [Pattern.CanonicalPattern]
224+ -> [P.CanonicalPattern]
140225 -> Result.Result Warning.Warning e ()
141−checkPatterns adtDict region patterns =
142− checkPatternsHelp [P.Anything] patterns
226+checkPatterns tagDict region patterns =
227+ checkPatternsHelp tagDict region [Anything] patterns
143228
144229
145230checkPatternsHelp
146− :: AdtDict
231+ :: TagDict
147232 -> Region.Region
148− -> [P.Pattern]
149− -> [Pattern.CanonicalPattern]
233+ -> [Pattern]
234+ -> [P.CanonicalPattern]
150235 -> Result.Result Warning.Warning e ()
151−checkPatternsHelp adtDict region unhandled patterns =
236+checkPatternsHelp tagDict region unhandled patterns =
152237 case (unhandled, patterns) of
153238 ([], []) ->
154239 return ()
155240
156241 (_:_, []) ->
157− Result.warn region (Inexhaustive unhandled)
242+ Result.warn region Warning.InexhaustivePatternMatch
158243
159− (_, A.A region pattern : remainingPatterns) ->
160− do newUnhandled <- filterPatterns adtDict region pattern unhandled
161− checkPatternsHelp adtDict newUnhandled remainingPatterns
244+ (_, pattern@(A.A localRegion _) : remainingPatterns) ->
245+ do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
246+ checkPatternsHelp tagDict region newUnhandled remainingPatterns
162247
163248
164249filterPatterns
165− :: AdtDict
250+ :: TagDict
166251 -> Region.Region
167− -> P.Pattern
168− -> [P.Pattern]
169− -> Result.Result Warning.Warning e [P.Pattern]
170−filterPatterns adtDict region pattern unhandled =
252+ -> P.CanonicalPattern
253+ -> [Pattern]
254+ -> Result.Result Warning.Warning e [Pattern]
255+filterPatterns tagDict region pattern unhandled =
171256 let
172257 nitPattern =
173− P.fromPattern pattern
258+ fromCanonicalPattern pattern
174259
175260 noIntersection pat =
176261 intersection pat nitPattern == Nothing
177262 in
178− if all noIntersection unhandled
179− then
180− do Result.warn region Redundant
181− return unhandled
182− else
183− do let complementPatterns = complement adtDict nitPattern
184− return $
185− concatMap (\p -> Maybe.mapMaybe (intersection p) complementPatterns) unhandled
263+ if all noIntersection unhandled then
264+ do Result.warn region Warning.RedundantPatternMatch
265+ return unhandled
266+ else
267+ do let complementPatterns = complement tagDict nitPattern
268+ return $
269+ concatMap
270+ (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
271+ unhandled
186272
187273
188274-- PATTERN INTERSECTION
189275
190−intersection :: P.Pattern -> P.Pattern -> Maybe P.Pattern
276+intersection :: Pattern -> Pattern -> Maybe Pattern
191277intersection pattern1 pattern2 =
192278 case (pattern1, pattern2) of
193− (P.Alias _ pattern1', _) ->
279+ (Alias _ pattern1', _) ->
194280 intersection pattern1' pattern2
195281
196− (_, P.Alias _ pattern2') ->
282+ (_, Alias _ pattern2') ->
197283 intersection pattern1 pattern2'
198284
199− (P.Anything, _) ->
285+ (Anything, _) ->
200286 Just pattern2
201287
202− (P.Var _, _) ->
288+ (Var _, _) ->
203289 Just pattern2
204290
205− (_, P.Anything) ->
291+ (_, Anything) ->
206292 Just pattern1
207293
208− (_, P.Var _) ->
294+ (_, Var _) ->
209295 Just pattern1
210296
211− (P.Data ctor1 args1, P.Data ctor2 args2) ->
212− if ctor1 /= ctor2
213− then Nothing
214− else Data ctor1 <$> sequence (zipWith intersection args1 args2)
297+ (Data ctor1 args1, Data ctor2 args2) ->
298+ if ctor1 /= ctor2 then
299+ Nothing
300+ else
301+ Data ctor1 <$> sequence (zipWith intersection args1 args2)
215302
216− -- TODO Assuming the fields are identical.
217− (P.Record _fields, P.Record _) ->
303+ (Record _, Record _) ->
218304 Just pattern1
219305
220− (P.Literal lit1, P.Literal lit2) ->
221− if lit1 == lit2
222− then Just pattern1
223− else Nothing
224−
225− (P.AnythingBut literals, P.Literal lit) ->
226− if Set.member lit literals
227− then Nothing
228− else Just pattern2
229−
230− (P.Literal lit, P.AnythingBut literals) ->
231− if Set.membur lit literals
232− then Nothing
233− else Just pattern1
234−
235− (P.AnythingBut literals1, P.AnythingBut literals2) ->
306+ (Literal lit1, Literal lit2) ->
307+ if lit1 == lit2 then
308+ Just pattern1
309+ else
310+ Nothing
311+
312+ (AnythingBut literals, Literal lit) ->
313+ if Set.member lit literals then
314+ Nothing
315+ else
316+ Just pattern2
317+
318+ (Literal lit, AnythingBut literals) ->
319+ if Set.member lit literals then
320+ Nothing
321+ else
322+ Just pattern1
323+
324+ (AnythingBut literals1, AnythingBut literals2) ->
236325 Just (AnythingBut (Set.union literals1 literals2))
237326
238327 _ ->
@@ -241,64 +330,67 @@ intersection pattern1 pattern2 =
241330
242331-- PATTERN COMPLEMENT
243332
244−complement :: AdtDict -> P.Pattern -> [P.Pattern]
245−complement adtDict nitPattern =
333+complement :: TagDict -> Pattern -> [Pattern]
334+complement tagDict nitPattern =
246335 case nitPattern of
247− P.Record _fields ->
336+ Record _fields ->
248337 []
249338
250− P.Alias _name pattern ->
251− complement adtDict pattern
339+ Alias _name pattern ->
340+ complement tagDict pattern
252341
253− P.Var _name ->
342+ Var _name ->
254343 []
255344
256− P.Anything ->
345+ Anything ->
257346 []
258347
259− P.Literal lit ->
348+ Literal lit ->
260349 [AnythingBut (Set.singleton lit)]
261350
262− P.AnythingBut literals ->
351+ AnythingBut literals ->
263352 map Literal (Set.toList literals)
264353
265− P.Data ctor patterns ->
266− complementData adtDict ctor patterns
354+ Data ctor patterns ->
355+ complementData tagDict ctor patterns
267356
268357
269−complementData :: AdtDict -> Var.Canonical -> [P.Pattern] -> [P.Pattern]
270−complementData adtDict canonicalTag patterns =
358+complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
359+complementData tagDict tag patterns =
271360 let
272− ctors =
273− lookupOtherCtors ctor adtDict
361+ otherTags =
362+ lookupOtherCtors tag tagDict
274363
275− dataComplements =
276− Maybe.mapMaybe (maybeData canonicalTag) ctors
364+ tagComplements =
365+ Maybe.mapMaybe (tagToPattern tag) otherTags
277366
278− numArgs = length patterns
367+ arity =
368+ length patterns
279369
280370 argComplements =
281− concat (zipWith (makeArgComplements adtDict numArgs) [0..] patterns)
371+ concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
282372 in
283− dataComplements ++ argComplements
373+ tagComplements ++ argComplements
284374
285375
286−maybeData :: Var.Canonical -> (String, Module.AdtInfo) -> Maybe P.Pattern
287−maybeData (Var.Canonical home name) (tag, args) =
288− if tag == name
289− then
290− Nothing
291− else
292− Just (P.Data (Var.Canonical home tag) (replicate (length args) P.Anything))
376+tagToPattern :: Var.Canonical -> (Tag, Int) -> Maybe Pattern
377+tagToPattern (Var.Canonical home rootTag) (tag, arity) =
378+ if rootTag == tag then
379+ Nothing
380+ else
381+ Just (Data (Var.Canonical home tag) (replicate arity Anything))
293382
294383
295−makeArgComplements :: AdtDict -> Int -> Int -> P.Pattern -> [P.Pattern]
296−makeArgComplements adtDict numArgs index argPattern =
384+makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
385+makeArgComplements tagDict tag arity index argPattern =
297386 let
298387 complementList =
299− complement adtDict argPattern
388+ complement tagDict argPattern
300389
301− paddedArgs pat =
302− replicate index P.Anything ++ pat : replicate (numArgs - index - 1) P.Anything
390+ padArgs pattern =
391+ replicate index Anything
392+ ++ pattern
393+ : replicate (arity - index - 1) Anything
303394 in
304− map (P.Data ctor . paddedArgs) complementList
395+ map (Data tag . padArgs) complementList
396+