git.iko.soy/elk
on 0ff8a91 help sign in
elk/src/Nitpick/PatternMatches.hs
386 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
26type Result warning a =
27 Result.Result () warning Error.Error a
30patternMatches :: Module.Interfaces -> Module.Canonical -> Result wrn DT.VariantDict
31patternMatches interfaces (Module.Module name _ info) =
32 let
33 tagDict =
34 toTagDict interfaces name (Module.unions info)
35 in
36 const (Map.map (Map.map length) tagDict)
37 <$> checkExpression tagDict (Module.program info)
41-- TAG DICT
44type TagDict =
45 Map.Map Var.Home (Map.Map Tag [TagInfo])
48type Tag = String
51data TagInfo = TagInfo
52 { _tag :: Tag
53 , _arity :: Int
54 }
57toTagDict :: Module.Interfaces -> ModuleName.Canonical -> Module.Unions -> TagDict
58toTagDict interfaces localName localUnions =
59 let
60 listTags =
61 [ TagInfo "::" 2
62 , TagInfo "[]" 0
63 ]
65 boolTags =
66 [ TagInfo "True" 0
67 , TagInfo "False" 0
68 ]
70 builtinDict =
71 Map.singleton Var.BuiltIn $
72 Map.fromList
73 [ ("::", listTags)
74 , ("[]", listTags)
75 , ("True", boolTags)
76 , ("False", boolTags)
77 ]
79 interfaceDict =
80 interfaces
81 |> Map.map (toTagMapping . Module.iUnions)
82 |> Map.mapKeysMonotonic Var.Module
83 |> Map.insert (Var.Module localName) (toTagMapping localUnions)
84 in
85 Map.union builtinDict interfaceDict
88toTagMapping :: Module.Unions -> Map.Map Tag [TagInfo]
89toTagMapping adts =
90 let
91 toTagAndArity (_tvars, tagInfoList) =
92 let
93 info = map (\(tag, args) -> TagInfo tag (length args)) tagInfoList
94 in
95 map (second (const info)) tagInfoList
96 in
97 Map.elems adts
98 |> concatMap toTagAndArity
99 |> Map.fromList
102lookupOtherTags :: Var.Canonical -> TagDict -> [TagInfo]
103lookupOtherTags (Var.Canonical home name) tagDict =
104 case Map.lookup name =<< Map.lookup home tagDict of
105 Just otherTags ->
106 otherTags
108 Nothing ->
109 if Help.isTuple name then
110 [ TagInfo name (read (drop 6 name)) ]
111 else
112 error
113 "Since the Nitpick phase happens after canonicalization and type \
114 \inference, it is impossible that a pattern in a case cannot be \
115 \found."
119-- CHECK EXPRESSIONS
122checkExpression :: TagDict -> Canonical.Expr -> Result wrn ()
123checkExpression tagDict (A.A region expression) =
124 let
125 go =
126 checkExpression tagDict
128 go2 a b =
129 go a <* go b
130 in
131 case expression of
132 E.Literal _ ->
133 Result.ok ()
135 E.Var _ ->
136 Result.ok ()
138 E.Range low high ->
139 go2 low high
141 E.ExplicitList listExprs ->
142 F.traverse_ go listExprs
144 E.Binop _ leftExpr rightExpr ->
145 go2 leftExpr rightExpr
147 E.Lambda pattern@(A.A patRegion _) body ->
148 checkPatterns tagDict patRegion Error.Arg [pattern]
149 <* go body
151 E.App func arg ->
152 go2 func arg
154 E.If branches finally ->
155 F.traverse_ (uncurry go2) branches
156 <* go finally
158 E.Let defs body ->
159 go body
160 <* F.traverse_ goDef defs
161 where
162 goDef (Canonical.Def _ pattern@(A.A patRegion _) expr _) =
163 checkPatterns tagDict patRegion Error.LetBound [pattern]
164 <* go expr
166 E.Case expr branches ->
167 go expr
168 <* checkPatterns tagDict region Error.Case (map fst branches)
169 <* F.traverse_ (go . snd) branches
171 E.Data _ctor exprs ->
172 F.traverse_ go exprs
174 E.Access record _field ->
175 go record
177 E.Update record fields ->
178 go record
179 <* F.traverse_ (go . snd) fields
181 E.Record fields ->
182 F.traverse_ (go . snd) fields
184 E.Cmd _ ->
185 Result.ok ()
187 E.Sub _ ->
188 Result.ok ()
190 E.ForeignCmd _ _ ->
191 Result.ok ()
193 E.ForeignSub _ _ ->
194 Result.ok ()
196 E.Program _ _ ->
197 error "DANGER - Program AST nodes should not be in Nitpick.PatternMatches."
199 E.SaveEnv _ _ ->
200 Result.ok ()
202 E.GLShader _ _ _ ->
203 Result.ok ()
207-- CHECK PATTERNS
210checkPatterns :: TagDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()
211checkPatterns tagDict region origin patterns =
212 checkPatternsHelp tagDict region origin [Anything] patterns
215checkPatternsHelp
216 :: TagDict
217 -> Region.Region
218 -> Error.Origin
219 -> [Pattern]
220 -> [Pattern.Canonical]
221 -> Result wrn ()
222checkPatternsHelp tagDict region origin unhandled patterns =
223 case (unhandled, patterns) of
224 ([], []) ->
225 return ()
227 (_:_, []) ->
228 Result.throw region (Error.Incomplete origin unhandled)
230 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
231 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
232 checkPatternsHelp tagDict region origin newUnhandled remainingPatterns
235filterPatterns
236 :: TagDict
237 -> Region.Region
238 -> Pattern.Canonical
239 -> [Pattern]
240 -> Result wrn [Pattern]
241filterPatterns tagDict region pattern unhandled =
242 let
243 nitPattern =
244 fromCanonicalPattern pattern
246 noIntersection pat =
247 intersection pat nitPattern == Nothing
248 in
249 if all noIntersection unhandled then
250 Result.throw region Error.Redundant
252 else
253 do let complementPatterns = complement tagDict nitPattern
254 return $
255 concatMap
256 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
257 unhandled
261-- PATTERN INTERSECTION
264intersection :: Pattern -> Pattern -> Maybe Pattern
265intersection pattern1 pattern2 =
266 case (pattern1, pattern2) of
267 (Alias _ pattern1', _) ->
268 intersection pattern1' pattern2
270 (_, Alias _ pattern2') ->
271 intersection pattern1 pattern2'
273 (Anything, _) ->
274 Just pattern2
276 (Var _, _) ->
277 Just pattern2
279 (_, Anything) ->
280 Just pattern1
282 (_, Var _) ->
283 Just pattern1
285 (Data ctor1 args1, Data ctor2 args2) ->
286 if ctor1 /= ctor2 then
287 Nothing
288 else
289 Data ctor1 <$> sequence (zipWith intersection args1 args2)
291 (Record _, Record _) ->
292 Just pattern1
294 (Literal lit1, Literal lit2) ->
295 if lit1 == lit2 then
296 Just pattern1
297 else
298 Nothing
300 (AnythingBut literals, Literal lit) ->
301 if Set.member lit literals then
302 Nothing
303 else
304 Just pattern2
306 (Literal lit, AnythingBut literals) ->
307 if Set.member lit literals then
308 Nothing
309 else
310 Just pattern1
312 (AnythingBut literals1, AnythingBut literals2) ->
313 Just (AnythingBut (Set.union literals1 literals2))
315 _ ->
316 Nothing
320-- PATTERN COMPLEMENT
323complement :: TagDict -> Pattern -> [Pattern]
324complement tagDict nitPattern =
325 case nitPattern of
326 Record _fields ->
327 []
329 Alias _name pattern ->
330 complement tagDict pattern
332 Var _name ->
333 []
335 Anything ->
336 []
338 Literal lit ->
339 [AnythingBut (Set.singleton lit)]
341 AnythingBut literals ->
342 map Literal (Set.toList literals)
344 Data ctor patterns ->
345 complementData tagDict ctor patterns
348complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
349complementData tagDict tag patterns =
350 let
351 otherTags =
352 lookupOtherTags tag tagDict
354 tagComplements =
355 Maybe.mapMaybe (tagToPattern tag) otherTags
357 arity =
358 length patterns
360 argComplements =
361 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
362 in
363 tagComplements ++ argComplements
366tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
367tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =
368 if rootTag == tag then
369 Nothing
370 else
371 Just (Data (Var.Canonical home tag) (replicate arity Anything))
374makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
375makeArgComplements tagDict tag arity index argPattern =
376 let
377 complementList =
378 complement tagDict argPattern
380 padArgs pattern =
381 replicate index Anything
382 ++ pattern
383 : replicate (arity - index - 1) Anything
384 in
385 map (Data tag . padArgs) complementList