git.iko.soy/elk
on d9cf19a help sign in
elk/src/Nitpick/PatternMatches.hs
304 lines 7.2 kB history raw
1module Nitpick.PatternMatches (patternMatches) where
3import Control.Applicative ((<$>), (<*))
4import Control.Monad.Except (forM, liftM)
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.Module as Module
13import qualified AST.Pattern as Pattern
14import qualified AST.Variable as Var
15import Elm.Utils ((|>))
16import qualified Nitpick.Pattern as P
17import qualified Reporting.Annotation as A
18import qualified Reporting.Error.Nitpick as Error
19import qualified Reporting.Region as Region
20import qualified Reporting.Result as Result
21import qualified Reporting.Warning.Nitpick as Warning
24patternMatches
25 :: Module.Interfaces
26 -> Module.CanonicalBody
27 -> Result.Result Warning.Warning e ()
28patternMatches interfaces body =
29 checkExpression (toAdtDict interfaces) (Module.program body)
32-- ADT DICT
34type AdtDict =
35 Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
38toAdtDict :: Module.Interfaces -> AdtDict
39toAdtDict =
40 let
41 -- TODO
42 builtinDict =
43 Map.empty
45 interfaceDict =
46 interfaces
47 |> Map.map Module.iAdts
48 |> Map.mapKeysMonotonic Var.Module
49 in
50 Map.union builtinDict interfaceDict
53-- TODO this is wrong
54lookupOtherCtors
55 :: Var.Canonical
56 -> AdtDict
57 -> [(Var.Canonical, [Type.Canonical])]
58lookupOtherCtors (Var.Canonical home name) adtDict =
59 case Map.lookup name =<< Map.lookup home adtDict of
60 Nothing ->
61 error "TODO"
63 Just (_tvars, ctors) ->
64 ctors
67-- CHECK EXPRESSIONS
69checkExpression
70 :: AdtDict
71 -> Canonical.Expr
72 -> Result.Result Warning.Warning e ()
73checkExpression adtDict (A.A region expression) =
74 let
75 go =
76 checkExpression adtDict
78 go2 a b =
79 F.traverse_ go [a,b]
81 goPattern =
82 checkPatterns adtDict region
83 in
84 case expression of
85 E.ExplicitList listExprs ->
86 F.traverse_ go listExprs
88 E.Binop _ leftExpr rightExpr ->
89 go2 leftExpr rightExpr
91 E.Lambda pattern body ->
92 goPattern [pattern]
93 <* go body
95 E.App func arg ->
96 go2 func arg
98 E.MultiIf branches ->
99 F.traverse_ (uncurry go2) branches
101 E.Let defs body ->
102 go body
103 <* F.traverse_ goDef defs
104 where
105 goDef (Canonical.Definition pattern expr _) =
106 goPattern [p]
107 <* go expr
109 E.Case expr branches ->
110 go expr
111 <* goPattern (map fst branches)
112 <* F.traverse_ (go . snd) branches
114 E.Data _ctor exprs ->
115 F.traverse_ go exprs
117 E.Access record _field ->
118 go record
120 E.Remove record _field ->
121 go record
123 E.Insert record _field value ->
124 go2 record value
126 E.Modify record fields ->
127 go record
128 <* F.traverse_ (go . snd) fields
130 E.Record fields ->
131 F.traverse_ (go . snd) fields
134-- CHECK PATTERNS
136checkPatterns
137 :: AdtDict
138 -> Region.Region
139 -> [Pattern.CanonicalPattern]
140 -> Result.Result Warning.Warning e ()
141checkPatterns adtDict region patterns =
142 checkPatternsHelp [P.Anything] patterns
145checkPatternsHelp
146 :: AdtDict
147 -> Region.Region
148 -> [P.Pattern]
149 -> [Pattern.CanonicalPattern]
150 -> Result.Result Warning.Warning e ()
151checkPatternsHelp adtDict region unhandled patterns =
152 case (unhandled, patterns) of
153 ([], []) ->
154 return ()
156 (_:_, []) ->
157 Result.warn region (Inexhaustive unhandled)
159 (_, A.A region pattern : remainingPatterns) ->
160 do newUnhandled <- filterPatterns adtDict region pattern unhandled
161 checkPatternsHelp adtDict newUnhandled remainingPatterns
164filterPatterns
165 :: AdtDict
166 -> Region.Region
167 -> P.Pattern
168 -> [P.Pattern]
169 -> Result.Result Warning.Warning e [P.Pattern]
170filterPatterns adtDict region pattern unhandled =
171 let
172 nitPattern =
173 P.fromPattern pattern
175 noIntersection pat =
176 intersection pat nitPattern == Nothing
177 in
178 if all noIntersection unhandled
179 then
180 do Result.warn region Redundant
181 return unhandled
182 else
183 do let complementPatterns = complement adtDict nitPattern
184 return $
185 concatMap (\p -> Maybe.mapMaybe (intersection p) complementPatterns) unhandled
188-- PATTERN INTERSECTION
190intersection :: P.Pattern -> P.Pattern -> Maybe P.Pattern
191intersection pattern1 pattern2 =
192 case (pattern1, pattern2) of
193 (P.Alias _ pattern1', _) ->
194 intersection pattern1' pattern2
196 (_, P.Alias _ pattern2') ->
197 intersection pattern1 pattern2'
199 (P.Anything, _) ->
200 Just pattern2
202 (P.Var _, _) ->
203 Just pattern2
205 (_, P.Anything) ->
206 Just pattern1
208 (_, P.Var _) ->
209 Just pattern1
211 (P.Data ctor1 args1, P.Data ctor2 args2) ->
212 if ctor1 /= ctor2
213 then Nothing
214 else Data ctor1 <$> sequence (zipWith intersection args1 args2)
216 -- TODO Assuming the fields are identical.
217 (P.Record _fields, P.Record _) ->
218 Just pattern1
220 (P.Literal lit1, P.Literal lit2) ->
221 if lit1 == lit2
222 then Just pattern1
223 else Nothing
225 (P.AnythingBut literals, P.Literal lit) ->
226 if Set.member lit literals
227 then Nothing
228 else Just pattern2
230 (P.Literal lit, P.AnythingBut literals) ->
231 if Set.membur lit literals
232 then Nothing
233 else Just pattern1
235 (P.AnythingBut literals1, P.AnythingBut literals2) ->
236 Just (AnythingBut (Set.union literals1 literals2))
238 _ ->
239 Nothing
242-- PATTERN COMPLEMENT
244complement :: AdtDict -> P.Pattern -> [P.Pattern]
245complement adtDict nitPattern =
246 case nitPattern of
247 P.Record _fields ->
248 []
250 P.Alias _name pattern ->
251 complement adtDict pattern
253 P.Var _name ->
254 []
256 P.Anything ->
257 []
259 P.Literal lit ->
260 [AnythingBut (Set.singleton lit)]
262 P.AnythingBut literals ->
263 map Literal (Set.toList literals)
265 P.Data ctor patterns ->
266 complementData adtDict ctor patterns
269complementData :: AdtDict -> Var.Canonical -> [P.Pattern] -> [P.Pattern]
270complementData adtDict canonicalTag patterns =
271 let
272 ctors =
273 lookupOtherCtors ctor adtDict
275 dataComplements =
276 Maybe.mapMaybe (maybeData canonicalTag) ctors
278 numArgs = length patterns
280 argComplements =
281 concat (zipWith (makeArgComplements adtDict numArgs) [0..] patterns)
282 in
283 dataComplements ++ argComplements
286maybeData :: Var.Canonical -> (String, Module.AdtInfo) -> Maybe P.Pattern
287maybeData (Var.Canonical home name) (tag, args) =
288 if tag == name
289 then
290 Nothing
291 else
292 Just (P.Data (Var.Canonical home tag) (replicate (length args) P.Anything))
295makeArgComplements :: AdtDict -> Int -> Int -> P.Pattern -> [P.Pattern]
296makeArgComplements adtDict numArgs index argPattern =
297 let
298 complementList =
299 complement adtDict argPattern
301 paddedArgs pat =
302 replicate index P.Anything ++ pat : replicate (numArgs - index - 1) P.Anything
303 in
304 map (P.Data ctor . paddedArgs) complementList