git.iko.soy/elk
on bbb6583 help sign in
elk/src/Nitpick/PatternMatches.hs
381 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.GLShader _ _ _ ->
193 Result.ok ()
197-- CHECK PATTERNS
200checkPatterns
201 :: TagDict
202 -> Region.Region
203 -> Error.Origin
204 -> [Pattern.Canonical]
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.Canonical]
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.Canonical
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
256-- PATTERN INTERSECTION
259intersection :: Pattern -> Pattern -> Maybe Pattern
260intersection pattern1 pattern2 =
261 case (pattern1, pattern2) of
262 (Alias _ pattern1', _) ->
263 intersection pattern1' pattern2
265 (_, Alias _ pattern2') ->
266 intersection pattern1 pattern2'
268 (Anything, _) ->
269 Just pattern2
271 (Var _, _) ->
272 Just pattern2
274 (_, Anything) ->
275 Just pattern1
277 (_, Var _) ->
278 Just pattern1
280 (Data ctor1 args1, Data ctor2 args2) ->
281 if ctor1 /= ctor2 then
282 Nothing
283 else
284 Data ctor1 <$> sequence (zipWith intersection args1 args2)
286 (Record _, Record _) ->
287 Just pattern1
289 (Literal lit1, Literal lit2) ->
290 if lit1 == lit2 then
291 Just pattern1
292 else
293 Nothing
295 (AnythingBut literals, Literal lit) ->
296 if Set.member lit literals then
297 Nothing
298 else
299 Just pattern2
301 (Literal lit, AnythingBut literals) ->
302 if Set.member lit literals then
303 Nothing
304 else
305 Just pattern1
307 (AnythingBut literals1, AnythingBut literals2) ->
308 Just (AnythingBut (Set.union literals1 literals2))
310 _ ->
311 Nothing
315-- PATTERN COMPLEMENT
318complement :: TagDict -> Pattern -> [Pattern]
319complement tagDict nitPattern =
320 case nitPattern of
321 Record _fields ->
322 []
324 Alias _name pattern ->
325 complement tagDict pattern
327 Var _name ->
328 []
330 Anything ->
331 []
333 Literal lit ->
334 [AnythingBut (Set.singleton lit)]
336 AnythingBut literals ->
337 map Literal (Set.toList literals)
339 Data ctor patterns ->
340 complementData tagDict ctor patterns
343complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
344complementData tagDict tag patterns =
345 let
346 otherTags =
347 lookupOtherTags tag tagDict
349 tagComplements =
350 Maybe.mapMaybe (tagToPattern tag) otherTags
352 arity =
353 length patterns
355 argComplements =
356 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
357 in
358 tagComplements ++ argComplements
361tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
362tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =
363 if rootTag == tag then
364 Nothing
365 else
366 Just (Data (Var.Canonical home tag) (replicate arity Anything))
369makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
370makeArgComplements tagDict tag arity index argPattern =
371 let
372 complementList =
373 complement tagDict argPattern
375 padArgs pattern =
376 replicate index Anything
377 ++ pattern
378 : replicate (arity - index - 1) Anything
379 in
380 map (Data tag . padArgs) complementList