git.iko.soy/elk
on master help sign in
Give line numbers when there is a kind error in a pattern
2e38f7bEvan Czaplicki
compiler/Type/Constrain/Expression.hs+10−2
compare with master
unifiedsplit
@@ -6,6 +6,7 @@ import qualified Data.Set as Set
6import Control.Arrow (second)
6import Control.Arrow (second)
7import Control.Applicative ((<$>),(<*>))
7import Control.Applicative ((<$>),(<*>))
8import qualified Control.Monad as Monad
8import qualified Control.Monad as Monad
9+import Control.Monad.Error (ErrorT, runErrorT)
9import Control.Monad.State
10import Control.Monad.State
10import Data.Traversable (traverse)
11import Data.Traversable (traverse)
11
12
@@ -56,7 +57,7 @@ constrain env (L span expr) tipe =
56 Lambda p e ->
57 Lambda p e ->
57 exists $ \t1 ->
58 exists $ \t1 ->
58 exists $ \t2 -> do
59 exists $ \t2 -> do
59− fragment <- Pattern.constrain env p t1
60+ fragment <- try span $ Pattern.constrain env p t1
60 c2 <- constrain env e t2
61 c2 <- constrain env e t2
61 let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
62 let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
62 (typeConstraint fragment /\ c2 ))
63 (typeConstraint fragment /\ c2 ))
@@ -80,7 +81,7 @@ constrain env (L span expr) tipe =
80 exists $ \t -> do
81 exists $ \t -> do
81 ce <- constrain env exp t
82 ce <- constrain env exp t
82 let branch (p,e) = do
83 let branch (p,e) = do
83− fragment <- Pattern.constrain env p t
84+ fragment <- try span $ Pattern.constrain env p t
84 clet [toScheme fragment] <$> constrain env e tipe
85 clet [toScheme fragment] <$> constrain env e tipe
85 and . (:) ce <$> mapM branch branches
86 and . (:) ce <$> mapM branch branches
86
87
@@ -213,3 +214,10 @@ collapseDefs = concatMap expandPattern . go [] Map.empty Map.empty
213 go ((pattern, body, Nothing) : output) defs typs ds
214 go ((pattern, body, Nothing) : output) defs typs ds
214 TypeAnnotation name typ ->
215 TypeAnnotation name typ ->
215 go output defs (Map.insert name typ typs) ds
216 go output defs (Map.insert name typ typs) ds
217+
218+try :: SrcSpan -> ErrorT String IO a -> IO a
219+try span computation = do
220+ result <- runErrorT computation
221+ case result of
222+ Left msg -> error $ "\nType error " ++ show span ++ "\n" ++ msg
223+ Right value -> return value
compiler/Type/Constrain/Pattern.hs+8−7
@@ -3,6 +3,7 @@ module Type.Constrain.Pattern where
3import Control.Arrow (second)
3import Control.Arrow (second)
4import Control.Applicative ((<$>))
4import Control.Applicative ((<$>))
5import qualified Control.Monad as Monad
5import qualified Control.Monad as Monad
6+import Control.Monad.Error
6import qualified Data.List as List
7import qualified Data.List as List
7import qualified Data.Maybe as Maybe
8import qualified Data.Maybe as Maybe
8import qualified Data.Map as Map
9import qualified Data.Map as Map
@@ -17,7 +18,7 @@ import Type.Environment as Env
17import qualified Type.Constrain.Literal as Literal
18import qualified Type.Constrain.Literal as Literal
18
19
19
20
20−constrain :: Environment -> Pattern -> Type -> IO Fragment
21+constrain :: Environment -> Pattern -> Type -> ErrorT String IO Fragment
21constrain env pattern tipe =
22constrain env pattern tipe =
22 let span = Loc.NoSpan (render $ pretty pattern)
23 let span = Loc.NoSpan (render $ pretty pattern)
23 t1 === t2 = Loc.L span (CEqual t1 t2)
24 t1 === t2 = Loc.L span (CEqual t1 t2)
@@ -27,11 +28,11 @@ constrain env pattern tipe =
27 PAnything -> return emptyFragment
28 PAnything -> return emptyFragment
28
29
29 PLiteral lit -> do
30 PLiteral lit -> do
30− c <- Literal.constrain env span lit tipe
31+ c <- liftIO $ Literal.constrain env span lit tipe
31 return $ emptyFragment { typeConstraint = c }
32 return $ emptyFragment { typeConstraint = c }
32
33
33 PVar name -> do
34 PVar name -> do
34− v <- var Flexible
35+ v <- liftIO $ var Flexible
35 return $ Fragment {
36 return $ Fragment {
36 typeEnv = Map.singleton name (VarN v),
37 typeEnv = Map.singleton name (VarN v),
37 vars = [v],
38 vars = [v],
@@ -46,11 +47,11 @@ constrain env pattern tipe =
46 }
47 }
47
48
48 PData name patterns -> do
49 PData name patterns -> do
49− (kind, cvars, args, result) <- freshDataScheme env name
50+ (kind, cvars, args, result) <- liftIO $ freshDataScheme env name
50 let msg = concat [ "Constructor '", name, "' expects ", show kind
51 let msg = concat [ "Constructor '", name, "' expects ", show kind
51 , " argument", if kind == 1 then "" else "s"
52 , " argument", if kind == 1 then "" else "s"
52 , " but was given ", show (length patterns), "." ]
53 , " but was given ", show (length patterns), "." ]
53− if length patterns /= kind then error msg else do
54+ if length patterns /= kind then throwError msg else do
54 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
55 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
55 return $ fragment {
56 return $ fragment {
56 typeConstraint = typeConstraint fragment /\ tipe === result,
57 typeConstraint = typeConstraint fragment /\ tipe === result,
@@ -58,9 +59,9 @@ constrain env pattern tipe =
58 }
59 }
59
60
60 PRecord fields -> do
61 PRecord fields -> do
61− pairs <- mapM (\name -> (,) name <$> var Flexible) fields
62+ pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
62 let tenv = Map.fromList (map (second VarN) pairs)
63 let tenv = Map.fromList (map (second VarN) pairs)
63− c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
64+ c <- liftIO . exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
64 return $ Fragment {
65 return $ Fragment {
65 typeEnv = tenv,
66 typeEnv = tenv,
66 vars = map snd pairs,
67 vars = map snd pairs,