git.iko.soy/elk
on master help sign in
Refactor to make Nitpick code simpler/clearer
511475bEvan Czaplicki
src/Nitpick/Pattern.hsnew file+38
compare with master
unifiedsplit
@@ -0,0 +1,38 @@
1+module Nitpick.Pattern where
2+
3+import qualified AST.Pattern as P
4+import qualified AST.Variable as Var
5+
6+
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
38+
src/Nitpick/PatternMatches.hs+231−196
@@ -1,270 +1,305 @@
1−{-# LANGUAGE NamedFieldPuns, TupleSections #-}
2−module Nitpick.PatternMatches
1+module Nitpick.PatternMatches (patternMatches) where
3− ( checkBody
2+
4− , Pat (..)
5− , CanonicalPat
6− ) where
7−
8−import Control.Applicative ((<$>), (<*>))
3+import Control.Applicative ((<$>), (<*))
9−import Control.Monad.Except (forM, liftM, throwError)
4+import Control.Monad.Except (forM, liftM)
10−import Data.Maybe (mapMaybe, catMaybes)
11−import qualified Data.Set as Set
5+import qualified Data.Foldable as F
12import qualified Data.Map as Map
6import qualified Data.Map as Map
7+import qualified Data.Maybe as Maybe
8+import qualified Data.Set as Set
13
9
14−import qualified AST.Expression.General as General
10+import qualified AST.Expression.General as E
15import qualified AST.Expression.Canonical as Canonical
11import qualified AST.Expression.Canonical as Canonical
16import qualified AST.Module as Module
12import qualified AST.Module as Module
17import qualified AST.Pattern as Pattern
13import qualified AST.Pattern as Pattern
18import qualified AST.Variable as Var
14import qualified AST.Variable as Var
19import Elm.Utils ((|>))
15import Elm.Utils ((|>))
16+import qualified Nitpick.Pattern as P
20−import qualified Reporting.Annotation as Annotation
17+import qualified Reporting.Annotation as A
21import qualified Reporting.Error.Nitpick as Error
18import qualified Reporting.Error.Nitpick as Error
22import qualified Reporting.Region as Region
19import qualified Reporting.Region as Region
20+import qualified Reporting.Result as Result
23import qualified Reporting.Warning.Nitpick as Warning
21import qualified Reporting.Warning.Nitpick as Warning
24
22
25
23
26−type M =
24+patternMatches
27− Either (Annotation.Located Error.Error)
25+ :: Module.Interfaces
28−
26+ -> Module.CanonicalBody
29−
27+ -> Result.Result Warning.Warning e ()
30−fromPattern :: CanonicalPattern -> CanonicalPat
28+patternMatches interfaces body =
31−fromPattern (Annotation.A _region p) =
29+ checkExpression (toAdtDict interfaces) (Module.program body)
32− case p of
33− Pattern.Data ctor ps ->
34− Data ctor (map fromPattern ps)
35
30
36− Pattern.Record fs ->
37− Record fs
38
31
39− Pattern.Alias s p ->
32+-- ADT DICT
40− Alias s (fromPattern p)
41
33
42− Pattern.Var s ->
34+type AdtDict =
43− Var s
35+ Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
44
36
45− Pattern.Anything ->
46− Anything
47
37
48− Pattern.Literal l ->
38+toAdtDict :: Module.Interfaces -> AdtDict
49− Literal l
39+toAdtDict =
40+ let
41+ -- TODO
42+ builtinDict =
43+ Map.empty
50
44
45+ interfaceDict =
46+ interfaces
47+ |> Map.map Module.iAdts
48+ |> Map.mapKeysMonotonic Var.Module
49+ in
50+ Map.union builtinDict interfaceDict
51
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
52
65− General.Binop _ e e' ->
53+-- TODO this is wrong
66− (++) <$> checkExpr e <*> checkExpr e'
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"
67
62
68− General.Lambda p e ->
63+ Just (_tvars, ctors) ->
69− maybeCons <$> checkMatch r [p] <*> checkExpr e
64+ ctors
70
65
71− General.App e e' ->
72− (++) <$> checkExpr e <*> checkExpr e'
73
66
74− General.MultiIf branches ->
67+-- CHECK EXPRESSIONS
75− concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
76
68
77− General.Let defs e ->
69+checkExpression
78− concat <$> sequence [ps, rhssResults, checkExpr e]
70+ :: AdtDict
79− where
71+ -> Canonical.Expr
80− ps = filterMapM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
72+ -> Result.Result Warning.Warning e ()
73+checkExpression adtDict (A.A region expression) =
74+ let
75+ go =
76+ checkExpression adtDict
81
77
82− rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
78+ go2 a b =
79+ F.traverse_ go [a,b]
83
80
84− General.Case e branches ->
81+ goPattern =
85− do eResults <- checkExpr e
82+ checkPatterns adtDict region
86− result <- checkMatch r ps
83+ in
87− branchResults <- concatMapM (checkExpr . snd) branches
84+ case expression of
88− return (eResults ++ maybeCons result branchResults)
85+ E.ExplicitList listExprs ->
89− where ps = map fst branches
86+ F.traverse_ go listExprs
90
87
91− General.Data _ctor es ->
88+ E.Binop _ leftExpr rightExpr ->
92− concatMapM checkExpr es
89+ go2 leftExpr rightExpr
93
90
94− General.Access e _f ->
91+ E.Lambda pattern body ->
95− checkExpr e
92+ goPattern [pattern]
93+ <* go body
96
94
97− General.Remove e _f ->
95+ E.App func arg ->
98− checkExpr e
96+ go2 func arg
99
97
100− General.Insert e _f e' ->
98+ E.MultiIf branches ->
101− (++) <$> checkExpr e <*> checkExpr e'
99+ F.traverse_ (uncurry go2) branches
102
100
103− General.Modify e _ ->
101+ E.Let defs body ->
104− checkExpr e
102+ go body
105−
103+ <* F.traverse_ goDef defs
106− General.Record fields ->
104+ where
107− concatMapM (checkExpr . snd) fields
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
108
119
109− _ ->
120+ E.Remove record _field ->
110− return []
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
111
143
112
144
113− ctorToAdt :: Var.Canonical -> Maybe (Module.AdtInfo String)
145+checkPatternsHelp
114− ctorToAdt =
146+ :: AdtDict
115− \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m
147+ -> Region.Region
116− where
148+ -> [P.Pattern]
117− -- Maps home to ctor name to the adt to which that ctor belongs
149+ -> [Pattern.CanonicalPattern]
118− m :: Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
150+ -> Result.Result Warning.Warning e ()
119− m =
151+checkPatternsHelp adtDict region unhandled patterns =
120− builtins `Map.union` fromModules
152+ case (unhandled, patterns) of
121− where
153+ ([], []) ->
122− -- TODO
154+ return ()
123− builtins = Map.empty
124
155
125− fromModules = Map.mapKeysMonotonic Var.Module (Map.map Module.iAdts interfaces)
156+ (_:_, []) ->
157+ Result.warn region (Inexhaustive unhandled)
126
158
159+ (_, A.A region pattern : remainingPatterns) ->
160+ do newUnhandled <- filterPatterns adtDict region pattern unhandled
161+ checkPatternsHelp adtDict newUnhandled remainingPatterns
127
162
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
163
134− Just adt ->
164+filterPatterns
135− return adt
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
136
174
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
137
186
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
187
151− otherCtorPatterns =
188+-- PATTERN INTERSECTION
152− filter (\(ctor', _) -> ctor' /= ctorName) ctors
153− |> map otherCtorPat
154
189
155− -- or if it uses this constructor and one of its argument patterns is
190+intersection :: P.Pattern -> P.Pattern -> Maybe P.Pattern
156− -- in the complement of an argument pattern here.
191+intersection pattern1 pattern2 =
157− numArgs = length ps
192+ case (pattern1, pattern2) of
158− sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
193+ (P.Alias _ pattern1', _) ->
194+ intersection pattern1' pattern2
159
195
160− argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
196+ (_, P.Alias _ pattern2') ->
161− map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
197+ intersection pattern1 pattern2'
162
198
163− return (otherCtorPatterns ++ argComplement)
199+ (P.Anything, _) ->
200+ Just pattern2
164
201
165− Record _fs ->
202+ (P.Var _, _) ->
166− return []
203+ Just pattern2
167
204
168− Alias _s p ->
205+ (_, P.Anything) ->
169− complement region p
206+ Just pattern1
170
207
171− Var _s ->
208+ (_, P.Var _) ->
172− return []
209+ Just pattern1
173
210
174− Anything ->
211+ (P.Data ctor1 args1, P.Data ctor2 args2) ->
175− return []
212+ if ctor1 /= ctor2
213+ then Nothing
214+ else Data ctor1 <$> sequence (zipWith intersection args1 args2)
176
215
177− Literal l ->
216+ -- TODO Assuming the fields are identical.
178− return [AnythingBut (Set.singleton l)]
217+ (P.Record _fields, P.Record _) ->
218+ Just pattern1
179
219
180− AnythingBut ls ->
220+ (P.Literal lit1, P.Literal lit2) ->
181− return (map Literal (Set.toList ls))
221+ if lit1 == lit2
222+ then Just pattern1
223+ else Nothing
182
224
183− intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
225+ (P.AnythingBut literals, P.Literal lit) ->
184− intersection p1 p2 =
226+ if Set.member lit literals
185− case (p1, p2) of
227+ then Nothing
186− (Alias _ p1', _) ->
228+ else Just pattern2
187− intersection p1' p2
188
229
189− (_, Alias _ p2') ->
230+ (P.Literal lit, P.AnythingBut literals) ->
190− intersection p1 p2'
231+ if Set.membur lit literals
232+ then Nothing
233+ else Just pattern1
191
234
192− (Anything, _) ->
235+ (P.AnythingBut literals1, P.AnythingBut literals2) ->
193− Just p2
236+ Just (AnythingBut (Set.union literals1 literals2))
194
237
195− (Var _, _) ->
238+ _ ->
196− Just p2
239+ Nothing
197
240
198− (_, Anything) ->
199− Just p1
200
241
201− (_, Var _) ->
242+-- PATTERN COMPLEMENT
202− Just p1
203
243
204− (Data ctor1 args1, Data ctor2 args2) ->
244+complement :: AdtDict -> P.Pattern -> [P.Pattern]
205− if ctor1 /= ctor2
245+complement adtDict nitPattern =
206− then Nothing
246+ case nitPattern of
207− else fmap (Data ctor1) (sequence (zipWith intersection args1 args2))
247+ P.Record _fields ->
248+ []
208
249
209− -- TODO Assuming the fields are identical.
250+ P.Alias _name pattern ->
210− (Record _fs, Record _) ->
251+ complement adtDict pattern
211− Just p1
212
252
213− (Literal l1, Literal l2) ->
253+ P.Var _name ->
214− if l1 == l2 then Just p1 else Nothing
254+ []
215
255
216− (AnythingBut ls, Literal l) ->
256+ P.Anything ->
217− if l `Set.member` ls then Nothing else Just p2
257+ []
218
258
219− (Literal l, AnythingBut ls) ->
259+ P.Literal lit ->
220− if l `Set.member` ls then Nothing else Just p1
260+ [AnythingBut (Set.singleton lit)]
221
261
222− (AnythingBut ls1, AnythingBut ls2) ->
262+ P.AnythingBut literals ->
223− Just (AnythingBut (Set.union ls1 ls2))
263+ map Literal (Set.toList literals)
224
264
225− _ -> Nothing
265+ P.Data ctor patterns ->
266+ complementData adtDict ctor patterns
226
267
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
268
237− (_:_, []) ->
269+complementData :: AdtDict -> Var.Canonical -> [P.Pattern] -> [P.Pattern]
238− return (Just (Annotation.A region (Inexhaustive unhandled)))
270+complementData adtDict canonicalTag patterns =
271+ let
272+ ctors =
273+ lookupOtherCtors ctor adtDict
239
274
240− (_, p:ps') ->
275+ dataComplements =
241− let pp = fromPattern p
276+ Maybe.mapMaybe (maybeData canonicalTag) ctors
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
277
278+ numArgs = length patterns
250
279
251−-- Util
280+ argComplements =
281+ concat (zipWith (makeArgComplements adtDict numArgs) [0..] patterns)
282+ in
283+ dataComplements ++ argComplements
252
284
253−concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
254−concatMapM f list =
255− liftM concat (mapM f list)
256
285
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))
257
293
258−filterMapM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
259−filterMapM f list =
260− liftM catMaybes (mapM f list)
261
294
295+makeArgComplements :: AdtDict -> Int -> Int -> P.Pattern -> [P.Pattern]
296+makeArgComplements adtDict numArgs index argPattern =
297+ let
298+ complementList =
299+ complement adtDict argPattern
262
300
263−maybeCons :: Maybe a -> [a] -> [a]
301+ paddedArgs pat =
264−maybeCons maybe list =
302+ replicate index P.Anything ++ pat : replicate (numArgs - index - 1) P.Anything
265− case maybe of
303+ in
266− Just x ->
304+ map (P.Data ctor . paddedArgs) complementList
267− x : list
268
305
269− Nothing ->
270− list
src/Reporting/Result.hs+5
@@ -56,6 +56,11 @@ mapError f (Result warnings rawResult) =
56 Err (map (A.map f) msgs)
56 Err (map (A.map f) msgs)
57
57
58
58
59+warn :: R.Region -> w -> Result w e ()
60+warn region warning =
61+ Result [A.A region warning] (Ok ())
62+
63+
59addWarnings :: [A.Located w] -> Result w e a -> Result w e a
64addWarnings :: [A.Located w] -> Result w e a -> Result w e a
60addWarnings newWarnings (Result warnings rawResult) =
65addWarnings newWarnings (Result warnings rawResult) =
61 Result (newWarnings ++ warnings) rawResult
66 Result (newWarnings ++ warnings) rawResult
src/Reporting/Warning/Nitpick.hs−17
@@ -6,23 +6,6 @@ import qualified Data.Set as Set
6import qualified AST.Variable as Var
6import qualified AST.Variable as Var
7
7
8
8
9−data Pat var
10− = Data var [Pat var]
11− | Record [String]
12− | Alias String (Pat var)
13− | Var String
14− | Anything
15− | Literal Literal.Literal
16− -- It's a shame that I had to replicate the entire pattern type, but it's
17− -- essential to have this constructor.
18− | AnythingBut (Set.Set Literal.Literal)
19− deriving (Show, Eq)
20−
21−
22−type CanonicalPat =
23− Pat Var.Canonical
24−
25−
26data Warning
9data Warning
27 = Redundant Pattern.CanonicalPattern
10 = Redundant Pattern.CanonicalPattern
28 -- The argument is the list of patterns that would have to
11 -- The argument is the list of patterns that would have to