git.iko.soy/elk
on 0206049 help sign in
elk/src/Nitpick/PatternMatches.hs
377 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
25patternMatches
26 :: Module.Interfaces
27 -> Module.CanonicalModule
28 -> Result.Result w Error.Error DT.VariantDict
29patternMatches interfaces modul =
30 let
31 name = Module.name modul
32 body = Module.body modul
33 tagDict =
34 toTagDict interfaces name (Module.datatypes body)
35 in
36 const (Map.map (Map.map length) tagDict)
37 <$> checkExpression tagDict (Module.program body)
40-- TAG DICT
42type TagDict =
43 Map.Map Var.Home (Map.Map Tag [TagInfo])
46type Tag = String
49data TagInfo = TagInfo
50 { _tag :: Tag
51 , _arity :: Int
52 }
55toTagDict :: Module.Interfaces -> ModuleName.Canonical -> Module.ADTs -> TagDict
56toTagDict interfaces localName localAdts =
57 let
58 listTags =
59 [ TagInfo "::" 2
60 , TagInfo "[]" 0
61 ]
63 boolTags =
64 [ TagInfo "True" 0
65 , TagInfo "False" 0
66 ]
68 builtinDict =
69 Map.singleton Var.BuiltIn $
70 Map.fromList
71 [ ("::", listTags)
72 , ("[]", listTags)
73 , ("True", boolTags)
74 , ("False", boolTags)
75 ]
77 interfaceDict =
78 interfaces
79 |> Map.map (toTagMapping . Module.iAdts)
80 |> Map.mapKeysMonotonic Var.Module
81 |> Map.insert (Var.Module localName) (toTagMapping localAdts)
82 in
83 Map.union builtinDict interfaceDict
86toTagMapping :: Module.ADTs -> Map.Map Tag [TagInfo]
87toTagMapping adts =
88 let
89 toTagAndArity (_tvars, tagInfoList) =
90 let
91 info = map (\(tag, args) -> TagInfo tag (length args)) tagInfoList
92 in
93 map (second (const info)) tagInfoList
94 in
95 Map.elems adts
96 |> concatMap toTagAndArity
97 |> Map.fromList
100lookupOtherTags :: Var.Canonical -> TagDict -> [TagInfo]
101lookupOtherTags (Var.Canonical home name) tagDict =
102 case Map.lookup name =<< Map.lookup home tagDict of
103 Just otherTags ->
104 otherTags
106 Nothing ->
107 if Help.isTuple name then
108 [ TagInfo name (read (drop 6 name)) ]
109 else
110 error
111 "Since the Nitpick phase happens after canonicalization and type \
112 \inference, it is impossible that a pattern in a case cannot be \
113 \found."
116-- CHECK EXPRESSIONS
118checkExpression
119 :: TagDict
120 -> Canonical.Expr
121 -> Result.Result w Error.Error ()
122checkExpression tagDict (A.A region expression) =
123 let
124 go =
125 checkExpression tagDict
127 go2 a b =
128 go a <* go b
129 in
130 case expression of
131 E.Literal _ ->
132 Result.ok ()
134 E.Var _ ->
135 Result.ok ()
137 E.Range low high ->
138 go2 low high
140 E.ExplicitList listExprs ->
141 F.traverse_ go listExprs
143 E.Binop _ leftExpr rightExpr ->
144 go2 leftExpr rightExpr
146 E.Lambda pattern@(A.A patRegion _) body ->
147 checkPatterns tagDict patRegion Error.Arg [pattern]
148 <* go body
150 E.App func arg ->
151 go2 func arg
153 E.If branches finally ->
154 F.traverse_ (uncurry go2) branches
155 <* go finally
157 E.Let defs body ->
158 go body
159 <* F.traverse_ goDef defs
160 where
161 goDef (Canonical.Definition _ pattern@(A.A patRegion _) expr _) =
162 checkPatterns tagDict patRegion Error.LetBound [pattern]
163 <* go expr
165 E.Case expr branches ->
166 go expr
167 <* checkPatterns tagDict region Error.Case (map fst branches)
168 <* F.traverse_ (go . snd) branches
170 E.Data _ctor exprs ->
171 F.traverse_ go exprs
173 E.Access record _field ->
174 go record
176 E.Update record fields ->
177 go record
178 <* F.traverse_ (go . snd) fields
180 E.Record fields ->
181 F.traverse_ (go . snd) fields
183 E.Port impl ->
184 case impl of
185 E.In _ _ ->
186 Result.ok ()
188 E.Out _ expr _ ->
189 go expr
191 E.Task _ expr _ ->
192 go expr
194 E.GLShader _ _ _ ->
195 Result.ok ()
198-- CHECK PATTERNS
200checkPatterns
201 :: TagDict
202 -> Region.Region
203 -> Error.Origin
204 -> [Pattern.CanonicalPattern]
205 -> Result.Result w Error.Error ()
206checkPatterns tagDict region origin patterns =
207 checkPatternsHelp tagDict region origin [Anything] patterns
210checkPatternsHelp
211 :: TagDict
212 -> Region.Region
213 -> Error.Origin
214 -> [Pattern]
215 -> [Pattern.CanonicalPattern]
216 -> Result.Result w Error.Error ()
217checkPatternsHelp tagDict region origin unhandled patterns =
218 case (unhandled, patterns) of
219 ([], []) ->
220 return ()
222 (_:_, []) ->
223 Result.throw region (Error.Incomplete origin unhandled)
225 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
226 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
227 checkPatternsHelp tagDict region origin newUnhandled remainingPatterns
230filterPatterns
231 :: TagDict
232 -> Region.Region
233 -> Pattern.CanonicalPattern
234 -> [Pattern]
235 -> Result.Result w Error.Error [Pattern]
236filterPatterns tagDict region pattern unhandled =
237 let
238 nitPattern =
239 fromCanonicalPattern pattern
241 noIntersection pat =
242 intersection pat nitPattern == Nothing
243 in
244 if all noIntersection unhandled then
245 Result.throw region Error.Redundant
247 else
248 do let complementPatterns = complement tagDict nitPattern
249 return $
250 concatMap
251 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
252 unhandled
255-- PATTERN INTERSECTION
257intersection :: Pattern -> Pattern -> Maybe Pattern
258intersection pattern1 pattern2 =
259 case (pattern1, pattern2) of
260 (Alias _ pattern1', _) ->
261 intersection pattern1' pattern2
263 (_, Alias _ pattern2') ->
264 intersection pattern1 pattern2'
266 (Anything, _) ->
267 Just pattern2
269 (Var _, _) ->
270 Just pattern2
272 (_, Anything) ->
273 Just pattern1
275 (_, Var _) ->
276 Just pattern1
278 (Data ctor1 args1, Data ctor2 args2) ->
279 if ctor1 /= ctor2 then
280 Nothing
281 else
282 Data ctor1 <$> sequence (zipWith intersection args1 args2)
284 (Record _, Record _) ->
285 Just pattern1
287 (Literal lit1, Literal lit2) ->
288 if lit1 == lit2 then
289 Just pattern1
290 else
291 Nothing
293 (AnythingBut literals, Literal lit) ->
294 if Set.member lit literals then
295 Nothing
296 else
297 Just pattern2
299 (Literal lit, AnythingBut literals) ->
300 if Set.member lit literals then
301 Nothing
302 else
303 Just pattern1
305 (AnythingBut literals1, AnythingBut literals2) ->
306 Just (AnythingBut (Set.union literals1 literals2))
308 _ ->
309 Nothing
312-- PATTERN COMPLEMENT
314complement :: TagDict -> Pattern -> [Pattern]
315complement tagDict nitPattern =
316 case nitPattern of
317 Record _fields ->
318 []
320 Alias _name pattern ->
321 complement tagDict pattern
323 Var _name ->
324 []
326 Anything ->
327 []
329 Literal lit ->
330 [AnythingBut (Set.singleton lit)]
332 AnythingBut literals ->
333 map Literal (Set.toList literals)
335 Data ctor patterns ->
336 complementData tagDict ctor patterns
339complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
340complementData tagDict tag patterns =
341 let
342 otherTags =
343 lookupOtherTags tag tagDict
345 tagComplements =
346 Maybe.mapMaybe (tagToPattern tag) otherTags
348 arity =
349 length patterns
351 argComplements =
352 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
353 in
354 tagComplements ++ argComplements
357tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
358tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =
359 if rootTag == tag then
360 Nothing
361 else
362 Just (Data (Var.Canonical home tag) (replicate arity Anything))
365makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
366makeArgComplements tagDict tag arity index argPattern =
367 let
368 complementList =
369 complement tagDict argPattern
371 padArgs pattern =
372 replicate index Anything
373 ++ pattern
374 : replicate (arity - index - 1) Anything
375 in
376 map (Data tag . padArgs) complementList