git.iko.soy/elk
on 255f9df help sign in
elk/src/Nitpick/PatternMatches.hs
371 lines 8.6 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.Patterns.DecisionTree as Opt
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 Opt.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 builtinDict =
64 Map.singleton Var.BuiltIn $
65 Map.fromList
66 [ ("::", listTags)
67 , ("[]", listTags)
68 ]
70 interfaceDict =
71 interfaces
72 |> Map.map (toTagMapping . Module.iAdts)
73 |> Map.mapKeysMonotonic Var.Module
74 |> Map.insert (Var.Module localName) (toTagMapping localAdts)
75 in
76 Map.union builtinDict interfaceDict
79toTagMapping :: Module.ADTs -> Map.Map Tag [TagInfo]
80toTagMapping adts =
81 let
82 toTagAndArity (_tvars, tagInfoList) =
83 let
84 info = map (\(tag, args) -> TagInfo tag (length args)) tagInfoList
85 in
86 map (second (const info)) tagInfoList
87 in
88 Map.elems adts
89 |> concatMap toTagAndArity
90 |> Map.fromList
93lookupOtherTags :: Var.Canonical -> TagDict -> [TagInfo]
94lookupOtherTags (Var.Canonical home name) tagDict =
95 case Map.lookup name =<< Map.lookup home tagDict of
96 Just otherTags ->
97 otherTags
99 Nothing ->
100 if Help.isTuple name then
101 [ TagInfo name (read (drop 6 name)) ]
102 else
103 error
104 "Since the Nitpick phase happens after canonicalization and type \
105 \inference, it is impossible that a pattern in a case cannot be \
106 \found."
109-- CHECK EXPRESSIONS
111checkExpression
112 :: TagDict
113 -> Canonical.Expr
114 -> Result.Result w Error.Error ()
115checkExpression tagDict (A.A region expression) =
116 let
117 go =
118 checkExpression tagDict
120 go2 a b =
121 go a <* go b
123 goPattern =
124 checkPatterns tagDict region
125 in
126 case expression of
127 E.Literal _ ->
128 Result.ok ()
130 E.Var _ ->
131 Result.ok ()
133 E.Range low high ->
134 go2 low high
136 E.ExplicitList listExprs ->
137 F.traverse_ go listExprs
139 E.Binop _ leftExpr rightExpr ->
140 go2 leftExpr rightExpr
142 E.Lambda pattern body ->
143 goPattern [pattern]
144 <* go body
146 E.App func arg ->
147 go2 func arg
149 E.If branches finally ->
150 F.traverse_ (uncurry go2) branches
151 <* go finally
153 E.Let defs body ->
154 go body
155 <* F.traverse_ goDef defs
156 where
157 goDef (Canonical.Definition _ pattern expr _) =
158 goPattern [pattern]
159 <* go expr
161 E.Case expr branches ->
162 go expr
163 <* goPattern (map fst branches)
164 <* F.traverse_ (go . snd) branches
166 E.Data _ctor exprs ->
167 F.traverse_ go exprs
169 E.Access record _field ->
170 go record
172 E.Update record fields ->
173 go record
174 <* F.traverse_ (go . snd) fields
176 E.Record fields ->
177 F.traverse_ (go . snd) fields
179 E.Port impl ->
180 case impl of
181 E.In _ _ ->
182 Result.ok ()
184 E.Out _ expr _ ->
185 go expr
187 E.Task _ expr _ ->
188 go expr
190 E.GLShader _ _ _ ->
191 Result.ok ()
194-- CHECK PATTERNS
196checkPatterns
197 :: TagDict
198 -> Region.Region
199 -> [Pattern.CanonicalPattern]
200 -> Result.Result w Error.Error ()
201checkPatterns tagDict region patterns =
202 checkPatternsHelp tagDict region [Anything] patterns
205checkPatternsHelp
206 :: TagDict
207 -> Region.Region
208 -> [Pattern]
209 -> [Pattern.CanonicalPattern]
210 -> Result.Result w Error.Error ()
211checkPatternsHelp tagDict region unhandled patterns =
212 case (unhandled, patterns) of
213 ([], []) ->
214 return ()
216 (_:_, []) ->
217 Result.throw region (Error.Incomplete unhandled)
219 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
220 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
221 checkPatternsHelp tagDict region newUnhandled remainingPatterns
224filterPatterns
225 :: TagDict
226 -> Region.Region
227 -> Pattern.CanonicalPattern
228 -> [Pattern]
229 -> Result.Result w Error.Error [Pattern]
230filterPatterns tagDict region pattern unhandled =
231 let
232 nitPattern =
233 fromCanonicalPattern pattern
235 noIntersection pat =
236 intersection pat nitPattern == Nothing
237 in
238 if all noIntersection unhandled then
239 Result.throw region Error.Redundant
241 else
242 do let complementPatterns = complement tagDict nitPattern
243 return $
244 concatMap
245 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
246 unhandled
249-- PATTERN INTERSECTION
251intersection :: Pattern -> Pattern -> Maybe Pattern
252intersection pattern1 pattern2 =
253 case (pattern1, pattern2) of
254 (Alias _ pattern1', _) ->
255 intersection pattern1' pattern2
257 (_, Alias _ pattern2') ->
258 intersection pattern1 pattern2'
260 (Anything, _) ->
261 Just pattern2
263 (Var _, _) ->
264 Just pattern2
266 (_, Anything) ->
267 Just pattern1
269 (_, Var _) ->
270 Just pattern1
272 (Data ctor1 args1, Data ctor2 args2) ->
273 if ctor1 /= ctor2 then
274 Nothing
275 else
276 Data ctor1 <$> sequence (zipWith intersection args1 args2)
278 (Record _, Record _) ->
279 Just pattern1
281 (Literal lit1, Literal lit2) ->
282 if lit1 == lit2 then
283 Just pattern1
284 else
285 Nothing
287 (AnythingBut literals, Literal lit) ->
288 if Set.member lit literals then
289 Nothing
290 else
291 Just pattern2
293 (Literal lit, AnythingBut literals) ->
294 if Set.member lit literals then
295 Nothing
296 else
297 Just pattern1
299 (AnythingBut literals1, AnythingBut literals2) ->
300 Just (AnythingBut (Set.union literals1 literals2))
302 _ ->
303 Nothing
306-- PATTERN COMPLEMENT
308complement :: TagDict -> Pattern -> [Pattern]
309complement tagDict nitPattern =
310 case nitPattern of
311 Record _fields ->
312 []
314 Alias _name pattern ->
315 complement tagDict pattern
317 Var _name ->
318 []
320 Anything ->
321 []
323 Literal lit ->
324 [AnythingBut (Set.singleton lit)]
326 AnythingBut literals ->
327 map Literal (Set.toList literals)
329 Data ctor patterns ->
330 complementData tagDict ctor patterns
333complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
334complementData tagDict tag patterns =
335 let
336 otherTags =
337 lookupOtherTags tag tagDict
339 tagComplements =
340 Maybe.mapMaybe (tagToPattern tag) otherTags
342 arity =
343 length patterns
345 argComplements =
346 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
347 in
348 tagComplements ++ argComplements
351tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
352tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =
353 if rootTag == tag then
354 Nothing
355 else
356 Just (Data (Var.Canonical home tag) (replicate arity Anything))
359makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
360makeArgComplements tagDict tag arity index argPattern =
361 let
362 complementList =
363 complement tagDict argPattern
365 padArgs pattern =
366 replicate index Anything
367 ++ pattern
368 : replicate (arity - index - 1) Anything
369 in
370 map (Data tag . padArgs) complementList