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