git.iko.soy/elk
on df41ae8 help sign in
elk/src/Nitpick/PatternMatches.hs
384 lines 8.8 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.Definition _ 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.SaveEnv _ _ ->
193 Result.ok ()
195 E.GLShader _ _ _ ->
196 Result.ok ()
200-- CHECK PATTERNS
203checkPatterns
204 :: TagDict
205 -> Region.Region
206 -> Error.Origin
207 -> [Pattern.Canonical]
208 -> Result.Result w Error.Error ()
209checkPatterns tagDict region origin patterns =
210 checkPatternsHelp tagDict region origin [Anything] patterns
213checkPatternsHelp
214 :: TagDict
215 -> Region.Region
216 -> Error.Origin
217 -> [Pattern]
218 -> [Pattern.Canonical]
219 -> Result.Result w Error.Error ()
220checkPatternsHelp tagDict region origin unhandled patterns =
221 case (unhandled, patterns) of
222 ([], []) ->
223 return ()
225 (_:_, []) ->
226 Result.throw region (Error.Incomplete origin unhandled)
228 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
229 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
230 checkPatternsHelp tagDict region origin newUnhandled remainingPatterns
233filterPatterns
234 :: TagDict
235 -> Region.Region
236 -> Pattern.Canonical
237 -> [Pattern]
238 -> Result.Result w Error.Error [Pattern]
239filterPatterns tagDict region pattern unhandled =
240 let
241 nitPattern =
242 fromCanonicalPattern pattern
244 noIntersection pat =
245 intersection pat nitPattern == Nothing
246 in
247 if all noIntersection unhandled then
248 Result.throw region Error.Redundant
250 else
251 do let complementPatterns = complement tagDict nitPattern
252 return $
253 concatMap
254 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
255 unhandled
259-- PATTERN INTERSECTION
262intersection :: Pattern -> Pattern -> Maybe Pattern
263intersection pattern1 pattern2 =
264 case (pattern1, pattern2) of
265 (Alias _ pattern1', _) ->
266 intersection pattern1' pattern2
268 (_, Alias _ pattern2') ->
269 intersection pattern1 pattern2'
271 (Anything, _) ->
272 Just pattern2
274 (Var _, _) ->
275 Just pattern2
277 (_, Anything) ->
278 Just pattern1
280 (_, Var _) ->
281 Just pattern1
283 (Data ctor1 args1, Data ctor2 args2) ->
284 if ctor1 /= ctor2 then
285 Nothing
286 else
287 Data ctor1 <$> sequence (zipWith intersection args1 args2)
289 (Record _, Record _) ->
290 Just pattern1
292 (Literal lit1, Literal lit2) ->
293 if lit1 == lit2 then
294 Just pattern1
295 else
296 Nothing
298 (AnythingBut literals, Literal lit) ->
299 if Set.member lit literals then
300 Nothing
301 else
302 Just pattern2
304 (Literal lit, AnythingBut literals) ->
305 if Set.member lit literals then
306 Nothing
307 else
308 Just pattern1
310 (AnythingBut literals1, AnythingBut literals2) ->
311 Just (AnythingBut (Set.union literals1 literals2))
313 _ ->
314 Nothing
318-- PATTERN COMPLEMENT
321complement :: TagDict -> Pattern -> [Pattern]
322complement tagDict nitPattern =
323 case nitPattern of
324 Record _fields ->
325 []
327 Alias _name pattern ->
328 complement tagDict pattern
330 Var _name ->
331 []
333 Anything ->
334 []
336 Literal lit ->
337 [AnythingBut (Set.singleton lit)]
339 AnythingBut literals ->
340 map Literal (Set.toList literals)
342 Data ctor patterns ->
343 complementData tagDict ctor patterns
346complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
347complementData tagDict tag patterns =
348 let
349 otherTags =
350 lookupOtherTags tag tagDict
352 tagComplements =
353 Maybe.mapMaybe (tagToPattern tag) otherTags
355 arity =
356 length patterns
358 argComplements =
359 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
360 in
361 tagComplements ++ argComplements
364tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
365tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =
366 if rootTag == tag then
367 Nothing
368 else
369 Just (Data (Var.Canonical home tag) (replicate arity Anything))
372makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
373makeArgComplements tagDict tag arity index argPattern =
374 let
375 complementList =
376 complement tagDict argPattern
378 padArgs pattern =
379 replicate index Anything
380 ++ pattern
381 : replicate (arity - index - 1) Anything
382 in
383 map (Data tag . padArgs) complementList