95ec3a8 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Stop using `error` when constraining patterns and when instantiating source types

95ec3a8Evan Czaplicki13 years ago

compiler/Type/Constrain/Expression.hs+17−16

compare with master

unifiedsplit

@@ -6,9 +6,10 @@ import qualified Data.Set as Set

6import Control.Arrow (second)

7import Control.Applicative ((<$>),(<*>))

8import qualified Control.Monad as Monad

9−import Control.Monad.Error (ErrorT, runErrorT)

9+import Control.Monad.Error

10import Control.Monad.State

11import Data.Traversable (traverse)

12+import qualified Text.PrettyPrint as PP

13import SourceSyntax.Location as Loc

14import SourceSyntax.Location as Loc

14import SourceSyntax.Pattern (Pattern(PVar))

15import SourceSyntax.Pattern (Pattern(PVar))

@@ -22,7 +23,7 @@ import qualified Type.Constrain.Pattern as Pattern

22import qualified Transform.SortDefinitions as SD

23import qualified Transform.SortDefinitions as SD

25−constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint

26+constrain :: Env.Environment -> LExpr a b -> Type -> ErrorT [PP.Doc] IO TypeConstraint

26constrain env (L span expr) tipe =

27constrain env (L span expr) tipe =

27 let list t = Env.get env Env.types "_List" <| t

28 let list t = Env.get env Env.types "_List" <| t

28 and = L span . CAnd

29 and = L span . CAnd

@@ -32,7 +33,7 @@ constrain env (L span expr) tipe =

32 clet schemes c = L span (CLet schemes c)

33 clet schemes c = L span (CLet schemes c)

33 in

34 in

34 case expr of

35 case expr of

35− Literal lit -> Literal.constrain env span lit tipe

36+ Literal lit -> liftIO $ Literal.constrain env span lit tipe

37 Var name | name == saveEnvName -> return (L span CSaveEnv)

38 Var name | name == saveEnvName -> return (L span CSaveEnv)

38 | otherwise -> return (name <? tipe)

39 | otherwise -> return (name <? tipe)

@@ -87,7 +88,7 @@ constrain env (L span expr) tipe =

87 and . (:) ce <$> mapM branch branches

88 and . (:) ce <$> mapM branch branches

89 Data name exprs ->

90 Data name exprs ->

90− do vars <- forM exprs $ \_ -> var Flexible

91+ do vars <- forM exprs $ \_ -> liftIO (var Flexible)

91 let pairs = zip exprs (map VarN vars)

92 let pairs = zip exprs (map VarN vars)

92 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

93 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

93 return $ ex vars (cs /\ name <? ctipe)

94 return $ ex vars (cs /\ name <? ctipe)

@@ -114,11 +115,11 @@ constrain env (L span expr) tipe =

114

115

115 Modify e fields ->

116 Modify e fields ->

116 exists $ \t -> do

117 exists $ \t -> do

117− oldVars <- forM fields $ \_ -> var Flexible

118+ oldVars <- forM fields $ \_ -> liftIO (var Flexible)

118 let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))

119 let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))

119 cOld <- ex oldVars <$> constrain env e (record oldFields t)

120 cOld <- ex oldVars <$> constrain env e (record oldFields t)

120

121

121− newVars <- forM fields $ \_ -> var Flexible

122+ newVars <- forM fields $ \_ -> liftIO (var Flexible)

122 let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))

123 let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))

123 let cNew = tipe === record newFields t

124 let cNew = tipe === record newFields t

124

125

@@ -127,7 +128,7 @@ constrain env (L span expr) tipe =

127 return $ cOld /\ ex newVars (and (cNew : cs))

128 return $ cOld /\ ex newVars (and (cNew : cs))

128

129

129 Record fields ->

130 Record fields ->

130− do vars <- forM fields $ \_ -> var Flexible

131+ do vars <- forM fields $ \_ -> liftIO (var Flexible)

131 cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)

132 cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)

132 let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))

133 let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))

133 recordType = record fields' (TermN EmptyRecord1)

134 recordType = record fields' (TermN EmptyRecord1)

@@ -146,15 +147,16 @@ constrain env (L span expr) tipe =

146 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

147 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

147 (c1 /\ c))

148 (c1 /\ c))

148

149

150+

149constrainDef env info (pattern, expr, maybeTipe) =

151constrainDef env info (pattern, expr, maybeTipe) =

150 let qs = [] -- should come from the def, but I'm not sure what would live there...

152 let qs = [] -- should come from the def, but I'm not sure what would live there...

151 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

153 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

152 in

154 in

153− do rigidVars <- mapM (\_ -> var Rigid) qs -- Some mistake may be happening here.

155+ do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.

154− -- Currently, qs is always the empty list.

156+ -- Currently, qs is always [].

155 case (pattern, maybeTipe) of

157 case (pattern, maybeTipe) of

156 (PVar name, Just tipe) -> do

158 (PVar name, Just tipe) -> do

157− flexiVars <- mapM (\_ -> var Flexible) qs

159+ flexiVars <- forM qs (\_ -> liftIO $ var Flexible)

158 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars

160 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars

159 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

161 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

160 (vars, typ) <- Env.instantiateType env tipe Map.empty

162 (vars, typ) <- Env.instantiateType env tipe Map.empty

@@ -171,7 +173,7 @@ constrainDef env info (pattern, expr, maybeTipe) =

171 , fl rigidVars c /\ c1 )

173 , fl rigidVars c /\ c1 )

172

174

173 (PVar name, Nothing) -> do

175 (PVar name, Nothing) -> do

174− v <- var Flexible

176+ v <- liftIO $ var Flexible

175 let tipe = VarN v

177 let tipe = VarN v

176 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars

178 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars

177 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

179 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

@@ -183,7 +185,6 @@ constrainDef env info (pattern, expr, maybeTipe) =

183 , c /\ c2

185 , c /\ c2

184 , c1 )

186 , c1 )

185

187

186−

187expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)

188expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)

188 -> [(Pattern, LExpr t v, Maybe SrcT.Type)]

189 -> [(Pattern, LExpr t v, Maybe SrcT.Type)]

189expandPattern triple@(pattern, lexpr@(L s _), maybeType) =

190expandPattern triple@(pattern, lexpr@(L s _), maybeType) =

@@ -212,9 +213,9 @@ collapseDefs = concatMap expandPattern . go [] Map.empty Map.empty

212 TypeAnnotation name typ ->

213 TypeAnnotation name typ ->

213 go output defs (Map.insert name typ typs) ds

214 go output defs (Map.insert name typ typs) ds

214

215

215−try :: SrcSpan -> ErrorT String IO a -> IO a

216+try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

216try span computation = do

217try span computation = do

217− result <- runErrorT computation

218+ result <- liftIO $ runErrorT computation

218 case result of

219 case result of

219− Left msg -> error $ "\nType error " ++ show span ++ "\n" ++ msg

220+ Left err -> throwError [err span]

220− Right value -> return value

221+ Right value -> return value

compiler/Type/Constrain/Pattern.hs+16−3

@@ -1,3 +1,4 @@

1+{-# LANGUAGE FlexibleInstances #-}

1module Type.Constrain.Pattern where

2module Type.Constrain.Pattern where

3import Control.Arrow (second)

4import Control.Arrow (second)

@@ -7,8 +8,10 @@ import Control.Monad.Error

7import qualified Data.List as List

8import qualified Data.List as List

8import qualified Data.Maybe as Maybe

9import qualified Data.Maybe as Maybe

9import qualified Data.Map as Map

10import qualified Data.Map as Map

11+import qualified Text.PrettyPrint as PP

11import SourceSyntax.Pattern

13import SourceSyntax.Pattern

14+import SourceSyntax.Location

12import SourceSyntax.PrettyPrint

15import SourceSyntax.PrettyPrint

13import Text.PrettyPrint (render)

16import Text.PrettyPrint (render)

14import qualified SourceSyntax.Location as Loc

17import qualified SourceSyntax.Location as Loc

@@ -18,7 +21,7 @@ import Type.Environment as Env

18import qualified Type.Constrain.Literal as Literal

21import qualified Type.Constrain.Literal as Literal

21−constrain :: Environment -> Pattern -> Type -> ErrorT String IO Fragment

24+constrain :: Environment -> Pattern -> Type -> ErrorT (SrcSpan -> PP.Doc) IO Fragment

22constrain env pattern tipe =

25constrain env pattern tipe =

23 let span = Loc.NoSpan (render $ pretty pattern)

26 let span = Loc.NoSpan (render $ pretty pattern)

24 t1 === t2 = Loc.L span (CEqual t1 t2)

27 t1 === t2 = Loc.L span (CEqual t1 t2)

@@ -51,7 +54,11 @@ constrain env pattern tipe =

51 let msg = concat [ "Constructor '", name, "' expects ", show kind

54 let msg = concat [ "Constructor '", name, "' expects ", show kind

52 , " argument", if kind == 1 then "" else "s"

55 , " argument", if kind == 1 then "" else "s"

53 , " but was given ", show (length patterns), "." ]

56 , " but was given ", show (length patterns), "." ]

57+ err span = PP.vcat [ PP.text $ "Type error " ++ show span

58+ , PP.text msg ]

54− if length patterns /= kind then throwError msg else do

59+ case length patterns == kind of

60+ False -> throwError err

61+ True -> do

55 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)

62 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)

56 return $ fragment {

63 return $ fragment {

57 typeConstraint = typeConstraint fragment /\ tipe === result,

64 typeConstraint = typeConstraint fragment /\ tipe === result,

@@ -61,9 +68,15 @@ constrain env pattern tipe =

61 PRecord fields -> do

68 PRecord fields -> do

62 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields

69 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields

63 let tenv = Map.fromList (map (second VarN) pairs)

70 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)

65 return $ Fragment {

72 return $ Fragment {

66 typeEnv = tenv,

73 typeEnv = tenv,

67 vars = map snd pairs,

74 vars = map snd pairs,

68 typeConstraint = c

75 typeConstraint = c

69 }

76 }

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 @@

1module Type.Environment where

3import Control.Applicative ((<$>), (<*>))

4+import Control.Exception (try, SomeException)

4import Control.Monad

5import Control.Monad

6+import Control.Monad.Trans.Error (ErrorList(..))

7+import Control.Monad.Error (ErrorT, throwError, liftIO)

5import qualified Control.Monad.State as State

8import qualified Control.Monad.State as State

6import qualified Data.Traversable as Traverse

9import qualified Data.Traversable as Traverse

7import qualified Data.Map as Map

10import qualified Data.Map as Map

8import Data.List (isPrefixOf)

11import Data.List (isPrefixOf)

9import qualified Data.UnionFind.IO as UF

12import qualified Data.UnionFind.IO as UF

13+import qualified Text.PrettyPrint as PP

11import qualified SourceSyntax.Type as Src

15import qualified SourceSyntax.Type as Src

12import SourceSyntax.Module (ADT)

16import SourceSyntax.Module (ADT)

@@ -105,11 +109,15 @@ get env subDict key = Map.findWithDefault err key (subDict env)

105freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

109freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

106freshDataScheme env name = get env constructor name

110freshDataScheme env name = get env constructor name

107

111

108−instantiateType ::

112+instance ErrorList PP.Doc where

113+ listMsg str = [PP.text str]

114+

109− Environment -> Src.Type -> VarDict -> IO ([Variable], Type)

115+instantiateType :: Environment -> Src.Type -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)

110instantiateType env sourceType dict =

116instantiateType env sourceType dict =

111− do (tipe, (dict',_)) <- State.runStateT (instantiator env sourceType) (dict, Map.empty)

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 ]

112− return (Map.elems dict', tipe)

120+ Right (tipe, (dict',_)) -> return (Map.elems dict', tipe)

113

121

114instantiator :: Environment -> Src.Type

122instantiator :: Environment -> Src.Type

115 -> State.StateT (VarDict, TypeDict) IO Type

123 -> State.StateT (VarDict, TypeDict) IO Type

compiler/Type/Inference.hs+24−18

@@ -16,7 +16,8 @@ import SourceSyntax.Type (Type)

16import Text.PrettyPrint

17import qualified Type.State as TS

18import Type.ExtraChecks (extraChecks)

19−import Control.Monad.State

19+import Control.Monad.State (execStateT, forM)

20+import Control.Monad.Error (runErrorT, liftIO)

20import Control.Arrow (second)

21import Control.Arrow (second)

21import qualified Type.Alias as Alias

22import qualified Type.Alias as Alias

@@ -33,20 +34,25 @@ infer interfaces modul = unsafePerformIO $ do

33 do (_, vars, args, result) <- Env.freshDataScheme env name

34 do (_, vars, args, result) <- Env.freshDataScheme env name

34 return (name, (vars, foldr (T.==>) result args))

35 return (name, (vars, foldr (T.==>) result args))

37+ attemptConstraint <- runErrorT $ do

36− importedVars <-

38+ importedVars <-

37− forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->

39+ forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->

38− (,) name `fmap` Env.instantiateType env tipe Map.empty

40+ (,) name `fmap` Env.instantiateType env tipe Map.empty

39−

41+

40− let allTypes = ctors ++ importedVars

42+ let allTypes = ctors ++ importedVars

41− vars = concatMap (fst . snd) allTypes

43+ vars = concatMap (fst . snd) allTypes

42− header = Map.map snd (Map.fromList allTypes)

44+ header = Map.map snd (Map.fromList allTypes)

43− environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]

45+ environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]

44−

46+

45− fvar <- T.var T.Flexible

47+ fvar <- liftIO $ T.var T.Flexible

46− constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)

48+ c <- TcExpr.constrain env (program modul) (T.VarN fvar)

47−

49+ return (header, environ c)

50+

51+ case attemptConstraint of

52+ Left err -> return $ Left err

53+ Right (header, constraint) -> do

48− state <- execStateT (Solve.solve constraint) TS.initialState

54+ state <- execStateT (Solve.solve constraint) TS.initialState

49− let rules = Alias.rules interfaces modul

55+ let rules = Alias.rules interfaces modul

50− case TS.sErrors state of

56+ case TS.sErrors state of

51− errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

57+ errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

52− [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)

58+ [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)

compiler/Type/Type.hs+3−2

@@ -9,6 +9,7 @@ import Text.PrettyPrint as P

9import System.IO.Unsafe

10import Control.Applicative ((<$>),(<*>))

11import Control.Monad.State

12+import Control.Monad.Error

12import Data.Traversable (traverse)

13import Data.Traversable (traverse)

13import SourceSyntax.Location

14import SourceSyntax.Location

14import SourceSyntax.Helpers (isTuple)

15import SourceSyntax.Helpers (isTuple)

@@ -130,9 +131,9 @@ ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s

130fl :: [Variable] -> TypeConstraint -> TypeConstraint

131fl :: [Variable] -> TypeConstraint -> TypeConstraint

131fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)

132fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)

132

133

133−exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint

134+exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

134exists f = do

135exists f = do

135− v <- var Flexible

136+ v <- liftIO $ var Flexible

136 ex [v] <$> f (VarN v)

137 ex [v] <$> f (VarN v)

137

138

139