git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
A start on #745 - a type for error messages
commit306ba7b35b72d9d96d478e48d8a730f6c0ab7f40 authorPhil Freeman <paf31@cantab.net> dateSat 21 Feb 2015, 19:27 (12 years ago) parentf4375ae
21 files changed+261−241
compare with golang
unifiedsplit
psci/Main.hs+1−1 src/Control/Monad/Unify.hs+10−6 src/Language/PureScript.hs+4−4 src/Language/PureScript/AST/SourcePos.hs+2−2 src/Language/PureScript/Errors.hs+122−96 src/Language/PureScript/Sugar.hs+1−1 src/Language/PureScript/Sugar/BindingGroups.hs+11−11 src/Language/PureScript/Sugar/CaseDeclarations.hs+9−9 src/Language/PureScript/Sugar/DoNotation.hs+4−4 src/Language/PureScript/Sugar/Names.hs+53−63 src/Language/PureScript/Sugar/ObjectWildcards.hs+1−1 src/Language/PureScript/Sugar/Operators.hs+8−8 src/Language/PureScript/Sugar/TypeClasses.hs+8−8 src/Language/PureScript/Sugar/TypeDeclarations.hs+6−6 src/Language/PureScript/TypeChecker.hs+1−1 src/Language/PureScript/TypeChecker/Kinds.hs+1−1 src/Language/PureScript/TypeChecker/Monad.hs+9−9 src/Language/PureScript/TypeChecker/Rows.hs+1−1 src/Language/PureScript/TypeChecker/Skolems.hs+2−2 src/Language/PureScript/TypeChecker/Synonyms.hs+3−3 src/Language/PureScript/TypeChecker/Types.hs+4−4
psci/Main.hs+1−1
@@ -531,7 +531,7 @@ handleKindOf typ = do
531531 let chk = P.CheckState env' 0 0 (Just mName)
532532 k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk
533533 case k of
534− Left errStack -> PSCI . outputStrLn . P.prettyPrintErrorStack False $ errStack
534+ Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack
535535 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
536536 Nothing -> PSCI $ outputStrLn "Could not find kind"
537537
src/Control/Monad/Unify.hs+10−6
@@ -20,11 +20,9 @@
2020{-# LANGUAGE MultiParamTypeClasses #-}
2121{-# LANGUAGE FunctionalDependencies #-}
2222{-# LANGUAGE UndecidableInstances #-}
23−{-# LANGUAGE OverloadedStrings #-}
2423
2524module Control.Monad.Unify where
2625
27−import Data.String (IsString)
2826import Data.Monoid
2927
3028import Control.Applicative
@@ -84,10 +82,16 @@ data UnifyState t = UnifyState {
8482defaultUnifyState :: (Partial t) => UnifyState t
8583defaultUnifyState = UnifyState 0 mempty
8684
85+-- \
86+-- A class for errors which support unification errors
87+--
88+class UnificationError t e where
89+ occursCheckFailed :: t -> e
90+
8791-- |
8892-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
8993--
90−newtype UnifyT t m a = UnifyT { unUnify :: (StateT (UnifyState t) m) a }
94+newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a }
9195 deriving (Functor, Monad, Applicative, Alternative, MonadPlus)
9296
9397instance (MonadState s m) => MonadState s (UnifyT t m) where
@@ -113,7 +117,7 @@ substituteOne u t = Substitution $ M.singleton u t
113117-- |
114118-- Replace a unification variable with the specified value in the current substitution
115119--
116−(=:=) :: (IsString e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()
120+(=:=) :: (UnificationError t e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()
117121(=:=) u t' = do
118122 st <- UnifyT get
119123 let sub = unifyCurrentSubstitution st
@@ -128,10 +132,10 @@ substituteOne u t = Substitution $ M.singleton u t
128132-- |
129133-- Perform the occurs check, to make sure a unification variable does not occur inside a value
130134--
131−occursCheck :: (IsString e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()
135+occursCheck :: (UnificationError t e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()
132136occursCheck u t =
133137 case isUnknown t of
134− Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ "Occurs check fails"
138+ Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ occursCheckFailed t
135139 _ -> return ()
136140
137141-- |
src/Language/PureScript.hs+4−4
@@ -96,9 +96,9 @@ compile' env ms prefix = do
9696 additional <- asks optionsAdditional
9797 mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)
9898 (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms
99− (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
99+ (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ desugar sorted
100100 (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
101− regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
101+ regrouped <- interpretMultipleErrors True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
102102 let corefn = map (CoreFn.moduleToCoreFn env') regrouped
103103 let entryPoints = moduleNameFromString `map` entryPointModules additional
104104 let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
@@ -192,7 +192,7 @@ make outputDir ms prefix = do
192192
193193 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
194194
195− (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
195+ (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
196196
197197 evalSupplyT nextVar $ go initEnvironment desugared
198198
@@ -212,7 +212,7 @@ make outputDir ms prefix = do
212212
213213 (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
214214
215− regrouped <- stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
215+ regrouped <- interpretMultipleErrors True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
216216
217217 let mod' = Module coms moduleName' regrouped exps
218218 let corefn = CoreFn.moduleToCoreFn env' mod'
src/Language/PureScript/AST/SourcePos.hs+2−2
@@ -30,7 +30,7 @@ data SourcePos = SourcePos
3030 -- Column number
3131 --
3232 , sourcePosColumn :: Int
33− } deriving (D.Data, D.Typeable)
33+ } deriving (Eq, D.Data, D.Typeable)
3434
3535instance Show SourcePos where
3636 show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)
@@ -47,7 +47,7 @@ data SourceSpan = SourceSpan
4747 -- End of the span
4848 --
4949 , spanEnd :: SourcePos
50− } deriving (D.Data, D.Typeable)
50+ } deriving (Eq, D.Data, D.Typeable)
5151
5252instance Show SourceSpan where
5353 show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp)
src/Language/PureScript/Errors.hs+122−96
@@ -12,108 +12,145 @@
1212--
1313-----------------------------------------------------------------------------
1414
15−{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}
15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE MultiParamTypeClasses #-}
1618
1719module Language.PureScript.Errors where
1820
1921import Data.Either (lefts, rights)
20−import Data.String (IsString(..))
21−import Data.List (intersperse, intercalate)
22+import Data.List (intersperse)
2223import Data.Monoid
24+import Data.Foldable (fold, foldMap)
2325
2426import Control.Monad.Except
27+import Control.Monad.Unify
2528import Control.Applicative ((<$>))
2629
2730import Language.PureScript.AST
2831import Language.PureScript.Pretty
2932import Language.PureScript.Types
33+import Language.PureScript.Names
34+import Language.PureScript.Kinds
3035
3136-- |
32−-- Type for sources of type checking errors
33−--
34−data ErrorSource
35− -- |
36− -- An error which originated at a Expr
37− --
38− = ExprError Expr
39− -- |
40− -- An error which originated at a Type
41− --
42− | TypeError Type deriving (Show)
37+-- A type of error messages
38+--
39+data ErrorMessage
40+ = InfiniteType Type
41+ | InfiniteKind Kind
42+ | CannotReorderOperators
43+ | MultipleFixities Ident
44+ | OrphanTypeDeclaration Ident
45+ | RedefinedModule ModuleName
46+ | OverlappingNamesInLet
47+ | UnknownModule ModuleName
48+ | UnknownType (Qualified ProperName)
49+ | UnknownTypeClass (Qualified ProperName)
50+ | UnknownValue (Qualified Ident)
51+ | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))
52+ | ConflictingImport String ModuleName
53+ | ConflictingImports String ModuleName ModuleName
54+ | ConflictingTypeDecls ProperName
55+ | ConflictingCtorDecls ProperName
56+ | TypeConflictsWithClass ProperName
57+ | CtorConflictsWithClass ProperName
58+ | ClassConflictsWithType ProperName
59+ | ClassConflictsWithCtor ProperName
60+ | DuplicateClassExport ProperName
61+ | DuplicateValueExport Ident
62+ | ErrorInModule ModuleName ErrorMessage
63+ | PositionedError SourceSpan ErrorMessage
64+ deriving (Show, Eq)
65+
66+instance UnificationError Type ErrorMessage where
67+ occursCheckFailed = InfiniteType
68+
69+instance UnificationError Kind ErrorMessage where
70+ occursCheckFailed = InfiniteKind
4371
4472-- |
45−-- Compilation errors
46−--
47−data CompileError
48− = CompileError
49− { -- |
50− -- Error message
51− --
52− compileErrorMessage :: String
53− -- |
54− -- The value where the error occurred
55− --
56− , compileErrorValue :: Maybe ErrorSource
57− -- |
58− -- Optional source position information
59− --
60− , compileErrorPosition :: Maybe SourceSpan
61− }
62− deriving (Show)
73+-- Pretty print an ErrorMessage
74+--
75+prettyPrintErrorMessage :: ErrorMessage -> String
76+prettyPrintErrorMessage CannotReorderOperators = "Unable to reorder operators"
77+prettyPrintErrorMessage OverlappingNamesInLet = "Overlapping names in let binding."
78+prettyPrintErrorMessage (InfiniteType ty) = "Infinite type detected: " ++ prettyPrintType ty
79+prettyPrintErrorMessage (InfiniteKind ki) = "Infinite kind detected: " ++ prettyPrintKind ki
80+prettyPrintErrorMessage (MultipleFixities name) = "Multiple fixity declarations for " ++ show name
81+prettyPrintErrorMessage (OrphanTypeDeclaration pn) = "Orphan type declaration for: " ++ show pn
82+prettyPrintErrorMessage (RedefinedModule name) = "Module " ++ show name ++ " has been defined multiple times"
83+prettyPrintErrorMessage (UnknownModule mn) = "Unknown module: " ++ show mn
84+prettyPrintErrorMessage (UnknownType name) = "Unknown type: " ++ show name
85+prettyPrintErrorMessage (UnknownTypeClass name) = "Unknown type class: " ++ show name
86+prettyPrintErrorMessage (UnknownValue name) = "Unknown value: " ++ show name
87+prettyPrintErrorMessage (UnknownDataConstructor dc tc) = "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc
88+prettyPrintErrorMessage (ConflictingImport nm mn) = "Declaration " ++ nm ++ " conflicts with import " ++ show mn
89+prettyPrintErrorMessage (ConflictingImports nm m1 m2) = "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2
90+prettyPrintErrorMessage (ConflictingTypeDecls nm) = "Conflicting type declarations for " ++ show nm
91+prettyPrintErrorMessage (ConflictingCtorDecls nm) = "Conflicting data constructor declarations for " ++ show nm
92+prettyPrintErrorMessage (TypeConflictsWithClass nm) = "Type " ++ show nm ++ " conflicts with type class declaration of the same name"
93+prettyPrintErrorMessage (CtorConflictsWithClass nm) = "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name"
94+prettyPrintErrorMessage (ClassConflictsWithType nm) = "Type class " ++ show nm ++ " conflicts with type declaration of the same name"
95+prettyPrintErrorMessage (ClassConflictsWithCtor nm) = "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"
96+prettyPrintErrorMessage (DuplicateClassExport nm) = "Duplicate export declaration for type class " ++ show nm
97+prettyPrintErrorMessage (DuplicateValueExport nm) = "Duplicate export declaration for value " ++ show nm
98+prettyPrintErrorMessage (ErrorInModule mn err) = "Error in module " ++ show mn ++ ": " ++ prettyPrintErrorMessage err
99+prettyPrintErrorMessage (PositionedError pos err) = "Error at " ++ show pos ++ ": \n" ++ prettyPrintErrorMessage err
63100
64101-- |
65102-- A stack trace for an error
66103--
67−data ErrorStack
68− = ErrorStack { runErrorStack :: [CompileError] }
69− | MultipleErrors [ErrorStack] deriving (Show)
104+newtype MultipleErrors = MultipleErrors
105+ { runMultipleErrors :: [ErrorMessage] } deriving (Show, Eq, Monoid)
70106
71−-- TODO: Remove strMsg, the IsString instance, and unnecessary
72−-- OverloadedStrings pragmas. See #745
73−-- | Create an ErrorStack from a string
74−strMsg :: String -> ErrorStack
75−strMsg s = ErrorStack [CompileError s Nothing Nothing]
107+-- |
108+-- Simplify an error message
109+--
110+simplifyErrorMessage :: ErrorMessage -> ErrorMessage
111+simplifyErrorMessage = unwrap Nothing
112+ where
113+ unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
114+ unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
115+ unwrap _ (PositionedError pos err) = unwrap (Just pos) err
116+ unwrap pos other = wrap pos other
117+
118+ wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
119+ wrap Nothing = id
120+ wrap (Just pos) = PositionedError pos
76121
77−instance IsString ErrorStack where
78− fromString = strMsg
122+-- |
123+-- Create an error set from a single error message
124+--
125+errorMessage :: ErrorMessage -> MultipleErrors
126+errorMessage err = MultipleErrors [err]
79127
80−prettyPrintErrorStack :: Bool -> ErrorStack -> String
81−prettyPrintErrorStack printFullStack (ErrorStack es) =
82− case mconcat $ map (Last . compileErrorPosition) es of
83− Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'
84− _ -> prettyPrintErrorStack'
85− where
86− prettyPrintErrorStack' :: String
87− prettyPrintErrorStack'
88− | printFullStack = intercalate "\n" (map showError (filter isErrorNonEmpty es))
89− | otherwise =
90− let
91− es' = filter isErrorNonEmpty es
92− in case length es' of
93− 1 -> showError (head es')
94− _ -> showError (head es') ++ "\n" ++ showError (last es')
95−prettyPrintErrorStack printFullStack (MultipleErrors es) =
96− unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es
97−
98−stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a
99−stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return
100−
101−isErrorNonEmpty :: CompileError -> Bool
102−isErrorNonEmpty = not . null . compileErrorMessage
103−
104−showError :: CompileError -> String
105−showError (CompileError msg Nothing _) = msg
106−showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " ++ prettyPrintValue val ++ ":\n" ++ msg
107−showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg
108−
109−mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
110−mkErrorStack msg t = ErrorStack [mkCompileError msg t]
111−
112−mkCompileError :: String -> Maybe ErrorSource -> CompileError
113−mkCompileError msg t = CompileError msg t Nothing
114−
115−positionError :: SourceSpan -> CompileError
116−positionError pos = CompileError "" Nothing (Just pos)
128+-- |
129+-- Lift a function on ErrorMessage to a function on MultipleErrors
130+--
131+onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
132+onErrorMessages f = MultipleErrors . map f . runMultipleErrors
133+
134+-- |
135+-- Pretty print a single error, simplifying if necessary
136+--
137+prettyPrintSingleError :: Bool -> ErrorMessage -> String
138+prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else simplifyErrorMessage e)
139+
140+-- |
141+-- Pretty print multiple errors
142+--
143+prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
144+prettyPrintMultipleErrors full (MultipleErrors [e]) =
145+ prettyPrintSingleError full e
146+prettyPrintMultipleErrors full (MultipleErrors es) =
147+ unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintSingleError full) es
148+
149+-- |
150+-- Interpret multiple errors in a monad supporting errors
151+--
152+interpretMultipleErrors :: (MonadError String m) => Bool -> Either MultipleErrors a -> m a
153+interpretMultipleErrors printFullStack = either (throwError . prettyPrintMultipleErrors printFullStack) return
117154
118155-- |
119156-- Rethrow an error with a more detailed error message in the case of failure
@@ -124,30 +161,19 @@ rethrow f = flip catchError $ \e -> throwError (f e)
124161-- |
125162-- Rethrow an error with source position information
126163--
127−rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a
128−rethrowWithPosition pos = rethrow (positionError pos `combineErrors`)
164+rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a
165+rethrowWithPosition pos = rethrow (onErrorMessages (PositionedError pos))
129166
130167-- |
131168-- Collect errors in in parallel
132169--
133−parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b]
170+parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b]
134171parU xs f = forM xs (withError . f) >>= collectErrors
135172 where
136− withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a)
173+ withError :: (MonadError MultipleErrors m, Functor m) => m a -> m (Either MultipleErrors a)
137174 withError u = catchError (Right <$> u) (return . Left)
138175
139− collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]
176+ collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]
140177 collectErrors es = case lefts es of
141− [err] -> throwError err
142178 [] -> return $ rights es
143− errs -> throwError $ MultipleErrors errs
144−
145−-- |
146−-- Add an extra error string onto the top of each error stack in a list of possibly many errors
147−--
148−combineErrors :: CompileError -> ErrorStack -> ErrorStack
149−combineErrors ce err = go (ErrorStack [ce]) err
150− where
151− go (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)
152− go (MultipleErrors es) x = MultipleErrors [ go e x | e <- es ]
153− go x (MultipleErrors es) = MultipleErrors [ go x e | e <- es ]
179+ errs -> throwError $ fold errs
src/Language/PureScript/Sugar.hs+1−1
@@ -58,7 +58,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S
5858--
5959-- * Group mutually recursive value and data declarations into binding groups.
6060--
61−desugar :: (Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]
61+desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
6262desugar = map removeSignedLiterals
6363 >>> mapM desugarObjectConstructors
6464 >=> mapM desugarOperatorSections
src/Language/PureScript/Sugar/BindingGroups.hs+11−11
@@ -41,7 +41,7 @@ import Language.PureScript.Errors
4141-- |
4242-- Replace all sets of mutually-recursive declarations in a module with binding groups
4343--
44−createBindingGroupsModule :: (Functor m, Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]
44+createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
4545createBindingGroupsModule = mapM $ \(Module coms name ds exps) -> Module coms name <$> createBindingGroups name ds <*> pure exps
4646
4747-- |
@@ -50,20 +50,20 @@ createBindingGroupsModule = mapM $ \(Module coms name ds exps) -> Module coms na
5050collapseBindingGroupsModule :: [Module] -> [Module]
5151collapseBindingGroupsModule = map $ \(Module coms name ds exps) -> Module coms name (collapseBindingGroups ds) exps
5252
53−createBindingGroups :: (Functor m, Applicative m, MonadError ErrorStack m) => ModuleName -> [Declaration] -> m [Declaration]
53+createBindingGroups :: (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]
5454createBindingGroups moduleName = mapM f <=< handleDecls
5555
5656 where
5757 (f, _, _) = everywhereOnValuesTopDownM return handleExprs return
5858
59− handleExprs :: (Functor m, MonadError ErrorStack m) => Expr -> m Expr
59+ handleExprs :: (Functor m, MonadError MultipleErrors m) => Expr -> m Expr
6060 handleExprs (Let ds val) = flip Let val <$> handleDecls ds
6161 handleExprs other = return other
6262
6363 -- |
6464 -- Replace all sets of mutually-recursive declarations with binding groups
6565 --
66− handleDecls :: (Functor m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
66+ handleDecls :: (Functor m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
6767 handleDecls ds = do
6868 let values = filter isValueDecl ds
6969 dataDecls = filter isDataDecl ds
@@ -154,7 +154,7 @@ getProperName _ = error "Expected DataDeclaration"
154154-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).
155155--
156156--
157−toBindingGroup :: (Functor m, MonadError ErrorStack m) => ModuleName -> SCC Declaration -> m Declaration
157+toBindingGroup :: (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration
158158toBindingGroup _ (AcyclicSCC d) = return d
159159toBindingGroup _ (CyclicSCC [d]) = return d
160160toBindingGroup moduleName (CyclicSCC ds') =
@@ -175,24 +175,24 @@ toBindingGroup moduleName (CyclicSCC ds') =
175175 valueVerts :: [(Declaration, Ident, [Ident])]
176176 valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'
177177
178− toBinding :: (MonadError ErrorStack m) => SCC Declaration -> m (Ident, NameKind, Expr)
178+ toBinding :: (MonadError MultipleErrors m) => SCC Declaration -> m (Ident, NameKind, Expr)
179179 toBinding (AcyclicSCC d) = return $ fromValueDecl d
180180 toBinding (CyclicSCC ~(d:ds)) = cycleError d ds
181181
182− cycleError :: (MonadError ErrorStack m) => Declaration -> [Declaration] -> m a
182+ cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a
183183 cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds
184184 cycleError (ValueDeclaration n _ _ (Right e)) [] = throwError $
185− mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))
185+ mkMultipleErrors ("Cycle in definition of " ++ show n) (Just (ExprError e))
186186 cycleError d ds@(_:_) = rethrow (mkCompileError ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing `combineErrors`) $ cycleError d []
187187 cycleError _ _ = error "Expected ValueDeclaration"
188188
189−toDataBindingGroup :: (MonadError ErrorStack m) => SCC Declaration -> m Declaration
189+toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration
190190toDataBindingGroup (AcyclicSCC d) = return d
191191toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
192− Just pn -> throwError $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing
192+ Just pn -> throwError $ mkMultipleErrors ("Cycle in type synonym " ++ show pn) Nothing
193193 _ -> return d
194194toDataBindingGroup (CyclicSCC ds')
195− | all (isJust . isTypeSynonym) ds' = throwError $ mkErrorStack "Cycle in type synonyms" Nothing
195+ | all (isJust . isTypeSynonym) ds' = throwError $ mkMultipleErrors "Cycle in type synonyms" Nothing
196196 | otherwise = return $ DataBindingGroupDeclaration ds'
197197
198198isTypeSynonym :: Declaration -> Maybe ProperName
src/Language/PureScript/Sugar/CaseDeclarations.hs+9−9
@@ -44,17 +44,17 @@ isLeft (Right _) = False
4444-- |
4545-- Replace all top-level binders in a module with case expressions.
4646--
47−desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]
47+desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
4848desugarCasesModule ms = forM ms $ \(Module coms name ds exps) ->
4949 rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $
5050 Module coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
5151
52−desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
52+desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
5353desugarAbs = flip parU f
5454 where
5555 (f, _, _) = everywhereOnValuesM return replace return
5656
57− replace :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Expr -> m Expr
57+ replace :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Expr -> m Expr
5858 replace (Abs (Right binder) val) = do
5959 ident <- Ident <$> freshName
6060 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
@@ -63,10 +63,10 @@ desugarAbs = flip parU f
6363-- |
6464-- Replace all top-level binders with case expressions.
6565--
66−desugarCases :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
66+desugarCases :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
6767desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
6868 where
69− desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
69+ desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
7070 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
7171 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
7272 desugarRest (ValueDeclaration name nameKind bs result : rest) =
@@ -89,7 +89,7 @@ inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2
8989inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2
9090inSameGroup _ _ = False
9191
92−toDecls :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
92+toDecls :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
9393toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do
9494 let args = map (\(VarBinder arg) -> arg) bs
9595 body = foldr (Abs . Left) val args
@@ -98,9 +98,9 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs =
9898toDecls ds@(ValueDeclaration ident _ bs result : _) = do
9999 let tuples = map toTuple ds
100100 unless (all ((== length bs) . length . fst) tuples) $
101− throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing
101+ throwError $ mkMultipleErrors ("Argument list lengths differ in declaration " ++ show ident) Nothing
102102 unless (not (null bs) || isLeft result) $
103− throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing
103+ throwError $ mkMultipleErrors ("Duplicate value declaration '" ++ show ident ++ "'") Nothing
104104 caseDecl <- makeCaseDeclaration ident tuples
105105 return [caseDecl]
106106toDecls (PositionedDeclaration pos com d : ds) = do
@@ -117,7 +117,7 @@ toTuple (ValueDeclaration _ _ bs result) = (bs, result)
117117toTuple (PositionedDeclaration _ _ d) = toTuple d
118118toTuple _ = error "Not a value declaration"
119119
120−makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
120+makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
121121makeCaseDeclaration ident alternatives = do
122122 let argPattern = length . fst . head $ alternatives
123123 args <- map Ident <$> replicateM argPattern freshName
src/Language/PureScript/Sugar/DoNotation.hs+4−4
@@ -35,10 +35,10 @@ import Control.Monad.Supply.Class
3535-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
3636-- and all @DoNotationLet@ constructors with let expressions.
3737--
38−desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> m Module
38+desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
3939desugarDoModule (Module coms mn ds exts) = Module coms mn <$> parU ds desugarDo <*> pure exts
4040
41−desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Declaration -> m Declaration
41+desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
4242desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)
4343desugarDo d =
4444 let (f, _, _) = everywhereOnValuesM return replace return
@@ -61,7 +61,7 @@ desugarDo d =
6161 go (DoNotationValue val : rest) = do
6262 rest' <- go rest
6363 return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')
64− go [DoNotationBind _ _] = throwError $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
64+ go [DoNotationBind _ _] = throwError $ mkMultipleErrors "Bind statement cannot be the last statement in a do block" Nothing
6565 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
6666 go (DoNotationBind (VarBinder ident) val : rest) = do
6767 rest' <- go rest
@@ -70,7 +70,7 @@ desugarDo d =
7070 rest' <- go rest
7171 ident <- Ident <$> freshName
7272 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
73− go [DoNotationLet _] = throwError $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
73+ go [DoNotationLet _] = throwError $ mkMultipleErrors "Let statement cannot be the last statement in a do block" Nothing
7474 go (DoNotationLet ds : rest) = do
7575 rest' <- go rest
7676 return $ Let ds rest'
src/Language/PureScript/Sugar/Names.hs+53−63
@@ -87,7 +87,7 @@ data ImportEnvironment = ImportEnvironment
8787-- Updates the exports for a module from the global environment. If the module was not previously
8888-- present in the global environment, it is created.
8989--
90−updateExportedModule :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment
90+updateExportedModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment
9191updateExportedModule env mn update = do
9292 let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
9393 exports' <- update exports
@@ -96,61 +96,61 @@ updateExportedModule env mn update = do
9696-- |
9797-- Adds an empty module to an ExportEnvironment.
9898--
99−addEmptyModule :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> m ExportEnvironment
99+addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> m ExportEnvironment
100100addEmptyModule env name =
101101 if name `M.member` env
102− then throwError $ mkErrorStack ("Module '" ++ show name ++ "' has been defined more than once") Nothing
102+ then throwError . errorMessage $ RedefinedModule name
103103 else return $ M.insert name (Exports [] [] []) env
104104
105105-- |
106106-- Adds a type belonging to a module to the export environment.
107107--
108−addType :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment
108+addType :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment
109109addType env mn name dctors = updateExportedModule env mn $ \m -> do
110110 let exTypes = exportedTypes m
111111 let exDctors = snd `concatMap` exTypes
112112 let exClasses = exportedTypeClasses m
113− when (any ((== name) . fst) exTypes) $ throwMultipleDefError "type" name
114− when (name `elem` exClasses) $ throwConflictingDefError "Type" "type class" name
113+ when (any ((== name) . fst) exTypes) $ throwConflictError ConflictingTypeDecls name
114+ when (name `elem` exClasses) $ throwConflictError TypeConflictsWithClass name
115115 forM_ dctors $ \dctor -> do
116− when (dctor `elem` exDctors) $ throwMultipleDefError "data constructor" dctor
117− when (dctor `elem` exClasses) $ throwConflictingDefError "Data constructor" "type class" dctor
116+ when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor
117+ when (dctor `elem` exClasses) $ throwConflictError CtorConflictsWithClass dctor
118118 return $ m { exportedTypes = (name, dctors) : exTypes }
119119
120120-- |
121121-- Adds a class to the export environment.
122122--
123−addTypeClass :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment
123+addTypeClass :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment
124124addTypeClass env mn name = updateExportedModule env mn $ \m -> do
125125 let exTypes = exportedTypes m
126126 let exDctors = snd `concatMap` exTypes
127− when (any ((== name) . fst) exTypes) $ throwConflictingDefError "Type class" "type" name
128− when (name `elem` exDctors) $ throwConflictingDefError "Type class" "data constructor" name
129− classes <- addExport "type class" (exportedTypeClasses m) name
127+ when (any ((== name) . fst) exTypes) $ throwConflictError ClassConflictsWithType name
128+ when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
129+ classes <- addExport DuplicateClassExport (exportedTypeClasses m) name
130130 return $ m { exportedTypeClasses = classes }
131131
132132-- |
133133-- Adds a class to the export environment.
134134--
135−addValue :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment
135+addValue :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment
136136addValue env mn name = updateExportedModule env mn $ \m -> do
137− values <- addExport "value" (exportedValues m) name
137+ values <- addExport DuplicateValueExport (exportedValues m) name
138138 return $ m { exportedValues = values }
139139
140140-- |
141141-- Adds an entry to a list of exports unless it is already present, in which case an error is
142142-- returned.
143143--
144−addExport :: (Applicative m, MonadError ErrorStack m, Eq a, Show a) => String -> [a] -> a -> m [a]
144+addExport :: (Applicative m, MonadError MultipleErrors m, Eq a, Show a) => (a -> ErrorMessage) -> [a] -> a -> m [a]
145145addExport what exports name =
146146 if name `elem` exports
147− then throwMultipleDefError what name
147+ then throwConflictError what name
148148 else return $ name : exports
149149
150150-- |
151151-- Replaces all local names with qualified names within a set of modules.
152152--
153−desugarImports :: forall m. (Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]
153+desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
154154desugarImports modules = do
155155 unfilteredExports <- findExports modules
156156 exports <- foldM filterModuleExports unfilteredExports modules
@@ -168,7 +168,7 @@ desugarImports modules = do
168168 -- the module has access to an unfiltered list of its own members.
169169 renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module
170170 renameInModule' unfilteredExports exports m@(Module _ mn _ _) =
171− rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ do
171+ rethrow (onErrorMessages (ErrorInModule mn)) $ do
172172 let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
173173 let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
174174 imports <- resolveImports env m
@@ -205,7 +205,7 @@ elaborateImports (Module coms mn decls exps) = Module coms mn decls' exps
205205-- Replaces all local names with qualified names within a module and checks that all existing
206206-- qualified names are valid.
207207--
208−renameInModule :: forall m. (Applicative m, MonadError ErrorStack m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module
208+renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module
209209renameInModule imports exports (Module coms mn decls exps) =
210210 Module coms mn <$> parU decls go <*> pure exps
211211 where
@@ -236,7 +236,7 @@ renameInModule imports exports (Module coms mn decls exps) =
236236 let args = mapMaybe letBoundVariable ds
237237 unless (length (nub args) == length args) $
238238 maybe id rethrowWithPosition pos $
239− throwError $ mkErrorStack ("Overlapping names in let binding.") Nothing
239+ throwError . errorMessage $ OverlappingNamesInLet
240240 return ((pos, args ++ bound), Let ds val')
241241 where
242242 updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
@@ -271,28 +271,28 @@ renameInModule imports exports (Module coms mn decls exps) =
271271
272272 updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)
273273
274− updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
275− updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)
276− updateValueName = update "value" importedValues (flip elem . exportedValues)
277− updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
274+ updateTypeName = update UnknownType importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
275+ updateClassName = update UnknownTypeClass importedTypeClasses (flip elem . exportedTypeClasses)
276+ updateValueName = update UnknownValue importedValues (flip elem . exportedValues)
277+ updateDataConstructorName = update (flip UnknownDataConstructor Nothing) importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
278278
279279 -- Update names so unqualified references become qualified, and locally qualified references
280280 -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)
281− update :: (Ord a, Show a) => String
281+ update :: (Ord a, Show a) => (Qualified a -> ErrorMessage)
282282 -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
283283 -> (Exports -> a -> Bool)
284284 -> Qualified a
285285 -> Maybe SourceSpan
286286 -> m (Qualified a)
287− update t getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
287+ update unknown getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
288288 (Just qname', _) -> return qname'
289289 (Nothing, Just mn'') -> do
290− when (isExplicitQualModule mn'') $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
290+ when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname
291291 modExports <- getExports mn''
292292 if checkE modExports name
293293 then return qname
294− else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
295− _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing
294+ else throwError . errorMessage $ unknown qname
295+ _ -> throwError . errorMessage $ unknown qname
296296 where
297297 isExplicitQualModule :: ModuleName -> Bool
298298 isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')
@@ -303,12 +303,12 @@ renameInModule imports exports (Module coms mn decls exps) =
303303
304304 -- Gets the exports for a module, or an error message if the module doesn't exist
305305 getExports :: ModuleName -> m Exports
306− getExports mn' = maybe (throwError $ mkErrorStack ("Unknown module '" ++ show mn' ++ "'") Nothing) return $ M.lookup mn' exports
306+ getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') return $ M.lookup mn' exports
307307
308308-- |
309309-- Finds all exported declarations in a set of modules.
310310--
311−findExports :: forall m. (Applicative m, MonadError ErrorStack m) => [Module] -> m ExportEnvironment
311+findExports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m ExportEnvironment
312312findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports
313313 where
314314
@@ -321,7 +321,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
321321 addModule :: ExportEnvironment -> Module -> m ExportEnvironment
322322 addModule env (Module _ mn ds _) = do
323323 env' <- addEmptyModule env mn
324− rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ foldM (addDecl mn) env' ds
324+ rethrow (onErrorMessages (ErrorInModule mn)) $ foldM (addDecl mn) env' ds
325325
326326 -- Add a declaration from a module to the global export environment
327327 addDecl :: ModuleName -> ExportEnvironment -> Declaration -> m ExportEnvironment
@@ -344,10 +344,10 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
344344-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
345345-- environment.
346346--
347−filterExports :: forall m. (Applicative m, MonadError ErrorStack m) => ModuleName -> [DeclarationRef] -> ExportEnvironment -> m ExportEnvironment
347+filterExports :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> ExportEnvironment -> m ExportEnvironment
348348filterExports mn exps env = do
349349 let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
350− moduleExports' <- rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ filterModule moduleExports
350+ moduleExports' <- rethrow (onErrorMessages (ErrorInModule mn)) $ filterModule moduleExports
351351 return $ M.insert mn moduleExports' env
352352 where
353353
@@ -364,7 +364,7 @@ filterExports mn exps env = do
364364 filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]
365365 filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r
366366 filterTypes expTys result (TypeRef name expDcons) = do
367− dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys
367+ dcons <- maybe (throwError . errorMessage $ UnknownType name) return $ name `lookup` expTys
368368 dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
369369 return $ (name, dcons') : result
370370 filterTypes _ result _ = return result
@@ -374,7 +374,7 @@ filterExports mn exps env = do
374374 filterDcons tcon exps' result name =
375375 if name `elem` exps'
376376 then return $ name : result
377− else throwError $ mkErrorStack ("Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'") Nothing
377+ else throwError . errorMessage $ UnknownDataConstructor name (Just tcon)
378378
379379 -- Ensure the exported classes exist in the module and add them to the set of exports
380380 filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]
@@ -382,7 +382,7 @@ filterExports mn exps env = do
382382 filterClasses exps' result (TypeClassRef name) =
383383 if name `elem` exps'
384384 then return $ name : result
385− else throwError $ mkErrorStack ("Cannot export undefined type class '" ++ show name ++ "'") Nothing
385+ else throwError . errorMessage $ UnknownTypeClass name
386386 filterClasses _ result _ = return result
387387
388388 -- Ensure the exported values exist in the module and add them to the set of exports
@@ -391,7 +391,7 @@ filterExports mn exps env = do
391391 filterValues exps' result (ValueRef name) =
392392 if name `elem` exps'
393393 then return $ name : result
394− else throwError $ mkErrorStack ("Cannot export undefined value '" ++ show name ++ "'") Nothing
394+ else throwError . errorMessage $ UnknownValue name
395395 filterValues _ result _ = return result
396396
397397-- |
@@ -408,7 +408,7 @@ findImports = foldl (findImports' Nothing) M.empty
408408-- |
409409-- Constructs a local environment for a module.
410410--
411−resolveImports :: forall m. (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> Module -> m ImportEnvironment
411+resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment
412412resolveImports env (Module _ currentModule decls _) =
413413 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
414414 where
@@ -421,7 +421,7 @@ resolveImports env (Module _ currentModule decls _) =
421421
422422 resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> m ImportEnvironment
423423 resolveImport' imp (mn, (pos, typ, impQual)) = do
424− modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
424+ modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) return $ mn `M.lookup` env
425425 positioned $ resolveImport currentModule mn modExports imp impQual typ
426426 where
427427 positioned err = case pos of
@@ -431,7 +431,7 @@ resolveImports env (Module _ currentModule decls _) =
431431-- |
432432-- Extends the local environment for a module by resolving an import of another module.
433433--
434−resolveImport :: forall m. (Applicative m, MonadError ErrorStack m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment
434+resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment
435435resolveImport currentModule importModule exps imps impQual =
436436 resolveByType
437437 where
@@ -492,14 +492,14 @@ resolveImport currentModule importModule exps imps impQual =
492492 check (PositionedDeclarationRef pos _ r) =
493493 rethrowWithPosition pos $ check r
494494 check ref@(ValueRef name) =
495− checkImportExists "value" values name >> return ref
495+ checkImportExists UnknownValue values name >> return ref
496496 check ref@(TypeRef name dctors) = do
497− _ <- checkImportExists "type" availableTypes name
497+ _ <- checkImportExists UnknownType availableTypes name
498498 let allDctors = allExportedDataConstructors name
499499 _ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
500500 return ref
501501 check ref@(TypeClassRef name) =
502− checkImportExists "type class" classes name >> return ref
502+ checkImportExists UnknownTypeClass classes name >> return ref
503503 check _ = error "Invalid argument to checkRefIsValid"
504504
505505 -- Find all exported data constructors for a given type
@@ -511,11 +511,11 @@ resolveImport currentModule importModule exps imps impQual =
511511 updateImports m name = case M.lookup (Qualified impQual name) m of
512512 Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m
513513 Just (Qualified Nothing _) -> error "Invalid state in updateImports"
514− Just x@(Qualified (Just mn) _) -> throwError $ mkErrorStack err Nothing
514+ Just x@(Qualified (Just mn) _) -> throwError . errorMessage $ err
515515 where
516516 err = if mn == currentModule || importModule == currentModule
517− then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"
518− else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
517+ then ConflictingImport (show name) mn
518+ else ConflictingImports (show name) mn importModule
519519
520520 -- The available values, types, and classes in the module being imported
521521 values = exportedValues exps
@@ -525,27 +525,17 @@ resolveImport currentModule importModule exps imps impQual =
525525 -- Ensure that an explicitly imported data constructor exists for the type it is being imported
526526 -- from
527527 checkDctorExists :: [ProperName] -> ProperName -> m ProperName
528− checkDctorExists = checkImportExists "data constructor"
528+ checkDctorExists = checkImportExists (flip UnknownDataConstructor Nothing)
529529
530530 -- Check that an explicitly imported item exists in the module it is being imported from
531− checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> m a
532− checkImportExists t exports item =
531+ checkImportExists :: (Eq a, Show a) => (Qualified a -> ErrorMessage) -> [a] -> a -> m a
532+ checkImportExists unknown exports item =
533533 if item `elem` exports
534534 then return item
535− else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
535+ else throwError . errorMessage . unknown $ Qualified (Just importModule) item
536536
537537-- |
538538-- Raises an error for when there is more than one definition for something.
539539--
540−throwMultipleDefError :: (Applicative m, MonadError ErrorStack m, Show a) => String -> a -> m b
541−throwMultipleDefError what name = throwError $
542− mkErrorStack ("Multiple definitions for " ++ what ++ " '" ++ show name ++ "'") Nothing
543−
544−-- |
545−-- Raises an error for when there is a conflicting definition for something, for example, a type
546−-- class and data constructor of the same name.
547−--
548−throwConflictingDefError :: (Applicative m, MonadError ErrorStack m, Show a) => String -> String -> a -> m b
549−throwConflictingDefError what1 what2 name = throwError $
550− mkErrorStack (what1 ++ " '" ++ show name ++ "' cannot be defined in the same module as a " ++ what2 ++ " of the same name") Nothing
551−
540+throwConflictError :: (Applicative m, MonadError MultipleErrors m, Show a) => (a -> ErrorMessage) -> a -> m b
541+throwConflictError conflict = throwError . errorMessage . conflict
src/Language/PureScript/Sugar/ObjectWildcards.hs+1−1
@@ -31,7 +31,7 @@ import Language.PureScript.AST
3131import Language.PureScript.Errors
3232import Language.PureScript.Names
3333
34−desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> m Module
34+desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
3535desugarObjectConstructors (Module coms mn ds exts) = Module coms mn <$> mapM desugarDecl ds <*> pure exts
3636 where
3737
src/Language/PureScript/Sugar/Operators.hs+8−8
@@ -49,7 +49,7 @@ import qualified Language.PureScript.Constants as C
4949-- |
5050-- Remove explicit parentheses and reorder binary operator applications
5151--
52−rebracket :: (Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]
52+rebracket :: (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
5353rebracket ms = do
5454 let fixities = concatMap collectFixities ms
5555 ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities
@@ -64,7 +64,7 @@ removeSignedLiterals (Module coms mn ds exts) = Module coms mn (map f' ds) exts
6464 go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val
6565 go other = other
6666
67−rebracketModule :: (Applicative m, MonadError ErrorStack m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module
67+rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module
6868rebracketModule opTable (Module coms mn ds exts) =
6969 let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
7070 in Module coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
@@ -85,15 +85,15 @@ collectFixities (Module _ moduleName ds _) = concatMap collect ds
8585 collect FixityDeclaration{} = error "Fixity without srcpos info"
8686 collect _ = []
8787
88−ensureNoDuplicates :: (MonadError ErrorStack m) => [(Qualified Ident, SourceSpan)] -> m ()
88+ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()
8989ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
9090 where
9191 go [] = return ()
9292 go [_] = return ()
9393 go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =
94− rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $
94+ rethrow (onErrorMessages (ErrorInModule mn)) $
9595 rethrowWithPosition pos $
96− throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing
96+ throwError . errorMessage $ MultipleFixities name
9797 go (_ : rest) = go rest
9898
9999customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]
@@ -108,7 +108,7 @@ customOperatorTable fixities =
108108
109109type Chain = [Either Expr Expr]
110110
111−matchOperators :: forall m. (MonadError ErrorStack m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> m Expr
111+matchOperators :: forall m. (MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> m Expr
112112matchOperators ops = parseChains
113113 where
114114 parseChains :: Expr -> m Expr
@@ -118,7 +118,7 @@ matchOperators ops = parseChains
118118 extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r
119119 extendChain other = [Left other]
120120 bracketChain :: Chain -> m Expr
121− bracketChain = either (throwError . (`mkErrorStack` Nothing) . show) return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
121+ bracketChain = either (const . throwError . errorMessage $ CannotReorderOperators) return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
122122 opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]
123123 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
124124 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
@@ -151,7 +151,7 @@ matchOp op = do
151151 ident <- parseOp
152152 guard $ ident == op
153153
154−desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> m Module
154+desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
155155desugarOperatorSections (Module coms mn ds exts) = Module coms mn <$> mapM goDecl ds <*> pure exts
156156 where
157157
src/Language/PureScript/Sugar/TypeClasses.hs+8−8
@@ -51,10 +51,10 @@ type Desugar = StateT MemberMap
5151-- Add type synonym declarations for type class dictionary types, and value declarations for type class
5252-- instance dictionary expressions.
5353--
54−desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]
54+desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
5555desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
5656
57−desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> Desugar m Module
57+desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module
5858desugarModule (Module coms name decls (Just exps)) = do
5959 (newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps)
6060 return $ Module coms name (concat declss) $ Just (exps ++ catMaybes newExpss)
@@ -154,7 +154,7 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
154154-- return new Sub(fooString, "");
155155-- };
156156-}
157−desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])
157+desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])
158158desugarDecl mn exps = go
159159 where
160160 go d@(TypeClassDeclaration name args implies members) = do
@@ -224,18 +224,18 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type
224224unit :: Type
225225unit = TypeApp tyObject REmpty
226226
227−typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration
227+typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration
228228typeInstanceDictionaryDeclaration name mn deps className tys decls =
229229 rethrow (mkCompileError ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") Nothing `combineErrors`) $ do
230230 m <- get
231231
232232 -- Lookup the type arguments and member types for the type class
233233 (TypeClassDeclaration _ args implies tyDecls) <-
234− maybe (throwError $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) return $
234+ maybe (throwError $ mkMultipleErrors ("Type class " ++ show className ++ " is undefined") Nothing) return $
235235 M.lookup (qualify mn className) m
236236
237237 case mapMaybe declName tyDecls \\ mapMaybe declName decls of
238− x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
238+ x : _ -> throwError $ mkMultipleErrors ("Member '" ++ show x ++ "' has not been implemented") Nothing
239239 [] -> do
240240
241241 let instanceTys = map memberToNameAndType tyDecls
@@ -270,9 +270,9 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
270270 declName (TypeDeclaration ident _) = Just ident
271271 declName _ = Nothing
272272
273− memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [(Ident, Type)] -> Declaration -> Desugar m Expr
273+ memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr
274274 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do
275− _ <- maybe (throwError $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) return $ lookup ident tys'
275+ _ <- maybe (throwError $ mkMultipleErrors ("Type class does not define member '" ++ show ident ++ "'") Nothing) return $ lookup ident tys'
276276 return val
277277 memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do
278278 val <- memberToValue tys' d
src/Language/PureScript/Sugar/TypeDeclarations.hs+6−6
@@ -35,15 +35,15 @@ import Language.PureScript.Traversals
3535-- |
3636-- Replace all top level type declarations in a module with type annotations
3737--
38−desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]
38+desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
3939desugarTypeDeclarationsModule ms = forM ms $ \(Module coms name ds exps) ->
40− rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $
40+ rethrow (onErrorMessages (ErrorInModule name)) $
4141 Module coms name <$> desugarTypeDeclarations ds <*> pure exps
4242
4343-- |
4444-- Replace all top level type declarations with type annotations
4545--
46−desugarTypeDeclarations :: (Functor m, Applicative m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
46+desugarTypeDeclarations :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
4747desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do
4848 (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
4949 return (PositionedDeclaration pos com d' : ds')
@@ -51,13 +51,13 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
5151 (_, nameKind, val) <- fromValueDeclaration d
5252 desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
5353 where
54− fromValueDeclaration :: (Functor m, Applicative m, MonadError ErrorStack m) => Declaration -> m (Ident, NameKind, Expr)
54+ fromValueDeclaration :: (Functor m, Applicative m, MonadError MultipleErrors m) => Declaration -> m (Ident, NameKind, Expr)
5555 fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
5656 fromValueDeclaration (PositionedDeclaration pos com d') = do
5757 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
5858 return (ident, nameKind, PositionedValue pos com val)
59− fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
60−desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
59+ fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name
60+desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError . errorMessage $ OrphanTypeDeclaration name
6161desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do
6262 let (_, f, _) = everywhereOnValuesTopDownM return go return
6363 f' (Left gs) = Left <$> mapM (pairM return f) gs
src/Language/PureScript/TypeChecker.hs+1−1
@@ -106,7 +106,7 @@ checkTypeClassInstance _ (TypeConstructor ctor) = do
106106 when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed"
107107 return ()
108108checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
109−checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance head is invalid." (Just (TypeError ty))
109+checkTypeClassInstance _ ty = throwError $ mkMultipleErrors "Type class instance head is invalid." (Just (TypeError ty))
110110
111111-- |
112112-- Check that type synonyms are fully-applied in a type
src/Language/PureScript/TypeChecker/Kinds.hs+1−1
@@ -192,7 +192,7 @@ infer' other = (, []) <$> go other
192192 go c@(TypeConstructor v) = do
193193 env <- liftCheck getEnv
194194 case M.lookup v (types env) of
195− Nothing -> UnifyT . lift . throwError $ mkErrorStack "Unknown type constructor" (Just (TypeError c))
195+ Nothing -> UnifyT . lift . throwError $ mkMultipleErrors "Unknown type constructor" (Just (TypeError c))
196196 Just (kind, _) -> return kind
197197 go (TypeApp t1 t2) = do
198198 k0 <- fresh
src/Language/PureScript/TypeChecker/Monad.hs+9−9
@@ -109,7 +109,7 @@ makeBindingGroupVisible action = do
109109-- |
110110-- Lookup the type of a value by name in the @Environment@
111111--
112−lookupVariable :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
112+lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
113113lookupVariable currentModule (Qualified moduleName var) = do
114114 env <- getEnv
115115 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
@@ -119,7 +119,7 @@ lookupVariable currentModule (Qualified moduleName var) = do
119119-- |
120120-- Lookup the visibility of a value by name in the @Environment@
121121--
122−getVisibility :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility
122+getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility
123123getVisibility currentModule (Qualified moduleName var) = do
124124 env <- getEnv
125125 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
@@ -129,7 +129,7 @@ getVisibility currentModule (Qualified moduleName var) = do
129129-- |
130130-- Assert that a name is visible
131131--
132−checkVisibility :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()
132+checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()
133133checkVisibility currentModule name@(Qualified _ var) = do
134134 vis <- getVisibility currentModule name
135135 case vis of
@@ -139,7 +139,7 @@ checkVisibility currentModule name@(Qualified _ var) = do
139139-- |
140140-- Lookup the kind of a type by name in the @Environment@
141141--
142−lookupTypeVariable :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind
142+lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind
143143lookupTypeVariable currentModule (Qualified moduleName name) = do
144144 env <- getEnv
145145 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
@@ -171,8 +171,8 @@ data CheckState = CheckState {
171171-- |
172172-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
173173--
174−newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a }
175− deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError ErrorStack)
174+newtype Check a = Check { unCheck :: StateT CheckState (Either MultipleErrors) a }
175+ deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError MultipleErrors)
176176
177177-- |
178178-- Get the current @Environment@
@@ -204,9 +204,9 @@ runCheck = runCheck' initEnvironment
204204runCheck' :: (MonadReader (Options mode) m, MonadError String m) => Environment -> Check a -> m (a, Environment)
205205runCheck' env c = do
206206 verbose <- asks optionsVerboseErrors
207− stringifyErrorStack verbose $ do
208− (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
209− return (a, checkEnv s)
207+ interpretMultipleErrors verbose $ do
208+ (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
209+ return (a, checkEnv s)
210210
211211-- |
212212-- Make an assertion, failing with an error message
src/Language/PureScript/TypeChecker/Rows.hs+1−1
@@ -53,7 +53,7 @@ checkDuplicateLabels =
5353 checkDups r@RCons{} =
5454 let (ls, _) = rowToList r in
5555 case firstDup . sort . map fst $ ls of
56− Just l -> throwError $ mkErrorStack ("Duplicate label " ++ show l ++ " in row") $ Just (ExprError val)
56+ Just l -> throwError $ mkMultipleErrors ("Duplicate label " ++ show l ++ " in row") $ Just (ExprError val)
5757 Nothing -> return ()
5858 checkDups _ = return ()
5959
src/Language/PureScript/TypeChecker/Skolems.hs+2−2
@@ -89,7 +89,7 @@ skolemEscapeCheck root@TypedValue{} =
8989 let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def
9090 in case f root of
9191 [] -> return ()
92− ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ExprError val))
92+ ((binding, val) : _) -> throwError $ mkMultipleErrors ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ExprError val))
9393 where
9494 def s _ = (s, [])
9595
@@ -112,4 +112,4 @@ skolemEscapeCheck root@TypedValue{} =
112112 where
113113 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)
114114 go' _ = mempty
115−skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))
115+skolemEscapeCheck val = throwError $ mkMultipleErrors "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))
src/Language/PureScript/TypeChecker/Synonyms.hs+3−3
@@ -83,7 +83,7 @@ replaceAllTypeSynonyms' env d =
8383 in
8484 saturateAllTypeSynonyms syns d
8585
86−replaceAllTypeSynonyms :: (e ~ ErrorStack, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
86+replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
8787replaceAllTypeSynonyms d = do
8888 env <- getEnv
8989 either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d
@@ -99,12 +99,12 @@ expandTypeSynonym' env name args =
9999 replaceAllTypeSynonyms' env repl
100100 Nothing -> error "Type synonym was not defined"
101101
102−expandTypeSynonym :: (e ~ ErrorStack, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type
102+expandTypeSynonym :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type
103103expandTypeSynonym name args = do
104104 env <- getEnv
105105 either (throwError . strMsg) return $ expandTypeSynonym' env name args
106106
107−expandAllTypeSynonyms :: (e ~ ErrorStack, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
107+expandAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
108108expandAllTypeSynonyms = everywhereOnTypesTopDownM go
109109 where
110110 go (SaturatedTypeSynonym name args) = expandTypeSynonym name args
src/Language/PureScript/TypeChecker/Types.hs+4−4
@@ -568,7 +568,7 @@ check' val kt@(KindedType ty kind) = do
568568 return $ TypedValue True val' kt
569569check' (PositionedValue pos _ val) ty =
570570 rethrowWithPosition pos $ check' val ty
571−check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))
571+check' val ty = throwError $ mkMultipleErrors ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))
572572
573573containsTypeSynonyms :: Type -> Bool
574574containsTypeSynonyms = everythingOnTypes (||) go where
@@ -589,8 +589,8 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
589589 return []
590590 go [] [] Skolem{} | lax = return []
591591 go [] ((p, _): _) _ | lax = return []
592− | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))
593− go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))
592+ | otherwise = throwError $ mkMultipleErrors ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))
593+ go ((p,_):_) [] REmpty = throwError $ mkMultipleErrors ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))
594594 go ((p,v):ps') ts r =
595595 case lookup p ts of
596596 Nothing -> do
@@ -603,7 +603,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
603603 v' <- check v ty
604604 ps'' <- go ps' (delete (p, ty) ts) r
605605 return $ (p, v') : ps''
606− go _ _ _ = throwError $ mkErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ExprError (ObjectLiteral ps)))
606+ go _ _ _ = throwError $ mkMultipleErrors ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ExprError (ObjectLiteral ps)))
607607
608608-- |
609609-- Check the type of a function application, rethrowing errors to provide a better error message