git.iko.soy/elk
on ed7f3ff help sign in
elk/src/CheckMatch.hs
239 lines 7.8 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 = Either (Annotation.Located Error.Error)
32fromPattern :: CanonicalPattern -> CanonicalPat
33fromPattern (Annotation.A _region p) = case p of
34 Pattern.Data ctor ps ->
35 Data ctor (map fromPattern ps)
37 Pattern.Record fs ->
38 Record fs
40 Pattern.Alias s p ->
41 Alias s (fromPattern p)
43 Pattern.Var s ->
44 Var s
46 Pattern.Anything ->
47 Anything
49 Pattern.Literal l ->
50 Literal l
53checkBody
54 :: Module.Interfaces
55 -> Module.CanonicalBody
56 -> M [Annotation.Located Warning]
57checkBody interfaces = checkExpr . Module.program where
58 checkExpr :: Canonical.Expr -> M [Annotation.Located Warning]
59 checkExpr (Annotation.A r e) = case e of
60 General.ExplicitList es ->
61 concatMapM checkExpr es
63 General.Binop _ e e' ->
64 (++) <$> checkExpr e <*> checkExpr e'
66 General.Lambda p e ->
67 maybeCons <$> checkMatch r [p] <*> checkExpr e
69 General.App e e' ->
70 (++) <$> checkExpr e <*> checkExpr e'
72 General.MultiIf branches ->
73 concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
75 General.Let defs e ->
76 concat <$> sequence [ps, rhssResults, checkExpr e]
77 where
78 ps = mapMaybeM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
79 rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
81 General.Case e branches ->
82 do eResults <- checkExpr e
83 result <- checkMatch r ps
84 branchResults <- concatMapM (checkExpr . snd) branches
85 return (eResults ++ maybeCons result branchResults)
86 where ps = map fst branches
88 General.Data _ctor es ->
89 concatMapM checkExpr es
91 General.Access e _f ->
92 checkExpr e
94 General.Remove e _f ->
95 checkExpr e
97 General.Insert e _f e' ->
98 (++) <$> checkExpr e <*> checkExpr e'
100 General.Modify e _ ->
101 checkExpr e
103 General.Record fields ->
104 concatMapM (checkExpr . snd) fields
106 _ ->
107 return []
110 ctorToAdt :: Var.Canonical -> Maybe (Module.AdtInfo String)
111 ctorToAdt = \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m where
112 -- Maps home to ctor name to the adt to which that ctor belongs
113 m :: Map.Map Var.Home (Map.Map String (Module.AdtInfo String))
114 m = builtins `Map.union` fromModules where
115 -- TODO
116 builtins = Map.empty
118 fromModules = Map.mapKeysMonotonic Var.Module (Map.map Module.iAdts interfaces)
121 ctorToAdtErr :: Region.Region -> Var.Canonical -> M (Module.AdtInfo String)
122 ctorToAdtErr region c = case ctorToAdt c of
123 Nothing ->
124 throwError (Annotation.A region (Error.ConstructorTypeNotFound c))
126 Just adt ->
127 return adt
130 complement :: Region.Region -> CanonicalPat -> M [CanonicalPat]
131 complement region p = case p of
132 Data ctor ps ->
133 do let ctorName = Var.name ctor
134 ctorHome = Var.home ctor
135 (_tyVars, ctors) <- ctorToAdtErr region ctor
136 -- A pattern is in the complement of this one if it uses one of the
137 -- other constructors of this type...
138 let otherCtorPat (ctor', args) =
139 Data (Var.Canonical {Var.name = ctor', Var.home = ctorHome})
140 (replicate (length args) Anything)
142 otherCtorPatterns =
143 filter (\(ctor', _) -> ctor' /= ctorName) ctors
144 |> map otherCtorPat
146 -- or if it uses this constructor and one of its argument patterns is
147 -- in the complement of an argument pattern here.
148 numArgs = length ps
149 sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
151 argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
152 map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
154 return (otherCtorPatterns ++ argComplement)
156 Record _fs -> return []
157 Alias _s p -> complement region p
158 Var _s -> return []
159 Anything -> return []
160 Literal l -> return [AnythingBut (Set.singleton l)]
161 AnythingBut ls -> return (map Literal (Set.toList ls))
163 intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
164 intersection p1 p2 =
165 case (p1, p2) of
166 (Alias _ p1', _) ->
167 intersection p1' p2
169 (_, Alias _ p2') ->
170 intersection p1 p2'
172 (Anything, _) ->
173 Just p2
175 (Var _, _) ->
176 Just p2
178 (_, Anything) ->
179 Just p1
181 (_, Var _) ->
182 Just p1
184 (Data ctor1 args1, Data ctor2 args2) ->
185 if ctor1 /= ctor2
186 then Nothing
187 else fmap (Data ctor1) (sequence (zipWith intersection args1 args2))
189 -- TODO Assuming the fields are identical.
190 (Record _fs, Record _) ->
191 Just p1
193 (Literal l1, Literal l2) ->
194 if l1 == l2 then Just p1 else Nothing
196 (AnythingBut ls, Literal l) ->
197 if l `Set.member` ls then Nothing else Just p2
199 (Literal l, AnythingBut ls) ->
200 if l `Set.member` ls then Nothing else Just p1
202 (AnythingBut ls1, AnythingBut ls2) ->
203 Just (AnythingBut (Set.union ls1 ls2))
205 _ -> Nothing
207 checkMatch :: Region.Region -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
208 checkMatch region = go [Anything] where
209 go :: [CanonicalPat] -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
210 go unhandled ps =
211 case (unhandled, ps) of
212 ([], []) ->
213 return Nothing
215 (_:_, []) ->
216 return (Just (Annotation.A region (Inexhaustive unhandled)))
218 (_, p:ps') ->
219 let pp = fromPattern p
220 Annotation.A region _ = p
221 in
222 if all (\q -> intersection q pp == Nothing) unhandled
223 then return (Just (Annotation.A region (Redundant p)))
224 else
225 do pComp <- complement region pp
226 go (concatMap (\q -> mapMaybe (intersection q) pComp) unhandled) ps'
228-- Util
229concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
230concatMapM f = liftM concat . mapM f
233mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
234mapMaybeM f = liftM catMaybes . mapM f
237maybeCons :: Maybe a -> [a] -> [a]
238maybeCons = maybe id (:)