git.iko.soy/elk
on b97576d help sign in
elk/src/Nitpick/PatternMatches.hs
382 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.Canonical as C
10import qualified AST.Helpers as Help
11import qualified AST.Module as Module
12import qualified AST.Module.Name as ModuleName
13import qualified AST.Pattern as Pattern
14import qualified AST.Variable as Var
15import Elm.Utils ((|>))
16import Nitpick.Pattern (Pattern(..), fromCanonicalPattern)
17import qualified Optimize.DecisionTree as DT
18import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Pattern as Error
20import qualified Reporting.Region as Region
21import qualified Reporting.Result as Result
25type Result warning a =
26 Result.Result () warning Error.Error a
29patternMatches :: Module.Interfaces -> Module.Canonical -> Result wrn 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 :: TagDict -> C.Expr -> Result wrn ()
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 C.Literal _ ->
132 Result.ok ()
134 C.Var _ ->
135 Result.ok ()
137 C.List listExprs ->
138 F.traverse_ go listExprs
140 C.Binop _ leftExpr rightExpr ->
141 go2 leftExpr rightExpr
143 C.Lambda pattern@(A.A patRegion _) body ->
144 checkPatterns tagDict patRegion Error.Arg [pattern]
145 <* go body
147 C.App func arg ->
148 go2 func arg
150 C.If branches finally ->
151 F.traverse_ (uncurry go2) branches
152 <* go finally
154 C.Let defs body ->
155 go body
156 <* F.traverse_ goDef defs
157 where
158 goDef (C.Def _ pattern@(A.A patRegion _) expr _) =
159 checkPatterns tagDict patRegion Error.LetBound [pattern]
160 <* go expr
162 C.Case expr branches ->
163 go expr
164 <* checkPatterns tagDict region Error.Case (map fst branches)
165 <* F.traverse_ (go . snd) branches
167 C.Ctor _ctor exprs ->
168 F.traverse_ go exprs
170 C.Access record _field ->
171 go record
173 C.Update record fields ->
174 go record
175 <* F.traverse_ (go . snd) fields
177 C.Record fields ->
178 F.traverse_ (go . snd) fields
180 C.Cmd _ ->
181 Result.ok ()
183 C.Sub _ ->
184 Result.ok ()
186 C.OutgoingPort _ _ ->
187 Result.ok ()
189 C.IncomingPort _ _ ->
190 Result.ok ()
192 C.Program _ _ ->
193 error "DANGER - Program AST nodes should not be in Nitpick.PatternMatches."
195 C.SaveEnv _ _ ->
196 Result.ok ()
198 C.GLShader _ _ _ ->
199 Result.ok ()
203-- CHECK PATTERNS
206checkPatterns :: TagDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()
207checkPatterns tagDict region origin patterns =
208 checkPatternsHelp tagDict region origin [Anything] patterns
211checkPatternsHelp
212 :: TagDict
213 -> Region.Region
214 -> Error.Origin
215 -> [Pattern]
216 -> [Pattern.Canonical]
217 -> Result wrn ()
218checkPatternsHelp tagDict region origin unhandled patterns =
219 case (unhandled, patterns) of
220 ([], []) ->
221 return ()
223 (_:_, []) ->
224 Result.throw region (Error.Incomplete origin unhandled)
226 (_, pattern@(A.A localRegion _) : remainingPatterns) ->
227 do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
228 checkPatternsHelp tagDict region origin newUnhandled remainingPatterns
231filterPatterns
232 :: TagDict
233 -> Region.Region
234 -> Pattern.Canonical
235 -> [Pattern]
236 -> Result wrn [Pattern]
237filterPatterns tagDict region pattern unhandled =
238 let
239 nitPattern =
240 fromCanonicalPattern pattern
242 noIntersection pat =
243 intersection pat nitPattern == Nothing
244 in
245 if all noIntersection unhandled then
246 Result.throw region Error.Redundant
248 else
249 do let complementPatterns = complement tagDict nitPattern
250 return $
251 concatMap
252 (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
253 unhandled
257-- PATTERN INTERSECTION
260intersection :: Pattern -> Pattern -> Maybe Pattern
261intersection pattern1 pattern2 =
262 case (pattern1, pattern2) of
263 (Alias _ pattern1', _) ->
264 intersection pattern1' pattern2
266 (_, Alias _ pattern2') ->
267 intersection pattern1 pattern2'
269 (Anything, _) ->
270 Just pattern2
272 (Var _, _) ->
273 Just pattern2
275 (_, Anything) ->
276 Just pattern1
278 (_, Var _) ->
279 Just pattern1
281 (Data ctor1 args1, Data ctor2 args2) ->
282 if ctor1 /= ctor2 then
283 Nothing
284 else
285 Data ctor1 <$> sequence (zipWith intersection args1 args2)
287 (Record _, Record _) ->
288 Just pattern1
290 (Literal lit1, Literal lit2) ->
291 if lit1 == lit2 then
292 Just pattern1
293 else
294 Nothing
296 (AnythingBut literals, Literal lit) ->
297 if Set.member lit literals then
298 Nothing
299 else
300 Just pattern2
302 (Literal lit, AnythingBut literals) ->
303 if Set.member lit literals then
304 Nothing
305 else
306 Just pattern1
308 (AnythingBut literals1, AnythingBut literals2) ->
309 Just (AnythingBut (Set.union literals1 literals2))
311 _ ->
312 Nothing
316-- PATTERN COMPLEMENT
319complement :: TagDict -> Pattern -> [Pattern]
320complement tagDict nitPattern =
321 case nitPattern of
322 Record _fields ->
323 []
325 Alias _name pattern ->
326 complement tagDict pattern
328 Var _name ->
329 []
331 Anything ->
332 []
334 Literal lit ->
335 [AnythingBut (Set.singleton lit)]
337 AnythingBut literals ->
338 map Literal (Set.toList literals)
340 Data ctor patterns ->
341 complementData tagDict ctor patterns
344complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
345complementData tagDict tag patterns =
346 let
347 otherTags =
348 lookupOtherTags tag tagDict
350 tagComplements =
351 Maybe.mapMaybe (tagToPattern tag) otherTags
353 arity =
354 length patterns
356 argComplements =
357 concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
358 in
359 tagComplements ++ argComplements
362tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
363tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =
364 if rootTag == tag then
365 Nothing
366 else
367 Just (Data (Var.Canonical home tag) (replicate arity Anything))
370makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
371makeArgComplements tagDict tag arity index argPattern =
372 let
373 complementList =
374 complement tagDict argPattern
376 padArgs pattern =
377 replicate index Anything
378 ++ pattern
379 : replicate (arity - index - 1) Anything
380 in
381 map (Data tag . padArgs) complementList