git.iko.soy/elk
on ccc138c help sign in
elk/src/CheckMatch.hs
161 lines 7.2 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 qualified AST.Expression.General as General
18import qualified AST.Expression.Canonical as Canonical
19import qualified AST.Module as Module
20import qualified AST.Pattern as Pattern
21import AST.Pattern (CanonicalPattern)
22import qualified Reporting.Annotation as Annotation
23import qualified Reporting.Region as Region
24import qualified AST.Variable as Var
25import qualified Reporting.Error.CheckMatch as Error
26import Reporting.Warning.CheckMatch
28fromPattern :: CanonicalPattern -> CanonicalPat
29fromPattern (Annotation.A _region p) = case p of
30 Pattern.Data ctor ps -> Data ctor (map fromPattern ps)
31 Pattern.Record fs -> Record fs
32 Pattern.Alias s p -> Alias s (fromPattern p)
33 Pattern.Var s -> Var s
34 Pattern.Anything -> Anything
35 Pattern.Literal l -> Literal l
37concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
38concatMapM f = liftM concat . mapM f
40mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
41mapMaybeM f = liftM catMaybes . mapM f
43maybeCons :: Maybe a -> [a] -> [a]
44maybeCons = maybe id (:)
46type M = Either (Annotation.Located Error.Error)
47checkBody
48 :: Module.Interfaces
49 -> Module.CanonicalBody
50 -> M [Annotation.Located Warning]
51checkBody interfaces = checkExpr . Module.program where
52 checkExpr :: Canonical.Expr -> M [Annotation.Located Warning]
53 checkExpr (Annotation.A r e) = case e of
54 General.ExplicitList es -> concatMapM checkExpr es
55 General.Binop _ e e' -> (++) <$> checkExpr e <*> checkExpr e'
56 General.Lambda p e -> maybeCons <$> checkMatch r [p] <*> checkExpr e
57 General.App e e' -> (++) <$> checkExpr e <*> checkExpr e'
58 General.MultiIf branches -> concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
60 General.Let defs e -> fmap concat $ sequence [ps, rhssResults, checkExpr e]
61 where
62 ps = mapMaybeM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
63 rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
65 General.Case e branches -> do
66 eResults <- checkExpr e
67 result <- checkMatch r ps
68 branchResults <- concatMapM (checkExpr . snd) branches
69 return (eResults ++ maybeCons result branchResults)
70 where ps = map fst branches
72 General.Data _ctor es -> concatMapM checkExpr es
73 General.Access e _f -> checkExpr e
74 General.Remove e _f -> checkExpr e
75 General.Insert e _f e' -> (++) <$> checkExpr e <*> checkExpr e'
76 General.Modify e _ -> checkExpr e
77 General.Record fields -> concatMapM (checkExpr . snd) fields
78 General.Port _pi -> return []
79 _ -> return []
81 ctorToAdt :: Var.Canonical -> Maybe (Module.AdtInfo String)
82 ctorToAdt = \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m where
83 m :: Map.Map Var.Home (Map.Map String {- ctor name -} (Module.AdtInfo String))
84 m = builtins `Map.union` fromModules where
85 builtins = Map.empty -- TODO
87 fromModules = Map.mapKeysMonotonic Var.Module (Map.map Module.iAdts interfaces)
89 ctorToAdtErr :: Region.Region -> Var.Canonical -> M (Module.AdtInfo String)
90 ctorToAdtErr region c = case ctorToAdt c of
91 Nothing -> throwError (Annotation.A region (Error.ConstructorTypeNotFound c))
92 Just adt -> return adt
94 complement :: Region.Region -> CanonicalPat -> M [CanonicalPat]
95 complement region p = case p of
96 Data ctor ps -> do
97 let ctorName = Var.name ctor
98 ctorHome = Var.home ctor
99 (_tyVars, ctors) <- ctorToAdtErr region ctor
100 -- A pattern is in the complement of this one if it uses one of the
101 -- other constructors of this type...
102 let otherCtorPatterns =
103 map (\(ctor',args) ->
104 Data (Var.Canonical {Var.name = ctor', Var.home = ctorHome})
105 (replicate (length args) Anything))
106 $ filter (\(ctor', _) -> ctor' /= ctorName) ctors
107 -- or if it uses this constructor and one of its argument patterns is
108 -- in the complement of an argument pattern here.
109 numArgs = length ps
110 sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
112 argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
113 map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
115 return (otherCtorPatterns ++ argComplement)
117 Record _fs -> return []
118 Alias _s p -> complement region p
119 Var _s -> return []
120 Anything -> return []
121 Literal l -> return [AnythingBut (Set.singleton l)]
122 AnythingBut ls -> return (map Literal (Set.toList ls))
124 intersection :: CanonicalPat -> CanonicalPat -> Maybe CanonicalPat
125 intersection p1 p2 = case (p1, p2) of
126 (Alias _ p1', _) -> intersection p1' p2
127 (_, Alias _ p2') -> intersection p1 p2'
128 (Anything, _) -> Just p2
129 (Var _, _) -> Just p2
130 (_, Anything) -> Just p1
131 (_, Var _) -> Just p1
133 (Data ctor1 args1, Data ctor2 args2) ->
134 if ctor1 /= ctor2
135 then Nothing
136 -- TODO: Assumes that args must be the same length. I think that's ok.
137 else fmap (Data ctor1) (sequence (zipWith intersection args1 args2))
139 -- TODO Assuming the fields are identical.
140 (Record _fs, Record _) -> Just p1
141 (Literal l1, Literal l2) -> if l1 == l2 then Just p1 else Nothing
142 (AnythingBut ls, Literal l) -> if l `Set.member` ls then Nothing else Just p2
143 (Literal l, AnythingBut ls) -> if l `Set.member` ls then Nothing else Just p1
144 (AnythingBut ls1, AnythingBut ls2) -> Just (AnythingBut (Set.union ls1 ls2))
145 _ -> Nothing
147 checkMatch :: Region.Region -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
148 checkMatch region = go [Anything] where
149 go :: [CanonicalPat] -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
150 go [] [] = return Nothing
151 go qs@(_:_) [] = return (Just (Annotation.A region (Inexhaustive qs)))
152 go unhandled (p:ps) =
153 let pp = fromPattern p
154 Annotation.A region _ = p
155 in
156 if all (\q -> intersection q pp == Nothing) unhandled
157 then return (Just (Annotation.A region (Redundant p)))
158 else do
159 pComp <- complement region pp
160 go (concatMap (\q -> mapMaybe (intersection q) pComp) unhandled) ps