git.iko.soy/elk
on ffe32c7 help sign in
elk/src/CheckMatch.hs
268 lines 8.1 kB history raw
1{-# LANGUAGE NamedFieldPuns, TupleSections #-}
2module CheckMatch
3 ( checkBody
4 , Pat (..)
5 , CanonicalPat
6 ) where
8import Control.Applicative ((<$>), (<*>))
9import Control.Monad.Except (throwError)
10import Control.Monad (liftM)
11import Control.Monad (forM)
13import Data.Maybe (mapMaybe, catMaybes)
14import qualified Data.Set as Set
15import qualified Data.Map as Map
17import Elm.Utils ((|>))
18import qualified AST.Expression.General as General
19import qualified AST.Expression.Canonical as Canonical
20import qualified AST.Module as Module
21import qualified AST.Pattern as Pattern
22import AST.Pattern (CanonicalPattern)
23import qualified Reporting.Annotation as Annotation
24import qualified Reporting.Region as Region
25import qualified AST.Variable as Var
26import qualified Reporting.Error.CheckMatch as Error
27import Reporting.Warning.CheckMatch
29type M =
30 Either (Annotation.Located Error.Error)
33fromPattern :: CanonicalPattern -> CanonicalPat
34fromPattern (Annotation.A _region p) =
35 case p of
36 Pattern.Data ctor ps ->
37 Data ctor (map fromPattern ps)
39 Pattern.Record fs ->
40 Record fs
42 Pattern.Alias s p ->
43 Alias s (fromPattern p)
45 Pattern.Var s ->
46 Var s
48 Pattern.Anything ->
49 Anything
51 Pattern.Literal l ->
52 Literal l
55checkBody
56 :: Module.Interfaces
57 -> Module.CanonicalBody
58 -> M [Annotation.Located Warning]
59checkBody interfaces =
60 checkExpr . Module.program
61 where
62 checkExpr :: Canonical.Expr -> M [Annotation.Located Warning]
63 checkExpr (Annotation.A r e) =
64 case e of
65 General.ExplicitList es ->
66 concatMapM checkExpr es
68 General.Binop _ e e' ->
69 (++) <$> checkExpr e <*> checkExpr e'
71 General.Lambda p e ->
72 maybeCons <$> checkMatch r [p] <*> checkExpr e
74 General.App e e' ->
75 (++) <$> checkExpr e <*> checkExpr e'
77 General.MultiIf branches ->
78 concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
80 General.Let defs e ->
81 concat <$> sequence [ps, rhssResults, checkExpr e]
82 where
83 ps = mapMaybeM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
85 rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
87 General.Case e branches ->
88 do eResults <- checkExpr e
89 result <- checkMatch r ps
90 branchResults <- concatMapM (checkExpr . snd) branches
91 return (eResults ++ maybeCons result branchResults)
92 where ps = map fst branches
94 General.Data _ctor es ->
95 concatMapM checkExpr es
97 General.Access e _f ->
98 checkExpr e
100 General.Remove e _f ->
101 checkExpr e
103 General.Insert e _f e' ->
104 (++) <$> checkExpr e <*> checkExpr e'
106 General.Modify e _ ->
107 checkExpr e
109 General.Record fields ->
110 concatMapM (checkExpr . snd) fields
112 _ ->
113 return []
116 ctorToAdt :: Var.Canonical -> Maybe (Module.AdtInfo String)
117 ctorToAdt =
118 \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m
119 where
120 -- Maps home to ctor name to the adt to which that ctor belongs
121 m :: Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
122 m =
123 builtins `Map.union` fromModules
124 where
125 -- TODO
126 builtins = Map.empty
128 fromModules = Map.mapKeysMonotonic Var.Module (Map.map Module.iAdts interfaces)
131 ctorToAdtErr :: Region.Region -> Var.Canonical -> M (Module.AdtInfo String)
132 ctorToAdtErr region c =
133 case ctorToAdt c of
134 Nothing ->
135 throwError (Annotation.A region (Error.ConstructorTypeNotFound c))
137 Just adt ->
138 return adt
141 complement :: Region.Region -> CanonicalPat -> M [CanonicalPat]
142 complement region p =
143 case p of
144 Data ctor ps ->
145 do let ctorName = Var.name ctor
146 ctorHome = Var.home ctor
147 (_tyVars, ctors) <- ctorToAdtErr region ctor
148 -- A pattern is in the complement of this one if it uses one of the
149 -- other constructors of this type...
150 let otherCtorPat (ctor', args) =
151 Data (Var.Canonical {Var.name = ctor', Var.home = ctorHome})
152 (replicate (length args) Anything)
154 otherCtorPatterns =
155 filter (\(ctor', _) -> ctor' /= ctorName) ctors
156 |> map otherCtorPat
158 -- or if it uses this constructor and one of its argument patterns is
159 -- in the complement of an argument pattern here.
160 numArgs = length ps
161 sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
163 argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
164 map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
166 return (otherCtorPatterns ++ argComplement)
168 Record _fs ->
169 return []
171 Alias _s p ->
172 complement region p
174 Var _s ->
175 return []
177 Anything ->
178 return []
180 Literal l ->
181 return [AnythingBut (Set.singleton l)]
183 AnythingBut ls ->
184 return (map Literal (Set.toList ls))
186 intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
187 intersection p1 p2 =
188 case (p1, p2) of
189 (Alias _ p1', _) ->
190 intersection p1' p2
192 (_, Alias _ p2') ->
193 intersection p1 p2'
195 (Anything, _) ->
196 Just p2
198 (Var _, _) ->
199 Just p2
201 (_, Anything) ->
202 Just p1
204 (_, Var _) ->
205 Just p1
207 (Data ctor1 args1, Data ctor2 args2) ->
208 if ctor1 /= ctor2
209 then Nothing
210 else fmap (Data ctor1) (sequence (zipWith intersection args1 args2))
212 -- TODO Assuming the fields are identical.
213 (Record _fs, Record _) ->
214 Just p1
216 (Literal l1, Literal l2) ->
217 if l1 == l2 then Just p1 else Nothing
219 (AnythingBut ls, Literal l) ->
220 if l `Set.member` ls then Nothing else Just p2
222 (Literal l, AnythingBut ls) ->
223 if l `Set.member` ls then Nothing else Just p1
225 (AnythingBut ls1, AnythingBut ls2) ->
226 Just (AnythingBut (Set.union ls1 ls2))
228 _ -> Nothing
230 checkMatch :: Region.Region -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
231 checkMatch region =
232 go [Anything]
233 where
234 go :: [CanonicalPat] -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
235 go unhandled ps =
236 case (unhandled, ps) of
237 ([], []) ->
238 return Nothing
240 (_:_, []) ->
241 return (Just (Annotation.A region (Inexhaustive unhandled)))
243 (_, p:ps') ->
244 let pp = fromPattern p
245 Annotation.A region _ = p
246 in
247 if all (\q -> intersection q pp == Nothing) unhandled
248 then return (Just (Annotation.A region (Redundant p)))
249 else
250 do pComp <- complement region pp
251 go (concatMap (\q -> mapMaybe (intersection q) pComp) unhandled) ps'
254-- Util
255concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
256concatMapM f =
257 liftM concat . mapM f
260mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
261mapMaybeM f =
262 liftM catMaybes . mapM f
265maybeCons :: Maybe a -> [a] -> [a]
266maybeCons =
267 maybe id (:)