git.iko.soy/elk
on master help sign in
Fix tag lookup, add check to the compilation pipeline
9d9e439Evan Czaplicki
src/Compile.hs+3
compare with master
unifiedsplit
@@ -5,6 +5,7 @@ import qualified Data.Map as Map
5import qualified AST.Module as Module
5import qualified AST.Module as Module
6import qualified Canonicalize
6import qualified Canonicalize
7import Elm.Utils ((|>))
7import Elm.Utils ((|>))
8+import qualified Nitpick.PatternMatches as Nitpick
8import qualified Nitpick.TopLevelTypes as Nitpick
9import qualified Nitpick.TopLevelTypes as Nitpick
9import qualified Parse.Helpers as Parse
10import qualified Parse.Helpers as Parse
10import qualified Parse.Parse as Parse
11import qualified Parse.Parse as Parse
@@ -47,6 +48,8 @@ compile user projectName isRoot interfaces source =
47 Result.mapError Error.Type $
48 Result.mapError Error.Type $
48 Nitpick.topLevelTypes types (Module.body validModule)
49 Nitpick.topLevelTypes types (Module.body validModule)
49
50
51+ Nitpick.patternMatches interfaces (Module.body canonicalModule)
52+
50 -- Add the real list of types
53 -- Add the real list of types
51 let body = (Module.body canonicalModule) { Module.types = types }
54 let body = (Module.body canonicalModule) { Module.types = types }
52
55
src/Nitpick/Pattern.hs+4−31
@@ -1,37 +1,10 @@
1module Nitpick.Pattern where
1module Nitpick.Pattern where
2
2
3+import qualified Data.Set as Set
4+
5+import qualified AST.Literal as L
3import qualified AST.Pattern as P
6import qualified AST.Pattern as P
4import qualified AST.Variable as Var
7import qualified AST.Variable as Var
8+import qualified Reporting.Annotation as A
5
9
6
10
7−data Pattern
8− = Data Var.Canonical [Pattern]
9− | Record [String]
10− | Alias String Pattern
11− | Var String
12− | Anything
13− | Literal Literal.Literal
14− | AnythingBut (Set.Set Literal.Literal)
15− deriving (Show, Eq)
16−
17−
18−fromPattern :: P.CanonicalPattern -> Pattern
19−fromPattern (Annotation.A _region pattern) =
20− case pattern of
21− P.Data ctor patterns ->
22− Data ctor (map fromPattern patterns)
23−
24− P.Record fields ->
25− Record fields
26−
27− P.Alias name pattern ->
28− Alias name (fromPattern pattern)
29−
30− P.Var name ->
31− Var name
32−
33− P.Anything ->
34− Anything
35−
36− P.Literal literal ->
37− Literal literal
src/Nitpick/PatternMatches.hs+212−120
@@ -1,7 +1,7 @@
1module Nitpick.PatternMatches (patternMatches) where
1module Nitpick.PatternMatches (patternMatches) where
2
2
3import Control.Applicative ((<$>), (<*))
3import Control.Applicative ((<$>), (<*))
4−import Control.Monad.Except (forM, liftM)
4+import Control.Arrow (second)
5import qualified Data.Foldable as F
5import qualified Data.Foldable as F
6import qualified Data.Map as Map
6import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
7import qualified Data.Maybe as Maybe
@@ -9,79 +9,146 @@ import qualified Data.Set as Set
9
9
10import qualified AST.Expression.General as E
10import qualified AST.Expression.General as E
11import qualified AST.Expression.Canonical as Canonical
11import qualified AST.Expression.Canonical as Canonical
12+import qualified AST.Literal as L
12import qualified AST.Module as Module
13import qualified AST.Module as Module
13−import qualified AST.Pattern as Pattern
14+import qualified AST.Pattern as P
14import qualified AST.Variable as Var
15import qualified AST.Variable as Var
15import Elm.Utils ((|>))
16import Elm.Utils ((|>))
16−import qualified Nitpick.Pattern as P
17import qualified Reporting.Annotation as A
17import qualified Reporting.Annotation as A
18−import qualified Reporting.Error.Nitpick as Error
19import qualified Reporting.Region as Region
18import qualified Reporting.Region as Region
20import qualified Reporting.Result as Result
19import qualified Reporting.Result as Result
21−import qualified Reporting.Warning.Nitpick as Warning
20+import qualified Reporting.Warning as Warning
22
21
23
22
24patternMatches
23patternMatches
25 :: Module.Interfaces
24 :: Module.Interfaces
26− -> Module.CanonicalBody
25+ -> Module.Body Canonical.Expr
27 -> Result.Result Warning.Warning e ()
26 -> Result.Result Warning.Warning e ()
28patternMatches interfaces body =
27patternMatches interfaces body =
29− checkExpression (toAdtDict interfaces) (Module.program body)
28+ checkExpression (toTagDict interfaces) (Module.program body)
30
29
31
30
32−-- ADT DICT
31+-- PATTERN MATCH DATA STRUCTURE
33
32
34−type AdtDict =
33+data Pattern
35− Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
34+ = Data Var.Canonical [Pattern]
35+ | Record [String]
36+ | Alias String Pattern
37+ | Var String
38+ | Anything
39+ | Literal L.Literal
40+ | AnythingBut (Set.Set L.Literal)
41+ deriving (Show, Eq)
36
42
37
43
44+fromCanonicalPattern :: P.CanonicalPattern -> Pattern
45+fromCanonicalPattern (A.A _ pattern) =
46+ case pattern of
47+ P.Data ctor patterns ->
48+ Data ctor (map fromCanonicalPattern patterns)
49+
50+ P.Record fields ->
51+ Record fields
52+
53+ P.Alias name pattern ->
54+ Alias name (fromCanonicalPattern pattern)
55+
56+ P.Var name ->
57+ Var name
58+
59+ P.Anything ->
60+ Anything
61+
62+ P.Literal literal ->
63+ Literal literal
64+
65+
66+
67+-- TAG DICT
68+
69+type TagDict =
70+ Map.Map Var.Home (Map.Map Tag [(Tag, Int)])
71+
72+
73+type Tag = String
74+
75+
38−toAdtDict :: Module.Interfaces -> AdtDict
76+toTagDict :: Module.Interfaces -> TagDict
39−toAdtDict =
77+toTagDict interfaces =
40 let
78 let
41− -- TODO
79+ listTags =
80+ [ ("::", 2), ("[]", 0) ]
81+
42 builtinDict =
82 builtinDict =
43− Map.empty
83+ Map.singleton Var.BuiltIn $
84+ Map.fromList
85+ [ ("::", listTags)
86+ , ("[]", listTags)
87+ ]
44
88
45 interfaceDict =
89 interfaceDict =
46 interfaces
90 interfaces
47− |> Map.map Module.iAdts
91+ |> Map.map (toTagMapping . Module.iAdts)
48 |> Map.mapKeysMonotonic Var.Module
92 |> Map.mapKeysMonotonic Var.Module
49 in
93 in
50 Map.union builtinDict interfaceDict
94 Map.union builtinDict interfaceDict
51
95
52
96
53−-- TODO this is wrong
97+toTagMapping :: Module.ADTs -> Map.Map Tag ([(Tag,Int)])
54−lookupOtherCtors
98+toTagMapping adts =
55− :: Var.Canonical
99+ let
56− -> AdtDict
100+ toTagAndArity (_tvars, tagInfoList) =
57− -> [(Var.Canonical, [Type.Canonical])]
101+ let
58−lookupOtherCtors (Var.Canonical home name) adtDict =
102+ info = map (\(tag, args) -> (tag, length args)) tagInfoList
59− case Map.lookup name =<< Map.lookup home adtDict of
103+ in
60− Nothing ->
104+ map (second (const info)) tagInfoList
61− error "TODO"
105+ in
106+ Map.elems adts
107+ |> concatMap toTagAndArity
108+ |> Map.fromList
62
109
63− Just (_tvars, ctors) ->
110+
64− ctors
111+lookupOtherCtors :: Var.Canonical -> TagDict -> [(Tag, Int)]
112+lookupOtherCtors (Var.Canonical home name) tagDict =
113+ case Map.lookup name =<< Map.lookup home tagDict of
114+ Just otherTags ->
115+ otherTags
116+
117+ Nothing ->
118+ error
119+ "Since the Nitpick phase happens after canonicalization and type \
120+ \inference, it is impossible that a pattern in a case cannot be \
121+ \found."
65
122
66
123
67-- CHECK EXPRESSIONS
124-- CHECK EXPRESSIONS
68
125
69checkExpression
126checkExpression
70− :: AdtDict
127+ :: TagDict
71 -> Canonical.Expr
128 -> Canonical.Expr
72 -> Result.Result Warning.Warning e ()
129 -> Result.Result Warning.Warning e ()
73−checkExpression adtDict (A.A region expression) =
130+checkExpression tagDict (A.A region expression) =
74 let
131 let
75 go =
132 go =
76− checkExpression adtDict
133+ checkExpression tagDict
77
134
78 go2 a b =
135 go2 a b =
79 F.traverse_ go [a,b]
136 F.traverse_ go [a,b]
80
137
81 goPattern =
138 goPattern =
82− checkPatterns adtDict region
139+ checkPatterns tagDict region
83 in
140 in
84 case expression of
141 case expression of
142+ E.Literal _ ->
143+ Result.ok ()
144+
145+ E.Var _ ->
146+ Result.ok ()
147+
148+ E.Range low high ->
149+ go low
150+ <* go high
151+
85 E.ExplicitList listExprs ->
152 E.ExplicitList listExprs ->
86 F.traverse_ go listExprs
153 F.traverse_ go listExprs
87
154
@@ -95,15 +162,16 @@ checkExpression adtDict (A.A region expression) =
95 E.App func arg ->
162 E.App func arg ->
96 go2 func arg
163 go2 func arg
97
164
98− E.MultiIf branches ->
165+ E.MultiIf branches finally ->
99 F.traverse_ (uncurry go2) branches
166 F.traverse_ (uncurry go2) branches
167+ <* go finally
100
168
101 E.Let defs body ->
169 E.Let defs body ->
102 go body
170 go body
103 <* F.traverse_ goDef defs
171 <* F.traverse_ goDef defs
104 where
172 where
105 goDef (Canonical.Definition pattern expr _) =
173 goDef (Canonical.Definition pattern expr _) =
106− goPattern [p]
174+ goPattern [pattern]
107 <* go expr
175 <* go expr
108
176
109 E.Case expr branches ->
177 E.Case expr branches ->
@@ -130,109 +198,130 @@ checkExpression adtDict (A.A region expression) =
130 E.Record fields ->
198 E.Record fields ->
131 F.traverse_ (go . snd) fields
199 F.traverse_ (go . snd) fields
132
200
201+ E.Port impl ->
202+ case impl of
203+ E.In _ _ ->
204+ Result.ok ()
205+
206+ E.Out _ expr _ ->
207+ go expr
208+
209+ E.Task _ expr _ ->
210+ go expr
211+
212+ E.GLShader _ _ _ ->
213+ Result.ok ()
214+
215+ E.Crash _ ->
216+ Result.ok ()
217+
133
218
134-- CHECK PATTERNS
219-- CHECK PATTERNS
135
220
136checkPatterns
221checkPatterns
137− :: AdtDict
222+ :: TagDict
138 -> Region.Region
223 -> Region.Region
139− -> [Pattern.CanonicalPattern]
224+ -> [P.CanonicalPattern]
140 -> Result.Result Warning.Warning e ()
225 -> Result.Result Warning.Warning e ()
141−checkPatterns adtDict region patterns =
226+checkPatterns tagDict region patterns =
142− checkPatternsHelp [P.Anything] patterns
227+ checkPatternsHelp tagDict region [Anything] patterns
143
228
144
229
145checkPatternsHelp
230checkPatternsHelp
146− :: AdtDict
231+ :: TagDict
147 -> Region.Region
232 -> Region.Region
148− -> [P.Pattern]
233+ -> [Pattern]
149− -> [Pattern.CanonicalPattern]
234+ -> [P.CanonicalPattern]
150 -> Result.Result Warning.Warning e ()
235 -> Result.Result Warning.Warning e ()
151−checkPatternsHelp adtDict region unhandled patterns =
236+checkPatternsHelp tagDict region unhandled patterns =
152 case (unhandled, patterns) of
237 case (unhandled, patterns) of
153 ([], []) ->
238 ([], []) ->
154 return ()
239 return ()
155
240
156 (_:_, []) ->
241 (_:_, []) ->
157− Result.warn region (Inexhaustive unhandled)
242+ Result.warn region Warning.InexhaustivePatternMatch
158
243
159− (_, A.A region pattern : remainingPatterns) ->
244+ (_, pattern@(A.A localRegion _) : remainingPatterns) ->
160− do newUnhandled <- filterPatterns adtDict region pattern unhandled
245+ do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
161− checkPatternsHelp adtDict newUnhandled remainingPatterns
246+ checkPatternsHelp tagDict region newUnhandled remainingPatterns
162
247
163
248
164filterPatterns
249filterPatterns
165− :: AdtDict
250+ :: TagDict
166 -> Region.Region
251 -> Region.Region
167− -> P.Pattern
252+ -> P.CanonicalPattern
168− -> [P.Pattern]
253+ -> [Pattern]
169− -> Result.Result Warning.Warning e [P.Pattern]
254+ -> Result.Result Warning.Warning e [Pattern]
170−filterPatterns adtDict region pattern unhandled =
255+filterPatterns tagDict region pattern unhandled =
171 let
256 let
172 nitPattern =
257 nitPattern =
173− P.fromPattern pattern
258+ fromCanonicalPattern pattern
174
259
175 noIntersection pat =
260 noIntersection pat =
176 intersection pat nitPattern == Nothing
261 intersection pat nitPattern == Nothing
177 in
262 in
178− if all noIntersection unhandled
263+ if all noIntersection unhandled then
179− then
180− do Result.warn region Redundant
264+ do Result.warn region Warning.RedundantPatternMatch
181− return unhandled
265+ return unhandled
182− else
266+ else
183− do let complementPatterns = complement adtDict nitPattern
267+ do let complementPatterns = complement tagDict nitPattern
184− return $
268+ return $
269+ concatMap
185− concatMap (\p -> Maybe.mapMaybe (intersection p) complementPatterns) unhandled
270+ (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
271+ unhandled
186
272
187
273
188-- PATTERN INTERSECTION
274-- PATTERN INTERSECTION
189
275
190−intersection :: P.Pattern -> P.Pattern -> Maybe P.Pattern
276+intersection :: Pattern -> Pattern -> Maybe Pattern
191intersection pattern1 pattern2 =
277intersection pattern1 pattern2 =
192 case (pattern1, pattern2) of
278 case (pattern1, pattern2) of
193− (P.Alias _ pattern1', _) ->
279+ (Alias _ pattern1', _) ->
194 intersection pattern1' pattern2
280 intersection pattern1' pattern2
195
281
196− (_, P.Alias _ pattern2') ->
282+ (_, Alias _ pattern2') ->
197 intersection pattern1 pattern2'
283 intersection pattern1 pattern2'
198
284
199− (P.Anything, _) ->
285+ (Anything, _) ->
200 Just pattern2
286 Just pattern2
201
287
202− (P.Var _, _) ->
288+ (Var _, _) ->
203 Just pattern2
289 Just pattern2
204
290
205− (_, P.Anything) ->
291+ (_, Anything) ->
206 Just pattern1
292 Just pattern1
207
293
208− (_, P.Var _) ->
294+ (_, Var _) ->
209 Just pattern1
295 Just pattern1
210
296
211− (P.Data ctor1 args1, P.Data ctor2 args2) ->
297+ (Data ctor1 args1, Data ctor2 args2) ->
212− if ctor1 /= ctor2
298+ if ctor1 /= ctor2 then
213− then Nothing
299+ Nothing
300+ else
214− else Data ctor1 <$> sequence (zipWith intersection args1 args2)
301+ Data ctor1 <$> sequence (zipWith intersection args1 args2)
215
302
216− -- TODO Assuming the fields are identical.
217− (P.Record _fields, P.Record _) ->
303+ (Record _, Record _) ->
218 Just pattern1
304 Just pattern1
219
305
220− (P.Literal lit1, P.Literal lit2) ->
306+ (Literal lit1, Literal lit2) ->
221− if lit1 == lit2
307+ if lit1 == lit2 then
222− then Just pattern1
308+ Just pattern1
309+ else
223− else Nothing
310+ Nothing
224−
311+
225− (P.AnythingBut literals, P.Literal lit) ->
312+ (AnythingBut literals, Literal lit) ->
226− if Set.member lit literals
313+ if Set.member lit literals then
227− then Nothing
314+ Nothing
315+ else
228− else Just pattern2
316+ Just pattern2
229−
317+
230− (P.Literal lit, P.AnythingBut literals) ->
318+ (Literal lit, AnythingBut literals) ->
231− if Set.membur lit literals
319+ if Set.member lit literals then
232− then Nothing
320+ Nothing
321+ else
233− else Just pattern1
322+ Just pattern1
234−
323+
235− (P.AnythingBut literals1, P.AnythingBut literals2) ->
324+ (AnythingBut literals1, AnythingBut literals2) ->
236 Just (AnythingBut (Set.union literals1 literals2))
325 Just (AnythingBut (Set.union literals1 literals2))
237
326
238 _ ->
327 _ ->
@@ -241,64 +330,67 @@ intersection pattern1 pattern2 =
241
330
242-- PATTERN COMPLEMENT
331-- PATTERN COMPLEMENT
243
332
244−complement :: AdtDict -> P.Pattern -> [P.Pattern]
333+complement :: TagDict -> Pattern -> [Pattern]
245−complement adtDict nitPattern =
334+complement tagDict nitPattern =
246 case nitPattern of
335 case nitPattern of
247− P.Record _fields ->
336+ Record _fields ->
248 []
337 []
249
338
250− P.Alias _name pattern ->
339+ Alias _name pattern ->
251− complement adtDict pattern
340+ complement tagDict pattern
252
341
253− P.Var _name ->
342+ Var _name ->
254 []
343 []
255
344
256− P.Anything ->
345+ Anything ->
257 []
346 []
258
347
259− P.Literal lit ->
348+ Literal lit ->
260 [AnythingBut (Set.singleton lit)]
349 [AnythingBut (Set.singleton lit)]
261
350
262− P.AnythingBut literals ->
351+ AnythingBut literals ->
263 map Literal (Set.toList literals)
352 map Literal (Set.toList literals)
264
353
265− P.Data ctor patterns ->
354+ Data ctor patterns ->
266− complementData adtDict ctor patterns
355+ complementData tagDict ctor patterns
267
356
268
357
269−complementData :: AdtDict -> Var.Canonical -> [P.Pattern] -> [P.Pattern]
358+complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
270−complementData adtDict canonicalTag patterns =
359+complementData tagDict tag patterns =
271 let
360 let
272− ctors =
361+ otherTags =
273− lookupOtherCtors ctor adtDict
362+ lookupOtherCtors tag tagDict
274
363
275− dataComplements =
364+ tagComplements =
276− Maybe.mapMaybe (maybeData canonicalTag) ctors
365+ Maybe.mapMaybe (tagToPattern tag) otherTags
277
366
367+ arity =
278− numArgs = length patterns
368+ length patterns
279
369
280 argComplements =
370 argComplements =
281− concat (zipWith (makeArgComplements adtDict numArgs) [0..] patterns)
371+ concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
282 in
372 in
283− dataComplements ++ argComplements
373+ tagComplements ++ argComplements
284
374
285
375
286−maybeData :: Var.Canonical -> (String, Module.AdtInfo) -> Maybe P.Pattern
376+tagToPattern :: Var.Canonical -> (Tag, Int) -> Maybe Pattern
287−maybeData (Var.Canonical home name) (tag, args) =
377+tagToPattern (Var.Canonical home rootTag) (tag, arity) =
288− if tag == name
289− then
378+ if rootTag == tag then
290− Nothing
379+ Nothing
291− else
380+ else
292− Just (P.Data (Var.Canonical home tag) (replicate (length args) P.Anything))
381+ Just (Data (Var.Canonical home tag) (replicate arity Anything))
293
382
294
383
295−makeArgComplements :: AdtDict -> Int -> Int -> P.Pattern -> [P.Pattern]
384+makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
296−makeArgComplements adtDict numArgs index argPattern =
385+makeArgComplements tagDict tag arity index argPattern =
297 let
386 let
298 complementList =
387 complementList =
299− complement adtDict argPattern
388+ complement tagDict argPattern
300
389
301− paddedArgs pat =
390+ padArgs pattern =
302− replicate index P.Anything ++ pat : replicate (numArgs - index - 1) P.Anything
391+ replicate index Anything
392+ ++ pattern
393+ : replicate (arity - index - 1) Anything
303 in
394 in
304− map (P.Data ctor . paddedArgs) complementList
395+ map (Data tag . padArgs) complementList
396+
src/Reporting/Warning.hs+22
@@ -19,6 +19,8 @@ import qualified Reporting.Report as Report
19data Warning
19data Warning
20 = UnusedImport Module.Name
20 = UnusedImport Module.Name
21 | MissingTypeAnnotation String Type.Canonical
21 | MissingTypeAnnotation String Type.Canonical
22+ | InexhaustivePatternMatch
23+ | RedundantPatternMatch
22
24
23
25
24-- TO STRING
26-- TO STRING
@@ -56,6 +58,26 @@ toReport dealiaser warning =
56 4
58 4
57 (P.pretty dealiaser False inferredType)
59 (P.pretty dealiaser False inferredType)
58
60
61+ InexhaustivePatternMatch ->
62+ Report.simple
63+ "missing pattern"
64+ "The following case expression does not handle all possible inputs."
65+ ( "If none of the patterns match the given value, we have no choice but to crash!\n"
66+ ++ "\n"
67+ ++ "If you somehow know that this pattern can never happen, you want to:\n"
68+ ++ "\n"
69+ ++ " 1. Rethink the data structures you are using. Is there a way to model the\n"
70+ ++ " values more precisely?\n"
71+ ++ " 2. End the pattern match with a wildcard match that leads to an expression\n"
72+ ++ " like: Debug.crash \"This should never happen, but I guess it can!\""
73+ )
74+
75+ RedundantPatternMatch ->
76+ Report.simple
77+ "redundant pattern"
78+ "The following pattern is redundant."
79+ "Any value with this shape will be handled by a previous pattern."
80+
59
81
60-- TO JSON
82-- TO JSON
61
83