@@ -0,0 +1,270 @@
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
12+import qualified Data.Map as Map
13+
14+import qualified AST.Expression.General as General
15+import qualified AST.Expression.Canonical as Canonical
16+import qualified AST.Module as Module
17+import qualified AST.Pattern as Pattern
18+import qualified AST.Variable as Var
19+import Elm.Utils ((|>))
20+import qualified Reporting.Annotation as Annotation
21+import qualified Reporting.Error.Nitpick as Error
22+import qualified Reporting.Region as Region
23+import qualified Reporting.Warning.Nitpick as Warning
24+
25+
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)
35+
36+ Pattern.Record fs ->
37+ Record fs
38+
39+ Pattern.Alias s p ->
40+ Alias s (fromPattern p)
41+
42+ Pattern.Var s ->
43+ Var s
44+
45+ Pattern.Anything ->
46+ Anything
47+
48+ Pattern.Literal l ->
49+ Literal l
50+
51+
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
64+
65+ General.Binop _ e e' ->
66+ (++) <$> checkExpr e <*> checkExpr e'
67+
68+ General.Lambda p e ->
69+ maybeCons <$> checkMatch r [p] <*> checkExpr e
70+
71+ General.App e e' ->
72+ (++) <$> checkExpr e <*> checkExpr e'
73+
74+ General.MultiIf branches ->
75+ concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
76+
77+ General.Let defs e ->
78+ concat <$> sequence [ps, rhssResults, checkExpr e]
79+ where
80+ ps = filterMapM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
81+
82+ rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
83+
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
90+
91+ General.Data _ctor es ->
92+ concatMapM checkExpr es
93+
94+ General.Access e _f ->
95+ checkExpr e
96+
97+ General.Remove e _f ->
98+ checkExpr e
99+
100+ General.Insert e _f e' ->
101+ (++) <$> checkExpr e <*> checkExpr e'
102+
103+ General.Modify e _ ->
104+ checkExpr e
105+
106+ General.Record fields ->
107+ concatMapM (checkExpr . snd) fields
108+
109+ _ ->
110+ return []
111+
112+
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
124+
125+ fromModules = Map.mapKeysMonotonic Var.Module (Map.map Module.iAdts interfaces)
126+
127+
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))
133+
134+ Just adt ->
135+ return adt
136+
137+
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)
150+
151+ otherCtorPatterns =
152+ filter (\(ctor', _) -> ctor' /= ctorName) ctors
153+ |> map otherCtorPat
154+
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
159+
160+ argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
161+ map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
162+
163+ return (otherCtorPatterns ++ argComplement)
164+
165+ Record _fs ->
166+ return []
167+
168+ Alias _s p ->
169+ complement region p
170+
171+ Var _s ->
172+ return []
173+
174+ Anything ->
175+ return []
176+
177+ Literal l ->
178+ return [AnythingBut (Set.singleton l)]
179+
180+ AnythingBut ls ->
181+ return (map Literal (Set.toList ls))
182+
183+ intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
184+ intersection p1 p2 =
185+ case (p1, p2) of
186+ (Alias _ p1', _) ->
187+ intersection p1' p2
188+
189+ (_, Alias _ p2') ->
190+ intersection p1 p2'
191+
192+ (Anything, _) ->
193+ Just p2
194+
195+ (Var _, _) ->
196+ Just p2
197+
198+ (_, Anything) ->
199+ Just p1
200+
201+ (_, Var _) ->
202+ Just p1
203+
204+ (Data ctor1 args1, Data ctor2 args2) ->
205+ if ctor1 /= ctor2
206+ then Nothing
207+ else fmap (Data ctor1) (sequence (zipWith intersection args1 args2))
208+
209+ -- TODO Assuming the fields are identical.
210+ (Record _fs, Record _) ->
211+ Just p1
212+
213+ (Literal l1, Literal l2) ->
214+ if l1 == l2 then Just p1 else Nothing
215+
216+ (AnythingBut ls, Literal l) ->
217+ if l `Set.member` ls then Nothing else Just p2
218+
219+ (Literal l, AnythingBut ls) ->
220+ if l `Set.member` ls then Nothing else Just p1
221+
222+ (AnythingBut ls1, AnythingBut ls2) ->
223+ Just (AnythingBut (Set.union ls1 ls2))
224+
225+ _ -> Nothing
226+
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
236+
237+ (_:_, []) ->
238+ return (Just (Annotation.A region (Inexhaustive unhandled)))
239+
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'
249+
250+
251+-- Util
252+
253+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
254+concatMapM f list =
255+ liftM concat (mapM f list)
256+
257+
258+filterMapM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
259+filterMapM f list =
260+ liftM catMaybes (mapM f list)
261+
262+
263+maybeCons :: Maybe a -> [a] -> [a]
264+maybeCons maybe list =
265+ case maybe of
266+ Just x ->
267+ x : list
268+
269+ Nothing ->
270+ list