git.iko.soy/elk
on fb08d70 help sign in
elk/src/Nitpick/PatternMatches.hs
270 lines 8.1 kB history raw
1{-# LANGUAGE NamedFieldPuns, TupleSections #-}
2module Nitpick.PatternMatches
3 ( checkBody
4 , Pat (..)
5 , CanonicalPat
6 ) where
8import Control.Applicative ((<$>), (<*>))
9import Control.Monad.Except (forM, liftM, throwError)
10import Data.Maybe (mapMaybe, catMaybes)
11import qualified Data.Set as Set
12import qualified Data.Map as Map
14import qualified AST.Expression.General as General
15import qualified AST.Expression.Canonical as Canonical
16import qualified AST.Module as Module
17import qualified AST.Pattern as Pattern
18import qualified AST.Variable as Var
19import Elm.Utils ((|>))
20import qualified Reporting.Annotation as Annotation
21import qualified Reporting.Error.Nitpick as Error
22import qualified Reporting.Region as Region
23import qualified Reporting.Warning.Nitpick as Warning
26type M =
27 Either (Annotation.Located Error.Error)
30fromPattern :: CanonicalPattern -> CanonicalPat
31fromPattern (Annotation.A _region p) =
32 case p of
33 Pattern.Data ctor ps ->
34 Data ctor (map fromPattern ps)
36 Pattern.Record fs ->
37 Record fs
39 Pattern.Alias s p ->
40 Alias s (fromPattern p)
42 Pattern.Var s ->
43 Var s
45 Pattern.Anything ->
46 Anything
48 Pattern.Literal l ->
49 Literal l
52checkBody
53 :: Module.Interfaces
54 -> Module.CanonicalBody
55 -> M [Annotation.Located Warning]
56checkBody 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
65 General.Binop _ e e' ->
66 (++) <$> checkExpr e <*> checkExpr e'
68 General.Lambda p e ->
69 maybeCons <$> checkMatch r [p] <*> checkExpr e
71 General.App e e' ->
72 (++) <$> checkExpr e <*> checkExpr e'
74 General.MultiIf branches ->
75 concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
77 General.Let defs e ->
78 concat <$> sequence [ps, rhssResults, checkExpr e]
79 where
80 ps = filterMapM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
82 rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
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
91 General.Data _ctor es ->
92 concatMapM checkExpr es
94 General.Access e _f ->
95 checkExpr e
97 General.Remove e _f ->
98 checkExpr e
100 General.Insert e _f e' ->
101 (++) <$> checkExpr e <*> checkExpr e'
103 General.Modify e _ ->
104 checkExpr e
106 General.Record fields ->
107 concatMapM (checkExpr . snd) fields
109 _ ->
110 return []
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
125 fromModules = Map.mapKeysMonotonic Var.Module (Map.map Module.iAdts interfaces)
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))
134 Just adt ->
135 return adt
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)
151 otherCtorPatterns =
152 filter (\(ctor', _) -> ctor' /= ctorName) ctors
153 |> map otherCtorPat
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
160 argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
161 map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
163 return (otherCtorPatterns ++ argComplement)
165 Record _fs ->
166 return []
168 Alias _s p ->
169 complement region p
171 Var _s ->
172 return []
174 Anything ->
175 return []
177 Literal l ->
178 return [AnythingBut (Set.singleton l)]
180 AnythingBut ls ->
181 return (map Literal (Set.toList ls))
183 intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
184 intersection p1 p2 =
185 case (p1, p2) of
186 (Alias _ p1', _) ->
187 intersection p1' p2
189 (_, Alias _ p2') ->
190 intersection p1 p2'
192 (Anything, _) ->
193 Just p2
195 (Var _, _) ->
196 Just p2
198 (_, Anything) ->
199 Just p1
201 (_, Var _) ->
202 Just p1
204 (Data ctor1 args1, Data ctor2 args2) ->
205 if ctor1 /= ctor2
206 then Nothing
207 else fmap (Data ctor1) (sequence (zipWith intersection args1 args2))
209 -- TODO Assuming the fields are identical.
210 (Record _fs, Record _) ->
211 Just p1
213 (Literal l1, Literal l2) ->
214 if l1 == l2 then Just p1 else Nothing
216 (AnythingBut ls, Literal l) ->
217 if l `Set.member` ls then Nothing else Just p2
219 (Literal l, AnythingBut ls) ->
220 if l `Set.member` ls then Nothing else Just p1
222 (AnythingBut ls1, AnythingBut ls2) ->
223 Just (AnythingBut (Set.union ls1 ls2))
225 _ -> Nothing
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
237 (_:_, []) ->
238 return (Just (Annotation.A region (Inexhaustive unhandled)))
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'
251-- Util
253concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
254concatMapM f list =
255 liftM concat (mapM f list)
258filterMapM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
259filterMapM f list =
260 liftM catMaybes (mapM f list)
263maybeCons :: Maybe a -> [a] -> [a]
264maybeCons maybe list =
265 case maybe of
266 Just x ->
267 x : list
269 Nothing ->
270 list