git.iko.soy/elk
on 504b04c help sign in
elk/src/CheckMatch.hs
264 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
84 rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
86 General.Case e branches ->
87 do eResults <- checkExpr e
88 result <- checkMatch r ps
89 branchResults <- concatMapM (checkExpr . snd) branches
90 return (eResults ++ maybeCons result branchResults)
91 where ps = map fst branches
93 General.Data _ctor es ->
94 concatMapM checkExpr es
96 General.Access e _f ->
97 checkExpr e
99 General.Remove e _f ->
100 checkExpr e
102 General.Insert e _f e' ->
103 (++) <$> checkExpr e <*> checkExpr e'
105 General.Modify e _ ->
106 checkExpr e
108 General.Record fields ->
109 concatMapM (checkExpr . snd) fields
111 _ ->
112 return []
115 ctorToAdt :: Var.Canonical -> Maybe (Module.AdtInfo String)
116 ctorToAdt =
117 \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m
118 where
119 -- Maps home to ctor name to the adt to which that ctor belongs
120 m :: Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
121 m = builtins `Map.union` fromModules 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'
250-- Util
251concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
252concatMapM f =
253 liftM concat . mapM f
256mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
257mapMaybeM f =
258 liftM catMaybes . mapM f
261maybeCons :: Maybe a -> [a] -> [a]
262maybeCons =
263 maybe id (:)