git.iko.soy/elk
on 8d8afda help sign in
elk/src/Nitpick/PatternMatches.hs
375 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
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.GLShader _ _ _ ->
187 Result.ok ()
191-- CHECK PATTERNS
194checkPatterns
195 :: TagDict
196 -> Region.Region
197 -> Error.Origin
198 -> [Pattern.Canonical]
199 -> Result.Result w Error.Error ()
200checkPatterns tagDict region origin patterns =
201 checkPatternsHelp tagDict region origin [Anything] patterns
204checkPatternsHelp
205 :: TagDict
206 -> Region.Region
207 -> Error.Origin
208 -> [Pattern]
209 -> [Pattern.Canonical]
210 -> Result.Result w Error.Error ()
211checkPatternsHelp tagDict region origin unhandled patterns =
212 case (unhandled, patterns) of
213 ([], []) ->
214 return ()
216 (_:_, []) ->
217 Result.throw region (Error.Incomplete origin unhandled)
219 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
220 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
221 checkPatternsHelp tagDict region origin newUnhandled remainingPatterns
224filterPatterns
225 :: TagDict
226 -> Region.Region
227 -> Pattern.Canonical
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
250-- PATTERN INTERSECTION
253intersection :: Pattern -> Pattern -> Maybe Pattern
254intersection pattern1 pattern2 =
255 case (pattern1, pattern2) of
256 (Alias _ pattern1', _) ->
257 intersection pattern1' pattern2
259 (_, Alias _ pattern2') ->
260 intersection pattern1 pattern2'
262 (Anything, _) ->
263 Just pattern2
265 (Var _, _) ->
266 Just pattern2
268 (_, Anything) ->
269 Just pattern1
271 (_, Var _) ->
272 Just pattern1
274 (Data ctor1 args1, Data ctor2 args2) ->
275 if ctor1 /= ctor2 then
276 Nothing
277 else
278 Data ctor1 <$> sequence (zipWith intersection args1 args2)
280 (Record _, Record _) ->
281 Just pattern1
283 (Literal lit1, Literal lit2) ->
284 if lit1 == lit2 then
285 Just pattern1
286 else
287 Nothing
289 (AnythingBut literals, Literal lit) ->
290 if Set.member lit literals then
291 Nothing
292 else
293 Just pattern2
295 (Literal lit, AnythingBut literals) ->
296 if Set.member lit literals then
297 Nothing
298 else
299 Just pattern1
301 (AnythingBut literals1, AnythingBut literals2) ->
302 Just (AnythingBut (Set.union literals1 literals2))
304 _ ->
305 Nothing
309-- PATTERN COMPLEMENT
312complement :: TagDict -> Pattern -> [Pattern]
313complement tagDict nitPattern =
314 case nitPattern of
315 Record _fields ->
316 []
318 Alias _name pattern ->
319 complement tagDict pattern
321 Var _name ->
322 []
324 Anything ->
325 []
327 Literal lit ->
328 [AnythingBut (Set.singleton lit)]
330 AnythingBut literals ->
331 map Literal (Set.toList literals)
333 Data ctor patterns ->
334 complementData tagDict ctor patterns
337complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
338complementData tagDict tag patterns =
339 let
340 otherTags =
341 lookupOtherTags tag tagDict
343 tagComplements =
344 Maybe.mapMaybe (tagToPattern tag) otherTags
346 arity =
347 length patterns
349 argComplements =
350 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
351 in
352 tagComplements ++ argComplements
355tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
356tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =
357 if rootTag == tag then
358 Nothing
359 else
360 Just (Data (Var.Canonical home tag) (replicate arity Anything))
363makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
364makeArgComplements tagDict tag arity index argPattern =
365 let
366 complementList =
367 complement tagDict argPattern
369 padArgs pattern =
370 replicate index Anything
371 ++ pattern
372 : replicate (arity - index - 1) Anything
373 in
374 map (Data tag . padArgs) complementList