git.iko.soy/elk
on 6d9f01b help sign in
elk/src/Nitpick/PatternMatches.hs
366 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.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.GLShader _ _ _ ->
184 Result.ok ()
187-- CHECK PATTERNS
189checkPatterns
190 :: TagDict
191 -> Region.Region
192 -> Error.Origin
193 -> [Pattern.CanonicalPattern]
194 -> Result.Result w Error.Error ()
195checkPatterns tagDict region origin patterns =
196 checkPatternsHelp tagDict region origin [Anything] patterns
199checkPatternsHelp
200 :: TagDict
201 -> Region.Region
202 -> Error.Origin
203 -> [Pattern]
204 -> [Pattern.CanonicalPattern]
205 -> Result.Result w Error.Error ()
206checkPatternsHelp tagDict region origin unhandled patterns =
207 case (unhandled, patterns) of
208 ([], []) ->
209 return ()
211 (_:_, []) ->
212 Result.throw region (Error.Incomplete origin unhandled)
214 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
215 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
216 checkPatternsHelp tagDict region origin newUnhandled remainingPatterns
219filterPatterns
220 :: TagDict
221 -> Region.Region
222 -> Pattern.CanonicalPattern
223 -> [Pattern]
224 -> Result.Result w Error.Error [Pattern]
225filterPatterns tagDict region pattern unhandled =
226 let
227 nitPattern =
228 fromCanonicalPattern pattern
230 noIntersection pat =
231 intersection pat nitPattern == Nothing
232 in
233 if all noIntersection unhandled then
234 Result.throw region Error.Redundant
236 else
237 do let complementPatterns = complement tagDict nitPattern
238 return $
239 concatMap
240 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
241 unhandled
244-- PATTERN INTERSECTION
246intersection :: Pattern -> Pattern -> Maybe Pattern
247intersection pattern1 pattern2 =
248 case (pattern1, pattern2) of
249 (Alias _ pattern1', _) ->
250 intersection pattern1' pattern2
252 (_, Alias _ pattern2') ->
253 intersection pattern1 pattern2'
255 (Anything, _) ->
256 Just pattern2
258 (Var _, _) ->
259 Just pattern2
261 (_, Anything) ->
262 Just pattern1
264 (_, Var _) ->
265 Just pattern1
267 (Data ctor1 args1, Data ctor2 args2) ->
268 if ctor1 /= ctor2 then
269 Nothing
270 else
271 Data ctor1 <$> sequence (zipWith intersection args1 args2)
273 (Record _, Record _) ->
274 Just pattern1
276 (Literal lit1, Literal lit2) ->
277 if lit1 == lit2 then
278 Just pattern1
279 else
280 Nothing
282 (AnythingBut literals, Literal lit) ->
283 if Set.member lit literals then
284 Nothing
285 else
286 Just pattern2
288 (Literal lit, AnythingBut literals) ->
289 if Set.member lit literals then
290 Nothing
291 else
292 Just pattern1
294 (AnythingBut literals1, AnythingBut literals2) ->
295 Just (AnythingBut (Set.union literals1 literals2))
297 _ ->
298 Nothing
301-- PATTERN COMPLEMENT
303complement :: TagDict -> Pattern -> [Pattern]
304complement tagDict nitPattern =
305 case nitPattern of
306 Record _fields ->
307 []
309 Alias _name pattern ->
310 complement tagDict pattern
312 Var _name ->
313 []
315 Anything ->
316 []
318 Literal lit ->
319 [AnythingBut (Set.singleton lit)]
321 AnythingBut literals ->
322 map Literal (Set.toList literals)
324 Data ctor patterns ->
325 complementData tagDict ctor patterns
328complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
329complementData tagDict tag patterns =
330 let
331 otherTags =
332 lookupOtherTags tag tagDict
334 tagComplements =
335 Maybe.mapMaybe (tagToPattern tag) otherTags
337 arity =
338 length patterns
340 argComplements =
341 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
342 in
343 tagComplements ++ argComplements
346tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
347tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =
348 if rootTag == tag then
349 Nothing
350 else
351 Just (Data (Var.Canonical home tag) (replicate arity Anything))
354makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
355makeArgComplements tagDict tag arity index argPattern =
356 let
357 complementList =
358 complement tagDict argPattern
360 padArgs pattern =
361 replicate index Anything
362 ++ pattern
363 : replicate (arity - index - 1) Anything
364 in
365 map (Data tag . padArgs) complementList