git.iko.soy/elk
on db0d6cd help sign in
elk/src/Nitpick/PatternMatches.hs
383 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.ExplicitList listExprs ->
139 F.traverse_ go listExprs
141 E.Binop _ leftExpr rightExpr ->
142 go2 leftExpr rightExpr
144 E.Lambda pattern@(A.A patRegion _) body ->
145 checkPatterns tagDict patRegion Error.Arg [pattern]
146 <* go body
148 E.App func arg ->
149 go2 func arg
151 E.If branches finally ->
152 F.traverse_ (uncurry go2) branches
153 <* go finally
155 E.Let defs body ->
156 go body
157 <* F.traverse_ goDef defs
158 where
159 goDef (Canonical.Def _ pattern@(A.A patRegion _) expr _) =
160 checkPatterns tagDict patRegion Error.LetBound [pattern]
161 <* go expr
163 E.Case expr branches ->
164 go expr
165 <* checkPatterns tagDict region Error.Case (map fst branches)
166 <* F.traverse_ (go . snd) branches
168 E.Data _ctor exprs ->
169 F.traverse_ go exprs
171 E.Access record _field ->
172 go record
174 E.Update record fields ->
175 go record
176 <* F.traverse_ (go . snd) fields
178 E.Record fields ->
179 F.traverse_ (go . snd) fields
181 E.Cmd _ ->
182 Result.ok ()
184 E.Sub _ ->
185 Result.ok ()
187 E.OutgoingPort _ _ ->
188 Result.ok ()
190 E.IncomingPort _ _ ->
191 Result.ok ()
193 E.Program _ _ ->
194 error "DANGER - Program AST nodes should not be in Nitpick.PatternMatches."
196 E.SaveEnv _ _ ->
197 Result.ok ()
199 E.GLShader _ _ _ ->
200 Result.ok ()
204-- CHECK PATTERNS
207checkPatterns :: TagDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()
208checkPatterns tagDict region origin patterns =
209 checkPatternsHelp tagDict region origin [Anything] patterns
212checkPatternsHelp
213 :: TagDict
214 -> Region.Region
215 -> Error.Origin
216 -> [Pattern]
217 -> [Pattern.Canonical]
218 -> Result wrn ()
219checkPatternsHelp tagDict region origin unhandled patterns =
220 case (unhandled, patterns) of
221 ([], []) ->
222 return ()
224 (_:_, []) ->
225 Result.throw region (Error.Incomplete origin unhandled)
227 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
228 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
229 checkPatternsHelp tagDict region origin newUnhandled remainingPatterns
232filterPatterns
233 :: TagDict
234 -> Region.Region
235 -> Pattern.Canonical
236 -> [Pattern]
237 -> Result wrn [Pattern]
238filterPatterns tagDict region pattern unhandled =
239 let
240 nitPattern =
241 fromCanonicalPattern pattern
243 noIntersection pat =
244 intersection pat nitPattern == Nothing
245 in
246 if all noIntersection unhandled then
247 Result.throw region Error.Redundant
249 else
250 do let complementPatterns = complement tagDict nitPattern
251 return $
252 concatMap
253 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
254 unhandled
258-- PATTERN INTERSECTION
261intersection :: Pattern -> Pattern -> Maybe Pattern
262intersection pattern1 pattern2 =
263 case (pattern1, pattern2) of
264 (Alias _ pattern1', _) ->
265 intersection pattern1' pattern2
267 (_, Alias _ pattern2') ->
268 intersection pattern1 pattern2'
270 (Anything, _) ->
271 Just pattern2
273 (Var _, _) ->
274 Just pattern2
276 (_, Anything) ->
277 Just pattern1
279 (_, Var _) ->
280 Just pattern1
282 (Data ctor1 args1, Data ctor2 args2) ->
283 if ctor1 /= ctor2 then
284 Nothing
285 else
286 Data ctor1 <$> sequence (zipWith intersection args1 args2)
288 (Record _, Record _) ->
289 Just pattern1
291 (Literal lit1, Literal lit2) ->
292 if lit1 == lit2 then
293 Just pattern1
294 else
295 Nothing
297 (AnythingBut literals, Literal lit) ->
298 if Set.member lit literals then
299 Nothing
300 else
301 Just pattern2
303 (Literal lit, AnythingBut literals) ->
304 if Set.member lit literals then
305 Nothing
306 else
307 Just pattern1
309 (AnythingBut literals1, AnythingBut literals2) ->
310 Just (AnythingBut (Set.union literals1 literals2))
312 _ ->
313 Nothing
317-- PATTERN COMPLEMENT
320complement :: TagDict -> Pattern -> [Pattern]
321complement tagDict nitPattern =
322 case nitPattern of
323 Record _fields ->
324 []
326 Alias _name pattern ->
327 complement tagDict pattern
329 Var _name ->
330 []
332 Anything ->
333 []
335 Literal lit ->
336 [AnythingBut (Set.singleton lit)]
338 AnythingBut literals ->
339 map Literal (Set.toList literals)
341 Data ctor patterns ->
342 complementData tagDict ctor patterns
345complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
346complementData tagDict tag patterns =
347 let
348 otherTags =
349 lookupOtherTags tag tagDict
351 tagComplements =
352 Maybe.mapMaybe (tagToPattern tag) otherTags
354 arity =
355 length patterns
357 argComplements =
358 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
359 in
360 tagComplements ++ argComplements
363tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
364tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =
365 if rootTag == tag then
366 Nothing
367 else
368 Just (Data (Var.Canonical home tag) (replicate arity Anything))
371makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
372makeArgComplements tagDict tag arity index argPattern =
373 let
374 complementList =
375 complement tagDict argPattern
377 padArgs pattern =
378 replicate index Anything
379 ++ pattern
380 : replicate (arity - index - 1) Anything
381 in
382 map (Data tag . padArgs) complementList