git.iko.soy/elk
on master help sign in
hooked exhaustiveness checker into warnings system
ccc138cIzaak Meckler
src/CheckMatch.hs+86−83
compare with master
unifiedsplit
@@ -1,46 +1,32 @@
1−{-# LANGUAGE NamedFieldPuns #-}
1+{-# LANGUAGE NamedFieldPuns, TupleSections #-}
2module CheckMatch
2module CheckMatch
3− ( MatchResult (..)
3+ ( checkBody
4− , ErrorType (..)
4+ , Pat (..)
5− , checkModule
5+ , CanonicalPat
6 ) where
6 ) where
7
7
8−import Control.Applicative ((<$>))
8+import Control.Applicative ((<$>), (<*>))
9+import Control.Monad.Except (throwError)
10+import Control.Monad (liftM)
11+import Control.Monad (forM)
12+
13+import Data.Maybe (mapMaybe, catMaybes)
14+import qualified Data.Set as Set
15+import qualified Data.Map as Map
16+
9import qualified AST.Expression.General as General
17import qualified AST.Expression.General as General
10import qualified AST.Expression.Canonical as Canonical
18import qualified AST.Expression.Canonical as Canonical
11−import AST.Module
19+import qualified AST.Module as Module
12import qualified AST.Pattern as Pattern
20import qualified AST.Pattern as Pattern
13import AST.Pattern (CanonicalPattern)
21import AST.Pattern (CanonicalPattern)
14−import qualified AST.Annotation as Annotation
22+import qualified Reporting.Annotation as Annotation
15−import qualified Data.Map as Map
23+import qualified Reporting.Region as Region
16import qualified AST.Variable as Var
24import qualified AST.Variable as Var
17−import qualified AST.Literal as Literal
25+import qualified Reporting.Error.CheckMatch as Error
18−import Data.Maybe (mapMaybe)
26+import Reporting.Warning.CheckMatch
19−import Control.Monad (forM)
20−import qualified Data.Set as Set
21−
22−data MatchResult
23− = Redundant CanonicalPattern
24− | Inexhaustive CanonicalPat
25− | TypeNotFound
26− | Ok
27−
28−data Pat var
29− = Data var [Pat var]
30− | Record [String]
31− | Alias String (Pat var)
32− | Var String
33− | Anything
34− | Literal Literal.Literal
35− -- It's a shame that I had to replicate the entire pattern type, but it's
36− -- essential to have this constructor.
37− | AnythingBut (Set.Set Literal.Literal)
38− deriving (Show, Eq, Ord)
39−
40−type CanonicalPat = Pat Var.Canonical
41
27
42fromPattern :: CanonicalPattern -> CanonicalPat
28fromPattern :: CanonicalPattern -> CanonicalPat
43−fromPattern p = case p of
29+fromPattern (Annotation.A _region p) = case p of
44 Pattern.Data ctor ps -> Data ctor (map fromPattern ps)
30 Pattern.Data ctor ps -> Data ctor (map fromPattern ps)
45 Pattern.Record fs -> Record fs
31 Pattern.Record fs -> Record fs
46 Pattern.Alias s p -> Alias s (fromPattern p)
32 Pattern.Alias s p -> Alias s (fromPattern p)
@@ -48,73 +34,88 @@ fromPattern p = case p of
48 Pattern.Anything -> Anything
34 Pattern.Anything -> Anything
49 Pattern.Literal l -> Literal l
35 Pattern.Literal l -> Literal l
50
36
51−data ErrorType = ConstructorNotFound Var.Canonical
37+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
38+concatMapM f = liftM concat . mapM f
39+
40+mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
41+mapMaybeM f = liftM catMaybes . mapM f
52
42
53−checkModule :: [CanonicalAdt] -> Module exports CanonicalBody -> [(Either ErrorType MatchResult, Annotation.Region)]
43+maybeCons :: Maybe a -> [a] -> [a]
54−checkModule adts (Module {body}) = checkBody body where
44+maybeCons = maybe id (:)
55− checkBody :: CanonicalBody -> [(Either ErrorType MatchResult, Annotation.Region)]
56− checkBody (CanonicalBody {program}) = checkExpr program
57
45
46+type M = Either (Annotation.Located Error.Error)
47+checkBody
48+ :: Module.Interfaces
49+ -> Module.CanonicalBody
50+ -> M [Annotation.Located Warning]
51+checkBody interfaces = checkExpr . Module.program where
58− checkExpr :: Canonical.Expr -> [(Either ErrorType MatchResult, Annotation.Region)]
52+ checkExpr :: Canonical.Expr -> M [Annotation.Located Warning]
59 checkExpr (Annotation.A r e) = case e of
53 checkExpr (Annotation.A r e) = case e of
60− General.ExplicitList es -> concatMap checkExpr es
54+ General.ExplicitList es -> concatMapM checkExpr es
61− General.Binop _ e e' -> checkExpr e ++ checkExpr e'
55+ General.Binop _ e e' -> (++) <$> checkExpr e <*> checkExpr e'
62− General.Lambda p e -> (checkMatch [p], r) : checkExpr e
56+ General.Lambda p e -> maybeCons <$> checkMatch r [p] <*> checkExpr e
63− General.App e e' -> checkExpr e ++ checkExpr e'
57+ General.App e e' -> (++) <$> checkExpr e <*> checkExpr e'
64− General.MultiIf branches -> concatMap (\(b,e) -> checkExpr b ++ checkExpr e) branches
58+ General.MultiIf branches -> concatMapM (\(b,e) -> (++) <$> checkExpr b <*> checkExpr e) branches
65
59
66− General.Let defs e -> ps ++ rhssResults ++ checkExpr e
60+ General.Let defs e -> fmap concat $ sequence [ps, rhssResults, checkExpr e]
67 where
61 where
68− ps = map (\(Canonical.Definition p _ _) -> (checkMatch [p], r)) defs
62+ ps = mapMaybeM (\(Canonical.Definition p _ _) -> checkMatch r [p]) defs
69− rhssResults = concatMap (\(Canonical.Definition _ e _) -> checkExpr e) defs
63+ rhssResults = concatMapM (\(Canonical.Definition _ e _) -> checkExpr e) defs
70−
64+
71− General.Case e branches ->
65+ General.Case e branches -> do
66+ eResults <- checkExpr e
67+ result <- checkMatch r ps
72− (checkMatch ps, r) : checkExpr e ++ concatMap (checkExpr . snd) branches
68+ branchResults <- concatMapM (checkExpr . snd) branches
69+ return (eResults ++ maybeCons result branchResults)
73 where ps = map fst branches
70 where ps = map fst branches
74
71
75− General.Data _ctor es -> concatMap checkExpr es
72+ General.Data _ctor es -> concatMapM checkExpr es
76 General.Access e _f -> checkExpr e
73 General.Access e _f -> checkExpr e
77 General.Remove e _f -> checkExpr e
74 General.Remove e _f -> checkExpr e
78− General.Insert e _f e' -> checkExpr e ++ checkExpr e'
75+ General.Insert e _f e' -> (++) <$> checkExpr e <*> checkExpr e'
79 General.Modify e _ -> checkExpr e
76 General.Modify e _ -> checkExpr e
80− General.Record fields -> concatMap (checkExpr . snd) fields
77+ General.Record fields -> concatMapM (checkExpr . snd) fields
81− General.Port _pi -> []
78+ General.Port _pi -> return []
82− _ -> []
79+ _ -> return []
83−
80+
84− ctorToAdt :: Var.Canonical -> Maybe CanonicalAdt
81+ ctorToAdt :: Var.Canonical -> Maybe (Module.AdtInfo String)
85− ctorToAdt = \k -> Map.lookup k m where
82+ ctorToAdt = \(Var.Canonical {Var.home,Var.name}) -> Map.lookup name =<< Map.lookup home m where
86− m =
83+ m :: Map.Map Var.Home (Map.Map String {- ctor name -} (Module.AdtInfo String))
87− Map.fromList $ concatMap (\adt@(_adtName, (_tyVars, ctors)) ->
84+ m = builtins `Map.union` fromModules where
88− map (\(ctor,_args) -> (ctor, adt)) ctors)
85+ builtins = Map.empty -- TODO
89− adts
86+
90−
87+ fromModules = Map.mapKeysMonotonic Var.Module (Map.map Module.iAdts interfaces)
91− ctorToAdtExn :: Var.Canonical -> Either ErrorType CanonicalAdt
88+
89+ ctorToAdtErr :: Region.Region -> Var.Canonical -> M (Module.AdtInfo String)
92− ctorToAdtExn c = case ctorToAdt c of
90+ ctorToAdtErr region c = case ctorToAdt c of
93− Nothing -> Left (ConstructorNotFound c)
91+ Nothing -> throwError (Annotation.A region (Error.ConstructorTypeNotFound c))
94− Just adt -> Right adt
92+ Just adt -> return adt
95−
93+
96− complement :: CanonicalPat -> Either ErrorType [CanonicalPat]
94+ complement :: Region.Region -> CanonicalPat -> M [CanonicalPat]
97− complement p = case p of
95+ complement region p = case p of
98 Data ctor ps -> do
96 Data ctor ps -> do
97+ let ctorName = Var.name ctor
98+ ctorHome = Var.home ctor
99− (_adtName, (_tyVars, ctors)) <- ctorToAdtExn ctor
99+ (_tyVars, ctors) <- ctorToAdtErr region ctor
100 -- A pattern is in the complement of this one if it uses one of the
100 -- A pattern is in the complement of this one if it uses one of the
101 -- other constructors of this type...
101 -- other constructors of this type...
102 let otherCtorPatterns =
102 let otherCtorPatterns =
103 map (\(ctor',args) ->
103 map (\(ctor',args) ->
104+ Data (Var.Canonical {Var.name = ctor', Var.home = ctorHome})
104− Data ctor' (replicate (length args) Anything))
105+ (replicate (length args) Anything))
105− (filter (\(ctor', _) -> ctor' /= ctor) ctors)
106+ $ filter (\(ctor', _) -> ctor' /= ctorName) ctors
106 -- or if it uses this constructor and one of its argument patterns is
107 -- or if it uses this constructor and one of its argument patterns is
107 -- in the complement of an argument pattern here.
108 -- in the complement of an argument pattern here.
108 numArgs = length ps
109 numArgs = length ps
109 sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
110 sandwich pat i = replicate i Anything ++ pat : replicate (numArgs - i - 1) Anything
110
111
111 argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
112 argComplement <- fmap concat . forM (zip [0..] ps) $ \(i, argP) ->
112− map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement argP)
113+ map (\argP' -> Data ctor (sandwich argP' i)) <$> (complement region argP)
113
114
114 return (otherCtorPatterns ++ argComplement)
115 return (otherCtorPatterns ++ argComplement)
115
116
116 Record _fs -> return []
117 Record _fs -> return []
117− Alias _s p -> complement p
118+ Alias _s p -> complement region p
118 Var _s -> return []
119 Var _s -> return []
119 Anything -> return []
120 Anything -> return []
120 Literal l -> return [AnythingBut (Set.singleton l)]
121 Literal l -> return [AnythingBut (Set.singleton l)]
@@ -143,16 +144,18 @@ checkModule adts (Module {body}) = checkBody body where
143 (AnythingBut ls1, AnythingBut ls2) -> Just (AnythingBut (Set.union ls1 ls2))
144 (AnythingBut ls1, AnythingBut ls2) -> Just (AnythingBut (Set.union ls1 ls2))
144 _ -> Nothing
145 _ -> Nothing
145
146
146− checkMatch :: [CanonicalPattern] -> Either ErrorType MatchResult
147+ checkMatch :: Region.Region -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
147− checkMatch = go [Anything] where
148+ checkMatch region = go [Anything] where
148− go :: [CanonicalPat] -> [CanonicalPattern] -> Either ErrorType MatchResult
149+ go :: [CanonicalPat] -> [CanonicalPattern] -> M (Maybe (Annotation.Located Warning))
149− go [] [] = return Ok
150+ go [] [] = return Nothing
150− go (q:_) [] = return (Inexhaustive q)
151+ go qs@(_:_) [] = return (Just (Annotation.A region (Inexhaustive qs)))
151 go unhandled (p:ps) =
152 go unhandled (p:ps) =
152− let pp = fromPattern p in
153+ let pp = fromPattern p
154+ Annotation.A region _ = p
155+ in
153 if all (\q -> intersection q pp == Nothing) unhandled
156 if all (\q -> intersection q pp == Nothing) unhandled
154− then return (Redundant p)
157+ then return (Just (Annotation.A region (Redundant p)))
155 else do
158 else do
156− pComp <- complement pp
159+ pComp <- complement region pp
157 go (concatMap (\q -> mapMaybe (intersection q) pComp) unhandled) ps
160 go (concatMap (\q -> mapMaybe (intersection q) pComp) unhandled) ps
158
161
src/Compile.hs+6
@@ -9,8 +9,10 @@ import qualified Parse.Parse as Parse
9import qualified Reporting.Error as Error
9import qualified Reporting.Error as Error
10import qualified Reporting.Result as Result
10import qualified Reporting.Result as Result
11import qualified Reporting.Warning as Warning
11import qualified Reporting.Warning as Warning
12+import qualified Reporting.Annotation as A
12import qualified Type.Inference as TI
13import qualified Type.Inference as TI
13import qualified Canonicalize
14import qualified Canonicalize
15+import qualified CheckMatch
14
16
15
17
16compile
18compile
@@ -44,6 +46,10 @@ compile user projectName interfaces source =
44 -- Add the real list of tyes
46 -- Add the real list of tyes
45 let body = (Module.body canonicalModule) { Module.types = types }
47 let body = (Module.body canonicalModule) { Module.types = types }
46
48
49+ case CheckMatch.checkBody interfaces body of
50+ Left (A.A r matchError) -> Result.throw r (Error.CheckMatch matchError)
51+ Right matchWarnings -> Result.addWarnings (map (A.map Warning.MatchWarning) matchWarnings) (return ())
52+
47 return $ canonicalModule { Module.body = body }
53 return $ canonicalModule { Module.body = body }
48
54
49
55
src/Reporting/Error.hs+7
@@ -9,6 +9,7 @@ import qualified Reporting.Annotation as A
9import qualified Reporting.Error.Canonicalize as Canonicalize
9import qualified Reporting.Error.Canonicalize as Canonicalize
10import qualified Reporting.Error.Syntax as Syntax
10import qualified Reporting.Error.Syntax as Syntax
11import qualified Reporting.Error.Type as Type
11import qualified Reporting.Error.Type as Type
12+import qualified Reporting.Error.CheckMatch as CheckMatch
12
13
13
14
14-- ALL POSSIBLE ERRORS
15-- ALL POSSIBLE ERRORS
@@ -17,6 +18,7 @@ data Error
17 = Syntax Syntax.Error
18 = Syntax Syntax.Error
18 | Canonicalize Canonicalize.Error
19 | Canonicalize Canonicalize.Error
19 | Type Type.Error
20 | Type Type.Error
21+ | CheckMatch CheckMatch.Error
20
22
21
23
22-- TO STRING
24-- TO STRING
@@ -33,6 +35,8 @@ toString (A.A region err) =
33 Type typeError ->
35 Type typeError ->
34 Type.toString region typeError
36 Type.toString region typeError
35
37
38+ CheckMatch matchError ->
39+ CheckMatch.toString region matchError
36
40
37-- JSON
41-- JSON
38
42
@@ -48,6 +52,9 @@ toJson (A.A region err) =
48
52
49 Type typeError ->
53 Type typeError ->
50 Type.toJson typeError
54 Type.toJson typeError
55+
56+ CheckMatch matchError ->
57+ CheckMatch.toJson matchError
51 in
58 in
52 BS.unpack $ Json.encode $
59 BS.unpack $ Json.encode $
53 Json.object
60 Json.object
src/Reporting/Result.hs+1−1
@@ -105,4 +105,4 @@ instance M.Monad (Result w e) where
105 Ok value ->
105 Ok value ->
106 let (Result warnings' rawResult') = callback value
106 let (Result warnings' rawResult') = callback value
107 in
107 in
108− Result (warnings ++ warnings') rawResult'
108+ Result (warnings ++ warnings') rawResult'
src/Reporting/Warning.hs+3−1
@@ -4,11 +4,13 @@ import qualified AST.Module as Module
4
4
5import qualified Reporting.Annotation as A
5import qualified Reporting.Annotation as A
6
6
7+import qualified Reporting.Warning.CheckMatch as CheckMatch
8+
7
9
8data Warning
10data Warning
9 = UnusedImport Module.Name
11 = UnusedImport Module.Name
10 | MissingTypeAnnotation String
12 | MissingTypeAnnotation String
11−
13+ | MatchWarning CheckMatch.Warning
12
14
13-- TO STRING
15-- TO STRING
14
16