@@ -1,305 +0,0 @@
1−module Nitpick.PatternMatches (patternMatches) where
2−
3−import Control.Applicative ((<$>), (<*))
4−import Control.Monad.Except (forM, liftM)
5−import qualified Data.Foldable as F
6−import qualified Data.Map as Map
7−import qualified Data.Maybe as Maybe
8−import qualified Data.Set as Set
9−
10−import qualified AST.Expression.General as E
11−import qualified AST.Expression.Canonical as Canonical
12−import qualified AST.Module as Module
13−import qualified AST.Pattern as Pattern
14−import qualified AST.Variable as Var
15−import Elm.Utils ((|>))
16−import qualified Nitpick.Pattern as P
17−import qualified Reporting.Annotation as A
18−import qualified Reporting.Error.Nitpick as Error
19−import qualified Reporting.Region as Region
20−import qualified Reporting.Result as Result
21−import qualified Reporting.Warning.Nitpick as Warning
22−
23−
24−patternMatches
25− :: Module.Interfaces
26− -> Module.CanonicalBody
27− -> Result.Result Warning.Warning e ()
28−patternMatches interfaces body =
29− checkExpression (toAdtDict interfaces) (Module.program body)
30−
31−
32−-- ADT DICT
33−
34−type AdtDict =
35− Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
36−
37−
38−toAdtDict :: Module.Interfaces -> AdtDict
39−toAdtDict =
40− let
41− -- TODO
42− builtinDict =
43− Map.empty
44−
45− interfaceDict =
46− interfaces
47− |> Map.map Module.iAdts
48− |> Map.mapKeysMonotonic Var.Module
49− in
50− Map.union builtinDict interfaceDict
51−
52−
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"
62−
63− Just (_tvars, ctors) ->
64− ctors
65−
66−
67−-- CHECK EXPRESSIONS
68−
69−checkExpression
70− :: AdtDict
71− -> Canonical.Expr
72− -> Result.Result Warning.Warning e ()
73−checkExpression adtDict (A.A region expression) =
74− let
75− go =
76− checkExpression adtDict
77−
78− go2 a b =
79− F.traverse_ go [a,b]
80−
81− goPattern =
82− checkPatterns adtDict region
83− in
84− case expression of
85− E.ExplicitList listExprs ->
86− F.traverse_ go listExprs
87−
88− E.Binop _ leftExpr rightExpr ->
89− go2 leftExpr rightExpr
90−
91− E.Lambda pattern body ->
92− goPattern [pattern]
93− <* go body
94−
95− E.App func arg ->
96− go2 func arg
97−
98− E.MultiIf branches ->
99− F.traverse_ (uncurry go2) branches
100−
101− E.Let defs body ->
102− go body
103− <* F.traverse_ goDef defs
104− where
105− goDef (Canonical.Definition pattern expr _) =
106− goPattern [p]
107− <* go expr
108−
109− E.Case expr branches ->
110− go expr
111− <* goPattern (map fst branches)
112− <* F.traverse_ (go . snd) branches
113−
114− E.Data _ctor exprs ->
115− F.traverse_ go exprs
116−
117− E.Access record _field ->
118− go record
119−
120− E.Remove record _field ->
121− go record
122−
123− E.Insert record _field value ->
124− go2 record value
125−
126− E.Modify record fields ->
127− go record
128− <* F.traverse_ (go . snd) fields
129−
130− E.Record fields ->
131− F.traverse_ (go . snd) fields
132−
133−
134−-- CHECK PATTERNS
135−
136−checkPatterns
137− :: AdtDict
138− -> Region.Region
139− -> [Pattern.CanonicalPattern]
140− -> Result.Result Warning.Warning e ()
141−checkPatterns adtDict region patterns =
142− checkPatternsHelp [P.Anything] patterns
143−
144−
145−checkPatternsHelp
146− :: AdtDict
147− -> Region.Region
148− -> [P.Pattern]
149− -> [Pattern.CanonicalPattern]
150− -> Result.Result Warning.Warning e ()
151−checkPatternsHelp adtDict region unhandled patterns =
152− case (unhandled, patterns) of
153− ([], []) ->
154− return ()
155−
156− (_:_, []) ->
157− Result.warn region (Inexhaustive unhandled)
158−
159− (_, A.A region pattern : remainingPatterns) ->
160− do newUnhandled <- filterPatterns adtDict region pattern unhandled
161− checkPatternsHelp adtDict newUnhandled remainingPatterns
162−
163−
164−filterPatterns
165− :: AdtDict
166− -> Region.Region
167− -> P.Pattern
168− -> [P.Pattern]
169− -> Result.Result Warning.Warning e [P.Pattern]
170−filterPatterns adtDict region pattern unhandled =
171− let
172− nitPattern =
173− P.fromPattern pattern
174−
175− noIntersection pat =
176− intersection pat nitPattern == Nothing
177− 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
186−
187−
188−-- PATTERN INTERSECTION
189−
190−intersection :: P.Pattern -> P.Pattern -> Maybe P.Pattern
191−intersection pattern1 pattern2 =
192− case (pattern1, pattern2) of
193− (P.Alias _ pattern1', _) ->
194− intersection pattern1' pattern2
195−
196− (_, P.Alias _ pattern2') ->
197− intersection pattern1 pattern2'
198−
199− (P.Anything, _) ->
200− Just pattern2
201−
202− (P.Var _, _) ->
203− Just pattern2
204−
205− (_, P.Anything) ->
206− Just pattern1
207−
208− (_, P.Var _) ->
209− Just pattern1
210−
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)
215−
216− -- TODO Assuming the fields are identical.
217− (P.Record _fields, P.Record _) ->
218− Just pattern1
219−
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) ->
236− Just (AnythingBut (Set.union literals1 literals2))
237−
238− _ ->
239− Nothing
240−
241−
242−-- PATTERN COMPLEMENT
243−
244−complement :: AdtDict -> P.Pattern -> [P.Pattern]
245−complement adtDict nitPattern =
246− case nitPattern of
247− P.Record _fields ->
248− []
249−
250− P.Alias _name pattern ->
251− complement adtDict pattern
252−
253− P.Var _name ->
254− []
255−
256− P.Anything ->
257− []
258−
259− P.Literal lit ->
260− [AnythingBut (Set.singleton lit)]
261−
262− P.AnythingBut literals ->
263− map Literal (Set.toList literals)
264−
265− P.Data ctor patterns ->
266− complementData adtDict ctor patterns
267−
268−
269−complementData :: AdtDict -> Var.Canonical -> [P.Pattern] -> [P.Pattern]
270−complementData adtDict canonicalTag patterns =
271− let
272− ctors =
273− lookupOtherCtors ctor adtDict
274−
275− dataComplements =
276− Maybe.mapMaybe (maybeData canonicalTag) ctors
277−
278− numArgs = length patterns
279−
280− argComplements =
281− concat (zipWith (makeArgComplements adtDict numArgs) [0..] patterns)
282− in
283− dataComplements ++ argComplements
284−
285−
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))
293−
294−
295−makeArgComplements :: AdtDict -> Int -> Int -> P.Pattern -> [P.Pattern]
296−makeArgComplements adtDict numArgs index argPattern =
297− let
298− complementList =
299− complement adtDict argPattern
300−
301− paddedArgs pat =
302− replicate index P.Anything ++ pat : replicate (numArgs - index - 1) P.Anything
303− in
304− map (P.Data ctor . paddedArgs) complementList
305−