git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Revert "Initial work on #242"

This reverts commit 1a087e746637af668dbcc8c55f83fefdafda4495.

commitc7d2699bc822d9ee3fcb433774f806ec2c1864ed authorPhil Freeman <paf31@cantab.net> dateFri 28 Mar 2014, 10:27 (13 years ago) parent1a087e7
11 files changed+106−191
compare with golang
unifiedsplit
examples/failing/TypeClasses.purs+7 examples/failing/TypeClasses2.purs−2 psc-make/Main.hs+1−5 psc/Main.hs+1−5 psci/Main.hs+1−1 src/Language/PureScript.hs+6−7 src/Language/PureScript/Options.hs+1−5 src/Language/PureScript/TypeChecker.hs+14−14 src/Language/PureScript/TypeChecker/Kinds.hs+13−19 src/Language/PureScript/TypeChecker/Monad.hs+17−90 src/Language/PureScript/TypeChecker/Types.hs+45−43
examples/failing/TypeClasses.pursnew file+7
@@ -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 @@
11module Main where
22
3−import Prelude ()
4−
53class Show a where
64 show :: a -> String
75
psc-make/Main.hs+1−5
@@ -115,12 +115,8 @@ browserNamespace :: Term String
115115browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
116116 { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
117117
118−verboseErrors :: Term Bool
119−verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
120− { optDoc = "Display verbose error messages" }
121−
122118options :: 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 []
124120
125121inputFilesAndPrelude :: FilePath -> Term [FilePath]
126122inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles
psc/Main.hs+1−5
@@ -122,12 +122,8 @@ codeGenModules :: Term [String]
122122codeGenModules = value $ optAll [] $ (optInfo [ "codegen" ])
123123 { optDoc = "A list of modules for which Javascript and externs should be generated. This argument can be used multiple times." }
124124
125−verboseErrors :: Term Bool
126−verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
127− { optDoc = "Display verbose error messages" }
128−
129125options :: 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
131127
132128stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
133129stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
psci/Main.hs+1−1
@@ -194,7 +194,7 @@ completion = completeWord Nothing " \t\n\r" findCompletions
194194-- | Compilation options.
195195--
196196options :: 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" [] []
198198
199199-- |
200200-- 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,
7171compile' env opts ms = do
7272 (sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)
7373 desugared <- desugar sorted
74− (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent
74+ (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
7575 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
7676 let entryPoints = moduleNameFromString `map` optionsModules opts
7777 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
@@ -100,9 +100,8 @@ typeCheckModule mainModuleName (Module mn decls exps) = do
100100 checkTypesAreExported (ValueRef name) = do
101101 ty <- lookupVariable mn (Qualified (Just mn) name)
102102 case find isTconHidden (findTcons ty) of
103− Just hiddenType -> throwError . strMsg $
104− "Error in module '" ++ show mn ++ "':\n\
105− \Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"
103+ Just hiddenType -> throwError $ "Error in module '" ++ show mn ++ "':\n\
104+ \Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"
106105 Nothing -> return ()
107106 checkTypesAreExported _ = return ()
108107
@@ -119,7 +118,7 @@ typeCheckModule mainModuleName (Module mn decls exps) = do
119118 where
120119 go (TypeRef tyName' _) = tyName' /= tyName
121120 go _ = True
122−
121+
123122
124123generateMain :: Environment -> Options -> [JS] -> Either String [JS]
125124generateMain env opts js =
@@ -192,7 +191,7 @@ make opts ms = do
192191 go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()
193192 go _ [] = return ()
194193 go env ((False, m) : ms') = do
195− (_, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
194+ (_, env') <- liftError . runCheck' env $ typeCheckModule Nothing m
196195
197196 go env' ms'
198197 go env ((True, m@(Module moduleName' _ exps)) : ms') = do
@@ -200,7 +199,7 @@ make opts ms = do
200199 jsFile = "js" ++ pathSeparator : filePath ++ ".js"
201200 externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
202201
203− (Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
202+ (Module _ elaborated _, env') <- liftError . runCheck' env $ typeCheckModule Nothing m
204203
205204 regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
206205
src/Language/PureScript/Options.hs+1−5
@@ -57,14 +57,10 @@ data Options = Options {
5757 -- The modules to code gen
5858 --
5959 , optionsCodeGenModules :: [String]
60− -- |
61− -- Verbose error message
62− --
63− , optionsVerboseErrors :: Bool
6460 } deriving Show
6561
6662-- |
6763-- Default compiler options
6864--
6965defaultOptions :: 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
2626import Language.PureScript.TypeChecker.Synonyms as T
2727
2828import Data.Maybe
29−import Data.Monoid ((<>))
3029import qualified Data.Map as M
3130import Control.Monad.State
3231import Control.Monad.Error
@@ -37,13 +36,14 @@ import Language.PureScript.Kinds
3736import Language.PureScript.Declarations
3837import Language.PureScript.TypeClassDictionaries
3938import Language.PureScript.Environment
39+import Language.PureScript.Pretty.Types
4040
4141addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
4242addDataType moduleName name args dctors ctorKind = do
4343 env <- getEnv
4444 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
4545 forM_ dctors $ \(dctor, tys) ->
46− rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $
46+ rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $
4747 addDataConstructor moduleName name args dctor tys
4848
4949addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
@@ -64,7 +64,7 @@ valueIsNotDefined :: ModuleName -> Ident -> Check ()
6464valueIsNotDefined moduleName name = do
6565 env <- getEnv
6666 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"
6868 Nothing -> return ()
6969
7070addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
@@ -85,10 +85,10 @@ checkTypeClassInstance :: ModuleName -> Type -> Check ()
8585checkTypeClassInstance _ (TypeVar _) = return ()
8686checkTypeClassInstance _ (TypeConstructor ctor) = do
8787 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"
8989 return ()
9090checkTypeClassInstance 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
9292
9393-- |
9494-- Type check all declarations in a module
@@ -106,13 +106,13 @@ checkTypeClassInstance _ ty = throwError $ mkUnifyErrorStack "Type class instanc
106106typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]
107107typeCheckAll _ _ [] = return []
108108typeCheckAll 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
110110 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
111111 addDataType moduleName name args dctors ctorKind
112112 ds <- typeCheckAll mainModuleName moduleName rest
113113 return $ d : ds
114114typeCheckAll 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
116116 let syns = mapMaybe toTypeSynonym tys
117117 let dataDecls = mapMaybe toDataDecl tys
118118 (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
128128 toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)
129129 toDataDecl _ = Nothing
130130typeCheckAll 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
132132 kind <- kindsOf False moduleName name args [ty]
133133 addTypeSynonym moduleName name args ty kind
134134 ds <- typeCheckAll mainModuleName moduleName rest
135135 return $ d : ds
136136typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
137137typeCheckAll 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
139139 valueIsNotDefined moduleName name
140140 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
141141 addValue moduleName name ty nameKind
@@ -144,7 +144,7 @@ typeCheckAll mainModuleName moduleName (ValueDeclaration name nameKind [] Nothin
144144 return $ d : ds
145145typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared"
146146typeCheckAll 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
148148 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
149149 valueIsNotDefined moduleName name
150150 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
@@ -160,19 +160,19 @@ typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : re
160160 ds <- typeCheckAll mainModuleName moduleName rest
161161 return $ d : ds
162162typeCheckAll 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
164164 env <- getEnv
165165 kind <- kindOf moduleName ty
166− guardWith (strMsg "Expected kind *") $ kind == Star
166+ guardWith "Expected kind *" $ kind == Star
167167 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"
169169 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy) (names env) })
170170 ds <- typeCheckAll mainModuleName moduleName rest
171171 return $ d : ds
172172typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do
173173 ds <- typeCheckAll mainModuleName moduleName rest
174174 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
176176 return $ d : ds
177177typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do
178178 env <- getEnv
src/Language/PureScript/TypeChecker/Kinds.hs+13−19
@@ -14,7 +14,7 @@
1414-----------------------------------------------------------------------------
1515
1616{-# OPTIONS_GHC -fno-warn-orphans #-}
17−{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
17+{-# LANGUAGE MultiParamTypeClasses #-}
1818
1919module Language.PureScript.TypeChecker.Kinds (
2020 kindOf,
@@ -36,7 +36,6 @@ import Control.Monad.Unify
3636import Control.Applicative
3737
3838import qualified Data.Map as M
39−import Data.Monoid ((<>))
4039
4140instance Partial Kind where
4241 unknown = KUnknown
@@ -53,14 +52,14 @@ instance Unifiable Check Kind where
5352 FunKind k1 k2 =?= FunKind k3 k4 = do
5453 k1 =?= k3
5554 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 ++ "."
5756
5857-- |
5958-- Infer the kind of a single type
6059--
6160kindOf :: ModuleName -> Type -> Check Kind
6261kindOf _ ty =
63− rethrow (mkUnifyErrorStack "Error checking kind" (Just (TypeError ty)) <>) $
62+ rethrow (("Error checking kind of " ++ prettyPrintType ty ++ ":\n") ++) $
6463 fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty
6564 where
6665 tidyUp (k, sub) = sub $? k
@@ -106,7 +105,7 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
106105-- |
107106-- Solve the set of kind constraints associated with the data constructors for a type constructor
108107--
109−solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind (Check) Kind
108+solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind
110109solveTypes isData ts kargs tyCon = do
111110 ks <- mapM infer ts
112111 when isData $ do
@@ -129,44 +128,39 @@ starIfUnknown k = k
129128-- Infer a kind for a type
130129--
131130infer :: 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
136132 Just moduleName <- checkCurrentModule <$> get
137133 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
138−infer' c@(TypeConstructor v) = do
134+infer (TypeConstructor v) = do
139135 env <- liftCheck getEnv
140136 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 ++ "'"
142138 Just (kind, _) -> return kind
143−infer' (TypeApp t1 t2) = do
139+infer (TypeApp t1 t2) = do
144140 k0 <- fresh
145141 k1 <- infer t1
146142 k2 <- infer t2
147143 k1 =?= FunKind k2 k0
148144 return k0
149−infer' (ForAll ident ty _) = do
145+infer (ForAll ident ty _) = do
150146 k1 <- fresh
151147 Just moduleName <- checkCurrentModule <$> get
152148 k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty
153149 k2 =?= Star
154150 return Star
155−infer' REmpty = do
151+infer REmpty = do
156152 k <- fresh
157153 return $ Row k
158−infer' (RCons _ ty row) = do
154+infer (RCons _ ty row) = do
159155 k1 <- infer ty
160156 k2 <- infer row
161157 k2 =?= Row k1
162158 return $ Row k1
163−infer' (ConstrainedType deps ty) = do
159+infer (ConstrainedType deps ty) = do
164160 forM_ deps $ \(className, tys) -> do
165161 _ <- infer $ foldl TypeApp (TypeConstructor className) tys
166162 return ()
167163 k <- infer ty
168164 k =?= Star
169165 return Star
170−infer' _ = error "Invalid argument to infer"
171−
172−
166+infer _ = error "Invalid argument to infer"
src/Language/PureScript/TypeChecker/Monad.hs+17−90
@@ -21,14 +21,10 @@ module Language.PureScript.TypeChecker.Monad where
2121import Language.PureScript.Types
2222import Language.PureScript.Kinds
2323import Language.PureScript.Names
24−import Language.PureScript.Declarations
2524import Language.PureScript.Environment
2625import Language.PureScript.TypeClassDictionaries
27−import Language.PureScript.Pretty
28−import Language.PureScript.Options
2926
3027import Data.Maybe
31−import Data.Monoid
3228
3329import Control.Applicative
3430import Control.Monad.State
@@ -36,77 +32,6 @@ import Control.Monad.Error
3632import Control.Monad.Unify
3733
3834import 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]
11035
11136-- |
11237-- Temporarily bind a collection of names to values
@@ -164,21 +89,21 @@ bindLocalTypeVariables moduleName bindings =
16489-- |
16590-- Lookup the type of a value by name in the @Environment@
16691--
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
16893lookupVariable currentModule (Qualified moduleName var) = do
16994 env <- getEnv
17095 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"
17297 Just (ty, _) -> return ty
17398
17499-- |
175100-- Lookup the kind of a type by name in the @Environment@
176101--
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
178103lookupTypeVariable currentModule (Qualified moduleName name) = do
179104 env <- getEnv
180105 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"
182107 Just (k, _) -> return k
183108
184109-- |
@@ -206,8 +131,8 @@ data CheckState = CheckState {
206131-- |
207132-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
208133--
209−newtype Check a = Check { unCheck :: StateT CheckState (Either UnifyErrorStack) a }
210− deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError UnifyErrorStack)
134+newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
135+ deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
211136
212137-- |
213138-- Get the current @Environment@
@@ -230,14 +155,14 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
230155-- |
231156-- Run a computation in the Check monad, starting with an empty @Environment@
232157--
233−runCheck :: Options -> Check a -> Either String (a, Environment)
234−runCheck opts = runCheck' opts initEnvironment
158+runCheck :: Check a -> Either String (a, Environment)
159+runCheck = runCheck' initEnvironment
235160
236161-- |
237162-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
238163--
239−runCheck' :: Options -> Environment -> Check a -> Either String (a, Environment)
240−runCheck' opts env c = either (Left . prettyPrintUnifyErrorStack opts) Right $ do
164+runCheck' :: Environment -> Check a -> Either String (a, Environment)
165+runCheck' env c = do
241166 (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
242167 return (a, checkEnv s)
243168
@@ -267,7 +192,7 @@ freshDictionaryName = do
267192-- Lift a computation in the @Check@ monad into the substitution monad.
268193--
269194liftCheck :: Check a -> UnifyT t Check a
270−liftCheck = UnifyT . lift
195+liftCheck = UnifyT . lift . lift
271196
272197-- |
273198-- Run a computation in the substitution monad, generating a return value and the final substitution.
@@ -275,7 +200,9 @@ liftCheck = UnifyT . lift
275200liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t)
276201liftUnify unify = do
277202 st <- get
278− (a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify
279− modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
280− return (a, unifyCurrentSubstitution ust)
281−
203+ e <- 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 }
208+ return (a, unifyCurrentSubstitution ust)
src/Language/PureScript/TypeChecker/Types.hs+45−43
@@ -14,7 +14,6 @@
1414-----------------------------------------------------------------------------
1515
1616{-# OPTIONS_GHC -fno-warn-orphans #-}
17−{-# LANGUAGE FlexibleInstances #-}
1817{-# LANGUAGE FlexibleContexts #-}
1918{-# LANGUAGE MultiParamTypeClasses #-}
2019
@@ -71,7 +70,6 @@ import Control.Arrow (Arrow(..))
7170import qualified Data.Map as M
7271import Data.Function (on)
7372import Data.Ord (comparing)
74−import Data.Monoid ((<>))
7573
7674instance Partial Type where
7775 unknown = TUnknown
@@ -85,7 +83,7 @@ instance Unifiable Check Type where
8583-- Unify two types, updating the current substitution
8684--
8785unifyTypes :: 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) $
8987 unifyTypes' t1 t2
9088 where
9189 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
@@ -102,16 +100,16 @@ unifyTypes t1 t2 = rethrow (mkUnifyErrorStack ("Error unifying type " ++ prettyP
102100 let sk1 = skolemize ident1 sko sc1' ty1
103101 let sk2 = skolemize ident2 sko sc2' ty2
104102 sk1 `unifyTypes` sk2
105− _ -> error "Skolemized type variable was not given a scope"
103+ _ -> throwError (prettyPrintType ty1)
106104 unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do
107105 sko <- newSkolemConstant
108106 let sk = skolemize ident sko sc ty1
109107 sk `unifyTypes` ty2
110− unifyTypes' ForAll{} _ = throwError . strMsg $ "Skolem variable scope is unspecified"
108+ unifyTypes' ForAll{} _ = throwError "Skolem variable scope is unspecified"
111109 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty
112110 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
113111 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)
115113 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
116114 t3 `unifyTypes` t5
117115 t4 `unifyTypes` t6
@@ -120,9 +118,10 @@ unifyTypes t1 t2 = rethrow (mkUnifyErrorStack ("Error unifying type " ++ prettyP
120118 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2
121119 unifyTypes' r1@REmpty r2 = unifyRows r1 r2
122120 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."
124123 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 ++ "."
126125
127126-- |
128127-- Unify two rows, updating the current substitution
@@ -155,7 +154,7 @@ unifyRows r1 r2 =
155154 unifyRows' [] REmpty [] REmpty = return ()
156155 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
157156 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)) ++ ")."
159158
160159-- |
161160-- Infer the types of multiple mutually-recursive values, and return elaborated values including
@@ -218,7 +217,7 @@ typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do
218217 (ident, (val', Just (ty, checkType))) -> do
219218 -- Kind check
220219 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
222221 -- Check the type with the new names in scope
223222 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
224223 val'' <- bindNames dict' $ if checkType
@@ -271,7 +270,7 @@ replaceTypeClassDictionaries mn = everywhereM' (mkM go)
271270entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value
272271entails env moduleName context goal@(className, tys) = do
273272 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)
275274 (dict : _) -> return dict
276275 where
277276 go (className', tys') =
@@ -363,7 +362,7 @@ skolemEscapeCheck root@TypedValue{} =
363362 -- an escaped skolem variable.
364363 case everythingWithContext [] (++) (mkQ ((,) []) go) root of
365364 [] -> 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
367366 where
368367 go :: Value -> [(SkolemScope, Value)] -> ([(Maybe Value, Value)], [(SkolemScope, Value)])
369368 go val@(TypedValue _ _ (ForAll _ _ (Just sco))) scos = ([], (sco, val) : scos)
@@ -382,7 +381,7 @@ skolemEscapeCheck root@TypedValue{} =
382381 where
383382 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val
384383 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
386385
387386-- |
388387-- Ensure a row contains no duplicate labels
@@ -445,10 +444,10 @@ replaceAllTypeSynonyms' env d =
445444 in
446445 saturateAllTypeSynonyms syns d
447446
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
449448replaceAllTypeSynonyms d = do
450449 env <- getEnv
451− either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d
450+ either throwError return $ replaceAllTypeSynonyms' env d
452451
453452-- |
454453-- \"Desaturate\" @SaturatedTypeSynonym@s
@@ -470,12 +469,12 @@ expandTypeSynonym' env name args =
470469 replaceAllTypeSynonyms' env repl
471470 Nothing -> error "Type synonym was not defined"
472471
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
474473expandTypeSynonym name args = do
475474 env <- getEnv
476− either (throwError . strMsg) return $ expandTypeSynonym' env name args
475+ either throwError return $ expandTypeSynonym' env name args
477476
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
479478expandAllTypeSynonyms = everywhereM' (mkM go)
480479 where
481480 go (SaturatedTypeSynonym name args) = expandTypeSynonym name args
@@ -484,14 +483,14 @@ expandAllTypeSynonyms = everywhereM' (mkM go)
484483-- |
485484-- Ensure a set of property names and value does not contain duplicate labels
486485--
487−ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Value)] -> m ()
488−ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps
486+ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
487+ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
489488
490489-- |
491490-- Infer a type for a value, rethrowing any error to provide a more useful error message
492491--
493492infer :: 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
495494
496495-- |
497496-- Infer a type for a value
@@ -552,7 +551,7 @@ infer' (Var var) = do
552551infer' v@(Constructor c) = do
553552 env <- getEnv
554553 case M.lookup c (dataConstructors env) of
555− Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
554+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
556555 Just (_, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
557556 return $ TypedValue True v ty'
558557infer' (Case vals binders) = do
@@ -572,7 +571,7 @@ infer' (Let ds val) = do
572571infer' (TypedValue checkType val ty) = do
573572 Just moduleName <- checkCurrentModule <$> get
574573 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
576575 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
577576 val' <- if checkType then check val ty' else return val
578577 return $ TypedValue True val' ty'
@@ -632,8 +631,8 @@ inferBinder val (ConstructorBinder ctor binders) = do
632631 return M.empty
633632 go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =
634633 M.union <$> inferBinder obj binder <*> go binders' ret
635− go _ _ = throwError . strMsg $ "Wrong number of arguments to constructor " ++ show ctor
636− _ -> throwError . strMsg $ "Constructor " ++ show ctor ++ " is not defined"
634+ go _ _ = throwError $ "Wrong number of arguments to constructor " ++ show ctor
635+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
637636inferBinder val (ObjectBinder props) = do
638637 row <- fresh
639638 rest <- fresh
@@ -712,13 +711,15 @@ introduceSkolemScope = everywhereM (mkM go)
712711-- Check the type of a value, rethrowing errors to provide a better error message
713712--
714713check :: 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
716715 where
717− errorMessage =
716+ errorMessage msg =
718717 "Error checking type of term " ++
719718 prettyPrintValue val ++
720719 " against type " ++
721− prettyPrintType ty
720+ prettyPrintType ty ++
721+ ":\n" ++
722+ msg
722723
723724-- |
724725-- Check the type of a value
@@ -772,16 +773,16 @@ check' v@(Var var) ty = do
772773 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
773774 v' <- subsumes (Just v) repl ty'
774775 case v' of
775− Nothing -> throwError . strMsg $ "Unable to check type subsumption"
776+ Nothing -> throwError "Unable to check type subsumption"
776777 Just v'' -> return $ TypedValue True v'' ty'
777778check' (TypedValue checkType val ty1) ty2 = do
778779 Just moduleName <- checkCurrentModule <$> get
779780 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
781782 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
782783 val' <- subsumes (Just val) ty1' ty2
783784 case val' of
784− Nothing -> throwError . strMsg $ "Unable to check type subsumption"
785+ Nothing -> throwError "Unable to check type subsumption"
785786 Just val'' -> do
786787 val''' <- if checkType then check val'' ty1' else return val''
787788 return $ TypedValue checkType (TypedValue True val''' ty1) ty2
@@ -815,7 +816,7 @@ check' (Accessor prop val) ty = do
815816check' (Constructor c) ty = do
816817 env <- getEnv
817818 case M.lookup c (dataConstructors env) of
818− Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
819+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
819820 Just (_, ty1) -> do
820821 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
821822 _ <- subsumes Nothing repl ty
@@ -826,7 +827,7 @@ check' (Let ds val) ty = do
826827check' val ty | containsTypeSynonyms ty = do
827828 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty
828829 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
830831
831832containsTypeSynonyms :: Type -> Bool
832833containsTypeSynonyms = everything (||) (mkQ False go) where
@@ -845,8 +846,8 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
845846 return []
846847 go [] [] (Skolem _ _) | lax = return []
847848 go [] ((p, _): _) _ | lax = return []
848− | otherwise = throwError $ mkUnifyErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))
849− go ((p,_):_) [] REmpty = throwError $ mkUnifyErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps)))
849+ | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
850+ go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
850851 go ((p,v):ps') [] u@(TUnknown _) = do
851852 v'@(TypedValue _ _ ty) <- infer v
852853 rest <- fresh
@@ -865,17 +866,18 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
865866 v' <- check v ty
866867 ps'' <- go ps' (delete (p, ty) ts) r
867868 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)
869870
870871-- |
871872-- Check the type of a function application, rethrowing errors to provide a better error message
872873--
873874checkFunctionApplication :: 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
875876 where
876− errorMessage = "Error applying function of type "
877+ errorMessage msg = "Error applying function of type "
877878 ++ prettyPrintType fnTy
878879 ++ " to argument " ++ prettyPrintValue arg
880+ ++ ":\n" ++ msg
879881
880882-- |
881883-- Check the type of a function application
@@ -905,7 +907,7 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
905907checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
906908 dicts <- getTypeClassDictionaries
907909 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 "
909911 ++ prettyPrintType fnTy
910912 ++ " to argument " ++ prettyPrintValue arg
911913
@@ -913,12 +915,13 @@ checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a f
913915-- Check whether one type subsumes another, rethrowing errors to provide a better error message
914916--
915917subsumes :: 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
917919 where
918− errorMessage = "Error checking that type "
920+ errorMessage msg = "Error checking that type "
919921 ++ prettyPrintType ty1
920922 ++ " subsumes type "
921923 ++ prettyPrintType ty2
924+ ++ ":\n" ++ msg
922925
923926-- |
924927-- Check whether one type subsumes another
@@ -933,7 +936,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) =
933936 sko <- newSkolemConstant
934937 let sk = skolemize ident sko sco' ty2
935938 subsumes val ty1 sk
936− Nothing -> throwError . strMsg $ "Skolem variable scope is unspecified"
939+ Nothing -> throwError "Skolem variable scope is unspecified"
937940subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do
938941 _ <- subsumes Nothing arg2 arg1
939942 _ <- subsumes Nothing ret1 ret2
@@ -973,4 +976,3 @@ subsumes' val ty1 ty2 = do
973976 ty1 =?= ty2
974977 return val
975978
976−