git.iko.soy/elk
on master help sign in
Give line numbers when there is a kind error in a pattern
commit2e38f7b06121a3d70d2a76fce30273f0ef8284d3 authorEvan Czaplicki <info@elm-lang.org> dateTue 6 Aug 2013, 15:44 (13 years ago) parenta3f62c3
2 files changed+18−9
compare with master
unifiedsplit
compiler/Type/Constrain/Expression.hs+10−2 compiler/Type/Constrain/Pattern.hs+8−7
compiler/Type/Constrain/Expression.hs+10−2
@@ -6,6 +6,7 @@ import qualified Data.Set as Set
66import Control.Arrow (second)
77import Control.Applicative ((<$>),(<*>))
88import qualified Control.Monad as Monad
9+import Control.Monad.Error (ErrorT, runErrorT)
910import Control.Monad.State
1011import Data.Traversable (traverse)
1112
@@ -56,7 +57,7 @@ constrain env (L span expr) tipe =
5657 Lambda p e ->
5758 exists $ \t1 ->
5859 exists $ \t2 -> do
59− fragment <- Pattern.constrain env p t1
60+ fragment <- try span $ Pattern.constrain env p t1
6061 c2 <- constrain env e t2
6162 let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
6263 (typeConstraint fragment /\ c2 ))
@@ -80,7 +81,7 @@ constrain env (L span expr) tipe =
8081 exists $ \t -> do
8182 ce <- constrain env exp t
8283 let branch (p,e) = do
83− fragment <- Pattern.constrain env p t
84+ fragment <- try span $ Pattern.constrain env p t
8485 clet [toScheme fragment] <$> constrain env e tipe
8586 and . (:) ce <$> mapM branch branches
8687
@@ -213,3 +214,10 @@ collapseDefs = concatMap expandPattern . go [] Map.empty Map.empty
213214 go ((pattern, body, Nothing) : output) defs typs ds
214215 TypeAnnotation name typ ->
215216 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
33import Control.Arrow (second)
44import Control.Applicative ((<$>))
55import qualified Control.Monad as Monad
6+import Control.Monad.Error
67import qualified Data.List as List
78import qualified Data.Maybe as Maybe
89import qualified Data.Map as Map
@@ -17,7 +18,7 @@ import Type.Environment as Env
1718import qualified Type.Constrain.Literal as Literal
1819
1920
20−constrain :: Environment -> Pattern -> Type -> IO Fragment
21+constrain :: Environment -> Pattern -> Type -> ErrorT String IO Fragment
2122constrain env pattern tipe =
2223 let span = Loc.NoSpan (render $ pretty pattern)
2324 t1 === t2 = Loc.L span (CEqual t1 t2)
@@ -27,11 +28,11 @@ constrain env pattern tipe =
2728 PAnything -> return emptyFragment
2829
2930 PLiteral lit -> do
30− c <- Literal.constrain env span lit tipe
31+ c <- liftIO $ Literal.constrain env span lit tipe
3132 return $ emptyFragment { typeConstraint = c }
3233
3334 PVar name -> do
34− v <- var Flexible
35+ v <- liftIO $ var Flexible
3536 return $ Fragment {
3637 typeEnv = Map.singleton name (VarN v),
3738 vars = [v],
@@ -46,11 +47,11 @@ constrain env pattern tipe =
4647 }
4748
4849 PData name patterns -> do
49− (kind, cvars, args, result) <- freshDataScheme env name
50+ (kind, cvars, args, result) <- liftIO $ freshDataScheme env name
5051 let msg = concat [ "Constructor '", name, "' expects ", show kind
5152 , " argument", if kind == 1 then "" else "s"
5253 , " 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
5455 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
5556 return $ fragment {
5657 typeConstraint = typeConstraint fragment /\ tipe === result,
@@ -58,9 +59,9 @@ constrain env pattern tipe =
5859 }
5960
6061 PRecord fields -> do
61− pairs <- mapM (\name -> (,) name <$> var Flexible) fields
62+ pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
6263 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)
6465 return $ Fragment {
6566 typeEnv = tenv,
6667 vars = map snd pairs,