git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Revert "Initial work on #242"
c7d2699Phil Freeman
examples/failing/TypeClasses.pursnew file+7
compare with golang
unifiedsplit
@@ -0,0 +1,7 @@
1+module TypeClasses where
2+
3+class Show a where
4+ show :: a -> String
5+
6+instance TypeClasses.Show ([[String]]) where
7+ show _ = "array"
examples/failing/TypeClasses2.purs−2
@@ -1,7 +1,5 @@
1module Main where
1module Main where
2
2
3−import Prelude ()
4−
5class Show a where
3class Show a where
6 show :: a -> String
4 show :: a -> String
7
5
psc-make/Main.hs+1−5
@@ -115,12 +115,8 @@ browserNamespace :: Term String
115browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
115browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
116 { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
116 { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
117
117
118−verboseErrors :: Term Bool
119−verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
120− { optDoc = "Display verbose error messages" }
121−
122options :: Term P.Options
118options :: Term P.Options
123−options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure [] <*> verboseErrors
119+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure []
124
120
125inputFilesAndPrelude :: FilePath -> Term [FilePath]
121inputFilesAndPrelude :: FilePath -> Term [FilePath]
126inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles
122inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles
psc/Main.hs+1−5
@@ -122,12 +122,8 @@ codeGenModules :: Term [String]
122codeGenModules = value $ optAll [] $ (optInfo [ "codegen" ])
122codeGenModules = value $ optAll [] $ (optInfo [ "codegen" ])
123 { optDoc = "A list of modules for which Javascript and externs should be generated. This argument can be used multiple times." }
123 { optDoc = "A list of modules for which Javascript and externs should be generated. This argument can be used multiple times." }
124
124
125−verboseErrors :: Term Bool
126−verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
127− { optDoc = "Display verbose error messages" }
128−
129options :: Term P.Options
125options :: Term P.Options
130−options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules <*> verboseErrors
126+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules
131
127
132stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
128stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
133stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
129stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
psci/Main.hs+1−1
@@ -194,7 +194,7 @@ completion = completeWord Nothing " \t\n\r" findCompletions
194-- | Compilation options.
194-- | Compilation options.
195--
195--
196options :: P.Options
196options :: P.Options
197−options = P.Options False True False True (Just "Main") True "PS" [] [] False
197+options = P.Options False True False True (Just "Main") True "PS" [] []
198
198
199-- |
199-- |
200-- Makes a volatile module to execute the current expression.
200-- Makes a volatile module to execute the current expression.
src/Language/PureScript.hs+6−7
@@ -71,7 +71,7 @@ compile' :: Environment -> Options -> [Module] -> Either String (String, String,
71compile' env opts ms = do
71compile' env opts ms = do
72 (sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)
72 (sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)
73 desugared <- desugar sorted
73 desugared <- desugar sorted
74− (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent
74+ (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
75 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
75 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
76 let entryPoints = moduleNameFromString `map` optionsModules opts
76 let entryPoints = moduleNameFromString `map` optionsModules opts
77 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
77 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
@@ -100,9 +100,8 @@ typeCheckModule mainModuleName (Module mn decls exps) = do
100 checkTypesAreExported (ValueRef name) = do
100 checkTypesAreExported (ValueRef name) = do
101 ty <- lookupVariable mn (Qualified (Just mn) name)
101 ty <- lookupVariable mn (Qualified (Just mn) name)
102 case find isTconHidden (findTcons ty) of
102 case find isTconHidden (findTcons ty) of
103− Just hiddenType -> throwError . strMsg $
103+ Just hiddenType -> throwError $ "Error in module '" ++ show mn ++ "':\n\
104− "Error in module '" ++ show mn ++ "':\n\
105− \Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"
104+ \Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"
106 Nothing -> return ()
105 Nothing -> return ()
107 checkTypesAreExported _ = return ()
106 checkTypesAreExported _ = return ()
108
107
@@ -119,7 +118,7 @@ typeCheckModule mainModuleName (Module mn decls exps) = do
119 where
118 where
120 go (TypeRef tyName' _) = tyName' /= tyName
119 go (TypeRef tyName' _) = tyName' /= tyName
121 go _ = True
120 go _ = True
122−
121+
123
122
124generateMain :: Environment -> Options -> [JS] -> Either String [JS]
123generateMain :: Environment -> Options -> [JS] -> Either String [JS]
125generateMain env opts js =
124generateMain env opts js =
@@ -192,7 +191,7 @@ make opts ms = do
192 go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()
191 go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()
193 go _ [] = return ()
192 go _ [] = return ()
194 go env ((False, m) : ms') = do
193 go env ((False, m) : ms') = do
195− (_, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
194+ (_, env') <- liftError . runCheck' env $ typeCheckModule Nothing m
196
195
197 go env' ms'
196 go env' ms'
198 go env ((True, m@(Module moduleName' _ exps)) : ms') = do
197 go env ((True, m@(Module moduleName' _ exps)) : ms') = do
@@ -200,7 +199,7 @@ make opts ms = do
200 jsFile = "js" ++ pathSeparator : filePath ++ ".js"
199 jsFile = "js" ++ pathSeparator : filePath ++ ".js"
201 externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
200 externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
202
201
203− (Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
202+ (Module _ elaborated _, env') <- liftError . runCheck' env $ typeCheckModule Nothing m
204
203
205 regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
204 regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
206
205
src/Language/PureScript/Options.hs+1−5
@@ -57,14 +57,10 @@ data Options = Options {
57 -- The modules to code gen
57 -- The modules to code gen
58 --
58 --
59 , optionsCodeGenModules :: [String]
59 , optionsCodeGenModules :: [String]
60− -- |
61− -- Verbose error message
62− --
63− , optionsVerboseErrors :: Bool
64 } deriving Show
60 } deriving Show
65
61
66-- |
62-- |
67-- Default compiler options
63-- Default compiler options
68--
64--
69defaultOptions :: Options
65defaultOptions :: Options
70−defaultOptions = Options False False False False Nothing False "PS" [] [] False
66+defaultOptions = Options False False False False Nothing False "PS" [] []
src/Language/PureScript/TypeChecker.hs+14−14
@@ -26,7 +26,6 @@ import Language.PureScript.TypeChecker.Types as T
26import Language.PureScript.TypeChecker.Synonyms as T
26import Language.PureScript.TypeChecker.Synonyms as T
27
27
28import Data.Maybe
28import Data.Maybe
29−import Data.Monoid ((<>))
30import qualified Data.Map as M
29import qualified Data.Map as M
31import Control.Monad.State
30import Control.Monad.State
32import Control.Monad.Error
31import Control.Monad.Error
@@ -37,13 +36,14 @@ import Language.PureScript.Kinds
37import Language.PureScript.Declarations
36import Language.PureScript.Declarations
38import Language.PureScript.TypeClassDictionaries
37import Language.PureScript.TypeClassDictionaries
39import Language.PureScript.Environment
38import Language.PureScript.Environment
39+import Language.PureScript.Pretty.Types
40
40
41addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
41addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
42addDataType moduleName name args dctors ctorKind = do
42addDataType moduleName name args dctors ctorKind = do
43 env <- getEnv
43 env <- getEnv
44 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
44 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
45 forM_ dctors $ \(dctor, tys) ->
45 forM_ dctors $ \(dctor, tys) ->
46− rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $
46+ rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $
47 addDataConstructor moduleName name args dctor tys
47 addDataConstructor moduleName name args dctor tys
48
48
49addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
49addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
@@ -64,7 +64,7 @@ valueIsNotDefined :: ModuleName -> Ident -> Check ()
64valueIsNotDefined moduleName name = do
64valueIsNotDefined moduleName name = do
65 env <- getEnv
65 env <- getEnv
66 case M.lookup (moduleName, name) (names env) of
66 case M.lookup (moduleName, name) (names env) of
67− Just _ -> throwError . strMsg $ show name ++ " is already defined"
67+ Just _ -> throwError $ show name ++ " is already defined"
68 Nothing -> return ()
68 Nothing -> return ()
69
69
70addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
70addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
@@ -85,10 +85,10 @@ checkTypeClassInstance :: ModuleName -> Type -> Check ()
85checkTypeClassInstance _ (TypeVar _) = return ()
85checkTypeClassInstance _ (TypeVar _) = return ()
86checkTypeClassInstance _ (TypeConstructor ctor) = do
86checkTypeClassInstance _ (TypeConstructor ctor) = do
87 env <- getEnv
87 env <- getEnv
88− when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed"
88+ when (ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"
89 return ()
89 return ()
90checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
90checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
91−checkTypeClassInstance _ ty = throwError $ mkUnifyErrorStack "Type class instance head is invalid." (Just (TypeError ty))
91+checkTypeClassInstance _ ty = throwError $ "Type class instance head is invalid: " ++ prettyPrintType ty
92
92
93-- |
93-- |
94-- Type check all declarations in a module
94-- Type check all declarations in a module
@@ -106,13 +106,13 @@ checkTypeClassInstance _ ty = throwError $ mkUnifyErrorStack "Type class instanc
106typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]
106typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]
107typeCheckAll _ _ [] = return []
107typeCheckAll _ _ [] = return []
108typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do
108typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do
109− rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do
109+ rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do
110 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
110 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
111 addDataType moduleName name args dctors ctorKind
111 addDataType moduleName name args dctors ctorKind
112 ds <- typeCheckAll mainModuleName moduleName rest
112 ds <- typeCheckAll mainModuleName moduleName rest
113 return $ d : ds
113 return $ d : ds
114typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
114typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
115− rethrow (strMsg "Error in data binding group" <>) $ do
115+ rethrow ("Error in data binding group:\n" ++) $ do
116 let syns = mapMaybe toTypeSynonym tys
116 let syns = mapMaybe toTypeSynonym tys
117 let dataDecls = mapMaybe toDataDecl tys
117 let dataDecls = mapMaybe toDataDecl tys
118 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
118 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
@@ -128,14 +128,14 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re
128 toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)
128 toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)
129 toDataDecl _ = Nothing
129 toDataDecl _ = Nothing
130typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
130typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
131− rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do
131+ rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
132 kind <- kindsOf False moduleName name args [ty]
132 kind <- kindsOf False moduleName name args [ty]
133 addTypeSynonym moduleName name args ty kind
133 addTypeSynonym moduleName name args ty kind
134 ds <- typeCheckAll mainModuleName moduleName rest
134 ds <- typeCheckAll mainModuleName moduleName rest
135 return $ d : ds
135 return $ d : ds
136typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
136typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
137typeCheckAll mainModuleName moduleName (ValueDeclaration name nameKind [] Nothing val : rest) = do
137typeCheckAll mainModuleName moduleName (ValueDeclaration name nameKind [] Nothing val : rest) = do
138− d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do
138+ d <- rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do
139 valueIsNotDefined moduleName name
139 valueIsNotDefined moduleName name
140 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
140 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
141 addValue moduleName name ty nameKind
141 addValue moduleName name ty nameKind
@@ -144,7 +144,7 @@ typeCheckAll mainModuleName moduleName (ValueDeclaration name nameKind [] Nothin
144 return $ d : ds
144 return $ d : ds
145typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared"
145typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared"
146typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do
146typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do
147− d <- rethrow (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ do
147+ d <- rethrow (("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals) ++ ":\n") ++) $ do
148 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
148 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
149 valueIsNotDefined moduleName name
149 valueIsNotDefined moduleName name
150 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
150 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
@@ -160,19 +160,19 @@ typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : re
160 ds <- typeCheckAll mainModuleName moduleName rest
160 ds <- typeCheckAll mainModuleName moduleName rest
161 return $ d : ds
161 return $ d : ds
162typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do
162typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do
163− rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do
163+ rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
164 env <- getEnv
164 env <- getEnv
165 kind <- kindOf moduleName ty
165 kind <- kindOf moduleName ty
166− guardWith (strMsg "Expected kind *") $ kind == Star
166+ guardWith "Expected kind *" $ kind == Star
167 case M.lookup (moduleName, name) (names env) of
167 case M.lookup (moduleName, name) (names env) of
168− Just _ -> throwError . strMsg $ show name ++ " is already defined"
168+ Just _ -> throwError $ show name ++ " is already defined"
169 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy) (names env) })
169 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy) (names env) })
170 ds <- typeCheckAll mainModuleName moduleName rest
170 ds <- typeCheckAll mainModuleName moduleName rest
171 return $ d : ds
171 return $ d : ds
172typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do
172typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do
173 ds <- typeCheckAll mainModuleName moduleName rest
173 ds <- typeCheckAll mainModuleName moduleName rest
174 env <- getEnv
174 env <- getEnv
175− guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
175+ guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env
176 return $ d : ds
176 return $ d : ds
177typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do
177typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do
178 env <- getEnv
178 env <- getEnv
src/Language/PureScript/TypeChecker/Kinds.hs+13−19
@@ -14,7 +14,7 @@
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15
15
16{-# OPTIONS_GHC -fno-warn-orphans #-}
16{-# OPTIONS_GHC -fno-warn-orphans #-}
17−{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
17+{-# LANGUAGE MultiParamTypeClasses #-}
18
18
19module Language.PureScript.TypeChecker.Kinds (
19module Language.PureScript.TypeChecker.Kinds (
20 kindOf,
20 kindOf,
@@ -36,7 +36,6 @@ import Control.Monad.Unify
36import Control.Applicative
36import Control.Applicative
37
37
38import qualified Data.Map as M
38import qualified Data.Map as M
39−import Data.Monoid ((<>))
40
39
41instance Partial Kind where
40instance Partial Kind where
42 unknown = KUnknown
41 unknown = KUnknown
@@ -53,14 +52,14 @@ instance Unifiable Check Kind where
53 FunKind k1 k2 =?= FunKind k3 k4 = do
52 FunKind k1 k2 =?= FunKind k3 k4 = do
54 k1 =?= k3
53 k1 =?= k3
55 k2 =?= k4
54 k2 =?= k4
56− k1 =?= k2 = UnifyT . lift . throwError . strMsg $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
55+ k1 =?= k2 = UnifyT . lift . throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
57
56
58-- |
57-- |
59-- Infer the kind of a single type
58-- Infer the kind of a single type
60--
59--
61kindOf :: ModuleName -> Type -> Check Kind
60kindOf :: ModuleName -> Type -> Check Kind
62kindOf _ ty =
61kindOf _ ty =
63− rethrow (mkUnifyErrorStack "Error checking kind" (Just (TypeError ty)) <>) $
62+ rethrow (("Error checking kind of " ++ prettyPrintType ty ++ ":\n") ++) $
64 fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty
63 fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty
65 where
64 where
66 tidyUp (k, sub) = sub $? k
65 tidyUp (k, sub) = sub $? k
@@ -106,7 +105,7 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
106-- |
105-- |
107-- Solve the set of kind constraints associated with the data constructors for a type constructor
106-- Solve the set of kind constraints associated with the data constructors for a type constructor
108--
107--
109−solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind (Check) Kind
108+solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind
110solveTypes isData ts kargs tyCon = do
109solveTypes isData ts kargs tyCon = do
111 ks <- mapM infer ts
110 ks <- mapM infer ts
112 when isData $ do
111 when isData $ do
@@ -129,44 +128,39 @@ starIfUnknown k = k
129-- Infer a kind for a type
128-- Infer a kind for a type
130--
129--
131infer :: Type -> UnifyT Kind Check Kind
130infer :: Type -> UnifyT Kind Check Kind
132−infer ty = rethrow (mkUnifyErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty
133−
134−infer' :: Type -> UnifyT Kind Check Kind
135−infer' (TypeVar v) = do
131+infer (TypeVar v) = do
136 Just moduleName <- checkCurrentModule <$> get
132 Just moduleName <- checkCurrentModule <$> get
137 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
133 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
138−infer' c@(TypeConstructor v) = do
134+infer (TypeConstructor v) = do
139 env <- liftCheck getEnv
135 env <- liftCheck getEnv
140 case M.lookup v (types env) of
136 case M.lookup v (types env) of
141− Nothing -> UnifyT . lift . throwError $ mkUnifyErrorStack "Unknown type constructor" (Just (TypeError c))
137+ Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'"
142 Just (kind, _) -> return kind
138 Just (kind, _) -> return kind
143−infer' (TypeApp t1 t2) = do
139+infer (TypeApp t1 t2) = do
144 k0 <- fresh
140 k0 <- fresh
145 k1 <- infer t1
141 k1 <- infer t1
146 k2 <- infer t2
142 k2 <- infer t2
147 k1 =?= FunKind k2 k0
143 k1 =?= FunKind k2 k0
148 return k0
144 return k0
149−infer' (ForAll ident ty _) = do
145+infer (ForAll ident ty _) = do
150 k1 <- fresh
146 k1 <- fresh
151 Just moduleName <- checkCurrentModule <$> get
147 Just moduleName <- checkCurrentModule <$> get
152 k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty
148 k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty
153 k2 =?= Star
149 k2 =?= Star
154 return Star
150 return Star
155−infer' REmpty = do
151+infer REmpty = do
156 k <- fresh
152 k <- fresh
157 return $ Row k
153 return $ Row k
158−infer' (RCons _ ty row) = do
154+infer (RCons _ ty row) = do
159 k1 <- infer ty
155 k1 <- infer ty
160 k2 <- infer row
156 k2 <- infer row
161 k2 =?= Row k1
157 k2 =?= Row k1
162 return $ Row k1
158 return $ Row k1
163−infer' (ConstrainedType deps ty) = do
159+infer (ConstrainedType deps ty) = do
164 forM_ deps $ \(className, tys) -> do
160 forM_ deps $ \(className, tys) -> do
165 _ <- infer $ foldl TypeApp (TypeConstructor className) tys
161 _ <- infer $ foldl TypeApp (TypeConstructor className) tys
166 return ()
162 return ()
167 k <- infer ty
163 k <- infer ty
168 k =?= Star
164 k =?= Star
169 return Star
165 return Star
170−infer' _ = error "Invalid argument to infer"
166+infer _ = error "Invalid argument to infer"
171−
172−
src/Language/PureScript/TypeChecker/Monad.hs+17−90
@@ -21,14 +21,10 @@ module Language.PureScript.TypeChecker.Monad where
21import Language.PureScript.Types
21import Language.PureScript.Types
22import Language.PureScript.Kinds
22import Language.PureScript.Kinds
23import Language.PureScript.Names
23import Language.PureScript.Names
24−import Language.PureScript.Declarations
25import Language.PureScript.Environment
24import Language.PureScript.Environment
26import Language.PureScript.TypeClassDictionaries
25import Language.PureScript.TypeClassDictionaries
27−import Language.PureScript.Pretty
28−import Language.PureScript.Options
29
26
30import Data.Maybe
27import Data.Maybe
31−import Data.Monoid
32
28
33import Control.Applicative
29import Control.Applicative
34import Control.Monad.State
30import Control.Monad.State
@@ -36,77 +32,6 @@ import Control.Monad.Error
36import Control.Monad.Unify
32import Control.Monad.Unify
37
33
38import qualified Data.Map as M
34import qualified Data.Map as M
39−import Data.List (intercalate)
40−
41−-- |
42−-- Type for sources of type checking errors
43−--
44−data UnifyErrorSource
45− -- |
46− -- An error which originated at a Value
47− --
48− = ValueError Value
49− -- |
50− -- An error which originated at a Type
51− --
52− | TypeError Type deriving (Show)
53−
54−-- |
55−-- Unification errors
56−--
57−data UnifyError = UnifyError {
58− -- |
59− -- Error message
60− --
61− unifyErrorMessage :: String
62− -- |
63− -- The value where the error occurred
64− --
65− , unifyErrorValue :: Maybe UnifyErrorSource
66− } deriving (Show)
67−
68−-- |
69−-- A stack trace for an error
70−--
71−newtype UnifyErrorStack = UnifyErrorStack { runUnifyErrorStack :: [UnifyError] } deriving (Show, Monoid)
72−
73−instance Error UnifyErrorStack where
74− strMsg s = UnifyErrorStack [UnifyError s Nothing]
75− noMsg = UnifyErrorStack []
76−
77−prettyPrintUnifyErrorStack :: Options -> UnifyErrorStack -> String
78−prettyPrintUnifyErrorStack opts (UnifyErrorStack es) | optionsVerboseErrors opts = intercalate "\n" (map showError es)
79−prettyPrintUnifyErrorStack _ (UnifyErrorStack es) =
80− let
81− errorsWithValues = filter (isJust . unifyErrorValue) es
82− mostSpecificError = last es
83− in case (length errorsWithValues, isJust (unifyErrorValue mostSpecificError)) of
84− (0, _) -> showError mostSpecificError
85− (1, True) -> showError mostSpecificError
86− (1, False) ->
87− let errorWithValue = head errorsWithValues
88− in showError errorWithValue ++ "\n" ++
89− showError mostSpecificError
90− (_, True) ->
91− let errorWithValue = head errorsWithValues
92− in showError errorWithValue ++ "\n" ++
93− showError mostSpecificError
94− (_, False) ->
95− let
96− leastSpecificErrorWithValue = head errorsWithValues
97− mostSpecificErrorWithValue = last errorsWithValues
98− in
99− showError leastSpecificErrorWithValue ++ "\n" ++
100− showError mostSpecificErrorWithValue ++ "\n" ++
101− showError mostSpecificError
102−
103−showError :: UnifyError -> String
104−showError (UnifyError msg Nothing) = msg
105−showError (UnifyError msg (Just (ValueError val))) = "Error in value " ++ prettyPrintValue val ++ ": \n" ++ msg
106−showError (UnifyError msg (Just (TypeError ty))) = "Error in type " ++ prettyPrintType ty ++ ": \n" ++ msg
107−
108−mkUnifyErrorStack :: String -> Maybe UnifyErrorSource -> UnifyErrorStack
109−mkUnifyErrorStack msg t = UnifyErrorStack [UnifyError msg t]
110
35
111-- |
36-- |
112-- Temporarily bind a collection of names to values
37-- Temporarily bind a collection of names to values
@@ -164,21 +89,21 @@ bindLocalTypeVariables moduleName bindings =
164-- |
89-- |
165-- Lookup the type of a value by name in the @Environment@
90-- Lookup the type of a value by name in the @Environment@
166--
91--
167−lookupVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
92+lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type
168lookupVariable currentModule (Qualified moduleName var) = do
93lookupVariable currentModule (Qualified moduleName var) = do
169 env <- getEnv
94 env <- getEnv
170 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
95 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
171− Nothing -> throwError . strMsg $ show var ++ " is undefined"
96+ Nothing -> throwError $ show var ++ " is undefined"
172 Just (ty, _) -> return ty
97 Just (ty, _) -> return ty
173
98
174-- |
99-- |
175-- Lookup the kind of a type by name in the @Environment@
100-- Lookup the kind of a type by name in the @Environment@
176--
101--
177−lookupTypeVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind
102+lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind
178lookupTypeVariable currentModule (Qualified moduleName name) = do
103lookupTypeVariable currentModule (Qualified moduleName name) = do
179 env <- getEnv
104 env <- getEnv
180 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
105 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
181− Nothing -> throwError . strMsg $ "Type variable " ++ show name ++ " is undefined"
106+ Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"
182 Just (k, _) -> return k
107 Just (k, _) -> return k
183
108
184-- |
109-- |
@@ -206,8 +131,8 @@ data CheckState = CheckState {
206-- |
131-- |
207-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
132-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
208--
133--
209−newtype Check a = Check { unCheck :: StateT CheckState (Either UnifyErrorStack) a }
134+newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
210− deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError UnifyErrorStack)
135+ deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
211
136
212-- |
137-- |
213-- Get the current @Environment@
138-- Get the current @Environment@
@@ -230,14 +155,14 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
230-- |
155-- |
231-- Run a computation in the Check monad, starting with an empty @Environment@
156-- Run a computation in the Check monad, starting with an empty @Environment@
232--
157--
233−runCheck :: Options -> Check a -> Either String (a, Environment)
158+runCheck :: Check a -> Either String (a, Environment)
234−runCheck opts = runCheck' opts initEnvironment
159+runCheck = runCheck' initEnvironment
235
160
236-- |
161-- |
237-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
162-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
238--
163--
239−runCheck' :: Options -> Environment -> Check a -> Either String (a, Environment)
164+runCheck' :: Environment -> Check a -> Either String (a, Environment)
240−runCheck' opts env c = either (Left . prettyPrintUnifyErrorStack opts) Right $ do
165+runCheck' env c = do
241 (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
166 (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
242 return (a, checkEnv s)
167 return (a, checkEnv s)
243
168
@@ -267,7 +192,7 @@ freshDictionaryName = do
267-- Lift a computation in the @Check@ monad into the substitution monad.
192-- Lift a computation in the @Check@ monad into the substitution monad.
268--
193--
269liftCheck :: Check a -> UnifyT t Check a
194liftCheck :: Check a -> UnifyT t Check a
270−liftCheck = UnifyT . lift
195+liftCheck = UnifyT . lift . lift
271
196
272-- |
197-- |
273-- Run a computation in the substitution monad, generating a return value and the final substitution.
198-- Run a computation in the substitution monad, generating a return value and the final substitution.
@@ -275,7 +200,9 @@ liftCheck = UnifyT . lift
275liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t)
200liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t)
276liftUnify unify = do
201liftUnify unify = do
277 st <- get
202 st <- get
278− (a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify
203+ e <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify
204+ case e of
205+ Left err -> throwError err
206+ Right (a, ust) -> do
279− modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
207+ modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
280− return (a, unifyCurrentSubstitution ust)
208+ return (a, unifyCurrentSubstitution ust)
281−
src/Language/PureScript/TypeChecker/Types.hs+45−43
@@ -14,7 +14,6 @@
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15
15
16{-# OPTIONS_GHC -fno-warn-orphans #-}
16{-# OPTIONS_GHC -fno-warn-orphans #-}
17−{-# LANGUAGE FlexibleInstances #-}
18{-# LANGUAGE FlexibleContexts #-}
17{-# LANGUAGE FlexibleContexts #-}
19{-# LANGUAGE MultiParamTypeClasses #-}
18{-# LANGUAGE MultiParamTypeClasses #-}
20
19
@@ -71,7 +70,6 @@ import Control.Arrow (Arrow(..))
71import qualified Data.Map as M
70import qualified Data.Map as M
72import Data.Function (on)
71import Data.Function (on)
73import Data.Ord (comparing)
72import Data.Ord (comparing)
74−import Data.Monoid ((<>))
75
73
76instance Partial Type where
74instance Partial Type where
77 unknown = TUnknown
75 unknown = TUnknown
@@ -85,7 +83,7 @@ instance Unifiable Check Type where
85-- Unify two types, updating the current substitution
83-- Unify two types, updating the current substitution
86--
84--
87unifyTypes :: Type -> Type -> UnifyT Type Check ()
85unifyTypes :: Type -> Type -> UnifyT Type Check ()
88−unifyTypes t1 t2 = rethrow (mkUnifyErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $
86+unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $
89 unifyTypes' t1 t2
87 unifyTypes' t1 t2
90 where
88 where
91 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
89 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
@@ -102,16 +100,16 @@ unifyTypes t1 t2 = rethrow (mkUnifyErrorStack ("Error unifying type " ++ prettyP
102 let sk1 = skolemize ident1 sko sc1' ty1
100 let sk1 = skolemize ident1 sko sc1' ty1
103 let sk2 = skolemize ident2 sko sc2' ty2
101 let sk2 = skolemize ident2 sko sc2' ty2
104 sk1 `unifyTypes` sk2
102 sk1 `unifyTypes` sk2
105− _ -> error "Skolemized type variable was not given a scope"
103+ _ -> throwError (prettyPrintType ty1)
106 unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do
104 unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do
107 sko <- newSkolemConstant
105 sko <- newSkolemConstant
108 let sk = skolemize ident sko sc ty1
106 let sk = skolemize ident sko sc ty1
109 sk `unifyTypes` ty2
107 sk `unifyTypes` ty2
110− unifyTypes' ForAll{} _ = throwError . strMsg $ "Skolem variable scope is unspecified"
108+ unifyTypes' ForAll{} _ = throwError "Skolem variable scope is unspecified"
111 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty
109 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty
112 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
110 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
113 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =
111 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =
114− guardWith (strMsg ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".")) (c1 == c2)
112+ guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (c1 == c2)
115 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
113 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
116 t3 `unifyTypes` t5
114 t3 `unifyTypes` t5
117 t4 `unifyTypes` t6
115 t4 `unifyTypes` t6
@@ -120,9 +118,10 @@ unifyTypes t1 t2 = rethrow (mkUnifyErrorStack ("Error unifying type " ++ prettyP
120 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2
118 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2
121 unifyTypes' r1@REmpty r2 = unifyRows r1 r2
119 unifyTypes' r1@REmpty r2 = unifyRows r1 r2
122 unifyTypes' r1 r2@REmpty = unifyRows r1 r2
120 unifyTypes' r1 r2@REmpty = unifyRows r1 r2
123− unifyTypes' t@(ConstrainedType _ _) _ = throwError . strMsg $ "Attempted to unify a constrained type " ++ prettyPrintType t ++ " with another type."
121+ unifyTypes' t@(ConstrainedType _ _) _ = throwError $ "Attempted to unify a constrained type " ++ prettyPrintType t ++
122+ " with another type."
124 unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3
123 unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3
125− unifyTypes' t3 t4 = throwError . strMsg $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
124+ unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
126
125
127-- |
126-- |
128-- Unify two rows, updating the current substitution
127-- Unify two rows, updating the current substitution
@@ -155,7 +154,7 @@ unifyRows r1 r2 =
155 unifyRows' [] REmpty [] REmpty = return ()
154 unifyRows' [] REmpty [] REmpty = return ()
156 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
155 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
157 unifyRows' [] (Skolem s1 _) [] (Skolem s2 _) | s1 == s2 = return ()
156 unifyRows' [] (Skolem s1 _) [] (Skolem s2 _) | s1 == s2 = return ()
158− unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"
157+ unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")."
159
158
160-- |
159-- |
161-- Infer the types of multiple mutually-recursive values, and return elaborated values including
160-- Infer the types of multiple mutually-recursive values, and return elaborated values including
@@ -218,7 +217,7 @@ typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do
218 (ident, (val', Just (ty, checkType))) -> do
217 (ident, (val', Just (ty, checkType))) -> do
219 -- Kind check
218 -- Kind check
220 kind <- liftCheck $ kindOf moduleName ty
219 kind <- liftCheck $ kindOf moduleName ty
221− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
220+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
222 -- Check the type with the new names in scope
221 -- Check the type with the new names in scope
223 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
222 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
224 val'' <- bindNames dict' $ if checkType
223 val'' <- bindNames dict' $ if checkType
@@ -271,7 +270,7 @@ replaceTypeClassDictionaries mn = everywhereM' (mkM go)
271entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value
270entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value
272entails env moduleName context goal@(className, tys) = do
271entails env moduleName context goal@(className, tys) = do
273 case go goal of
272 case go goal of
274− [] -> throwError . strMsg $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)
273+ [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)
275 (dict : _) -> return dict
274 (dict : _) -> return dict
276 where
275 where
277 go (className', tys') =
276 go (className', tys') =
@@ -363,7 +362,7 @@ skolemEscapeCheck root@TypedValue{} =
363 -- an escaped skolem variable.
362 -- an escaped skolem variable.
364 case everythingWithContext [] (++) (mkQ ((,) []) go) root of
363 case everythingWithContext [] (++) (mkQ ((,) []) go) root of
365 [] -> return ()
364 [] -> return ()
366− ((binding, val) : _) -> throwError $ mkUnifyErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val))
365+ ((binding, val) : _) -> throwError $ "Rigid/skolem type variable bound by " ++ maybe "<unknown>" prettyPrintValue binding ++ " has escaped at " ++ prettyPrintValue val
367 where
366 where
368 go :: Value -> [(SkolemScope, Value)] -> ([(Maybe Value, Value)], [(SkolemScope, Value)])
367 go :: Value -> [(SkolemScope, Value)] -> ([(Maybe Value, Value)], [(SkolemScope, Value)])
369 go val@(TypedValue _ _ (ForAll _ _ (Just sco))) scos = ([], (sco, val) : scos)
368 go val@(TypedValue _ _ (ForAll _ _ (Just sco))) scos = ([], (sco, val) : scos)
@@ -382,7 +381,7 @@ skolemEscapeCheck root@TypedValue{} =
382 where
381 where
383 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val
382 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val
384 go' _ = Nothing
383 go' _ = Nothing
385−skolemEscapeCheck val = throwError $ mkUnifyErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ValueError val))
384+skolemEscapeCheck val = throwError $ "Untyped value passed to skolemEscapeCheck: " ++ prettyPrintValue val
386
385
387-- |
386-- |
388-- Ensure a row contains no duplicate labels
387-- Ensure a row contains no duplicate labels
@@ -445,10 +444,10 @@ replaceAllTypeSynonyms' env d =
445 in
444 in
446 saturateAllTypeSynonyms syns d
445 saturateAllTypeSynonyms syns d
447
446
448−replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => (D.Data d) => d -> m d
447+replaceAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
449replaceAllTypeSynonyms d = do
448replaceAllTypeSynonyms d = do
450 env <- getEnv
449 env <- getEnv
451− either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d
450+ either throwError return $ replaceAllTypeSynonyms' env d
452
451
453-- |
452-- |
454-- \"Desaturate\" @SaturatedTypeSynonym@s
453-- \"Desaturate\" @SaturatedTypeSynonym@s
@@ -470,12 +469,12 @@ expandTypeSynonym' env name args =
470 replaceAllTypeSynonyms' env repl
469 replaceAllTypeSynonyms' env repl
471 Nothing -> error "Type synonym was not defined"
470 Nothing -> error "Type synonym was not defined"
472
471
473−expandTypeSynonym :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type
472+expandTypeSynonym :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Qualified ProperName -> [Type] -> m Type
474expandTypeSynonym name args = do
473expandTypeSynonym name args = do
475 env <- getEnv
474 env <- getEnv
476− either (throwError . strMsg) return $ expandTypeSynonym' env name args
475+ either throwError return $ expandTypeSynonym' env name args
477
476
478−expandAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
477+expandAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Type -> m Type
479expandAllTypeSynonyms = everywhereM' (mkM go)
478expandAllTypeSynonyms = everywhereM' (mkM go)
480 where
479 where
481 go (SaturatedTypeSynonym name args) = expandTypeSynonym name args
480 go (SaturatedTypeSynonym name args) = expandTypeSynonym name args
@@ -484,14 +483,14 @@ expandAllTypeSynonyms = everywhereM' (mkM go)
484-- |
483-- |
485-- Ensure a set of property names and value does not contain duplicate labels
484-- Ensure a set of property names and value does not contain duplicate labels
486--
485--
487−ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Value)] -> m ()
486+ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
488−ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps
487+ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
489
488
490-- |
489-- |
491-- Infer a type for a value, rethrowing any error to provide a more useful error message
490-- Infer a type for a value, rethrowing any error to provide a more useful error message
492--
491--
493infer :: Value -> UnifyT Type Check Value
492infer :: Value -> UnifyT Type Check Value
494−infer val = rethrow (mkUnifyErrorStack "Error inferring type of value" (Just (ValueError val)) <>) $ infer' val
493+infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' val
495
494
496-- |
495-- |
497-- Infer a type for a value
496-- Infer a type for a value
@@ -552,7 +551,7 @@ infer' (Var var) = do
552infer' v@(Constructor c) = do
551infer' v@(Constructor c) = do
553 env <- getEnv
552 env <- getEnv
554 case M.lookup c (dataConstructors env) of
553 case M.lookup c (dataConstructors env) of
555− Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
554+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
556 Just (_, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
555 Just (_, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
557 return $ TypedValue True v ty'
556 return $ TypedValue True v ty'
558infer' (Case vals binders) = do
557infer' (Case vals binders) = do
@@ -572,7 +571,7 @@ infer' (Let ds val) = do
572infer' (TypedValue checkType val ty) = do
571infer' (TypedValue checkType val ty) = do
573 Just moduleName <- checkCurrentModule <$> get
572 Just moduleName <- checkCurrentModule <$> get
574 kind <- liftCheck $ kindOf moduleName ty
573 kind <- liftCheck $ kindOf moduleName ty
575− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
574+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
576 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
575 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
577 val' <- if checkType then check val ty' else return val
576 val' <- if checkType then check val ty' else return val
578 return $ TypedValue True val' ty'
577 return $ TypedValue True val' ty'
@@ -632,8 +631,8 @@ inferBinder val (ConstructorBinder ctor binders) = do
632 return M.empty
631 return M.empty
633 go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =
632 go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =
634 M.union <$> inferBinder obj binder <*> go binders' ret
633 M.union <$> inferBinder obj binder <*> go binders' ret
635− go _ _ = throwError . strMsg $ "Wrong number of arguments to constructor " ++ show ctor
634+ go _ _ = throwError $ "Wrong number of arguments to constructor " ++ show ctor
636− _ -> throwError . strMsg $ "Constructor " ++ show ctor ++ " is not defined"
635+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
637inferBinder val (ObjectBinder props) = do
636inferBinder val (ObjectBinder props) = do
638 row <- fresh
637 row <- fresh
639 rest <- fresh
638 rest <- fresh
@@ -712,13 +711,15 @@ introduceSkolemScope = everywhereM (mkM go)
712-- Check the type of a value, rethrowing errors to provide a better error message
711-- Check the type of a value, rethrowing errors to provide a better error message
713--
712--
714check :: Value -> Type -> UnifyT Type Check Value
713check :: Value -> Type -> UnifyT Type Check Value
715−check val ty = rethrow (mkUnifyErrorStack errorMessage (Just (ValueError val)) <>) $ check' val ty
714+check val ty = rethrow errorMessage $ check' val ty
716 where
715 where
717− errorMessage =
716+ errorMessage msg =
718 "Error checking type of term " ++
717 "Error checking type of term " ++
719 prettyPrintValue val ++
718 prettyPrintValue val ++
720 " against type " ++
719 " against type " ++
721− prettyPrintType ty
720+ prettyPrintType ty ++
721+ ":\n" ++
722+ msg
722
723
723-- |
724-- |
724-- Check the type of a value
725-- Check the type of a value
@@ -772,16 +773,16 @@ check' v@(Var var) ty = do
772 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
773 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
773 v' <- subsumes (Just v) repl ty'
774 v' <- subsumes (Just v) repl ty'
774 case v' of
775 case v' of
775− Nothing -> throwError . strMsg $ "Unable to check type subsumption"
776+ Nothing -> throwError "Unable to check type subsumption"
776 Just v'' -> return $ TypedValue True v'' ty'
777 Just v'' -> return $ TypedValue True v'' ty'
777check' (TypedValue checkType val ty1) ty2 = do
778check' (TypedValue checkType val ty1) ty2 = do
778 Just moduleName <- checkCurrentModule <$> get
779 Just moduleName <- checkCurrentModule <$> get
779 kind <- liftCheck $ kindOf moduleName ty1
780 kind <- liftCheck $ kindOf moduleName ty1
780− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
781+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
781 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
782 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
782 val' <- subsumes (Just val) ty1' ty2
783 val' <- subsumes (Just val) ty1' ty2
783 case val' of
784 case val' of
784− Nothing -> throwError . strMsg $ "Unable to check type subsumption"
785+ Nothing -> throwError "Unable to check type subsumption"
785 Just val'' -> do
786 Just val'' -> do
786 val''' <- if checkType then check val'' ty1' else return val''
787 val''' <- if checkType then check val'' ty1' else return val''
787 return $ TypedValue checkType (TypedValue True val''' ty1) ty2
788 return $ TypedValue checkType (TypedValue True val''' ty1) ty2
@@ -815,7 +816,7 @@ check' (Accessor prop val) ty = do
815check' (Constructor c) ty = do
816check' (Constructor c) ty = do
816 env <- getEnv
817 env <- getEnv
817 case M.lookup c (dataConstructors env) of
818 case M.lookup c (dataConstructors env) of
818− Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
819+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
819 Just (_, ty1) -> do
820 Just (_, ty1) -> do
820 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
821 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
821 _ <- subsumes Nothing repl ty
822 _ <- subsumes Nothing repl ty
@@ -826,7 +827,7 @@ check' (Let ds val) ty = do
826check' val ty | containsTypeSynonyms ty = do
827check' val ty | containsTypeSynonyms ty = do
827 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty
828 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty
828 check val ty'
829 check val ty'
829−check' val ty = throwError $ mkUnifyErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))
830+check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
830
831
831containsTypeSynonyms :: Type -> Bool
832containsTypeSynonyms :: Type -> Bool
832containsTypeSynonyms = everything (||) (mkQ False go) where
833containsTypeSynonyms = everything (||) (mkQ False go) where
@@ -845,8 +846,8 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
845 return []
846 return []
846 go [] [] (Skolem _ _) | lax = return []
847 go [] [] (Skolem _ _) | lax = return []
847 go [] ((p, _): _) _ | lax = return []
848 go [] ((p, _): _) _ | lax = return []
848− | otherwise = throwError $ mkUnifyErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))
849+ | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
849− go ((p,_):_) [] REmpty = throwError $ mkUnifyErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps)))
850+ go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
850 go ((p,v):ps') [] u@(TUnknown _) = do
851 go ((p,v):ps') [] u@(TUnknown _) = do
851 v'@(TypedValue _ _ ty) <- infer v
852 v'@(TypedValue _ _ ty) <- infer v
852 rest <- fresh
853 rest <- fresh
@@ -865,17 +866,18 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
865 v' <- check v ty
866 v' <- check v ty
866 ps'' <- go ps' (delete (p, ty) ts) r
867 ps'' <- go ps' (delete (p, ty) ts) r
867 return $ (p, v') : ps''
868 return $ (p, v') : ps''
868− go _ _ _ = throwError $ mkUnifyErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ValueError (ObjectLiteral ps)))
869+ go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (TypeApp tyObject row)
869
870
870-- |
871-- |
871-- Check the type of a function application, rethrowing errors to provide a better error message
872-- Check the type of a function application, rethrowing errors to provide a better error message
872--
873--
873checkFunctionApplication :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)
874checkFunctionApplication :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)
874−checkFunctionApplication fn fnTy arg ret = rethrow (mkUnifyErrorStack errorMessage (Just (ValueError fn)) <>) $ checkFunctionApplication' fn fnTy arg ret
875+checkFunctionApplication fn fnTy arg ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy arg ret
875 where
876 where
876− errorMessage = "Error applying function of type "
877+ errorMessage msg = "Error applying function of type "
877 ++ prettyPrintType fnTy
878 ++ prettyPrintType fnTy
878 ++ " to argument " ++ prettyPrintValue arg
879 ++ " to argument " ++ prettyPrintValue arg
880+ ++ ":\n" ++ msg
879
881
880-- |
882-- |
881-- Check the type of a function application
883-- Check the type of a function application
@@ -905,7 +907,7 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
905checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
907checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
906 dicts <- getTypeClassDictionaries
908 dicts <- getTypeClassDictionaries
907 checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg ret
909 checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg ret
908−checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "
910+checkFunctionApplication' _ fnTy arg _ = throwError $ "Cannot apply a function of type "
909 ++ prettyPrintType fnTy
911 ++ prettyPrintType fnTy
910 ++ " to argument " ++ prettyPrintValue arg
912 ++ " to argument " ++ prettyPrintValue arg
911
913
@@ -913,12 +915,13 @@ checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a f
913-- Check whether one type subsumes another, rethrowing errors to provide a better error message
915-- Check whether one type subsumes another, rethrowing errors to provide a better error message
914--
916--
915subsumes :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)
917subsumes :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)
916−subsumes val ty1 ty2 = rethrow (mkUnifyErrorStack errorMessage (ValueError <$> val) <>) $ subsumes' val ty1 ty2
918+subsumes val ty1 ty2 = rethrow errorMessage $ subsumes' val ty1 ty2
917 where
919 where
918− errorMessage = "Error checking that type "
920+ errorMessage msg = "Error checking that type "
919 ++ prettyPrintType ty1
921 ++ prettyPrintType ty1
920 ++ " subsumes type "
922 ++ " subsumes type "
921 ++ prettyPrintType ty2
923 ++ prettyPrintType ty2
924+ ++ ":\n" ++ msg
922
925
923-- |
926-- |
924-- Check whether one type subsumes another
927-- Check whether one type subsumes another
@@ -933,7 +936,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) =
933 sko <- newSkolemConstant
936 sko <- newSkolemConstant
934 let sk = skolemize ident sko sco' ty2
937 let sk = skolemize ident sko sco' ty2
935 subsumes val ty1 sk
938 subsumes val ty1 sk
936− Nothing -> throwError . strMsg $ "Skolem variable scope is unspecified"
939+ Nothing -> throwError "Skolem variable scope is unspecified"
937subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do
940subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do
938 _ <- subsumes Nothing arg2 arg1
941 _ <- subsumes Nothing arg2 arg1
939 _ <- subsumes Nothing ret1 ret2
942 _ <- subsumes Nothing ret1 ret2
@@ -973,4 +976,3 @@ subsumes' val ty1 ty2 = do
973 ty1 =?= ty2
976 ty1 =?= ty2
974 return val
977 return val
975
978
976−