git.iko.soy/elk
on master help sign in
Stop using `error` when constraining patterns and when instantiating source types
commit95ec3a822edeb97e667aab96996cc08aa8f605a9 authorEvan Czaplicki <info@elm-lang.org> dateSun 25 Aug 2013, 20:23 (13 years ago) parent7785eb8
5 files changed+72−43
compare with master
unifiedsplit
compiler/Type/Constrain/Expression.hs+17−16 compiler/Type/Constrain/Pattern.hs+16−3 compiler/Type/Environment.hs+12−4 compiler/Type/Inference.hs+24−18 compiler/Type/Type.hs+3−2
compiler/Type/Constrain/Expression.hs+17−16
@@ -6,9 +6,10 @@ 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)
9+import Control.Monad.Error
1010import Control.Monad.State
1111import Data.Traversable (traverse)
12+import qualified Text.PrettyPrint as PP
1213
1314import SourceSyntax.Location as Loc
1415import SourceSyntax.Pattern (Pattern(PVar))
@@ -22,7 +23,7 @@ import qualified Type.Constrain.Pattern as Pattern
2223import qualified Transform.SortDefinitions as SD
2324
2425
25−constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint
26+constrain :: Env.Environment -> LExpr a b -> Type -> ErrorT [PP.Doc] IO TypeConstraint
2627constrain env (L span expr) tipe =
2728 let list t = Env.get env Env.types "_List" <| t
2829 and = L span . CAnd
@@ -32,7 +33,7 @@ constrain env (L span expr) tipe =
3233 clet schemes c = L span (CLet schemes c)
3334 in
3435 case expr of
35− Literal lit -> Literal.constrain env span lit tipe
36+ Literal lit -> liftIO $ Literal.constrain env span lit tipe
3637
3738 Var name | name == saveEnvName -> return (L span CSaveEnv)
3839 | otherwise -> return (name <? tipe)
@@ -87,7 +88,7 @@ constrain env (L span expr) tipe =
8788 and . (:) ce <$> mapM branch branches
8889
8990 Data name exprs ->
90− do vars <- forM exprs $ \_ -> var Flexible
91+ do vars <- forM exprs $ \_ -> liftIO (var Flexible)
9192 let pairs = zip exprs (map VarN vars)
9293 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)
9394 return $ ex vars (cs /\ name <? ctipe)
@@ -114,11 +115,11 @@ constrain env (L span expr) tipe =
114115
115116 Modify e fields ->
116117 exists $ \t -> do
117− oldVars <- forM fields $ \_ -> var Flexible
118+ oldVars <- forM fields $ \_ -> liftIO (var Flexible)
118119 let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))
119120 cOld <- ex oldVars <$> constrain env e (record oldFields t)
120121
121− newVars <- forM fields $ \_ -> var Flexible
122+ newVars <- forM fields $ \_ -> liftIO (var Flexible)
122123 let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))
123124 let cNew = tipe === record newFields t
124125
@@ -127,7 +128,7 @@ constrain env (L span expr) tipe =
127128 return $ cOld /\ ex newVars (and (cNew : cs))
128129
129130 Record fields ->
130− do vars <- forM fields $ \_ -> var Flexible
131+ do vars <- forM fields $ \_ -> liftIO (var Flexible)
131132 cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
132133 let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))
133134 recordType = record fields' (TermN EmptyRecord1)
@@ -146,15 +147,16 @@ constrain env (L span expr) tipe =
146147 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]
147148 (c1 /\ c))
148149
150+
149151constrainDef env info (pattern, expr, maybeTipe) =
150152 let qs = [] -- should come from the def, but I'm not sure what would live there...
151153 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info
152154 in
153− do rigidVars <- mapM (\_ -> var Rigid) qs -- Some mistake may be happening here.
154− -- Currently, qs is always the empty list.
155+ do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.
156+ -- Currently, qs is always [].
155157 case (pattern, maybeTipe) of
156158 (PVar name, Just tipe) -> do
157− flexiVars <- mapM (\_ -> var Flexible) qs
159+ flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
158160 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
159161 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
160162 (vars, typ) <- Env.instantiateType env tipe Map.empty
@@ -171,7 +173,7 @@ constrainDef env info (pattern, expr, maybeTipe) =
171173 , fl rigidVars c /\ c1 )
172174
173175 (PVar name, Nothing) -> do
174− v <- var Flexible
176+ v <- liftIO $ var Flexible
175177 let tipe = VarN v
176178 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
177179 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
@@ -183,7 +185,6 @@ constrainDef env info (pattern, expr, maybeTipe) =
183185 , c /\ c2
184186 , c1 )
185187
186−
187188expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)
188189 -> [(Pattern, LExpr t v, Maybe SrcT.Type)]
189190expandPattern triple@(pattern, lexpr@(L s _), maybeType) =
@@ -212,9 +213,9 @@ collapseDefs = concatMap expandPattern . go [] Map.empty Map.empty
212213 TypeAnnotation name typ ->
213214 go output defs (Map.insert name typ typs) ds
214215
215−try :: SrcSpan -> ErrorT String IO a -> IO a
216+try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
216217try span computation = do
217− result <- runErrorT computation
218+ result <- liftIO $ runErrorT computation
218219 case result of
219− Left msg -> error $ "\nType error " ++ show span ++ "\n" ++ msg
220− Right value -> return value
220+ Left err -> throwError [err span]
221+ Right value -> return value
compiler/Type/Constrain/Pattern.hs+16−3
@@ -1,3 +1,4 @@
1+{-# LANGUAGE FlexibleInstances #-}
12module Type.Constrain.Pattern where
23
34import Control.Arrow (second)
@@ -7,8 +8,10 @@ import Control.Monad.Error
78import qualified Data.List as List
89import qualified Data.Maybe as Maybe
910import qualified Data.Map as Map
11+import qualified Text.PrettyPrint as PP
1012
1113import SourceSyntax.Pattern
14+import SourceSyntax.Location
1215import SourceSyntax.PrettyPrint
1316import Text.PrettyPrint (render)
1417import qualified SourceSyntax.Location as Loc
@@ -18,7 +21,7 @@ import Type.Environment as Env
1821import qualified Type.Constrain.Literal as Literal
1922
2023
21−constrain :: Environment -> Pattern -> Type -> ErrorT String IO Fragment
24+constrain :: Environment -> Pattern -> Type -> ErrorT (SrcSpan -> PP.Doc) IO Fragment
2225constrain env pattern tipe =
2326 let span = Loc.NoSpan (render $ pretty pattern)
2427 t1 === t2 = Loc.L span (CEqual t1 t2)
@@ -51,7 +54,11 @@ constrain env pattern tipe =
5154 let msg = concat [ "Constructor '", name, "' expects ", show kind
5255 , " argument", if kind == 1 then "" else "s"
5356 , " but was given ", show (length patterns), "." ]
54− if length patterns /= kind then throwError msg else do
57+ err span = PP.vcat [ PP.text $ "Type error " ++ show span
58+ , PP.text msg ]
59+ case length patterns == kind of
60+ False -> throwError err
61+ True -> do
5562 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
5663 return $ fragment {
5764 typeConstraint = typeConstraint fragment /\ tipe === result,
@@ -61,9 +68,15 @@ constrain env pattern tipe =
6168 PRecord fields -> do
6269 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
6370 let tenv = Map.fromList (map (second VarN) pairs)
64− c <- liftIO . exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
71+ c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
6572 return $ Fragment {
6673 typeEnv = tenv,
6774 vars = map snd pairs,
6875 typeConstraint = c
6976 }
77+
78+instance Error (SrcSpan -> PP.Doc) where
79+ noMsg _ = PP.empty
80+ strMsg str span =
81+ PP.vcat [ PP.text $ "Type error " ++ show span
82+ , PP.text str ]
compiler/Type/Environment.hs+12−4
@@ -1,12 +1,16 @@
11module Type.Environment where
22
33import Control.Applicative ((<$>), (<*>))
4+import Control.Exception (try, SomeException)
45import Control.Monad
6+import Control.Monad.Trans.Error (ErrorList(..))
7+import Control.Monad.Error (ErrorT, throwError, liftIO)
58import qualified Control.Monad.State as State
69import qualified Data.Traversable as Traverse
710import qualified Data.Map as Map
811import Data.List (isPrefixOf)
912import qualified Data.UnionFind.IO as UF
13+import qualified Text.PrettyPrint as PP
1014
1115import qualified SourceSyntax.Type as Src
1216import SourceSyntax.Module (ADT)
@@ -105,11 +109,15 @@ get env subDict key = Map.findWithDefault err key (subDict env)
105109freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
106110freshDataScheme env name = get env constructor name
107111
108−instantiateType ::
109− Environment -> Src.Type -> VarDict -> IO ([Variable], Type)
112+instance ErrorList PP.Doc where
113+ listMsg str = [PP.text str]
114+
115+instantiateType :: Environment -> Src.Type -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)
110116instantiateType env sourceType dict =
111− do (tipe, (dict',_)) <- State.runStateT (instantiator env sourceType) (dict, Map.empty)
112− return (Map.elems dict', tipe)
117+ do result <- liftIO $ try (State.runStateT (instantiator env sourceType) (dict, Map.empty))
118+ case result :: Either SomeException (Type, (VarDict, TypeDict)) of
119+ Left someError -> throwError [ PP.text $ show someError ]
120+ Right (tipe, (dict',_)) -> return (Map.elems dict', tipe)
113121
114122instantiator :: Environment -> Src.Type
115123 -> State.StateT (VarDict, TypeDict) IO Type
compiler/Type/Inference.hs+24−18
@@ -16,7 +16,8 @@ import SourceSyntax.Type (Type)
1616import Text.PrettyPrint
1717import qualified Type.State as TS
1818import Type.ExtraChecks (extraChecks)
19−import Control.Monad.State
19+import Control.Monad.State (execStateT, forM)
20+import Control.Monad.Error (runErrorT, liftIO)
2021import Control.Arrow (second)
2122import qualified Type.Alias as Alias
2223
@@ -33,20 +34,25 @@ infer interfaces modul = unsafePerformIO $ do
3334 do (_, vars, args, result) <- Env.freshDataScheme env name
3435 return (name, (vars, foldr (T.==>) result args))
3536
36− importedVars <-
37− forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->
38− (,) name `fmap` Env.instantiateType env tipe Map.empty
39−
40− let allTypes = ctors ++ importedVars
41− vars = concatMap (fst . snd) allTypes
42− header = Map.map snd (Map.fromList allTypes)
43− environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
44−
45− fvar <- T.var T.Flexible
46− constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)
47−
48− state <- execStateT (Solve.solve constraint) TS.initialState
49− let rules = Alias.rules interfaces modul
50− case TS.sErrors state of
51− errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
52− [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)
37+ attemptConstraint <- runErrorT $ do
38+ importedVars <-
39+ forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->
40+ (,) name `fmap` Env.instantiateType env tipe Map.empty
41+
42+ let allTypes = ctors ++ importedVars
43+ vars = concatMap (fst . snd) allTypes
44+ header = Map.map snd (Map.fromList allTypes)
45+ environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
46+
47+ fvar <- liftIO $ T.var T.Flexible
48+ c <- TcExpr.constrain env (program modul) (T.VarN fvar)
49+ return (header, environ c)
50+
51+ case attemptConstraint of
52+ Left err -> return $ Left err
53+ Right (header, constraint) -> do
54+ state <- execStateT (Solve.solve constraint) TS.initialState
55+ let rules = Alias.rules interfaces modul
56+ case TS.sErrors state of
57+ errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
58+ [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)
compiler/Type/Type.hs+3−2
@@ -9,6 +9,7 @@ import Text.PrettyPrint as P
99import System.IO.Unsafe
1010import Control.Applicative ((<$>),(<*>))
1111import Control.Monad.State
12+import Control.Monad.Error
1213import Data.Traversable (traverse)
1314import SourceSyntax.Location
1415import SourceSyntax.Helpers (isTuple)
@@ -130,9 +131,9 @@ ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s
130131fl :: [Variable] -> TypeConstraint -> TypeConstraint
131132fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)
132133
133−exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint
134+exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
134135exists f = do
135− v <- var Flexible
136+ v <- liftIO $ var Flexible
136137 ex [v] <$> f (VarN v)
137138
138139