d7f4923 · rowtype-yoga/purescript-native

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

Use ErrorStack everywhere

commitd7f492332d3f020f30296e34a96fc3c95a248ddb authorGary Burgess <gary.burgess@gmail.com> dateSat 29 Mar 2014, 18:28 (13 years ago) parent4326d49

14 files changed+158−164

compare with golang

unifiedsplit

src/Language/PureScript.hs+5−4

@@ -28,6 +28,7 @@ import Language.PureScript.Sugar as P

2828import Language.PureScript.Options as P

2929import Language.PureScript.ModuleDependencies as P

3030import Language.PureScript.Environment as P

31+import Language.PureScript.Errors as P

3132import Language.PureScript.DeadCodeElimination as P

3233

3334import qualified Language.PureScript.Constants as C

@@ -70,9 +71,9 @@ compile = compile' initEnvironment

7071compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment)

7172compile' env opts ms = do

7273 (sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)

73− desugared <- desugar sorted

74+ desugared <- stringifyErrorStack True $ desugar sorted

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

75− regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

76+ regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

7677 let entryPoints = moduleNameFromString `map` optionsModules opts

7778 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped

7879 let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts

@@ -184,7 +185,7 @@ make opts ms = do

184185

185186 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

186187

187− desugared <- liftError $ zip (map fst marked) <$> desugar (map snd marked)

188+ desugared <- liftError $ stringifyErrorStack True $ zip (map fst marked) <$> desugar (map snd marked)

188189

189190 go initEnvironment desugared

190191

@@ -202,7 +203,7 @@ make opts ms = do

202203

203204 (Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m

204205

205− regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

206+ regrouped <- liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

206207

207208 let mod' = Module moduleName' regrouped exps

208209 js = moduleToJs opts mod' env'

src/Language/PureScript/Errors.hs+26−23

@@ -12,7 +12,7 @@

1212--

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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

1616

1717module Language.PureScript.Errors where

1818

@@ -22,7 +22,6 @@ import Data.Monoid

2222import Control.Monad.Error

2323

2424import Language.PureScript.Declarations

25−import Language.PureScript.Names

2625import Language.PureScript.Pretty

2726import Language.PureScript.Types

2827

@@ -30,18 +29,10 @@ import Language.PureScript.Types

3029-- Type for sources of type checking errors

3130--

3231data ErrorSource

33− -- |

34− -- An error which originated in a module

35− --

36− = ModuleError ModuleName

37− -- |

38− -- An error which originated at a Declaration

39− --

40− | DeclarationError (Either ProperName Ident)

4132 -- |

4233 -- An error which originated at a Value

4334 --

44− | ValueError Value

35+ = ValueError Value

4536 -- |

4637 -- An error which originated at a Type

4738 --

@@ -68,21 +59,21 @@ data CompileError = CompileError {

6859-- |

6960-- A stack trace for an error

7061--

71−newtype ErrorStack = ErrorStack { runUnifyErrorStack :: [CompileError] } deriving (Show, Monoid)

62+newtype ErrorStack = ErrorStack { runErrorStack :: [CompileError] } deriving (Show, Monoid)

7263

7364instance Error ErrorStack where

7465 strMsg s = ErrorStack [CompileError s Nothing Nothing]

7566 noMsg = ErrorStack []

7667

7768prettyPrintErrorStack :: Bool -> ErrorStack -> String

78−prettyPrintErrorStack printAll (ErrorStack es) =

69+prettyPrintErrorStack printFullStack (ErrorStack es) =

7970 case mconcat $ map (Last . compileErrorPosition) es of

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

81− _ -> prettyPrintUnifyErrorStack'

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

72+ _ -> prettyPrintErrorStack'

8273 where

83− prettyPrintUnifyErrorStack' :: String

84− prettyPrintUnifyErrorStack'

85− | printAll = intercalate "\n" (map showError (filter isErrorNonEmpty es))

74+ prettyPrintErrorStack' :: String

75+ prettyPrintErrorStack'

76+ | printFullStack = intercalate "\n" (map showError (filter isErrorNonEmpty es))

8677 | otherwise =

8778 let

8879 es' = filter isErrorNonEmpty es

@@ -90,19 +81,31 @@ prettyPrintErrorStack printAll (ErrorStack es) =

9081 1 -> showError (head es')

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

9283

84+stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a

85+stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right

86+

9387isErrorNonEmpty :: CompileError -> Bool

9488isErrorNonEmpty = not . null . compileErrorMessage

9589

9690showError :: CompileError -> String

9791showError (CompileError msg Nothing _) = msg

98−showError (CompileError msg (Just (ModuleError mn)) _) = "Error in module " ++ runModuleName mn ++ ":\n" ++ msg

99−showError (CompileError msg (Just (DeclarationError (Left pn))) _) = "Error in declaration " ++ show pn ++ ":\n" ++ msg

100−showError (CompileError msg (Just (DeclarationError (Right i))) _) = "Error in declaration " ++ show i ++ ":\n" ++ msg

10192showError (CompileError msg (Just (ValueError val)) _) = "Error in value " ++ prettyPrintValue val ++ ":\n" ++ msg

10293showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg

10394

104−mkUnifyErrorStack :: String -> Maybe ErrorSource -> ErrorStack

105−mkUnifyErrorStack msg t = ErrorStack [CompileError msg t Nothing]

95+mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack

96+mkErrorStack msg t = ErrorStack [CompileError msg t Nothing]

10697

10798positionError :: SourcePos -> ErrorStack

10899positionError pos = ErrorStack [CompileError "" Nothing (Just pos)]

100+

101+-- |

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

103+--

104+rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

105+rethrow f = flip catchError $ \e -> throwError (f e)

106+

107+-- |

108+-- Rethrow an error with source position information

109+--

110+rethrowWithPosition :: (MonadError ErrorStack m) => SourcePos -> m a -> m a

111+rethrowWithPosition pos = rethrow (positionError pos <>)

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

@@ -18,6 +18,7 @@ module Language.PureScript.Sugar (desugar, module S) where

1818import Control.Monad

1919

2020import Language.PureScript.Declarations

21+import Language.PureScript.Errors

2122

2223import Language.PureScript.Sugar.Operators as S

2324import Language.PureScript.Sugar.DoNotation as S

@@ -46,7 +47,7 @@ import Control.Category ((>>>))

4647--

4748-- * Qualify any unqualified names and types

4849--

49−desugar :: [Module] -> Either String [Module]

50+desugar :: [Module] -> Either ErrorStack [Module]

5051desugar = removeSignedLiterals

5152 >>> desugarDo

5253 >=> desugarCasesModule

src/Language/PureScript/Sugar/BindingGroups.hs+7−6

@@ -33,11 +33,12 @@ import Language.PureScript.Declarations

3333import Language.PureScript.Names

3434import Language.PureScript.Types

3535import Language.PureScript.Environment

36+import Language.PureScript.Errors

3637

3738-- |

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

3940--

40−createBindingGroupsModule :: [Module] -> Either String [Module]

41+createBindingGroupsModule :: [Module] -> Either ErrorStack [Module]

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

4243

4344-- |

@@ -49,7 +50,7 @@ collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (colla

4950-- |

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

5152--

52−createBindingGroups :: ModuleName -> [Declaration] -> Either String [Declaration]

53+createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration]

5354createBindingGroups moduleName ds = do

5455 values <- mapM (createBindingGroupsForValue moduleName) $ filter isValueDecl ds

5556 let dataDecls = filter isDataDecl ds

@@ -68,7 +69,7 @@ createBindingGroups moduleName ds = do

6869 filter isExternDecl ds ++

6970 bindingGroupDecls

7071

71−createBindingGroupsForValue :: ModuleName -> Declaration -> Either String Declaration

72+createBindingGroupsForValue :: ModuleName -> Declaration -> Either ErrorStack Declaration

7273createBindingGroupsForValue moduleName = everywhereM' (mkM go)

7374 where

7475 go (Let ds val) = Let <$> createBindingGroups moduleName ds <*> pure val

@@ -124,13 +125,13 @@ toBindingGroup (AcyclicSCC d) = d

124125toBindingGroup (CyclicSCC [d]) = d

125126toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'

126127

127−toDataBindingGroup :: SCC Declaration -> Either String Declaration

128+toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration

128129toDataBindingGroup (AcyclicSCC d) = return d

129130toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of

130− Just pn -> Left $ "Cycle in type synonym " ++ show pn

131+ Just pn -> Left $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing

131132 _ -> return d

132133toDataBindingGroup (CyclicSCC ds')

133− | all (isJust . isTypeSynonym) ds' = Left "Cycle in type synonyms"

134+ | all (isJust . isTypeSynonym) ds' = Left $ mkErrorStack "Cycle in type synonyms" Nothing

134135 | otherwise = return $ DataBindingGroupDeclaration ds'

135136

136137isTypeSynonym :: Declaration -> Maybe ProperName

src/Language/PureScript/Sugar/CaseDeclarations.hs+6−5

@@ -31,11 +31,12 @@ import Language.PureScript.Names

3131import Language.PureScript.Declarations

3232import Language.PureScript.Scope

3333import Language.PureScript.Environment

34+import Language.PureScript.Errors

3435

3536-- |

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

3738--

38−desugarCasesModule :: [Module] -> Either String [Module]

39+desugarCasesModule :: [Module] -> Either ErrorStack [Module]

3940desugarCasesModule ms = forM ms $ \(Module name ds exps) -> Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps

4041

4142desugarAbs :: [Declaration] -> [Declaration]

@@ -51,10 +52,10 @@ desugarAbs = everywhere (mkT replace)

5152-- |

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

5354--

54−desugarCases :: [Declaration] -> Either String [Declaration]

55+desugarCases :: [Declaration] -> Either ErrorStack [Declaration]

5556desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup

5657 where

57− desugarRest :: [Declaration] -> Either String [Declaration]

58+ desugarRest :: [Declaration] -> Either ErrorStack [Declaration]

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

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

6061 desugarRest (ValueDeclaration name nameKind bs g val : rest) = do

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

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

7576inSameGroup _ _ = False

7677

77−toDecls :: [Declaration] -> Either String [Declaration]

78+toDecls :: [Declaration] -> Either ErrorStack [Declaration]

7879toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do

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

8081 body = foldr (Abs . Left) val args

@@ -82,7 +83,7 @@ toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs =

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

8384 let tuples = map toTuple ds

8485 unless (all ((== length bs) . length . fst) tuples) $

85− throwError $ "Argument list lengths differ in declaration " ++ show ident

86+ throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing

8687 return [makeCaseDeclaration ident tuples]

8788toDecls (PositionedDeclaration pos d : ds) = do

8889 (d' : ds') <- toDecls (d : ds)

src/Language/PureScript/Sugar/DoNotation.hs+6−5

@@ -24,6 +24,7 @@ import Data.Generics

2424import Language.PureScript.Names

2525import Language.PureScript.Scope

2626import Language.PureScript.Declarations

27+import Language.PureScript.Errors

2728

2829import qualified Language.PureScript.Constants as C

2930

@@ -33,23 +34,23 @@ import Control.Applicative

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

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

3536--

36−desugarDo :: (Data d) => d -> Either String d

37+desugarDo :: (Data d) => d -> Either ErrorStack d

3738desugarDo = everywhereM (mkM replace)

3839 where

3940 prelude :: ModuleName

4041 prelude = ModuleName [ProperName C.prelude]

4142 bind :: Value

4243 bind = Var (Qualified (Just prelude) (Op (C.>>=)))

43− replace :: Value -> Either String Value

44+ replace :: Value -> Either ErrorStack Value

4445 replace (Do els) = go els

4546 replace other = return other

46− go :: [DoNotationElement] -> Either String Value

47+ go :: [DoNotationElement] -> Either ErrorStack Value

4748 go [] = error "The impossible happened in desugarDo"

4849 go [DoNotationValue val] = return val

4950 go (DoNotationValue val : rest) = do

5051 rest' <- go rest

5152 return $ App (App bind val) (Abs (Left (Ident "_")) rest')

52− go [DoNotationBind _ _] = Left "Bind statement cannot be the last statement in a do block"

53+ go [DoNotationBind _ _] = Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing

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

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

5556 rest' <- go rest

@@ -58,7 +59,7 @@ desugarDo = everywhereM (mkM replace)

5859 rest' <- go rest

5960 let ident = head $ unusedNames rest'

6061 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))

61− go [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"

62+ go [DoNotationLet _ _] = Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing

6263 go (DoNotationLet binder val : rest) = do

6364 rest' <- go rest

6465 return $ Case [val] [CaseAlternative [binder] Nothing rest']

src/Language/PureScript/Sugar/Names.hs+69−72

@@ -18,6 +18,7 @@ module Language.PureScript.Sugar.Names (

1818

1919import Data.Data

2020import Data.Maybe (fromMaybe, isJust, mapMaybe)

21+import Data.Monoid ((<>))

2122import Data.Generics (extM, mkM, everywhereM)

2223import Data.Generics.Extras (mkS, extS, everywhereWithContextM')

2324

@@ -30,6 +31,7 @@ import Language.PureScript.Declarations

3031import Language.PureScript.Names

3132import Language.PureScript.Types

3233import Language.PureScript.Environment

34+import Language.PureScript.Errors

3335

3436-- |

3537-- The global export environment - every declaration exported from every module.

@@ -80,7 +82,7 @@ data ImportEnvironment = ImportEnvironment

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

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

8284--

83−updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either String Exports) -> Either String ExportEnvironment

85+updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either ErrorStack Exports) -> Either ErrorStack ExportEnvironment

8486updateExportedModule env mn update = do

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

8688 exports' <- update exports

@@ -89,16 +91,16 @@ updateExportedModule env mn update = do

8991-- |

9092-- Adds an empty module to an ExportEnvironment.

9193--

92−addEmptyModule :: ExportEnvironment -> ModuleName -> Either String ExportEnvironment

94+addEmptyModule :: ExportEnvironment -> ModuleName -> Either ErrorStack ExportEnvironment

9395addEmptyModule env name =

9496 if name `M.member` env

95− then throwError $ "Module '" ++ show name ++ "' has been defined more than once"

97+ then throwError $ mkErrorStack ("Module '" ++ show name ++ "' has been defined more than once") Nothing

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

9799

98100-- |

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

100102--

101−addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment

103+addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment

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

103105 types' <- addExport (exportedTypes m) (name, dctors)

104106 return $ m { exportedTypes = types' }

@@ -106,7 +108,7 @@ addType env mn name dctors = updateExportedModule env mn $ \m -> do

106108-- |

107109-- Adds a class to the export environment.

108110--

109−addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment

111+addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment

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

111113 classes <- addExport (exportedTypeClasses m) name

112114 return $ m { exportedTypeClasses = classes }

@@ -114,7 +116,7 @@ addTypeClass env mn name = updateExportedModule env mn $ \m -> do

114116-- |

115117-- Adds a class to the export environment.

116118--

117−addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment

119+addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment

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

119121 values <- addExport (exportedValues m) name

120122 return $ m { exportedValues = values }

@@ -123,16 +125,16 @@ addValue env mn name = updateExportedModule env mn $ \m -> do

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

124126-- returned.

125127--

126−addExport :: (Eq a, Show a) => [a] -> a -> Either String [a]

128+addExport :: (Eq a, Show a) => [a] -> a -> Either ErrorStack [a]

127129addExport exports name =

128130 if name `elem` exports

129− then throwError $ "Multiple definitions for '" ++ show name ++ "'"

131+ then throwError $ mkErrorStack ("Multiple definitions for '" ++ show name ++ "'") Nothing

130132 else return $ name : exports

131133

132134-- |

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

134136--

135−desugarImports :: [Module] -> Either String [Module]

137+desugarImports :: [Module] -> Either ErrorStack [Module]

136138desugarImports modules = do

137139 unfilteredExports <- findExports modules

138140 exports <- foldM filterModuleExports unfilteredExports modules

@@ -142,30 +144,19 @@ desugarImports modules = do

142144 -- Filters the exports for a module in the global exports environment so that only explicitly

143145 -- exported members remain. If the module does not explicitly export anything, everything is

144146 -- exported.

145− filterModuleExports :: ExportEnvironment -> Module -> Either String ExportEnvironment

147+ filterModuleExports :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment

146148 filterModuleExports env (Module mn _ (Just exps)) = filterExports mn exps env

147149 filterModuleExports env _ = return env

148150

149151 -- Rename and check all the names within a module. We tweak the global exports environment so

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

151− renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either String Module

152− renameInModule' unfilteredExports exports m@(Module mn _ _) = rethrowForModule m $ do

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

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

155− imports <- resolveImports env m

156− renameInModule imports env (elaborateExports exps m)

157−

158−-- |

159−-- Rethrow an error with an extra message line prepended

160−--

161−rethrow :: String -> Either String a -> Either String a

162−rethrow msg = flip catchError $ \e -> throwError (msg ++ ":\n" ++ e)

163−

164−-- |

165−-- Rethrow an error with details of the current module prepended to the message

166−--

167−rethrowForModule :: Module -> Either String a -> Either String a

168−rethrowForModule (Module mn _ _) = rethrow $ "Error in module '" ++ show mn ++ "'"

153+ renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module

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

155+ rethrow (strMsg ("Error in module " ++ show mn) <>) $ do

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

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

158+ imports <- resolveImports env m

159+ renameInModule imports env (elaborateExports exps m)

169160

170161-- |

171162-- Make all exports for a module explicit. This may still effect modules that have an exports list,

@@ -181,23 +172,27 @@ elaborateExports exps (Module mn decls _) = Module mn decls (Just $

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

182173-- qualified names are valid.

183174--

184−renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module

175+renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module

185176renameInModule imports exports (Module mn decls exps) =

186177 Module mn <$> mapM go decls <*> pure exps

187178 where

179+ go :: Declaration -> Either ErrorStack Declaration

188180 go (DataDeclaration name args dctors) =

189− rethrowFor "data declaration" name $ DataDeclaration <$> pure name <*> pure args <*> updateAll dctors

181+ rethrow (strMsg ("Error in data declaration " ++ show name) <>) $

182+ DataDeclaration <$> pure name <*> pure args <*> updateAll dctors

190183 go (DataBindingGroupDeclaration decls') =

191184 DataBindingGroupDeclaration <$> mapM go decls'

192185 go (TypeSynonymDeclaration name ps ty) =

193− rethrowFor "type synonym" name $ TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty

186+ rethrow (strMsg ("Error in type synonym " ++ show name) <>) $

187+ TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty

194188 go (TypeInstanceDeclaration name cs cn ts ds) =

195189 TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts <*> mapM go ds

196190 go (ExternInstanceDeclaration name cs cn ts) =

197191 ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts

198192 go (ValueDeclaration name nameKind [] Nothing val) = do

199193 val' <- everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val

200− rethrowFor "declaration" name $ ValueDeclaration name nameKind [] Nothing <$> updateAll val'

194+ rethrow (strMsg ("Error in declaration " ++ show name) <>) $

195+ ValueDeclaration name nameKind [] Nothing <$> updateAll val'

201196 where

202197 bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val')

203198 bindFunctionArgs bound (Let ds val') = let args = mapMaybe letBoundVariable ds in

@@ -211,7 +206,7 @@ renameInModule imports exports (Module mn decls exps) =

211206 bindFunctionArgs bound (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =

212207 (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2)

213208 bindFunctionArgs bound other = return (bound, other)

214− bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)

209+ bindBinders :: [Ident] -> CaseAlternative -> Either ErrorStack ([Ident], CaseAlternative)

215210 bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)

216211

217212 letBoundVariable :: Declaration -> Maybe Ident

@@ -220,17 +215,18 @@ renameInModule imports exports (Module mn decls exps) =

220215 letBoundVariable _ = Nothing

221216 go (ValueDeclaration name _ _ _ _) = error $ "Binders should have been desugared in " ++ show name

222217 go (ExternDeclaration fit name js ty) =

223− rethrowFor "declaration" name $ ExternDeclaration <$> pure fit <*> pure name <*> pure js <*> updateType' ty

218+ rethrow (strMsg ("Error in declaration " ++ show name) <>) $

219+ ExternDeclaration <$> pure fit <*> pure name <*> pure js <*> updateType' ty

224220 go (BindingGroupDeclaration decls') = do

225221 BindingGroupDeclaration <$> mapM go' decls'

226− where go' = \(name, nk, value) -> rethrowFor "declaration" name $ (,,) <$> pure name <*> pure nk <*> updateAll value

222+ where

223+ go' = \(name, nk, value) ->

224+ rethrow (strMsg ("Error in declaration " ++ show name) <>) $

225+ (,,) <$> pure name <*> pure nk <*> updateAll value

227226 go (PositionedDeclaration pos d) = PositionedDeclaration pos <$> go d

228227 go d = updateAll d

229228

230− rethrowFor :: (Show a) => String -> a -> Either String b -> Either String b

231− rethrowFor what name = rethrow $ "Error in " ++ what ++ " '" ++ show name ++ "'"

232−

233− updateAll :: Data d => d -> Either String d

229+ updateAll :: Data d => d -> Either ErrorStack d

234230 updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)

235231

236232 updateValue (Constructor name) = Constructor <$> updateDataConstructorName name

@@ -243,7 +239,7 @@ renameInModule imports exports (Module mn decls exps) =

243239 updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys

244240 updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t

245241 updateType t = return t

246− updateType' :: Data d => d -> Either String d

242+ updateType' :: Data d => d -> Either ErrorStack d

247243 updateType' = everywhereM (mkM updateType)

248244

249245 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)

@@ -259,24 +255,24 @@ renameInModule imports exports (Module mn decls exps) =

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

260256 -> (Exports -> a -> Bool)

261257 -> (Qualified a)

262− -> Either String (Qualified a)

258+ -> Either ErrorStack (Qualified a)

263259 update t getI checkE qname@(Qualified mn' name) = case (M.lookup qname (getI imports), mn') of

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

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

266262 modExports <- getExports mn''

267263 if checkE modExports name

268264 then return qname

269− else throwError $ "Unknown " ++ t ++ " '" ++ show (qname) ++ "'"

270− _ -> throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'"

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

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

271267

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

273− getExports :: ModuleName -> Either String Exports

274− getExports mn' = maybe (throwError $ "Unknown module '" ++ show mn' ++ "'") return $ M.lookup mn' exports

269+ getExports :: ModuleName -> Either ErrorStack Exports

270+ getExports mn' = maybe (throwError $ mkErrorStack ("Unknown module '" ++ show mn' ++ "'") Nothing) return $ M.lookup mn' exports

275271

276272-- |

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

278274--

279−findExports :: [Module] -> Either String ExportEnvironment

275+findExports :: [Module] -> Either ErrorStack ExportEnvironment

280276findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) primExports

281277 where

282278

@@ -286,13 +282,13 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri

286282 mkTypeEntry (Qualified _ name) = (name, [])

287283

288284 -- Add all of the exported declarations from a module to the global export environment

289− addModule :: ExportEnvironment -> Module -> Either String ExportEnvironment

285+ addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment

290286 addModule env m@(Module mn ds _) = do

291287 env' <- addEmptyModule env mn

292− rethrowForModule m $ foldM (addDecl mn) env' ds

288+ rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds

293289

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

295− addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either String ExportEnvironment

291+ addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment

296292 addDecl mn env (TypeClassDeclaration tcn _ ds) = do

297293 env' <- addTypeClass env mn tcn

298294 foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds

@@ -308,7 +304,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri

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

309305-- environment.

310306--

311−filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either String ExportEnvironment

307+filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment

312308filterExports mn exps env = do

313309 let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)

314310 moduleExports' <- filterModule moduleExports

@@ -316,7 +312,7 @@ filterExports mn exps env = do

316312 where

317313

318314 -- Filter the exports for the specific module

319− filterModule :: Exports -> Either String Exports

315+ filterModule :: Exports -> Either ErrorStack Exports

320316 filterModule exported = do

321317 types' <- foldM (filterTypes $ exportedTypes exported) [] exps

322318 values <- foldM (filterValues $ exportedValues exported) [] exps

@@ -325,34 +321,34 @@ filterExports mn exps env = do

325321

326322 -- Ensure the exported types and data constructors exist in the module and add them to the set of

327323 -- exports

328− filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either String [(ProperName, [ProperName])]

324+ filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])]

329325 filterTypes expTys result (TypeRef name expDcons) = do

330− dcons <- maybe (throwError $ "Cannot export undefined type '" ++ show name ++ "'") return $ name `lookup` expTys

326+ dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys

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

332328 return $ (name, dcons') : result

333329 filterTypes _ result _ = return result

334330

335331 -- Ensure the exported data constructors exists for a type and add them to the list of exports

336− filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either String [ProperName]

332+ filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either ErrorStack [ProperName]

337333 filterDcons tcon exps' result name =

338334 if name `elem` exps'

339335 then return $ name : result

340− else throwError $ "Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'"

336+ else throwError $ mkErrorStack ("Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'") Nothing

341337

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

343− filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either String [ProperName]

339+ filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]

344340 filterClasses exps' result (TypeClassRef name) =

345341 if name `elem` exps'

346342 then return $ name : result

347− else throwError $ "Cannot export undefined type class '" ++ show name ++ "'"

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

348344 filterClasses _ result _ = return result

349345

350346 -- Ensure the exported values exist in the module and add them to the set of exports

351− filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either String [Ident]

347+ filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]

352348 filterValues exps' result (ValueRef name) =

353349 if name `elem` exps'

354350 then return $ name : result

355− else throwError $ "Cannot export undefined value '" ++ show name ++ "'"

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

356352 filterValues _ result _ = return result

357353

358354-- |

@@ -374,7 +370,7 @@ findImports = foldl findImports' M.empty

374370-- |

375371-- Constructs a local environment for a module.

376372--

377−resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment

373+resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnvironment

378374resolveImports env (Module currentModule decls _) =

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

380376 where

@@ -382,25 +378,25 @@ resolveImports env (Module currentModule decls _) =

382378 scope :: M.Map ModuleName (Maybe ExplicitImports, Maybe ModuleName)

383379 scope = M.insert currentModule (Nothing, Nothing) (findImports decls)

384380 resolveImport' imp (mn, (explImports, impQual)) = do

385− modExports <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env

381+ modExports <- maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env

386382 resolveImport currentModule mn modExports imp impQual explImports

387383

388384-- |

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

390386--

391−resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> Maybe ExplicitImports-> Either String ImportEnvironment

387+resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> Maybe ExplicitImports-> Either ErrorStack ImportEnvironment

392388resolveImport currentModule importModule exps imps impQual = maybe importAll (foldM importExplicit imps)

393389 where

394390

395391 -- Import everything from a module

396− importAll :: Either String ImportEnvironment

392+ importAll :: Either ErrorStack ImportEnvironment

397393 importAll = do

398394 imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeRef name (Just dctors))) imps (exportedTypes exps)

399395 imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exps)

400396 foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exps)

401397

402398 -- Import something explicitly

403− importExplicit :: ImportEnvironment -> DeclarationRef -> Either String ImportEnvironment

399+ importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment

404400 importExplicit imp (ValueRef name) = do

405401 _ <- checkImportExists "value" values name

406402 values' <- updateImports (importedValues imp) name

@@ -423,14 +419,15 @@ resolveImport currentModule importModule exps imps impQual = maybe importAll (fo

423419 allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps

424420

425421 -- Add something to the ImportEnvironment if it does not already exist there

426− updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either String (M.Map (Qualified a) (Qualified a))

422+ updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either ErrorStack (M.Map (Qualified a) (Qualified a))

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

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

429425 Just (Qualified Nothing _) -> error "Invalid state in updateImports"

430− Just x@(Qualified (Just mn) _) -> throwError $

431− if mn == currentModule || importModule == currentModule

432− then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"

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

426+ Just x@(Qualified (Just mn) _) -> throwError $ mkErrorStack err Nothing

427+ where

428+ err = if mn == currentModule || importModule == currentModule

429+ then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"

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

434431

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

436433 values = exportedValues exps

@@ -439,14 +436,14 @@ resolveImport currentModule importModule exps imps impQual = maybe importAll (fo

439436

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

441438 -- from

442− checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName

439+ checkDctorExists :: [ProperName] -> ProperName -> Either ErrorStack ProperName

443440 checkDctorExists = checkImportExists "data constructor"

444441

445442 -- Check that an explicitly imported item exists in the module it is being imported from

446− checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either String a

443+ checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack a

447444 checkImportExists t exports item =

448445 if item `elem` exports

449446 then return item

450− else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"

447+ else throwError $ mkErrorStack ("Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'") Nothing

451448

452449

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

@@ -26,6 +26,7 @@ module Language.PureScript.Sugar.Operators (

2626

2727import Language.PureScript.Names

2828import Language.PureScript.Declarations

29+import Language.PureScript.Errors

2930

3031import Control.Applicative

3132import Control.Monad.State

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

4849-- |

4950-- Remove explicit parentheses and reorder binary operator applications

5051--

51−rebracket :: [Module] -> Either String [Module]

52+rebracket :: [Module] -> Either ErrorStack [Module]

5253rebracket ms = do

5354 let fixities = concatMap collectFixities ms

5455 ensureNoDuplicates $ map fst fixities

@@ -63,7 +64,7 @@ removeSignedLiterals = G.everywhere (G.mkT go)

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

6465 go other = other

6566

66−rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either String Module

67+rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either ErrorStack Module

6768rebracketModule opTable (Module mn ds exts) = Module mn <$> (removeParens <$> G.everywhereM' (G.mkM (matchOperators opTable)) ds) <*> pure exts

6869

6970removeParens :: (D.Data d) => d -> d

@@ -80,12 +81,12 @@ collectFixities (Module moduleName ds _) = concatMap collect ds

8081 collect (FixityDeclaration fixity name) = [(Qualified (Just moduleName) (Op name), fixity)]

8182 collect _ = []

8283

83−ensureNoDuplicates :: [Qualified Ident] -> Either String ()

84+ensureNoDuplicates :: [Qualified Ident] -> Either ErrorStack ()

8485ensureNoDuplicates m = go $ sort m

8586 where

8687 go [] = return ()

8788 go [_] = return ()

88− go (x : y : _) | x == y = throwError $ "Redefined fixity for " ++ show x

89+ go (x : y : _) | x == y = throwError $ mkErrorStack ("Redefined fixity for " ++ show x) Nothing

8990 go (_ : rest) = go rest

9091

9192customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]

@@ -100,17 +101,17 @@ customOperatorTable fixities =

100101

101102type Chain = [Either Value (Qualified Ident)]

102103

103−matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value

104+matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either ErrorStack Value

104105matchOperators ops = parseChains

105106 where

106− parseChains :: Value -> Either String Value

107+ parseChains :: Value -> Either ErrorStack Value

107108 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)

108109 parseChains other = return other

109110 extendChain :: Value -> Chain

110111 extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r

111112 extendChain other = [Left other]

112− bracketChain :: Chain -> Either String Value

113− bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

113+ bracketChain :: Chain -> Either ErrorStack Value

114+ bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

114115 opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]

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

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

src/Language/PureScript/Sugar/TypeClasses.hs+7−6

@@ -25,6 +25,7 @@ import Language.PureScript.Types

2525import Language.PureScript.CodeGen.JS.AST

2626import Language.PureScript.Sugar.CaseDeclarations

2727import Language.PureScript.Environment

28+import Language.PureScript.Errors

2829import Language.PureScript.CodeGen.Common (identToJs)

2930

3031import Control.Applicative

@@ -36,13 +37,13 @@ import qualified Data.Map as M

3637

3738type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])

3839

39−type Desugar = StateT MemberMap (Either String)

40+type Desugar = StateT MemberMap (Either ErrorStack)

4041

4142-- |

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

4344-- instance dictionary expressions.

4445--

45−desugarTypeClasses :: [Module] -> Either String [Module]

46+desugarTypeClasses :: [Module] -> Either ErrorStack [Module]

4647desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

4748

4849desugarModule :: Module -> Desugar Module

@@ -125,7 +126,7 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type

125126typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

126127typeInstanceDictionaryDeclaration name mn deps className tys decls = do

127128 m <- get

128− (args, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right

129+ (args, instanceTys) <- lift $ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right

129130 $ M.lookup (qualify mn className) m

130131 let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys

131132 let entryName = Escaped (show name)

@@ -144,7 +145,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

144145

145146 memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)

146147 memberToNameAndValue tys' (ValueDeclaration ident _ _ _ _) = do

147− memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys'

148+ memberType <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup (identToJs ident) tys'

148149 memberName <- mkDictionaryEntryName name ident

149150 return (identToJs ident, TypedValue False

150151 (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))

@@ -164,8 +165,8 @@ typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclarat

164165 return $ ValueDeclaration entryName TypeInstanceMember [] Nothing

165166 (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))

166167 where

167− lookupTypeClass m = maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn className) m

168− lookupIdent members = maybe (Left $ "Type class " ++ show className ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members

168+ lookupTypeClass m = maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $ M.lookup (qualify mn className) m

169+ lookupIdent members = maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " does not have method " ++ show ident) Nothing) Right $ lookup (identToJs ident) members

169170typeInstanceDictionaryEntryDeclaration name mn deps className tys (PositionedDeclaration pos d) =

170171 PositionedDeclaration pos <$> typeInstanceDictionaryEntryDeclaration name mn deps className tys d

171172typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition"

src/Language/PureScript/Sugar/TypeDeclarations.hs+5−4

@@ -29,17 +29,18 @@ import Control.Monad (forM)

2929import Language.PureScript.Declarations

3030import Language.PureScript.Names

3131import Language.PureScript.Environment

32+import Language.PureScript.Errors

3233

3334-- |

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

3536--

36−desugarTypeDeclarationsModule :: [Module] -> Either String [Module]

37+desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module]

3738desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) -> Module name <$> desugarTypeDeclarations ds <*> pure exps

3839

3940-- |

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

4142--

42−desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]

43+desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration]

4344desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do

4445 (d' : ds') <- desugarTypeDeclarations (d : ds)

4546 return (PositionedDeclaration pos d' : ds')

@@ -47,12 +48,12 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

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

4849 desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)

4950 where

50− fromValueDeclaration :: Declaration -> Either String (Ident, NameKind, Value)

51+ fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Value)

5152 fromValueDeclaration (ValueDeclaration name' nameKind [] Nothing val) | name == name' = return (name', nameKind, val)

5253 fromValueDeclaration (PositionedDeclaration pos d') = do

5354 (ident, nameKind, val) <- fromValueDeclaration d'

5455 return (ident, nameKind, PositionedValue pos val)

55− fromValueDeclaration _ = throwError $ "Orphan type declaration for " ++ show name

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

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

5758 (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest

5859 where

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

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

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

9090 return ()

9191checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2

92−checkTypeClassInstance _ ty = throwError $ mkUnifyErrorStack "Type class instance head is invalid." (Just (TypeError ty))

92+checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance head is invalid." (Just (TypeError ty))

9393

9494-- |

9595-- Type check all declarations in a module

src/Language/PureScript/TypeChecker/Kinds.hs+3−3

@@ -61,7 +61,7 @@ instance Unifiable Check Kind where

6161--

6262kindOf :: ModuleName -> Type -> Check Kind

6363kindOf _ ty =

64− rethrow (mkUnifyErrorStack "Error checking kind" (Just (TypeError ty)) <>) $

64+ rethrow (mkErrorStack "Error checking kind" (Just (TypeError ty)) <>) $

6565 fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty

6666 where

6767 tidyUp (k, sub) = sub $? k

@@ -130,7 +130,7 @@ starIfUnknown k = k

130130-- Infer a kind for a type

131131--

132132infer :: Type -> UnifyT Kind Check Kind

133−infer ty = rethrow (mkUnifyErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty

133+infer ty = rethrow (mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty

134134

135135infer' :: Type -> UnifyT Kind Check Kind

136136infer' (TypeVar v) = do

@@ -139,7 +139,7 @@ infer' (TypeVar v) = do

139139infer' c@(TypeConstructor v) = do

140140 env <- liftCheck getEnv

141141 case M.lookup v (types env) of

142− Nothing -> UnifyT . lift . throwError $ mkUnifyErrorStack "Unknown type constructor" (Just (TypeError c))

142+ Nothing -> UnifyT . lift . throwError $ mkErrorStack "Unknown type constructor" (Just (TypeError c))

143143 Just (kind, _) -> return kind

144144infer' (TypeApp t1 t2) = do

145145 k0 <- fresh

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

@@ -21,14 +21,12 @@ module Language.PureScript.TypeChecker.Monad where

2121import Language.PureScript.Types

2222import Language.PureScript.Kinds

2323import Language.PureScript.Names

24−import Language.PureScript.Declarations

2524import Language.PureScript.Environment

2625import Language.PureScript.TypeClassDictionaries

2726import Language.PureScript.Options

2827import Language.PureScript.Errors

2928

3029import Data.Maybe

31−import Data.Monoid

3230

3331import Control.Applicative

3432import Control.Monad.State

@@ -166,7 +164,7 @@ runCheck opts = runCheck' opts initEnvironment

166164-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.

167165--

168166runCheck' :: Options -> Environment -> Check a -> Either String (a, Environment)

169−runCheck' opts env c = either (Left . prettyPrintErrorStack (optionsVerboseErrors opts)) Right $ do

167+runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do

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

171169 return (a, checkEnv s)

172170

@@ -177,18 +175,6 @@ guardWith :: (MonadError e m) => e -> Bool -> m ()

177175guardWith _ True = return ()

178176guardWith e False = throwError e

179177

180−-- |

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

182−--

183−rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

184−rethrow f = flip catchError $ \e -> throwError (f e)

185−

186−-- |

187−-- Rethrow an error with source position information

188−--

189−rethrowWithPosition :: (MonadError ErrorStack m) => SourcePos -> m a -> m a

190−rethrowWithPosition pos = rethrow (positionError pos <>)

191−

192178-- |

193179-- Generate new type class dictionary name

194180--

src/Language/PureScript/TypeChecker/Types.hs+11−11

@@ -86,7 +86,7 @@ instance Unifiable Check Type where

8686-- Unify two types, updating the current substitution

8787--

8888unifyTypes :: Type -> Type -> UnifyT Type Check ()

89−unifyTypes t1 t2 = rethrow (mkUnifyErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $

89+unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $

9090 unifyTypes' t1 t2

9191 where

9292 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()

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

365365 -- an escaped skolem variable.

366366 case everythingWithContext [] (++) (mkQ ((,) []) go) root of

367367 [] -> return ()

368− ((binding, val) : _) -> throwError $ mkUnifyErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val))

368+ ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val))

369369 where

370370 go :: Value -> [(SkolemScope, Value)] -> ([(Maybe Value, Value)], [(SkolemScope, Value)])

371371 go val@(TypedValue _ _ (ForAll _ _ (Just sco))) scos = ([], (sco, val) : scos)

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

384384 where

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

386386 go' _ = Nothing

387−skolemEscapeCheck val = throwError $ mkUnifyErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ValueError val))

387+skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ValueError val))

388388

389389-- |

390390-- Ensure a row contains no duplicate labels

@@ -493,7 +493,7 @@ ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $

493493-- Infer a type for a value, rethrowing any error to provide a more useful error message

494494--

495495infer :: Value -> UnifyT Type Check Value

496−infer val = rethrow (mkUnifyErrorStack "Error inferring type of value" (Just (ValueError val)) <>) $ infer' val

496+infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ValueError val)) <>) $ infer' val

497497

498498-- |

499499-- Infer a type for a value

@@ -721,7 +721,7 @@ introduceSkolemScope = everywhereM (mkM go)

721721-- Check the type of a value, rethrowing errors to provide a better error message

722722--

723723check :: Value -> Type -> UnifyT Type Check Value

724−check val ty = rethrow (mkUnifyErrorStack errorMessage (Just (ValueError val)) <>) $ check' val ty

724+check val ty = rethrow (mkErrorStack errorMessage (Just (ValueError val)) <>) $ check' val ty

725725 where

726726 errorMessage =

727727 "Error checking type of term " ++

@@ -837,7 +837,7 @@ check' val ty | containsTypeSynonyms ty = do

837837 check val ty'

838838check' (PositionedValue pos val) ty =

839839 rethrowWithPosition pos $ check val ty

840−check' val ty = throwError $ mkUnifyErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))

840+check' val ty = throwError $ mkErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))

841841

842842containsTypeSynonyms :: Type -> Bool

843843containsTypeSynonyms = everything (||) (mkQ False go) where

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

856856 return []

857857 go [] [] (Skolem _ _) | lax = return []

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

859− | otherwise = throwError $ mkUnifyErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))

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

859+ | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))

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

861861 go ((p,v):ps') [] u@(TUnknown _) = do

862862 v'@(TypedValue _ _ ty) <- infer v

863863 rest <- fresh

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

876876 v' <- check v ty

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

878878 return $ (p, v') : ps''

879− go _ _ _ = throwError $ mkUnifyErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ValueError (ObjectLiteral ps)))

879+ go _ _ _ = throwError $ mkErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ValueError (ObjectLiteral ps)))

880880

881881-- |

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

883883--

884884checkFunctionApplication :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)

885−checkFunctionApplication fn fnTy arg ret = rethrow (mkUnifyErrorStack errorMessage (Just (ValueError fn)) <>) $ checkFunctionApplication' fn fnTy arg ret

885+checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ValueError fn)) <>) $ checkFunctionApplication' fn fnTy arg ret

886886 where

887887 errorMessage = "Error applying function of type "

888888 ++ prettyPrintType fnTy

@@ -924,7 +924,7 @@ checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a f

924924-- Check whether one type subsumes another, rethrowing errors to provide a better error message

925925--

926926subsumes :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)

927−subsumes val ty1 ty2 = rethrow (mkUnifyErrorStack errorMessage (ValueError <$> val) <>) $ subsumes' val ty1 ty2

927+subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ValueError <$> val) <>) $ subsumes' val ty1 ty2

928928 where

929929 errorMessage = "Error checking that type "

930930 ++ prettyPrintType ty1