git.iko.soy/elk
on 3bd0d85 help sign in
elk/src/Nitpick/PatternMatches.hs
376 lines 8.7 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.unions body)
35 in
36 const (Map.map (Map.map length) tagDict)
37 <$> checkExpression tagDict (Module.program body)
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
123 :: TagDict
124 -> Canonical.Expr
125 -> Result.Result w Error.Error ()
126checkExpression tagDict (A.A region expression) =
127 let
128 go =
129 checkExpression tagDict
131 go2 a b =
132 go a <* go b
133 in
134 case expression of
135 E.Literal _ ->
136 Result.ok ()
138 E.Var _ ->
139 Result.ok ()
141 E.Range low high ->
142 go2 low high
144 E.ExplicitList listExprs ->
145 F.traverse_ go listExprs
147 E.Binop _ leftExpr rightExpr ->
148 go2 leftExpr rightExpr
150 E.Lambda pattern@(A.A patRegion _) body ->
151 checkPatterns tagDict patRegion Error.Arg [pattern]
152 <* go body
154 E.App func arg ->
155 go2 func arg
157 E.If branches finally ->
158 F.traverse_ (uncurry go2) branches
159 <* go finally
161 E.Let defs body ->
162 go body
163 <* F.traverse_ goDef defs
164 where
165 goDef (Canonical.Definition _ pattern@(A.A patRegion _) expr _) =
166 checkPatterns tagDict patRegion Error.LetBound [pattern]
167 <* go expr
169 E.Case expr branches ->
170 go expr
171 <* checkPatterns tagDict region Error.Case (map fst branches)
172 <* F.traverse_ (go . snd) branches
174 E.Data _ctor exprs ->
175 F.traverse_ go exprs
177 E.Access record _field ->
178 go record
180 E.Update record fields ->
181 go record
182 <* F.traverse_ (go . snd) fields
184 E.Record fields ->
185 F.traverse_ (go . snd) fields
187 E.GLShader _ _ _ ->
188 Result.ok ()
192-- CHECK PATTERNS
195checkPatterns
196 :: TagDict
197 -> Region.Region
198 -> Error.Origin
199 -> [Pattern.Canonical]
200 -> Result.Result w Error.Error ()
201checkPatterns tagDict region origin patterns =
202 checkPatternsHelp tagDict region origin [Anything] patterns
205checkPatternsHelp
206 :: TagDict
207 -> Region.Region
208 -> Error.Origin
209 -> [Pattern]
210 -> [Pattern.Canonical]
211 -> Result.Result w Error.Error ()
212checkPatternsHelp tagDict region origin unhandled patterns =
213 case (unhandled, patterns) of
214 ([], []) ->
215 return ()
217 (_:_, []) ->
218 Result.throw region (Error.Incomplete origin unhandled)
220 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
221 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
222 checkPatternsHelp tagDict region origin newUnhandled remainingPatterns
225filterPatterns
226 :: TagDict
227 -> Region.Region
228 -> Pattern.Canonical
229 -> [Pattern]
230 -> Result.Result w Error.Error [Pattern]
231filterPatterns tagDict region pattern unhandled =
232 let
233 nitPattern =
234 fromCanonicalPattern pattern
236 noIntersection pat =
237 intersection pat nitPattern == Nothing
238 in
239 if all noIntersection unhandled then
240 Result.throw region Error.Redundant
242 else
243 do let complementPatterns = complement tagDict nitPattern
244 return $
245 concatMap
246 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
247 unhandled
251-- PATTERN INTERSECTION
254intersection :: Pattern -> Pattern -> Maybe Pattern
255intersection pattern1 pattern2 =
256 case (pattern1, pattern2) of
257 (Alias _ pattern1', _) ->
258 intersection pattern1' pattern2
260 (_, Alias _ pattern2') ->
261 intersection pattern1 pattern2'
263 (Anything, _) ->
264 Just pattern2
266 (Var _, _) ->
267 Just pattern2
269 (_, Anything) ->
270 Just pattern1
272 (_, Var _) ->
273 Just pattern1
275 (Data ctor1 args1, Data ctor2 args2) ->
276 if ctor1 /= ctor2 then
277 Nothing
278 else
279 Data ctor1 <$> sequence (zipWith intersection args1 args2)
281 (Record _, Record _) ->
282 Just pattern1
284 (Literal lit1, Literal lit2) ->
285 if lit1 == lit2 then
286 Just pattern1
287 else
288 Nothing
290 (AnythingBut literals, Literal lit) ->
291 if Set.member lit literals then
292 Nothing
293 else
294 Just pattern2
296 (Literal lit, AnythingBut literals) ->
297 if Set.member lit literals then
298 Nothing
299 else
300 Just pattern1
302 (AnythingBut literals1, AnythingBut literals2) ->
303 Just (AnythingBut (Set.union literals1 literals2))
305 _ ->
306 Nothing
310-- PATTERN COMPLEMENT
313complement :: TagDict -> Pattern -> [Pattern]
314complement tagDict nitPattern =
315 case nitPattern of
316 Record _fields ->
317 []
319 Alias _name pattern ->
320 complement tagDict pattern
322 Var _name ->
323 []
325 Anything ->
326 []
328 Literal lit ->
329 [AnythingBut (Set.singleton lit)]
331 AnythingBut literals ->
332 map Literal (Set.toList literals)
334 Data ctor patterns ->
335 complementData tagDict ctor patterns
338complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
339complementData tagDict tag patterns =
340 let
341 otherTags =
342 lookupOtherTags tag tagDict
344 tagComplements =
345 Maybe.mapMaybe (tagToPattern tag) otherTags
347 arity =
348 length patterns
350 argComplements =
351 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
352 in
353 tagComplements ++ argComplements
356tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
357tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =
358 if rootTag == tag then
359 Nothing
360 else
361 Just (Data (Var.Canonical home tag) (replicate arity Anything))
364makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
365makeArgComplements tagDict tag arity index argPattern =
366 let
367 complementList =
368 complement tagDict argPattern
370 padArgs pattern =
371 replicate index Anything
372 ++ pattern
373 : replicate (arity - index - 1) Anything
374 in
375 map (Data tag . padArgs) complementList