git.iko.soy/elk
on d119ce2 help sign in
elk/src/Nitpick/PatternMatches.hs
372 lines 8.7 kB history raw
1module Nitpick.PatternMatches (patternMatches) where
3import Control.Applicative ((<$>), (<*))
4import Control.Arrow (second)
5import qualified Data.Foldable as F
6import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
8import qualified Data.Set as Set
10import qualified AST.Expression.General as E
11import qualified AST.Expression.Canonical as Canonical
12import qualified AST.Helpers as Help
13import qualified AST.Module as Module
14import qualified AST.Module.Name as ModuleName
15import qualified AST.Pattern as Pattern
16import qualified AST.Variable as Var
17import Elm.Utils ((|>))
18import Nitpick.Pattern (Pattern(..), fromCanonicalPattern)
19import qualified Optimize.Patterns.DecisionTree as Opt
20import qualified Reporting.Annotation as A
21import qualified Reporting.Error.Pattern as Error
22import qualified Reporting.Region as Region
23import qualified Reporting.Result as Result
26patternMatches
27 :: Module.Interfaces
28 -> Module.CanonicalModule
29 -> Result.Result w Error.Error Opt.VariantDict
30patternMatches interfaces modul =
31 let
32 name = Module.name modul
33 body = Module.body modul
34 tagDict =
35 toTagDict interfaces name (Module.datatypes body)
36 in
37 const (Map.map (Map.map length) tagDict)
38 <$> checkExpression tagDict (Module.program body)
41-- 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.ADTs -> TagDict
57toTagDict interfaces localName localAdts =
58 let
59 listTags =
60 [ TagInfo "::" 2
61 , TagInfo "[]" 0
62 ]
64 builtinDict =
65 Map.singleton Var.BuiltIn $
66 Map.fromList
67 [ ("::", listTags)
68 , ("[]", listTags)
69 ]
71 interfaceDict =
72 interfaces
73 |> Map.map (toTagMapping . Module.iAdts)
74 |> Map.mapKeysMonotonic Var.Module
75 |> Map.insert (Var.Module localName) (toTagMapping localAdts)
76 in
77 Map.union builtinDict interfaceDict
80toTagMapping :: Module.ADTs -> Map.Map Tag [TagInfo]
81toTagMapping adts =
82 let
83 toTagAndArity (_tvars, tagInfoList) =
84 let
85 info = map (\(tag, args) -> TagInfo tag (length args)) tagInfoList
86 in
87 map (second (const info)) tagInfoList
88 in
89 Map.elems adts
90 |> concatMap toTagAndArity
91 |> Map.fromList
94lookupOtherTags :: Var.Canonical -> TagDict -> [TagInfo]
95lookupOtherTags (Var.Canonical home name) tagDict =
96 case Map.lookup name =<< Map.lookup home tagDict of
97 Just otherTags ->
98 otherTags
100 Nothing ->
101 if Help.isTuple name then
102 [ TagInfo name (read (drop 6 name)) ]
103 else
104 error
105 "Since the Nitpick phase happens after canonicalization and type \
106 \inference, it is impossible that a pattern in a case cannot be \
107 \found."
110-- CHECK EXPRESSIONS
112checkExpression
113 :: TagDict
114 -> Canonical.Expr
115 -> Result.Result w Error.Error ()
116checkExpression tagDict (A.A region expression) =
117 let
118 go =
119 checkExpression tagDict
121 go2 a b =
122 go a <* go b
124 goPattern =
125 checkPatterns tagDict region
126 in
127 case expression of
128 E.Literal _ ->
129 Result.ok ()
131 E.Var _ ->
132 Result.ok ()
134 E.Range low high ->
135 go2 low high
137 E.ExplicitList listExprs ->
138 F.traverse_ go listExprs
140 E.Binop _ leftExpr rightExpr ->
141 go2 leftExpr rightExpr
143 E.Lambda pattern body ->
144 goPattern [pattern]
145 <* go body
147 E.App func arg ->
148 go2 func arg
150 E.If branches finally ->
151 F.traverse_ (uncurry go2) branches
152 <* go finally
154 E.Let defs body ->
155 go body
156 <* F.traverse_ goDef defs
157 where
158 goDef (Canonical.Definition _ pattern expr _) =
159 goPattern [pattern]
160 <* go expr
162 E.Case expr branches ->
163 go expr
164 <* goPattern (map fst branches)
165 <* F.traverse_ (go . snd) branches
167 E.Data _ctor exprs ->
168 F.traverse_ go exprs
170 E.Access record _field ->
171 go record
173 E.Update record fields ->
174 go record
175 <* F.traverse_ (go . snd) fields
177 E.Record fields ->
178 F.traverse_ (go . snd) fields
180 E.Port impl ->
181 case impl of
182 E.In _ _ ->
183 Result.ok ()
185 E.Out _ expr _ ->
186 go expr
188 E.Task _ expr _ ->
189 go expr
191 E.GLShader _ _ _ ->
192 Result.ok ()
195-- CHECK PATTERNS
197checkPatterns
198 :: TagDict
199 -> Region.Region
200 -> [Pattern.CanonicalPattern]
201 -> Result.Result w Error.Error ()
202checkPatterns tagDict region patterns =
203 checkPatternsHelp tagDict region [Anything] patterns
206checkPatternsHelp
207 :: TagDict
208 -> Region.Region
209 -> [Pattern]
210 -> [Pattern.CanonicalPattern]
211 -> Result.Result w Error.Error ()
212checkPatternsHelp tagDict region unhandled patterns =
213 case (unhandled, patterns) of
214 ([], []) ->
215 return ()
217 (_:_, []) ->
218 Result.throw region (Error.Incomplete unhandled)
220 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
221 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
222 checkPatternsHelp tagDict region newUnhandled remainingPatterns
225filterPatterns
226 :: TagDict
227 -> Region.Region
228 -> Pattern.CanonicalPattern
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
250-- PATTERN INTERSECTION
252intersection :: Pattern -> Pattern -> Maybe Pattern
253intersection pattern1 pattern2 =
254 case (pattern1, pattern2) of
255 (Alias _ pattern1', _) ->
256 intersection pattern1' pattern2
258 (_, Alias _ pattern2') ->
259 intersection pattern1 pattern2'
261 (Anything, _) ->
262 Just pattern2
264 (Var _, _) ->
265 Just pattern2
267 (_, Anything) ->
268 Just pattern1
270 (_, Var _) ->
271 Just pattern1
273 (Data ctor1 args1, Data ctor2 args2) ->
274 if ctor1 /= ctor2 then
275 Nothing
276 else
277 Data ctor1 <$> sequence (zipWith intersection args1 args2)
279 (Record _, Record _) ->
280 Just pattern1
282 (Literal lit1, Literal lit2) ->
283 if lit1 == lit2 then
284 Just pattern1
285 else
286 Nothing
288 (AnythingBut literals, Literal lit) ->
289 if Set.member lit literals then
290 Nothing
291 else
292 Just pattern2
294 (Literal lit, AnythingBut literals) ->
295 if Set.member lit literals then
296 Nothing
297 else
298 Just pattern1
300 (AnythingBut literals1, AnythingBut literals2) ->
301 Just (AnythingBut (Set.union literals1 literals2))
303 _ ->
304 Nothing
307-- PATTERN COMPLEMENT
309complement :: TagDict -> Pattern -> [Pattern]
310complement tagDict nitPattern =
311 case nitPattern of
312 Record _fields ->
313 []
315 Alias _name pattern ->
316 complement tagDict pattern
318 Var _name ->
319 []
321 Anything ->
322 []
324 Literal lit ->
325 [AnythingBut (Set.singleton lit)]
327 AnythingBut literals ->
328 map Literal (Set.toList literals)
330 Data ctor patterns ->
331 complementData tagDict ctor patterns
334complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
335complementData tagDict tag patterns =
336 let
337 otherTags =
338 lookupOtherTags tag tagDict
340 tagComplements =
341 Maybe.mapMaybe (tagToPattern tag) otherTags
343 arity =
344 length patterns
346 argComplements =
347 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
348 in
349 tagComplements ++ argComplements
352tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
353tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =
354 if rootTag == tag then
355 Nothing
356 else
357 Just (Data (Var.Canonical home tag) (replicate arity Anything))
360makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
361makeArgComplements tagDict tag arity index argPattern =
362 let
363 complementList =
364 complement tagDict argPattern
366 padArgs pattern =
367 replicate index Anything
368 ++ pattern
369 : replicate (arity - index - 1) Anything
370 in
371 map (Data tag . padArgs) complementList