306ba7b · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

A start on #745 - a type for error messages

306ba7bPhil Freeman12 years ago

psci/Main.hs+1−1

compare with golang

unifiedsplit

@@ -531,7 +531,7 @@ handleKindOf typ = do

531 let chk = P.CheckState env' 0 0 (Just mName)

532 k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk

533 case k of

534− Left errStack -> PSCI . outputStrLn . P.prettyPrintErrorStack False $ errStack

534+ Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack

535 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind

536 Nothing -> PSCI $ outputStrLn "Could not find kind"

537

src/Control/Monad/Unify.hs+10−6

@@ -20,11 +20,9 @@

20{-# LANGUAGE MultiParamTypeClasses #-}

21{-# LANGUAGE FunctionalDependencies #-}

22{-# LANGUAGE UndecidableInstances #-}

23−{-# LANGUAGE OverloadedStrings #-}

25module Control.Monad.Unify where

24module Control.Monad.Unify where

27−import Data.String (IsString)

28import Data.Monoid

26import Data.Monoid

30import Control.Applicative

28import Control.Applicative

@@ -84,10 +82,16 @@ data UnifyState t = UnifyState {

84defaultUnifyState :: (Partial t) => UnifyState t

82defaultUnifyState :: (Partial t) => UnifyState t

85defaultUnifyState = UnifyState 0 mempty

83defaultUnifyState = UnifyState 0 mempty

85+-- \

86+-- A class for errors which support unification errors

87+--

88+class UnificationError t e where

89+ occursCheckFailed :: t -> e

90+

87-- |

91-- |

88-- The type checking monad, which provides the state of the type checker, and error reporting capabilities

92-- The type checking monad, which provides the state of the type checker, and error reporting capabilities

89--

93--

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 }

91 deriving (Functor, Monad, Applicative, Alternative, MonadPlus)

95 deriving (Functor, Monad, Applicative, Alternative, MonadPlus)

93instance (MonadState s m) => MonadState s (UnifyT t m) where

97instance (MonadState s m) => MonadState s (UnifyT t m) where

@@ -113,7 +117,7 @@ substituteOne u t = Substitution $ M.singleton u t

113-- |

117-- |

114-- Replace a unification variable with the specified value in the current substitution

118-- Replace a unification variable with the specified value in the current substitution

115--

119--

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

117(=:=) u t' = do

121(=:=) u t' = do

118 st <- UnifyT get

122 st <- UnifyT get

119 let sub = unifyCurrentSubstitution st

123 let sub = unifyCurrentSubstitution st

@@ -128,10 +132,10 @@ substituteOne u t = Substitution $ M.singleton u t

128-- |

132-- |

129-- Perform the occurs check, to make sure a unification variable does not occur inside a value

133-- Perform the occurs check, to make sure a unification variable does not occur inside a value

130--

134--

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

132occursCheck u t =

136occursCheck u t =

133 case isUnknown t of

137 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

135 _ -> return ()

139 _ -> return ()

136

140

137-- |

141-- |

src/Language/PureScript.hs+4−4

@@ -96,9 +96,9 @@ compile' env ms prefix = do

96 additional <- asks optionsAdditional

97 mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)

98 (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

100 (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent

101− regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

101+ regrouped <- interpretMultipleErrors True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

102 let corefn = map (CoreFn.moduleToCoreFn env') regrouped

103 let entryPoints = moduleNameFromString `map` entryPointModules additional

104 let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn

@@ -192,7 +192,7 @@ make outputDir ms prefix = do

192

193 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

194

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)

196

197 evalSupplyT nextVar $ go initEnvironment desugared

198

@@ -212,7 +212,7 @@ make outputDir ms prefix = do

212

213 (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m

214

215− regrouped <- stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

215+ regrouped <- interpretMultipleErrors True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

216

217 let mod' = Module coms moduleName' regrouped exps

218 let corefn = CoreFn.moduleToCoreFn env' mod'

src/Language/PureScript/AST/SourcePos.hs+2−2

@@ -30,7 +30,7 @@ data SourcePos = SourcePos

30 -- Column number

31 --

32 , sourcePosColumn :: Int

33− } deriving (D.Data, D.Typeable)

33+ } deriving (Eq, D.Data, D.Typeable)

35instance Show SourcePos where

36 show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)

@@ -47,7 +47,7 @@ data SourceSpan = SourceSpan

47 -- End of the span

48 --

49 , spanEnd :: SourcePos

50− } deriving (D.Data, D.Typeable)

50+ } deriving (Eq, D.Data, D.Typeable)

52instance Show SourceSpan where

53 show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp)

src/Language/PureScript/Errors.hs+122−96

@@ -12,108 +12,145 @@

12--

13-----------------------------------------------------------------------------

15−{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}

15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

16+{-# LANGUAGE FlexibleContexts #-}

17+{-# LANGUAGE MultiParamTypeClasses #-}

17module Language.PureScript.Errors where

19module Language.PureScript.Errors where

19import Data.Either (lefts, rights)

21import Data.Either (lefts, rights)

20−import Data.String (IsString(..))

21−import Data.List (intersperse, intercalate)

22+import Data.List (intersperse)

22import Data.Monoid

23import Data.Monoid

24+import Data.Foldable (fold, foldMap)

24import Control.Monad.Except

26import Control.Monad.Except

27+import Control.Monad.Unify

25import Control.Applicative ((<$>))

28import Control.Applicative ((<$>))

27import Language.PureScript.AST

30import Language.PureScript.AST

28import Language.PureScript.Pretty

31import Language.PureScript.Pretty

29import Language.PureScript.Types

32import Language.PureScript.Types

33+import Language.PureScript.Names

34+import Language.PureScript.Kinds

31-- |

36-- |

32−-- Type for sources of type checking errors

37+-- A type of error messages

33−--

38+--

34−data ErrorSource

39+data ErrorMessage

35− -- |

40+ = InfiniteType Type

36− -- An error which originated at a Expr

41+ | InfiniteKind Kind

37− --

42+ | CannotReorderOperators

38− = ExprError Expr

43+ | MultipleFixities Ident

39− -- |

44+ | OrphanTypeDeclaration Ident

40− -- An error which originated at a Type

45+ | RedefinedModule ModuleName

41− --

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

42− | TypeError Type deriving (Show)

64+ deriving (Show, Eq)

65+

66+instance UnificationError Type ErrorMessage where

67+ occursCheckFailed = InfiniteType

68+

69+instance UnificationError Kind ErrorMessage where

70+ occursCheckFailed = InfiniteKind

44-- |

72-- |

45−-- Compilation errors

73+-- Pretty print an ErrorMessage

46−--

47−data CompileError

48− = CompileError

49− { -- |

74+--

50− -- Error message

75+prettyPrintErrorMessage :: ErrorMessage -> String

51− --

76+prettyPrintErrorMessage CannotReorderOperators = "Unable to reorder operators"

52− compileErrorMessage :: String

77+prettyPrintErrorMessage OverlappingNamesInLet = "Overlapping names in let binding."

53− -- |

78+prettyPrintErrorMessage (InfiniteType ty) = "Infinite type detected: " ++ prettyPrintType ty

54− -- The value where the error occurred

79+prettyPrintErrorMessage (InfiniteKind ki) = "Infinite kind detected: " ++ prettyPrintKind ki

55− --

80+prettyPrintErrorMessage (MultipleFixities name) = "Multiple fixity declarations for " ++ show name

56− , compileErrorValue :: Maybe ErrorSource

81+prettyPrintErrorMessage (OrphanTypeDeclaration pn) = "Orphan type declaration for: " ++ show pn

57− -- |

82+prettyPrintErrorMessage (RedefinedModule name) = "Module " ++ show name ++ " has been defined multiple times"

58− -- Optional source position information

83+prettyPrintErrorMessage (UnknownModule mn) = "Unknown module: " ++ show mn

59− --

84+prettyPrintErrorMessage (UnknownType name) = "Unknown type: " ++ show name

60− , compileErrorPosition :: Maybe SourceSpan

85+prettyPrintErrorMessage (UnknownTypeClass name) = "Unknown type class: " ++ show name

61− }

86+prettyPrintErrorMessage (UnknownValue name) = "Unknown value: " ++ show name

62− deriving (Show)

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

100

64-- |

101-- |

65-- A stack trace for an error

102-- A stack trace for an error

66--

103--

67−data ErrorStack

104+newtype MultipleErrors = MultipleErrors

68− = ErrorStack { runErrorStack :: [CompileError] }

105+ { runMultipleErrors :: [ErrorMessage] } deriving (Show, Eq, Monoid)

69− | MultipleErrors [ErrorStack] deriving (Show)

106

71−-- TODO: Remove strMsg, the IsString instance, and unnecessary

107+-- |

72−-- OverloadedStrings pragmas. See #745

108+-- Simplify an error message

73−-- | Create an ErrorStack from a string

109+--

74−strMsg :: String -> ErrorStack

110+simplifyErrorMessage :: ErrorMessage -> ErrorMessage

75−strMsg s = ErrorStack [CompileError s Nothing Nothing]

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

121

77−instance IsString ErrorStack where

122+-- |

78− fromString = strMsg

123+-- Create an error set from a single error message

124+--

125+errorMessage :: ErrorMessage -> MultipleErrors

126+errorMessage err = MultipleErrors [err]

127

80−prettyPrintErrorStack :: Bool -> ErrorStack -> String

128+-- |

81−prettyPrintErrorStack printFullStack (ErrorStack es) =

129+-- Lift a function on ErrorMessage to a function on MultipleErrors

82− case mconcat $ map (Last . compileErrorPosition) es of

130+--

83− Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'

131+onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors

84− _ -> prettyPrintErrorStack'

132+onErrorMessages f = MultipleErrors . map f . runMultipleErrors

85− where

133+

86− prettyPrintErrorStack' :: String

134+-- |

87− prettyPrintErrorStack'

135+-- Pretty print a single error, simplifying if necessary

88− | printFullStack = intercalate "\n" (map showError (filter isErrorNonEmpty es))

136+--

89− | otherwise =

137+prettyPrintSingleError :: Bool -> ErrorMessage -> String

90− let

138+prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else simplifyErrorMessage e)

91− es' = filter isErrorNonEmpty es

139+

92− in case length es' of

140+-- |

93− 1 -> showError (head es')

141+-- Pretty print multiple errors

94− _ -> showError (head es') ++ "\n" ++ showError (last es')

142+--

95−prettyPrintErrorStack printFullStack (MultipleErrors es) =

143+prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String

144+prettyPrintMultipleErrors full (MultipleErrors [e]) =

145+ prettyPrintSingleError full e

146+prettyPrintMultipleErrors full (MultipleErrors es) =

96− unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es

147+ unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintSingleError full) es

97−

148+

149+-- |

150+-- Interpret multiple errors in a monad supporting errors

151+--

98−stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a

152+interpretMultipleErrors :: (MonadError String m) => Bool -> Either MultipleErrors a -> m a

99−stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return

153+interpretMultipleErrors printFullStack = either (throwError . prettyPrintMultipleErrors 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)

117

154

118-- |

155-- |

119-- Rethrow an error with a more detailed error message in the case of failure

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

124-- |

161-- |

125-- Rethrow an error with source position information

162-- Rethrow an error with source position information

126--

163--

127−rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a

164+rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a

128−rethrowWithPosition pos = rethrow (positionError pos `combineErrors`)

165+rethrowWithPosition pos = rethrow (onErrorMessages (PositionedError pos))

129

166

130-- |

167-- |

131-- Collect errors in in parallel

168-- Collect errors in in parallel

132--

169--

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]

134parU xs f = forM xs (withError . f) >>= collectErrors

171parU xs f = forM xs (withError . f) >>= collectErrors

135 where

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

137 withError u = catchError (Right <$> u) (return . Left)

174 withError u = catchError (Right <$> u) (return . Left)

138

175

139− collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]

176+ collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]

140 collectErrors es = case lefts es of

177 collectErrors es = case lefts es of

141− [err] -> throwError err

142 [] -> return $ rights es

178 [] -> return $ rights es

143− errs -> throwError $ MultipleErrors errs

179+ errs -> throwError $ fold 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 ]

src/Language/PureScript/Sugar.hs+1−1

@@ -58,7 +58,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S

58--

59-- * Group mutually recursive value and data declarations into binding groups.

60--

61−desugar :: (Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]

61+desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

62desugar = map removeSignedLiterals

63 >>> mapM desugarObjectConstructors

64 >=> mapM desugarOperatorSections

src/Language/PureScript/Sugar/BindingGroups.hs+11−11

@@ -41,7 +41,7 @@ import Language.PureScript.Errors

41-- |

42-- Replace all sets of mutually-recursive declarations in a module with binding groups

43--

44−createBindingGroupsModule :: (Functor m, Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]

44+createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

45createBindingGroupsModule = mapM $ \(Module coms name ds exps) -> Module coms name <$> createBindingGroups name ds <*> pure exps

47-- |

@@ -50,20 +50,20 @@ createBindingGroupsModule = mapM $ \(Module coms name ds exps) -> Module coms na

50collapseBindingGroupsModule :: [Module] -> [Module]

51collapseBindingGroupsModule = map $ \(Module coms name ds exps) -> Module coms name (collapseBindingGroups ds) exps

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]

54createBindingGroups moduleName = mapM f <=< handleDecls

56 where

57 (f, _, _) = everywhereOnValuesTopDownM return handleExprs return

59− handleExprs :: (Functor m, MonadError ErrorStack m) => Expr -> m Expr

59+ handleExprs :: (Functor m, MonadError MultipleErrors m) => Expr -> m Expr

60 handleExprs (Let ds val) = flip Let val <$> handleDecls ds

61 handleExprs other = return other

63 -- |

64 -- Replace all sets of mutually-recursive declarations with binding groups

65 --

66− handleDecls :: (Functor m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]

66+ handleDecls :: (Functor m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

67 handleDecls ds = do

68 let values = filter isValueDecl ds

69 dataDecls = filter isDataDecl ds

@@ -154,7 +154,7 @@ getProperName _ = error "Expected DataDeclaration"

154-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

155--

156--

157−toBindingGroup :: (Functor m, MonadError ErrorStack m) => ModuleName -> SCC Declaration -> m Declaration

157+toBindingGroup :: (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration

158toBindingGroup _ (AcyclicSCC d) = return d

159toBindingGroup _ (CyclicSCC [d]) = return d

160toBindingGroup moduleName (CyclicSCC ds') =

@@ -175,24 +175,24 @@ toBindingGroup moduleName (CyclicSCC ds') =

175 valueVerts :: [(Declaration, Ident, [Ident])]

176 valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'

177

178− toBinding :: (MonadError ErrorStack m) => SCC Declaration -> m (Ident, NameKind, Expr)

178+ toBinding :: (MonadError MultipleErrors m) => SCC Declaration -> m (Ident, NameKind, Expr)

179 toBinding (AcyclicSCC d) = return $ fromValueDecl d

180 toBinding (CyclicSCC ~(d:ds)) = cycleError d ds

181

182− cycleError :: (MonadError ErrorStack m) => Declaration -> [Declaration] -> m a

182+ cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a

183 cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds

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

186 cycleError d ds@(_:_) = rethrow (mkCompileError ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing `combineErrors`) $ cycleError d []

187 cycleError _ _ = error "Expected ValueDeclaration"

188

189−toDataBindingGroup :: (MonadError ErrorStack m) => SCC Declaration -> m Declaration

189+toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

190toDataBindingGroup (AcyclicSCC d) = return d

191toDataBindingGroup (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

193 _ -> return d

194toDataBindingGroup (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

196 | otherwise = return $ DataBindingGroupDeclaration ds'

197

198isTypeSynonym :: Declaration -> Maybe ProperName

src/Language/PureScript/Sugar/CaseDeclarations.hs+9−9

@@ -44,17 +44,17 @@ isLeft (Right _) = False

44-- |

45-- Replace all top-level binders in a module with case expressions.

46--

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]

48desugarCasesModule ms = forM ms $ \(Module coms name ds exps) ->

49 rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $

50 Module coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps

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]

53desugarAbs = flip parU f

54 where

55 (f, _, _) = everywhereOnValuesM return replace return

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

58 replace (Abs (Right binder) val) = do

59 ident <- Ident <$> freshName

60 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]

@@ -63,10 +63,10 @@ desugarAbs = flip parU f

63-- |

64-- Replace all top-level binders with case expressions.

65--

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]

67desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup

68 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]

70 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

71 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest

72 desugarRest (ValueDeclaration name nameKind bs result : rest) =

@@ -89,7 +89,7 @@ inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2

89inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2

90inSameGroup _ _ = False

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]

93toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do

94 let args = map (\(VarBinder arg) -> arg) bs

95 body = foldr (Abs . Left) val args

@@ -98,9 +98,9 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs =

98toDecls ds@(ValueDeclaration ident _ bs result : _) = do

99 let tuples = map toTuple ds

100 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

102 unless (not (null bs) || isLeft result) $

103− throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing

103+ throwError $ mkMultipleErrors ("Duplicate value declaration '" ++ show ident ++ "'") Nothing

104 caseDecl <- makeCaseDeclaration ident tuples

105 return [caseDecl]

106toDecls (PositionedDeclaration pos com d : ds) = do

@@ -117,7 +117,7 @@ toTuple (ValueDeclaration _ _ bs result) = (bs, result)

117toTuple (PositionedDeclaration _ _ d) = toTuple d

118toTuple _ = error "Not a value declaration"

119

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

121makeCaseDeclaration ident alternatives = do

122 let argPattern = length . fst . head $ alternatives

123 args <- map Ident <$> replicateM argPattern freshName

src/Language/PureScript/Sugar/DoNotation.hs+4−4

@@ -35,10 +35,10 @@ import Control.Monad.Supply.Class

35-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,

36-- and all @DoNotationLet@ constructors with let expressions.

37--

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

39desugarDoModule (Module coms mn ds exts) = Module coms mn <$> parU ds desugarDo <*> pure exts

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

42desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)

43desugarDo d =

44 let (f, _, _) = everywhereOnValuesM return replace return

@@ -61,7 +61,7 @@ desugarDo d =

61 go (DoNotationValue val : rest) = do

62 rest' <- go rest

63 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

65 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

66 go (DoNotationBind (VarBinder ident) val : rest) = do

67 rest' <- go rest

@@ -70,7 +70,7 @@ desugarDo d =

70 rest' <- go rest

71 ident <- Ident <$> freshName

72 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

74 go (DoNotationLet ds : rest) = do

75 rest' <- go rest

76 return $ Let ds rest'

src/Language/PureScript/Sugar/Names.hs+53−63

@@ -87,7 +87,7 @@ data ImportEnvironment = ImportEnvironment

87-- Updates the exports for a module from the global environment. If the module was not previously

88-- present in the global environment, it is created.

89--

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

91updateExportedModule env mn update = do

92 let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env

93 exports' <- update exports

@@ -96,61 +96,61 @@ updateExportedModule env mn update = do

96-- |

97-- Adds an empty module to an ExportEnvironment.

98--

99−addEmptyModule :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> m ExportEnvironment

99+addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> m ExportEnvironment

100addEmptyModule env name =

101 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

103 else return $ M.insert name (Exports [] [] []) env

104

105-- |

106-- Adds a type belonging to a module to the export environment.

107--

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

109addType env mn name dctors = updateExportedModule env mn $ \m -> do

110 let exTypes = exportedTypes m

111 let exDctors = snd `concatMap` exTypes

112 let exClasses = exportedTypeClasses m

113− when (any ((== name) . fst) exTypes) $ throwMultipleDefError "type" name

113+ when (any ((== name) . fst) exTypes) $ throwConflictError ConflictingTypeDecls name

114− when (name `elem` exClasses) $ throwConflictingDefError "Type" "type class" name

114+ when (name `elem` exClasses) $ throwConflictError TypeConflictsWithClass name

115 forM_ dctors $ \dctor -> do

116− when (dctor `elem` exDctors) $ throwMultipleDefError "data constructor" dctor

116+ when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

117− when (dctor `elem` exClasses) $ throwConflictingDefError "Data constructor" "type class" dctor

117+ when (dctor `elem` exClasses) $ throwConflictError CtorConflictsWithClass dctor

118 return $ m { exportedTypes = (name, dctors) : exTypes }

119

120-- |

121-- Adds a class to the export environment.

122--

123−addTypeClass :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment

123+addTypeClass :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment

124addTypeClass env mn name = updateExportedModule env mn $ \m -> do

125 let exTypes = exportedTypes m

126 let exDctors = snd `concatMap` exTypes

127− when (any ((== name) . fst) exTypes) $ throwConflictingDefError "Type class" "type" name

127+ when (any ((== name) . fst) exTypes) $ throwConflictError ClassConflictsWithType name

128− when (name `elem` exDctors) $ throwConflictingDefError "Type class" "data constructor" name

128+ when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

129− classes <- addExport "type class" (exportedTypeClasses m) name

129+ classes <- addExport DuplicateClassExport (exportedTypeClasses m) name

130 return $ m { exportedTypeClasses = classes }

131

132-- |

133-- Adds a class to the export environment.

134--

135−addValue :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment

135+addValue :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment

136addValue env mn name = updateExportedModule env mn $ \m -> do

137− values <- addExport "value" (exportedValues m) name

137+ values <- addExport DuplicateValueExport (exportedValues m) name

138 return $ m { exportedValues = values }

139

140-- |

141-- Adds an entry to a list of exports unless it is already present, in which case an error is

142-- returned.

143--

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]

145addExport what exports name =

146 if name `elem` exports

147− then throwMultipleDefError what name

147+ then throwConflictError what name

148 else return $ name : exports

149

150-- |

151-- Replaces all local names with qualified names within a set of modules.

152--

153−desugarImports :: forall m. (Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]

153+desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

154desugarImports modules = do

155 unfilteredExports <- findExports modules

156 exports <- foldM filterModuleExports unfilteredExports modules

@@ -168,7 +168,7 @@ desugarImports modules = do

168 -- the module has access to an unfiltered list of its own members.

169 renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module

170 renameInModule' unfilteredExports exports m@(Module _ mn _ _) =

171− rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ do

171+ rethrow (onErrorMessages (ErrorInModule mn)) $ do

172 let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports

173 let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports

174 imports <- resolveImports env m

@@ -205,7 +205,7 @@ elaborateImports (Module coms mn decls exps) = Module coms mn decls' exps

205-- Replaces all local names with qualified names within a module and checks that all existing

206-- qualified names are valid.

207--

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

209renameInModule imports exports (Module coms mn decls exps) =

210 Module coms mn <$> parU decls go <*> pure exps

211 where

@@ -236,7 +236,7 @@ renameInModule imports exports (Module coms mn decls exps) =

236 let args = mapMaybe letBoundVariable ds

237 unless (length (nub args) == length args) $

238 maybe id rethrowWithPosition pos $

239− throwError $ mkErrorStack ("Overlapping names in let binding.") Nothing

239+ throwError . errorMessage $ OverlappingNamesInLet

240 return ((pos, args ++ bound), Let ds val')

241 where

242 updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =

@@ -271,28 +271,28 @@ renameInModule imports exports (Module coms mn decls exps) =

271

272 updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)

273

274− updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))

274+ updateTypeName = update UnknownType importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))

275− updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)

275+ updateClassName = update UnknownTypeClass importedTypeClasses (flip elem . exportedTypeClasses)

276− updateValueName = update "value" importedValues (flip elem . exportedValues)

276+ updateValueName = update UnknownValue importedValues (flip elem . exportedValues)

277− updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))

277+ updateDataConstructorName = update (flip UnknownDataConstructor Nothing) importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))

278

279 -- Update names so unqualified references become qualified, and locally qualified references

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

282 -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))

283 -> (Exports -> a -> Bool)

284 -> Qualified a

285 -> Maybe SourceSpan

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

288 (Just qname', _) -> return qname'

289 (Nothing, Just mn'') -> do

290− when (isExplicitQualModule mn'') $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing

290+ when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname

291 modExports <- getExports mn''

292 if checkE modExports name

293 then return qname

294− else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing

294+ else throwError . errorMessage $ unknown qname

295− _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing

295+ _ -> throwError . errorMessage $ unknown qname

296 where

297 isExplicitQualModule :: ModuleName -> Bool

298 isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')

@@ -303,12 +303,12 @@ renameInModule imports exports (Module coms mn decls exps) =

303

304 -- Gets the exports for a module, or an error message if the module doesn't exist

305 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

307

308-- |

309-- Finds all exported declarations in a set of modules.

310--

311−findExports :: forall m. (Applicative m, MonadError ErrorStack m) => [Module] -> m ExportEnvironment

311+findExports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m ExportEnvironment

312findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports

313 where

314

@@ -321,7 +321,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri

321 addModule :: ExportEnvironment -> Module -> m ExportEnvironment

322 addModule env (Module _ mn ds _) = do

323 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

325

326 -- Add a declaration from a module to the global export environment

327 addDecl :: ModuleName -> ExportEnvironment -> Declaration -> m ExportEnvironment

@@ -344,10 +344,10 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri

344-- Filters the exports for a module to ensure only explicit exports are kept in the global exports

345-- environment.

346--

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

348filterExports mn exps env = do

349 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

351 return $ M.insert mn moduleExports' env

352 where

353

@@ -364,7 +364,7 @@ filterExports mn exps env = do

364 filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]

365 filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r

366 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

368 dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons

369 return $ (name, dcons') : result

370 filterTypes _ result _ = return result

@@ -374,7 +374,7 @@ filterExports mn exps env = do

374 filterDcons tcon exps' result name =

375 if name `elem` exps'

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

378

379 -- Ensure the exported classes exist in the module and add them to the set of exports

380 filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]

@@ -382,7 +382,7 @@ filterExports mn exps env = do

382 filterClasses exps' result (TypeClassRef name) =

383 if name `elem` exps'

384 then return $ name : result

385− else throwError $ mkErrorStack ("Cannot export undefined type class '" ++ show name ++ "'") Nothing

385+ else throwError . errorMessage $ UnknownTypeClass name

386 filterClasses _ result _ = return result

387

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

391 filterValues exps' result (ValueRef name) =

392 if name `elem` exps'

393 then return $ name : result

394− else throwError $ mkErrorStack ("Cannot export undefined value '" ++ show name ++ "'") Nothing

394+ else throwError . errorMessage $ UnknownValue name

395 filterValues _ result _ = return result

396

397-- |

@@ -408,7 +408,7 @@ findImports = foldl (findImports' Nothing) M.empty

408-- |

409-- Constructs a local environment for a module.

410--

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

412resolveImports env (Module _ currentModule decls _) =

413 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

414 where

@@ -421,7 +421,7 @@ resolveImports env (Module _ currentModule decls _) =

421

422 resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> m ImportEnvironment

423 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

425 positioned $ resolveImport currentModule mn modExports imp impQual typ

426 where

427 positioned err = case pos of

@@ -431,7 +431,7 @@ resolveImports env (Module _ currentModule decls _) =

431-- |

432-- Extends the local environment for a module by resolving an import of another module.

433--

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

435resolveImport currentModule importModule exps imps impQual =

436 resolveByType

437 where

@@ -492,14 +492,14 @@ resolveImport currentModule importModule exps imps impQual =

492 check (PositionedDeclarationRef pos _ r) =

493 rethrowWithPosition pos $ check r

494 check ref@(ValueRef name) =

495− checkImportExists "value" values name >> return ref

495+ checkImportExists UnknownValue values name >> return ref

496 check ref@(TypeRef name dctors) = do

497− _ <- checkImportExists "type" availableTypes name

497+ _ <- checkImportExists UnknownType availableTypes name

498 let allDctors = allExportedDataConstructors name

499 _ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors

500 return ref

501 check ref@(TypeClassRef name) =

502− checkImportExists "type class" classes name >> return ref

502+ checkImportExists UnknownTypeClass classes name >> return ref

503 check _ = error "Invalid argument to checkRefIsValid"

504

505 -- Find all exported data constructors for a given type

@@ -511,11 +511,11 @@ resolveImport currentModule importModule exps imps impQual =

511 updateImports m name = case M.lookup (Qualified impQual name) m of

512 Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m

513 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

515 where

516 err = if mn == currentModule || importModule == currentModule

517− then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"

517+ then ConflictingImport (show name) mn

518− else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"

518+ else ConflictingImports (show name) mn importModule

519

520 -- The available values, types, and classes in the module being imported

521 values = exportedValues exps

@@ -525,27 +525,17 @@ resolveImport currentModule importModule exps imps impQual =

525 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

526 -- from

527 checkDctorExists :: [ProperName] -> ProperName -> m ProperName

528− checkDctorExists = checkImportExists "data constructor"

528+ checkDctorExists = checkImportExists (flip UnknownDataConstructor Nothing)

529

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

531+ checkImportExists :: (Eq a, Show a) => (Qualified a -> ErrorMessage) -> [a] -> a -> m a

532− checkImportExists t exports item =

532+ checkImportExists unknown exports item =

533 if item `elem` exports

534 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

536

537-- |

538-- Raises an error for when there is more than one definition for something.

539--

540−throwMultipleDefError :: (Applicative m, MonadError ErrorStack m, Show a) => String -> a -> m b

540+throwConflictError :: (Applicative m, MonadError MultipleErrors m, Show a) => (a -> ErrorMessage) -> a -> m b

541−throwMultipleDefError what name = throwError $

541+throwConflictError conflict = throwError . errorMessage . conflict

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−

src/Language/PureScript/Sugar/ObjectWildcards.hs+1−1

@@ -31,7 +31,7 @@ import Language.PureScript.AST

31import Language.PureScript.Errors

32import Language.PureScript.Names

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

35desugarObjectConstructors (Module coms mn ds exts) = Module coms mn <$> mapM desugarDecl ds <*> pure exts

36 where

src/Language/PureScript/Sugar/Operators.hs+8−8

@@ -49,7 +49,7 @@ import qualified Language.PureScript.Constants as C

49-- |

50-- Remove explicit parentheses and reorder binary operator applications

51--

52−rebracket :: (Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]

52+rebracket :: (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

53rebracket ms = do

54 let fixities = concatMap collectFixities ms

55 ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities

@@ -64,7 +64,7 @@ removeSignedLiterals (Module coms mn ds exts) = Module coms mn (map f' ds) exts

64 go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val

65 go other = other

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

68rebracketModule opTable (Module coms mn ds exts) =

69 let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return

70 in Module coms mn <$> (map removeParens <$> parU ds f) <*> pure exts

@@ -85,15 +85,15 @@ collectFixities (Module _ moduleName ds _) = concatMap collect ds

85 collect FixityDeclaration{} = error "Fixity without srcpos info"

86 collect _ = []

88−ensureNoDuplicates :: (MonadError ErrorStack m) => [(Qualified Ident, SourceSpan)] -> m ()

88+ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()

89ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

90 where

91 go [] = return ()

92 go [_] = return ()

93 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)) $

95 rethrowWithPosition pos $

96− throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing

96+ throwError . errorMessage $ MultipleFixities name

97 go (_ : rest) = go rest

99customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]

@@ -108,7 +108,7 @@ customOperatorTable fixities =

108

109type Chain = [Either Expr Expr]

110

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

112matchOperators ops = parseChains

113 where

114 parseChains :: Expr -> m Expr

@@ -118,7 +118,7 @@ matchOperators ops = parseChains

118 extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r

119 extendChain other = [Left other]

120 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"

122 opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]

123 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

124 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

@@ -151,7 +151,7 @@ matchOp op = do

151 ident <- parseOp

152 guard $ ident == op

153

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

155desugarOperatorSections (Module coms mn ds exts) = Module coms mn <$> mapM goDecl ds <*> pure exts

156 where

157

src/Language/PureScript/Sugar/TypeClasses.hs+8−8

@@ -51,10 +51,10 @@ type Desugar = StateT MemberMap

51-- Add type synonym declarations for type class dictionary types, and value declarations for type class

52-- instance dictionary expressions.

53--

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]

55desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

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

58desugarModule (Module coms name decls (Just exps)) = do

59 (newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps)

60 return $ Module coms name (concat declss) $ Just (exps ++ catMaybes newExpss)

@@ -154,7 +154,7 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"

154-- return new Sub(fooString, "");

155-- };

156-}

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

158desugarDecl mn exps = go

159 where

160 go d@(TypeClassDeclaration name args implies members) = do

@@ -224,18 +224,18 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type

224unit :: Type

225unit = TypeApp tyObject REmpty

226

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

228typeInstanceDictionaryDeclaration name mn deps className tys decls =

229 rethrow (mkCompileError ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") Nothing `combineErrors`) $ do

230 m <- get

231

232 -- Lookup the type arguments and member types for the type class

233 (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 $

235 M.lookup (qualify mn className) m

236

237 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

239 [] -> do

240

241 let instanceTys = map memberToNameAndType tyDecls

@@ -270,9 +270,9 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

270 declName (TypeDeclaration ident _) = Just ident

271 declName _ = Nothing

272

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

274 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'

276 return val

277 memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do

278 val <- memberToValue tys' d

src/Language/PureScript/Sugar/TypeDeclarations.hs+6−6

@@ -35,15 +35,15 @@ import Language.PureScript.Traversals

35-- |

36-- Replace all top level type declarations in a module with type annotations

37--

38−desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]

38+desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

39desugarTypeDeclarationsModule ms = forM ms $ \(Module coms name ds exps) ->

40− rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $

40+ rethrow (onErrorMessages (ErrorInModule name)) $

41 Module coms name <$> desugarTypeDeclarations ds <*> pure exps

43-- |

44-- Replace all top level type declarations with type annotations

45--

46−desugarTypeDeclarations :: (Functor m, Applicative m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]

46+desugarTypeDeclarations :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

47desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do

48 (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)

49 return (PositionedDeclaration pos com d' : ds')

@@ -51,13 +51,13 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

51 (_, nameKind, val) <- fromValueDeclaration d

52 desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

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

55 fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)

56 fromValueDeclaration (PositionedDeclaration pos com d') = do

57 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

58 return (ident, nameKind, PositionedValue pos com val)

59− fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing

59+ fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

60−desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing

60+desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError . errorMessage $ OrphanTypeDeclaration name

61desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

62 let (_, f, _) = everywhereOnValuesTopDownM return go return

63 f' (Left gs) = Left <$> mapM (pairM return f) gs

src/Language/PureScript/TypeChecker.hs+1−1

@@ -106,7 +106,7 @@ checkTypeClassInstance _ (TypeConstructor ctor) = do

106 when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed"

107 return ()

108checkTypeClassInstance 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))

110

111-- |

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

192 go c@(TypeConstructor v) = do

193 env <- liftCheck getEnv

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

196 Just (kind, _) -> return kind

197 go (TypeApp t1 t2) = do

198 k0 <- fresh

src/Language/PureScript/TypeChecker/Monad.hs+9−9

@@ -109,7 +109,7 @@ makeBindingGroupVisible action = do

109-- |

110-- Lookup the type of a value by name in the @Environment@

111--

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

113lookupVariable currentModule (Qualified moduleName var) = do

114 env <- getEnv

115 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

@@ -119,7 +119,7 @@ lookupVariable currentModule (Qualified moduleName var) = do

119-- |

120-- Lookup the visibility of a value by name in the @Environment@

121--

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

123getVisibility currentModule (Qualified moduleName var) = do

124 env <- getEnv

125 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

@@ -129,7 +129,7 @@ getVisibility currentModule (Qualified moduleName var) = do

129-- |

130-- Assert that a name is visible

131--

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

133checkVisibility currentModule name@(Qualified _ var) = do

134 vis <- getVisibility currentModule name

135 case vis of

@@ -139,7 +139,7 @@ checkVisibility currentModule name@(Qualified _ var) = do

139-- |

140-- Lookup the kind of a type by name in the @Environment@

141--

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

143lookupTypeVariable currentModule (Qualified moduleName name) = do

144 env <- getEnv

145 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

@@ -171,8 +171,8 @@ data CheckState = CheckState {

171-- |

172-- The type checking monad, which provides the state of the type checker, and error reporting capabilities

173--

174−newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a }

174+newtype Check a = Check { unCheck :: StateT CheckState (Either MultipleErrors) a }

175− deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError ErrorStack)

175+ deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError MultipleErrors)

176

177-- |

178-- Get the current @Environment@

@@ -204,9 +204,9 @@ runCheck = runCheck' initEnvironment

204runCheck' :: (MonadReader (Options mode) m, MonadError String m) => Environment -> Check a -> m (a, Environment)

205runCheck' env c = do

206 verbose <- asks optionsVerboseErrors

207− stringifyErrorStack verbose $ do

207+ interpretMultipleErrors verbose $ do

208− (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c

208+ (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c

209− return (a, checkEnv s)

209+ return (a, checkEnv s)

210

211-- |

212-- Make an assertion, failing with an error message

src/Language/PureScript/TypeChecker/Rows.hs+1−1

@@ -53,7 +53,7 @@ checkDuplicateLabels =

53 checkDups r@RCons{} =

54 let (ls, _) = rowToList r in

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

57 Nothing -> return ()

58 checkDups _ = return ()

src/Language/PureScript/TypeChecker/Skolems.hs+2−2

@@ -89,7 +89,7 @@ skolemEscapeCheck root@TypedValue{} =

89 let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def

90 in case f root of

91 [] -> 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))

93 where

94 def s _ = (s, [])

@@ -112,4 +112,4 @@ skolemEscapeCheck root@TypedValue{} =

112 where

113 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)

114 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 =

83 in

84 saturateAllTypeSynonyms syns d

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

87replaceAllTypeSynonyms d = do

88 env <- getEnv

89 either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d

@@ -99,12 +99,12 @@ expandTypeSynonym' env name args =

99 replaceAllTypeSynonyms' env repl

100 Nothing -> error "Type synonym was not defined"

101

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

103expandTypeSynonym name args = do

104 env <- getEnv

105 either (throwError . strMsg) return $ expandTypeSynonym' env name args

106

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

108expandAllTypeSynonyms = everywhereOnTypesTopDownM go

109 where

110 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

568 return $ TypedValue True val' kt

569check' (PositionedValue pos _ val) ty =

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

572

573containsTypeSynonyms :: Type -> Bool

574containsTypeSynonyms = everythingOnTypes (||) go where

@@ -589,8 +589,8 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

589 return []

590 go [] [] Skolem{} | lax = return []

591 go [] ((p, _): _) _ | lax = return []

592− | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))

592+ | otherwise = throwError $ mkMultipleErrors ("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)))

593+ go ((p,_):_) [] REmpty = throwError $ mkMultipleErrors ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))

594 go ((p,v):ps') ts r =

595 case lookup p ts of

596 Nothing -> do

@@ -603,7 +603,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

603 v' <- check v ty

604 ps'' <- go ps' (delete (p, ty) ts) r

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

607

608-- |

609-- Check the type of a function application, rethrowing errors to provide a better error message