git.iko.soy/elk
on 0e50803 help sign in
elk/src/Nitpick/PatternMatches.hs
390 lines 8.9 kB history raw
1module Nitpick.PatternMatches (patternMatches) where
3import Control.Arrow (second)
4import qualified Data.Foldable as F
5import qualified Data.Map as Map
6import qualified Data.Maybe as Maybe
7import qualified Data.Set as Set
9import qualified AST.Expression.General as E
10import qualified AST.Expression.Canonical as Canonical
11import qualified AST.Helpers as Help
12import qualified AST.Module as Module
13import qualified AST.Module.Name as ModuleName
14import qualified AST.Pattern as Pattern
15import qualified AST.Variable as Var
16import Elm.Utils ((|>))
17import Nitpick.Pattern (Pattern(..), fromCanonicalPattern)
18import qualified Optimize.DecisionTree as DT
19import qualified Reporting.Annotation as A
20import qualified Reporting.Error.Pattern as Error
21import qualified Reporting.Region as Region
22import qualified Reporting.Result as Result
26patternMatches
27 :: Module.Interfaces
28 -> Module.Canonical
29 -> Result.Result w Error.Error DT.VariantDict
30patternMatches interfaces (Module.Module name _ info) =
31 let
32 tagDict =
33 toTagDict interfaces name (Module.unions info)
34 in
35 const (Map.map (Map.map length) tagDict)
36 <$> checkExpression tagDict (Module.program info)
40-- TAG DICT
43type TagDict =
44 Map.Map Var.Home (Map.Map Tag [TagInfo])
47type Tag = String
50data TagInfo = TagInfo
51 { _tag :: Tag
52 , _arity :: Int
53 }
56toTagDict :: Module.Interfaces -> ModuleName.Canonical -> Module.Unions -> TagDict
57toTagDict interfaces localName localUnions =
58 let
59 listTags =
60 [ TagInfo "::" 2
61 , TagInfo "[]" 0
62 ]
64 boolTags =
65 [ TagInfo "True" 0
66 , TagInfo "False" 0
67 ]
69 builtinDict =
70 Map.singleton Var.BuiltIn $
71 Map.fromList
72 [ ("::", listTags)
73 , ("[]", listTags)
74 , ("True", boolTags)
75 , ("False", boolTags)
76 ]
78 interfaceDict =
79 interfaces
80 |> Map.map (toTagMapping . Module.iUnions)
81 |> Map.mapKeysMonotonic Var.Module
82 |> Map.insert (Var.Module localName) (toTagMapping localUnions)
83 in
84 Map.union builtinDict interfaceDict
87toTagMapping :: Module.Unions -> Map.Map Tag [TagInfo]
88toTagMapping adts =
89 let
90 toTagAndArity (_tvars, tagInfoList) =
91 let
92 info = map (\(tag, args) -> TagInfo tag (length args)) tagInfoList
93 in
94 map (second (const info)) tagInfoList
95 in
96 Map.elems adts
97 |> concatMap toTagAndArity
98 |> Map.fromList
101lookupOtherTags :: Var.Canonical -> TagDict -> [TagInfo]
102lookupOtherTags (Var.Canonical home name) tagDict =
103 case Map.lookup name =<< Map.lookup home tagDict of
104 Just otherTags ->
105 otherTags
107 Nothing ->
108 if Help.isTuple name then
109 [ TagInfo name (read (drop 6 name)) ]
110 else
111 error
112 "Since the Nitpick phase happens after canonicalization and type \
113 \inference, it is impossible that a pattern in a case cannot be \
114 \found."
118-- CHECK EXPRESSIONS
121checkExpression
122 :: TagDict
123 -> Canonical.Expr
124 -> Result.Result w Error.Error ()
125checkExpression tagDict (A.A region expression) =
126 let
127 go =
128 checkExpression tagDict
130 go2 a b =
131 go a <* go b
132 in
133 case expression of
134 E.Literal _ ->
135 Result.ok ()
137 E.Var _ ->
138 Result.ok ()
140 E.Range low high ->
141 go2 low high
143 E.ExplicitList listExprs ->
144 F.traverse_ go listExprs
146 E.Binop _ leftExpr rightExpr ->
147 go2 leftExpr rightExpr
149 E.Lambda pattern@(A.A patRegion _) body ->
150 checkPatterns tagDict patRegion Error.Arg [pattern]
151 <* go body
153 E.App func arg ->
154 go2 func arg
156 E.If branches finally ->
157 F.traverse_ (uncurry go2) branches
158 <* go finally
160 E.Let defs body ->
161 go body
162 <* F.traverse_ goDef defs
163 where
164 goDef (Canonical.Def _ pattern@(A.A patRegion _) expr _) =
165 checkPatterns tagDict patRegion Error.LetBound [pattern]
166 <* go expr
168 E.Case expr branches ->
169 go expr
170 <* checkPatterns tagDict region Error.Case (map fst branches)
171 <* F.traverse_ (go . snd) branches
173 E.Data _ctor exprs ->
174 F.traverse_ go exprs
176 E.Access record _field ->
177 go record
179 E.Update record fields ->
180 go record
181 <* F.traverse_ (go . snd) fields
183 E.Record fields ->
184 F.traverse_ (go . snd) fields
186 E.Cmd _ ->
187 Result.ok ()
189 E.Sub _ ->
190 Result.ok ()
192 E.ForeignCmd _ _ ->
193 Result.ok ()
195 E.ForeignSub _ _ ->
196 Result.ok ()
198 E.SaveEnv _ _ ->
199 Result.ok ()
201 E.GLShader _ _ _ ->
202 Result.ok ()
206-- CHECK PATTERNS
209checkPatterns
210 :: TagDict
211 -> Region.Region
212 -> Error.Origin
213 -> [Pattern.Canonical]
214 -> Result.Result w Error.Error ()
215checkPatterns tagDict region origin patterns =
216 checkPatternsHelp tagDict region origin [Anything] patterns
219checkPatternsHelp
220 :: TagDict
221 -> Region.Region
222 -> Error.Origin
223 -> [Pattern]
224 -> [Pattern.Canonical]
225 -> Result.Result w Error.Error ()
226checkPatternsHelp tagDict region origin unhandled patterns =
227 case (unhandled, patterns) of
228 ([], []) ->
229 return ()
231 (_:_, []) ->
232 Result.throw region (Error.Incomplete origin unhandled)
234 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
235 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
236 checkPatternsHelp tagDict region origin newUnhandled remainingPatterns
239filterPatterns
240 :: TagDict
241 -> Region.Region
242 -> Pattern.Canonical
243 -> [Pattern]
244 -> Result.Result w Error.Error [Pattern]
245filterPatterns tagDict region pattern unhandled =
246 let
247 nitPattern =
248 fromCanonicalPattern pattern
250 noIntersection pat =
251 intersection pat nitPattern == Nothing
252 in
253 if all noIntersection unhandled then
254 Result.throw region Error.Redundant
256 else
257 do let complementPatterns = complement tagDict nitPattern
258 return $
259 concatMap
260 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
261 unhandled
265-- PATTERN INTERSECTION
268intersection :: Pattern -> Pattern -> Maybe Pattern
269intersection pattern1 pattern2 =
270 case (pattern1, pattern2) of
271 (Alias _ pattern1', _) ->
272 intersection pattern1' pattern2
274 (_, Alias _ pattern2') ->
275 intersection pattern1 pattern2'
277 (Anything, _) ->
278 Just pattern2
280 (Var _, _) ->
281 Just pattern2
283 (_, Anything) ->
284 Just pattern1
286 (_, Var _) ->
287 Just pattern1
289 (Data ctor1 args1, Data ctor2 args2) ->
290 if ctor1 /= ctor2 then
291 Nothing
292 else
293 Data ctor1 <$> sequence (zipWith intersection args1 args2)
295 (Record _, Record _) ->
296 Just pattern1
298 (Literal lit1, Literal lit2) ->
299 if lit1 == lit2 then
300 Just pattern1
301 else
302 Nothing
304 (AnythingBut literals, Literal lit) ->
305 if Set.member lit literals then
306 Nothing
307 else
308 Just pattern2
310 (Literal lit, AnythingBut literals) ->
311 if Set.member lit literals then
312 Nothing
313 else
314 Just pattern1
316 (AnythingBut literals1, AnythingBut literals2) ->
317 Just (AnythingBut (Set.union literals1 literals2))
319 _ ->
320 Nothing
324-- PATTERN COMPLEMENT
327complement :: TagDict -> Pattern -> [Pattern]
328complement tagDict nitPattern =
329 case nitPattern of
330 Record _fields ->
331 []
333 Alias _name pattern ->
334 complement tagDict pattern
336 Var _name ->
337 []
339 Anything ->
340 []
342 Literal lit ->
343 [AnythingBut (Set.singleton lit)]
345 AnythingBut literals ->
346 map Literal (Set.toList literals)
348 Data ctor patterns ->
349 complementData tagDict ctor patterns
352complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
353complementData tagDict tag patterns =
354 let
355 otherTags =
356 lookupOtherTags tag tagDict
358 tagComplements =
359 Maybe.mapMaybe (tagToPattern tag) otherTags
361 arity =
362 length patterns
364 argComplements =
365 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
366 in
367 tagComplements ++ argComplements
370tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
371tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =
372 if rootTag == tag then
373 Nothing
374 else
375 Just (Data (Var.Canonical home tag) (replicate arity Anything))
378makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
379makeArgComplements tagDict tag arity index argPattern =
380 let
381 complementList =
382 complement tagDict argPattern
384 padArgs pattern =
385 replicate index Anything
386 ++ pattern
387 : replicate (arity - index - 1) Anything
388 in
389 map (Data tag . padArgs) complementList