@@ -1,270 +1,305 @@
1−{-# LANGUAGE NamedFieldPuns, TupleSections #-}
2−module Nitpick.PatternMatches
3− ( checkBody
4− , Pat (..)
5− , CanonicalPat
6− ) where
7−
8−import Control.Applicative ((<$>), (<*>))
9−import Control.Monad.Except (forM, liftM, throwError)
10−import Data.Maybe (mapMaybe, catMaybes)
11−import qualified Data.Set as Set
1+module Nitpick.PatternMatches (patternMatches) where
2+
3+import Control.Applicative ((<$>), (<*))
4+import Control.Monad.Except (forM, liftM)
5+import qualified Data.Foldable as F
126import qualified Data.Map as Map
7+import qualified Data.Maybe as Maybe
8+import qualified Data.Set as Set
139
14−import qualified AST.Expression.General as General
10+import qualified AST.Expression.General as E
1511import qualified AST.Expression.Canonical as Canonical
1612import qualified AST.Module as Module
1713import qualified AST.Pattern as Pattern
1814import qualified AST.Variable as Var
1915import Elm.Utils ((|>))
20−import qualified Reporting.Annotation as Annotation
16+import qualified Nitpick.Pattern as P
17+import qualified Reporting.Annotation as A
2118import qualified Reporting.Error.Nitpick as Error
2219import qualified Reporting.Region as Region
20+import qualified Reporting.Result as Result
2321import qualified Reporting.Warning.Nitpick as Warning
2422
2523
26−type M =
27− Either (Annotation.Located Error.Error)
28−
29−
30−fromPattern :: CanonicalPattern -> CanonicalPat
31−fromPattern (Annotation.A _region p) =
32− case p of
33− Pattern.Data ctor ps ->
34− Data ctor (map fromPattern ps)
24+patternMatches
25+ :: Module.Interfaces
26+ -> Module.CanonicalBody
27+ -> Result.Result Warning.Warning e ()
28+patternMatches interfaces body =
29+ checkExpression (toAdtDict interfaces) (Module.program body)
3530
36− Pattern.Record fs ->
37− Record fs
3831
39− Pattern.Alias s p ->
40− Alias s (fromPattern p)
32+-- ADT DICT
4133
42− Pattern.Var s ->
43− Var s
34+type AdtDict =
35+ Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
4436
45− Pattern.Anything ->
46− Anything
4737
48− Pattern.Literal l ->
49− Literal l
38+toAdtDict :: Module.Interfaces -> AdtDict
39+toAdtDict =
40+ let
41+ -- TODO
42+ builtinDict =
43+ Map.empty
5044
45+ interfaceDict =
46+ interfaces
47+ |> Map.map Module.iAdts
48+ |> Map.mapKeysMonotonic Var.Module
49+ in
50+ Map.union builtinDict interfaceDict
5151
52−checkBody
53− :: Module.Interfaces
54− -> Module.CanonicalBody
55− -> M [Annotation.Located Warning]
56−checkBody interfaces =
57− checkExpr . Module.program
58− where
59− checkExpr :: Canonical.Expr -> M [Annotation.Located Warning]
60− checkExpr (Annotation.A r e) =
61− case e of
62− General.ExplicitList es ->
63− concatMapM checkExpr es
6452
65− General.Binop _ e e' ->
66− (++) <$> checkExpr e <*> checkExpr e'
53+-- TODO this is wrong
54+lookupOtherCtors
55+ :: Var.Canonical
56+ -> AdtDict
57+ -> [(Var.Canonical, [Type.Canonical])]
58+lookupOtherCtors (Var.Canonical home name) adtDict =
59+ case Map.lookup name =<< Map.lookup home adtDict of
60+ Nothing ->
61+ error "TODO"
6762
68− General.Lambda p e ->
69− maybeCons <$> checkMatch r [p] <*> checkExpr e
63+ Just (_tvars, ctors) ->
64+ ctors
7065
71− General.App e e' ->
72− (++) <$> checkExpr e <*> checkExpr e'
7366
74− General.MultiIf branches ->
75− concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
67+-- CHECK EXPRESSIONS
7668
77− General.Let defs e ->
78− concat <$> sequence [ps, rhssResults, checkExpr e]
79− where
80− ps = filterMapM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
69+checkExpression
70+ :: AdtDict
71+ -> Canonical.Expr
72+ -> Result.Result Warning.Warning e ()
73+checkExpression adtDict (A.A region expression) =
74+ let
75+ go =
76+ checkExpression adtDict
8177
82− rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
78+ go2 a b =
79+ F.traverse_ go [a,b]
8380
84− General.Case e branches ->
85− do eResults <- checkExpr e
86− result <- checkMatch r ps
87− branchResults <- concatMapM (checkExpr . snd) branches
88− return (eResults ++ maybeCons result branchResults)
89− where ps = map fst branches
81+ goPattern =
82+ checkPatterns adtDict region
83+ in
84+ case expression of
85+ E.ExplicitList listExprs ->
86+ F.traverse_ go listExprs
9087
91− General.Data _ctor es ->
92− concatMapM checkExpr es
88+ E.Binop _ leftExpr rightExpr ->
89+ go2 leftExpr rightExpr
9390
94− General.Access e _f ->
95− checkExpr e
91+ E.Lambda pattern body ->
92+ goPattern [pattern]
93+ <* go body
9694
97− General.Remove e _f ->
98− checkExpr e
95+ E.App func arg ->
96+ go2 func arg
9997
100− General.Insert e _f e' ->
101− (++) <$> checkExpr e <*> checkExpr e'
98+ E.MultiIf branches ->
99+ F.traverse_ (uncurry go2) branches
102100
103− General.Modify e _ ->
104− checkExpr e
105−
106− General.Record fields ->
107− concatMapM (checkExpr . snd) fields
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
108+
109+ E.Case expr branches ->
110+ go expr
111+ <* goPattern (map fst branches)
112+ <* F.traverse_ (go . snd) branches
113+
114+ E.Data _ctor exprs ->
115+ F.traverse_ go exprs
116+
117+ E.Access record _field ->
118+ go record
108119
109− _ ->
110− return []
120+ E.Remove record _field ->
121+ go record
122+
123+ E.Insert record _field value ->
124+ go2 record value
125+
126+ E.Modify record fields ->
127+ go record
128+ <* F.traverse_ (go . snd) fields
129+
130+ E.Record fields ->
131+ F.traverse_ (go . snd) fields
132+
133+
134+-- CHECK PATTERNS
135+
136+checkPatterns
137+ :: AdtDict
138+ -> Region.Region
139+ -> [Pattern.CanonicalPattern]
140+ -> Result.Result Warning.Warning e ()
141+checkPatterns adtDict region patterns =
142+ checkPatternsHelp [P.Anything] patterns
111143
112144
113− ctorToAdt :: Var.Canonical -> Maybe (Module.AdtInfo String)
114− ctorToAdt =
115− \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m
116− where
117− -- Maps home to ctor name to the adt to which that ctor belongs
118− m :: Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
119− m =
120− builtins `Map.union` fromModules
121− where
122− -- TODO
123− builtins = Map.empty
145+checkPatternsHelp
146+ :: AdtDict
147+ -> Region.Region
148+ -> [P.Pattern]
149+ -> [Pattern.CanonicalPattern]
150+ -> Result.Result Warning.Warning e ()
151+checkPatternsHelp adtDict region unhandled patterns =
152+ case (unhandled, patterns) of
153+ ([], []) ->
154+ return ()
124155
125− fromModules = Map.mapKeysMonotonic Var.Module (Map.map Module.iAdts interfaces)
156+ (_:_, []) ->
157+ Result.warn region (Inexhaustive unhandled)
126158
159+ (_, A.A region pattern : remainingPatterns) ->
160+ do newUnhandled <- filterPatterns adtDict region pattern unhandled
161+ checkPatternsHelp adtDict newUnhandled remainingPatterns
127162
128− ctorToAdtErr :: Region.Region -> Var.Canonical -> M (Module.AdtInfo String)
129− ctorToAdtErr region c =
130− case ctorToAdt c of
131− Nothing ->
132− throwError (Annotation.A region (Error.ConstructorTypeNotFound c))
133163
134− Just adt ->
135− return adt
164+filterPatterns
165+ :: AdtDict
166+ -> Region.Region
167+ -> P.Pattern
168+ -> [P.Pattern]
169+ -> Result.Result Warning.Warning e [P.Pattern]
170+filterPatterns adtDict region pattern unhandled =
171+ let
172+ nitPattern =
173+ P.fromPattern pattern
136174
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
137186
138− complement :: Region.Region -> CanonicalPat -> M [CanonicalPat]
139− complement region p =
140− case p of
141− Data ctor ps ->
142− do let ctorName = Var.name ctor
143− ctorHome = Var.home ctor
144− (_tyVars, ctors) <- ctorToAdtErr region ctor
145− -- A pattern is in the complement of this one if it uses one of the
146− -- other constructors of this type...
147− let otherCtorPat (ctor', args) =
148− Data (Var.Canonical {Var.name = ctor', Var.home = ctorHome})
149− (replicate (length args) Anything)
150187
151− otherCtorPatterns =
152− filter (\(ctor', _) -> ctor' /= ctorName) ctors
153− |> map otherCtorPat
188+-- PATTERN INTERSECTION
154189
155− -- or if it uses this constructor and one of its argument patterns is
156− -- in the complement of an argument pattern here.
157− numArgs = length ps
158− sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
190+intersection :: P.Pattern -> P.Pattern -> Maybe P.Pattern
191+intersection pattern1 pattern2 =
192+ case (pattern1, pattern2) of
193+ (P.Alias _ pattern1', _) ->
194+ intersection pattern1' pattern2
159195
160− argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
161− map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
196+ (_, P.Alias _ pattern2') ->
197+ intersection pattern1 pattern2'
162198
163− return (otherCtorPatterns ++ argComplement)
199+ (P.Anything, _) ->
200+ Just pattern2
164201
165− Record _fs ->
166− return []
202+ (P.Var _, _) ->
203+ Just pattern2
167204
168− Alias _s p ->
169− complement region p
205+ (_, P.Anything) ->
206+ Just pattern1
170207
171− Var _s ->
172− return []
208+ (_, P.Var _) ->
209+ Just pattern1
173210
174− Anything ->
175− return []
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)
176215
177− Literal l ->
178− return [AnythingBut (Set.singleton l)]
216+ -- TODO Assuming the fields are identical.
217+ (P.Record _fields, P.Record _) ->
218+ Just pattern1
179219
180− AnythingBut ls ->
181− return (map Literal (Set.toList ls))
220+ (P.Literal lit1, P.Literal lit2) ->
221+ if lit1 == lit2
222+ then Just pattern1
223+ else Nothing
182224
183− intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
184− intersection p1 p2 =
185− case (p1, p2) of
186− (Alias _ p1', _) ->
187− intersection p1' p2
225+ (P.AnythingBut literals, P.Literal lit) ->
226+ if Set.member lit literals
227+ then Nothing
228+ else Just pattern2
188229
189− (_, Alias _ p2') ->
190− intersection p1 p2'
230+ (P.Literal lit, P.AnythingBut literals) ->
231+ if Set.membur lit literals
232+ then Nothing
233+ else Just pattern1
191234
192− (Anything, _) ->
193− Just p2
235+ (P.AnythingBut literals1, P.AnythingBut literals2) ->
236+ Just (AnythingBut (Set.union literals1 literals2))
194237
195− (Var _, _) ->
196− Just p2
238+ _ ->
239+ Nothing
197240
198− (_, Anything) ->
199− Just p1
200241
201− (_, Var _) ->
202− Just p1
242+-- PATTERN COMPLEMENT
203243
204− (Data ctor1 args1, Data ctor2 args2) ->
205− if ctor1 /= ctor2
206− then Nothing
207− else fmap (Data ctor1) (sequence (zipWith intersection args1 args2))
244+complement :: AdtDict -> P.Pattern -> [P.Pattern]
245+complement adtDict nitPattern =
246+ case nitPattern of
247+ P.Record _fields ->
248+ []
208249
209− -- TODO Assuming the fields are identical.
210− (Record _fs, Record _) ->
211− Just p1
250+ P.Alias _name pattern ->
251+ complement adtDict pattern
212252
213− (Literal l1, Literal l2) ->
214− if l1 == l2 then Just p1 else Nothing
253+ P.Var _name ->
254+ []
215255
216− (AnythingBut ls, Literal l) ->
217− if l `Set.member` ls then Nothing else Just p2
256+ P.Anything ->
257+ []
218258
219− (Literal l, AnythingBut ls) ->
220− if l `Set.member` ls then Nothing else Just p1
259+ P.Literal lit ->
260+ [AnythingBut (Set.singleton lit)]
221261
222− (AnythingBut ls1, AnythingBut ls2) ->
223− Just (AnythingBut (Set.union ls1 ls2))
262+ P.AnythingBut literals ->
263+ map Literal (Set.toList literals)
224264
225− _ -> Nothing
265+ P.Data ctor patterns ->
266+ complementData adtDict ctor patterns
226267
227− checkMatch :: Region.Region -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
228− checkMatch region =
229− go [Anything]
230− where
231− go :: [CanonicalPat] -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
232− go unhandled ps =
233− case (unhandled, ps) of
234− ([], []) ->
235− return Nothing
236268
237− (_:_, []) ->
238− return (Just (Annotation.A region (Inexhaustive unhandled)))
269+complementData :: AdtDict -> Var.Canonical -> [P.Pattern] -> [P.Pattern]
270+complementData adtDict canonicalTag patterns =
271+ let
272+ ctors =
273+ lookupOtherCtors ctor adtDict
239274
240− (_, p:ps') ->
241− let pp = fromPattern p
242− Annotation.A region _ = p
243− in
244− if all (\q -> intersection q pp == Nothing) unhandled
245− then return (Just (Annotation.A region (Redundant p)))
246− else
247− do pComp <- complement region pp
248− go (concatMap (\q -> mapMaybe (intersection q) pComp) unhandled) ps'
275+ dataComplements =
276+ Maybe.mapMaybe (maybeData canonicalTag) ctors
249277
278+ numArgs = length patterns
250279
251−-- Util
280+ argComplements =
281+ concat (zipWith (makeArgComplements adtDict numArgs) [0..] patterns)
282+ in
283+ dataComplements ++ argComplements
252284
253−concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
254−concatMapM f list =
255− liftM concat (mapM f list)
256285
286+maybeData :: Var.Canonical -> (String, Module.AdtInfo) -> Maybe P.Pattern
287+maybeData (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))
257293
258−filterMapM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
259−filterMapM f list =
260− liftM catMaybes (mapM f list)
261294
295+makeArgComplements :: AdtDict -> Int -> Int -> P.Pattern -> [P.Pattern]
296+makeArgComplements adtDict numArgs index argPattern =
297+ let
298+ complementList =
299+ complement adtDict argPattern
262300
263−maybeCons :: Maybe a -> [a] -> [a]
264−maybeCons maybe list =
265− case maybe of
266− Just x ->
267− x : list
301+ paddedArgs pat =
302+ replicate index P.Anything ++ pat : replicate (numArgs - index - 1) P.Anything
303+ in
304+ map (P.Data ctor . paddedArgs) complementList
268305
269− Nothing ->
270− list