git.iko.soy/elk
on 5d8dfd9 help sign in
elk/src/Nitpick/PatternMatches.hs
370 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.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
122 in
123 case expression of
124 E.Literal _ ->
125 Result.ok ()
127 E.Var _ ->
128 Result.ok ()
130 E.Range low high ->
131 go2 low high
133 E.ExplicitList listExprs ->
134 F.traverse_ go listExprs
136 E.Binop _ leftExpr rightExpr ->
137 go2 leftExpr rightExpr
139 E.Lambda pattern@(A.A patRegion _) body ->
140 checkPatterns tagDict patRegion Error.Arg [pattern]
141 <* go body
143 E.App func arg ->
144 go2 func arg
146 E.If branches finally ->
147 F.traverse_ (uncurry go2) branches
148 <* go finally
150 E.Let defs body ->
151 go body
152 <* F.traverse_ goDef defs
153 where
154 goDef (Canonical.Definition _ pattern@(A.A patRegion _) expr _) =
155 checkPatterns tagDict patRegion Error.LetBound [pattern]
156 <* go expr
158 E.Case expr branches ->
159 go expr
160 <* checkPatterns tagDict region Error.Case (map fst branches)
161 <* F.traverse_ (go . snd) branches
163 E.Data _ctor exprs ->
164 F.traverse_ go exprs
166 E.Access record _field ->
167 go record
169 E.Update record fields ->
170 go record
171 <* F.traverse_ (go . snd) fields
173 E.Record fields ->
174 F.traverse_ (go . snd) fields
176 E.Port impl ->
177 case impl of
178 E.In _ _ ->
179 Result.ok ()
181 E.Out _ expr _ ->
182 go expr
184 E.Task _ expr _ ->
185 go expr
187 E.GLShader _ _ _ ->
188 Result.ok ()
191-- CHECK PATTERNS
193checkPatterns
194 :: TagDict
195 -> Region.Region
196 -> Error.Origin
197 -> [Pattern.CanonicalPattern]
198 -> Result.Result w Error.Error ()
199checkPatterns tagDict region origin patterns =
200 checkPatternsHelp tagDict region origin [Anything] patterns
203checkPatternsHelp
204 :: TagDict
205 -> Region.Region
206 -> Error.Origin
207 -> [Pattern]
208 -> [Pattern.CanonicalPattern]
209 -> Result.Result w Error.Error ()
210checkPatternsHelp tagDict region origin unhandled patterns =
211 case (unhandled, patterns) of
212 ([], []) ->
213 return ()
215 (_:_, []) ->
216 Result.throw region (Error.Incomplete origin unhandled)
218 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
219 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
220 checkPatternsHelp tagDict region origin newUnhandled remainingPatterns
223filterPatterns
224 :: TagDict
225 -> Region.Region
226 -> Pattern.CanonicalPattern
227 -> [Pattern]
228 -> Result.Result w Error.Error [Pattern]
229filterPatterns tagDict region pattern unhandled =
230 let
231 nitPattern =
232 fromCanonicalPattern pattern
234 noIntersection pat =
235 intersection pat nitPattern == Nothing
236 in
237 if all noIntersection unhandled then
238 Result.throw region Error.Redundant
240 else
241 do let complementPatterns = complement tagDict nitPattern
242 return $
243 concatMap
244 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
245 unhandled
248-- PATTERN INTERSECTION
250intersection :: Pattern -> Pattern -> Maybe Pattern
251intersection pattern1 pattern2 =
252 case (pattern1, pattern2) of
253 (Alias _ pattern1', _) ->
254 intersection pattern1' pattern2
256 (_, Alias _ pattern2') ->
257 intersection pattern1 pattern2'
259 (Anything, _) ->
260 Just pattern2
262 (Var _, _) ->
263 Just pattern2
265 (_, Anything) ->
266 Just pattern1
268 (_, Var _) ->
269 Just pattern1
271 (Data ctor1 args1, Data ctor2 args2) ->
272 if ctor1 /= ctor2 then
273 Nothing
274 else
275 Data ctor1 <$> sequence (zipWith intersection args1 args2)
277 (Record _, Record _) ->
278 Just pattern1
280 (Literal lit1, Literal lit2) ->
281 if lit1 == lit2 then
282 Just pattern1
283 else
284 Nothing
286 (AnythingBut literals, Literal lit) ->
287 if Set.member lit literals then
288 Nothing
289 else
290 Just pattern2
292 (Literal lit, AnythingBut literals) ->
293 if Set.member lit literals then
294 Nothing
295 else
296 Just pattern1
298 (AnythingBut literals1, AnythingBut literals2) ->
299 Just (AnythingBut (Set.union literals1 literals2))
301 _ ->
302 Nothing
305-- PATTERN COMPLEMENT
307complement :: TagDict -> Pattern -> [Pattern]
308complement tagDict nitPattern =
309 case nitPattern of
310 Record _fields ->
311 []
313 Alias _name pattern ->
314 complement tagDict pattern
316 Var _name ->
317 []
319 Anything ->
320 []
322 Literal lit ->
323 [AnythingBut (Set.singleton lit)]
325 AnythingBut literals ->
326 map Literal (Set.toList literals)
328 Data ctor patterns ->
329 complementData tagDict ctor patterns
332complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
333complementData tagDict tag patterns =
334 let
335 otherTags =
336 lookupOtherTags tag tagDict
338 tagComplements =
339 Maybe.mapMaybe (tagToPattern tag) otherTags
341 arity =
342 length patterns
344 argComplements =
345 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
346 in
347 tagComplements ++ argComplements
350tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
351tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =
352 if rootTag == tag then
353 Nothing
354 else
355 Just (Data (Var.Canonical home tag) (replicate arity Anything))
358makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
359makeArgComplements tagDict tag arity index argPattern =
360 let
361 complementList =
362 complement tagDict argPattern
364 padArgs pattern =
365 replicate index Anything
366 ++ pattern
367 : replicate (arity - index - 1) Anything
368 in
369 map (Data tag . padArgs) complementList