@@ -1,13 +1,23 @@
1+{-# OPTIONS_GHC -Wall #-}
12module Nitpick.PatternMatches (patternMatches) where
23
3−import Control.Arrow (second)
4+{- The algorithm used here comes from "Warnings for Pattern Matching"
5+by Luc Maranget. Check it out for more information!
6+
7+http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
8+
9+-}
10+
11+import Control.Arrow ((***), second)
412import qualified Data.Foldable as F
13+import qualified Data.List as List
514import qualified Data.Map as Map
615import qualified Data.Maybe as Maybe
716import qualified Data.Set as Set
817
918import qualified AST.Expression.Canonical as C
1019import qualified AST.Helpers as Help
20+import qualified AST.Literal as L
1121import qualified AST.Module as Module
1222import qualified AST.Module.Name as ModuleName
1323import qualified AST.Pattern as Pattern
@@ -29,100 +39,25 @@ type Result warning a =
2939patternMatches :: Module.Interfaces -> Module.Canonical -> Result wrn DT.VariantDict
3040patternMatches interfaces (Module.Module name _ info) =
3141 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)
37−
38−
39−
40−-- TAG DICT
41−
42−
43−type TagDict =
44− Map.Map Var.Home (Map.Map Tag [TagInfo])
42+ arityDict =
43+ toArityDict interfaces name (Module.unions info)
4544
46−
47−type Tag = String
48−
49−
50−data TagInfo = TagInfo
51− { _tag :: Tag
52− , _arity :: Int
53− }
54−
55−
56−toTagDict :: Module.Interfaces -> ModuleName.Canonical -> Module.Unions -> TagDict
57−toTagDict interfaces localName localUnions =
58− let
59− listTags =
60− [ TagInfo "::" 2
61− , TagInfo "[]" 0
62− ]
63−
64− boolTags =
65− [ TagInfo "True" 0
66− , TagInfo "False" 0
67− ]
68−
69− builtinDict =
70− Map.singleton Var.BuiltIn $
71− Map.fromList
72− [ ("::", listTags)
73− , ("[]", listTags)
74− , ("True", boolTags)
75− , ("False", boolTags)
76− ]
77−
78− interfaceDict =
79− interfaces
80− |> Map.map (toTagMapping . Module.iUnions)
81− |> Map.mapKeysMonotonic Var.Module
82− |> Map.insert (Var.Module localName) (toTagMapping localUnions)
45+ variantDict =
46+ Map.map (Map.map _size) arityDict
8347 in
84− Map.union builtinDict interfaceDict
85−
86−
87−toTagMapping :: Module.Unions -> Map.Map Tag [TagInfo]
88−toTagMapping 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
99−
100−
101−lookupOtherTags :: Var.Canonical -> TagDict -> [TagInfo]
102−lookupOtherTags (Var.Canonical home name) tagDict =
103− case Map.lookup name =<< Map.lookup home tagDict of
104− Just otherTags ->
105− otherTags
106−
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."
48+ pure variantDict
49+ <* checkExpression arityDict (Module.program info)
11550
11651
11752
11853-- CHECK EXPRESSIONS
11954
12055
121−checkExpression :: TagDict -> C.Expr -> Result wrn ()
122−checkExpression tagDict (A.A region expression) =
56+checkExpression :: ArityDict -> C.Expr -> Result wrn ()
57+checkExpression arityDict (A.A region expression) =
12358 let
12459 go =
125− checkExpression tagDict
60+ checkExpression arityDict
12661
12762 go2 a b =
12863 go a <* go b
@@ -141,7 +76,7 @@ checkExpression tagDict (A.A region expression) =
14176 go2 leftExpr rightExpr
14277
14378 C.Lambda pattern@(A.A patRegion _) body ->
144− checkPatterns tagDict patRegion Error.Arg [pattern]
79+ checkPatterns arityDict patRegion Error.Arg [pattern]
14580 <* go body
14681
14782 C.App func arg ->
@@ -156,12 +91,12 @@ checkExpression tagDict (A.A region expression) =
15691 <* F.traverse_ goDef defs
15792 where
15893 goDef (C.Def _ pattern@(A.A patRegion _) expr _) =
159− checkPatterns tagDict patRegion Error.LetBound [pattern]
94+ checkPatterns arityDict patRegion Error.LetBound [pattern]
16095 <* go expr
16196
16297 C.Case expr branches ->
16398 go expr
164− <* checkPatterns tagDict region Error.Case (map fst branches)
99+ <* checkPatterns arityDict region Error.Case (map fst branches)
165100 <* F.traverse_ (go . snd) branches
166101
167102 C.Ctor _ctor exprs ->
@@ -203,180 +138,245 @@ checkExpression tagDict (A.A region expression) =
203138-- CHECK PATTERNS
204139
205140
206−checkPatterns :: TagDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()
207−checkPatterns tagDict region origin patterns =
208− checkPatternsHelp tagDict region origin [Anything] patterns
141+checkPatterns :: ArityDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()
142+checkPatterns arityDict region origin patterns =
143+ let
144+ matrix =
145+ map (\p -> [fromCanonicalPattern p]) patterns
146+ in
147+ if isUseful arityDict matrix [Anything] then
148+ Result.throw region (Error.Incomplete origin (error "TODO"))
209149
150+ else
151+ return ()
210152
211−checkPatternsHelp
212− :: TagDict
213− -> Region.Region
214− -> Error.Origin
215− -> [Pattern]
216− -> [Pattern.Canonical]
217− -> Result wrn ()
218−checkPatternsHelp tagDict region origin unhandled patterns =
219− case (unhandled, patterns) of
220− ([], []) ->
221− return ()
222153
223− (_:_, []) ->
224− Result.throw region (Error.Incomplete origin unhandled)
225154
226− (_, pattern@(A.A localRegion _) : remainingPatterns) ->
227− do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
228− checkPatternsHelp tagDict region origin newUnhandled remainingPatterns
155+-- MISSING PATTERNS
229156
230157
231−filterPatterns
232− :: TagDict
233− -> Region.Region
234− -> Pattern.Canonical
235− -> [Pattern]
236− -> Result wrn [Pattern]
237−filterPatterns tagDict region pattern unhandled =
238− let
239− nitPattern =
240− fromCanonicalPattern pattern
158+--missingPatterns :: [[Pattern]] -> Int -> [Pattern]
159+--missingPatterns matrix n =
160+-- case matrix of
161+-- [] ->
241162
242− noIntersection pat =
243− intersection pat nitPattern == Nothing
244− in
245− if all noIntersection unhandled then
246− Result.throw region Error.Redundant
247163
248− else
249− do let complementPatterns = complement tagDict nitPattern
250− return $
251− concatMap
252− (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
253− unhandled
254164
255165
166+-- REDUNDANT PATTERNS
256167
257−-- PATTERN INTERSECTION
258168
169+isUseful :: ArityDict -> [[Pattern]] -> [Pattern] -> Bool
170+isUseful arityDict matrix vector =
171+ case (matrix, vector) of
172+ ([], _) ->
173+ True
259174
260−intersection :: Pattern -> Pattern -> Maybe Pattern
261−intersection pattern1 pattern2 =
262− case (pattern1, pattern2) of
263− (Alias _ pattern1', _) ->
264− intersection pattern1' pattern2
175+ (_, []) ->
176+ False
265177
266− (_, Alias _ pattern2') ->
267− intersection pattern1 pattern2'
178+ (_, firstPattern : patterns) ->
179+ case firstPattern of
180+ Ctor name args ->
181+ let
182+ newMatrix =
183+ Maybe.mapMaybe (specialize name (length args)) matrix
184+ in
185+ isUseful arityDict newMatrix (args ++ patterns)
268186
269− (Anything, _) ->
270− Just pattern2
187+ Anything ->
188+ case isComplete arityDict matrix of
189+ Nothing ->
190+ isUseful arityDict (Maybe.mapMaybe toDefault matrix) patterns
271191
272− (Var _, _) ->
273− Just pattern2
192+ Just arityInfo ->
193+ let
194+ isUsefulHelp (ctor, arity) =
195+ isUseful
196+ arityDict
197+ (Maybe.mapMaybe (specialize ctor arity) matrix)
198+ (replicate arity Anything ++ patterns)
199+ in
200+ any isUsefulHelp arityInfo
274201
275− (_, Anything) ->
276− Just pattern1
202+ Literal literal ->
203+ let
204+ newMatrix =
205+ Maybe.mapMaybe (specializeLiteral literal) matrix
206+ in
207+ isUseful arityDict newMatrix patterns
277208
278− (_, Var _) ->
279− Just pattern1
280209
281− (Data ctor1 args1, Data ctor2 args2) ->
282− if ctor1 /= ctor2 then
283− Nothing
284− else
285− Data ctor1 <$> sequence (zipWith intersection args1 args2)
286210
287− (Record _, Record _) ->
288− Just pattern1
211+-- SPECIALIZE MATRICES
289212
290− (Literal lit1, Literal lit2) ->
291− if lit1 == lit2 then
292− Just pattern1
293− else
294− Nothing
295213
296− (AnythingBut literals, Literal lit) ->
297− if Set.member lit literals then
298− Nothing
299− else
300− Just pattern2
214+specialize :: Var.Canonical -> Int -> [Pattern] -> Maybe [Pattern]
215+specialize ctorName arity row =
216+ case row of
217+ [] ->
218+ error "Compiler error! Empty matrices should not get specialized."
301219
302− (Literal lit, AnythingBut literals) ->
303− if Set.member lit literals then
304− Nothing
305− else
306− Just pattern1
220+ firstPattern : patterns ->
221+ case firstPattern of
222+ Ctor name args ->
223+ if name == ctorName then Just (args ++ patterns) else Nothing
307224
308− (AnythingBut literals1, AnythingBut literals2) ->
309− Just (AnythingBut (Set.union literals1 literals2))
225+ Anything ->
226+ Just (replicate arity Anything ++ patterns)
310227
311− _ ->
312− Nothing
228+ Literal _ ->
229+ error $
230+ "Compiler bug! After type checking, constructors and literals\
231+ \ should never align in pattern match exhaustiveness checks."
313232
314233
234+specializeLiteral :: L.Literal -> [Pattern] -> Maybe [Pattern]
235+specializeLiteral literal row =
236+ case row of
237+ [] ->
238+ error "Compiler error! Empty matrices should not get specialized."
315239
316−-- PATTERN COMPLEMENT
240+ firstPattern : patterns ->
241+ case firstPattern of
242+ Literal lit ->
243+ if lit == literal then Just patterns else Nothing
317244
245+ Anything ->
246+ Just patterns
318247
319−complement :: TagDict -> Pattern -> [Pattern]
320−complement tagDict nitPattern =
321− case nitPattern of
322− Record _fields ->
323− []
248+ Ctor _ _ ->
249+ error $
250+ "Compiler bug! After type checking, constructors and literals\
251+ \ should never align in pattern match exhaustiveness checks."
324252
325− Alias _name pattern ->
326− complement tagDict pattern
327253
328− Var _name ->
329− []
254+toDefault :: [Pattern] -> Maybe [Pattern]
255+toDefault row =
256+ case row of
257+ [] ->
258+ Nothing
330259
331− Anything ->
332− []
260+ Ctor _ _ : _ ->
261+ Nothing
333262
334− Literal lit ->
335− [AnythingBut (Set.singleton lit)]
263+ Anything : patterns ->
264+ Just patterns
336265
337− AnythingBut literals ->
338− map Literal (Set.toList literals)
266+ Literal _ : _ ->
267+ Nothing
339268
340− Data ctor patterns ->
341− complementData tagDict ctor patterns
342269
343270
344−complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]
345−complementData tagDict tag patterns =
346− let
347− otherTags =
348− lookupOtherTags tag tagDict
271+-- ALL CONSTRUCTORS ARE PRESENT?
349272
350− tagComplements =
351− Maybe.mapMaybe (tagToPattern tag) otherTags
352273
353− arity =
354− length patterns
274+isComplete :: ArityDict -> [[Pattern]] -> Maybe [(Var.Canonical, Int)]
275+isComplete arityDict matrix =
276+ let
277+ ctorSet =
278+ List.foldl' isCompleteHelp Set.empty matrix
355279
356− argComplements =
357− concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)
280+ actual =
281+ Set.size ctorSet
358282 in
359− tagComplements ++ argComplements
283+ if actual == 0 then
284+ Nothing
285+
286+ else
287+ let
288+ (ArityInfo expected info) =
289+ getArityInfo (Set.findMin ctorSet) arityDict
290+ in
291+ if expected == actual then Just info else Nothing
292+
293+
294+isCompleteHelp :: Set.Set Var.Canonical -> [Pattern] -> Set.Set Var.Canonical
295+isCompleteHelp ctors row =
296+ case row of
297+ Ctor name _ : _ ->
298+ Set.insert name ctors
299+
300+ _ ->
301+ ctors
302+
303+
304+
305+-- ARITY DICT
306+
307+
308+type ArityDict =
309+ Map.Map Var.Home (Map.Map String ArityInfo)
310+
311+
312+data ArityInfo =
313+ ArityInfo
314+ { _size :: !Int
315+ , _info :: [(Var.Canonical, Int)]
316+ }
360317
361318
362−tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern
363−tagToPattern (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))
319+toArityDict :: Module.Interfaces -> ModuleName.Canonical -> Module.Unions -> ArityDict
320+toArityDict interfaces localName localUnions =
321+ interfaces
322+ |> Map.mapWithKey (\name iface -> toArityEntry name (Module.iUnions iface))
323+ |> Map.mapKeysMonotonic Var.Module
324+ |> Map.insert (Var.Module localName) (toArityEntry localName localUnions)
325+ |> Map.union builtinDict
368326
369327
370−makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]
371−makeArgComplements tagDict tag arity index argPattern =
328+builtinDict :: ArityDict
329+builtinDict =
372330 let
373− complementList =
374− complement tagDict argPattern
331+ listInfo =
332+ ArityInfo 2 [ (Var.builtin "::", 2), (Var.builtin "[]", 0) ]
375333
376− padArgs pattern =
377− replicate index Anything
378− ++ pattern
379− : replicate (arity - index - 1) Anything
334+ boolInfo =
335+ ArityInfo 2 [ (Var.builtin "True", 0), (Var.builtin "False", 0) ]
380336 in
381− map (Data tag . padArgs) complementList
337+ Map.singleton Var.BuiltIn $ Map.fromList $
338+ [ ("::", listInfo)
339+ , ("[]", listInfo)
340+ , ("True", boolInfo)
341+ , ("False", boolInfo)
342+ ]
343+ ++ map makeTupleInfo [0..8]
382344
345+
346+makeTupleInfo :: Int -> ( String, ArityInfo )
347+makeTupleInfo n =
348+ let
349+ name =
350+ "_Tuple" ++ show n
351+ in
352+ ( name, ArityInfo 1 [ (Var.builtin name, n) ] )
353+
354+
355+toArityEntry :: ModuleName.Canonical -> Module.Unions -> Map.Map String ArityInfo
356+toArityEntry name unions =
357+ Map.fromList (concatMap (toArityEntryHelp name) (Map.elems unions))
358+
359+
360+toArityEntryHelp :: ModuleName.Canonical -> Module.UnionInfo String -> [(String, ArityInfo)]
361+toArityEntryHelp name (_tvars, ctors) =
362+ let
363+ arityInfo =
364+ ArityInfo (length ctors) (map (Var.fromModule name *** length) ctors)
365+ in
366+ map (second (\_ -> arityInfo)) ctors
367+
368+
369+getArityInfo :: Var.Canonical -> ArityDict -> ArityInfo
370+getArityInfo var@(Var.Canonical home name) arityDict =
371+ case Map.lookup name =<< Map.lookup home arityDict of
372+ Just arityInfo ->
373+ arityInfo
374+
375+ Nothing ->
376+ if Help.isTuple name then
377+ ArityInfo 1 [ (var, read (drop 6 name)) ]
378+ else
379+ error
380+ "Since the Nitpick phase happens after canonicalization and type\
381+ \ inference, it is impossible that a pattern in a case cannot be\
382+ \ found."