d7f4923 · rowtype-yoga/purescript-native

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

on golang help sign in

Use ErrorStack everywhere

d7f4923Gary Burgess13 years ago

src/Language/PureScript.hs+5−4

compare with golang

unifiedsplit

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

28import Language.PureScript.Options as P

29import Language.PureScript.ModuleDependencies as P

30import Language.PureScript.Environment as P

31+import Language.PureScript.Errors as P

31import Language.PureScript.DeadCodeElimination as P

32import Language.PureScript.DeadCodeElimination as P

33import qualified Language.PureScript.Constants as C

34import qualified Language.PureScript.Constants as C

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

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

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

71compile' env opts ms = do

72compile' env opts ms = do

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

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

73− desugared <- desugar sorted

74+ desugared <- stringifyErrorStack True $ desugar sorted

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

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

75− regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

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

76 let entryPoints = moduleNameFromString `map` optionsModules opts

77 let entryPoints = moduleNameFromString `map` optionsModules opts

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

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

78 let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts

79 let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts

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

184

185

185 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

186 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

186

187

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

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

188

189

189 go initEnvironment desugared

190 go initEnvironment desugared

190

191

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

202

203

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

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

204

205

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

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

206

207

207 let mod' = Module moduleName' regrouped exps

208 let mod' = Module moduleName' regrouped exps

208 js = moduleToJs opts mod' env'

209 js = moduleToJs opts mod' env'

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

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

12--

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

15−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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

17module Language.PureScript.Errors where

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

22import Control.Monad.Error

24import Language.PureScript.Declarations

25−import Language.PureScript.Names

26import Language.PureScript.Pretty

25import Language.PureScript.Pretty

27import Language.PureScript.Types

26import Language.PureScript.Types

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

30-- Type for sources of type checking errors

29-- Type for sources of type checking errors

31--

30--

32data ErrorSource

31data 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)

41 -- |

32 -- |

42 -- An error which originated at a Value

33 -- An error which originated at a Value

43 --

34 --

44− | ValueError Value

35+ = ValueError Value

45 -- |

36 -- |

46 -- An error which originated at a Type

37 -- An error which originated at a Type

47 --

38 --

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

68-- |

59-- |

69-- A stack trace for an error

60-- A stack trace for an error

70--

61--

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

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

73instance Error ErrorStack where

64instance Error ErrorStack where

74 strMsg s = ErrorStack [CompileError s Nothing Nothing]

65 strMsg s = ErrorStack [CompileError s Nothing Nothing]

75 noMsg = ErrorStack []

66 noMsg = ErrorStack []

77prettyPrintErrorStack :: Bool -> ErrorStack -> String

68prettyPrintErrorStack :: Bool -> ErrorStack -> String

78−prettyPrintErrorStack printAll (ErrorStack es) =

69+prettyPrintErrorStack printFullStack (ErrorStack es) =

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

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

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

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

81− _ -> prettyPrintUnifyErrorStack'

72+ _ -> prettyPrintErrorStack'

82 where

73 where

83− prettyPrintUnifyErrorStack' :: String

74+ prettyPrintErrorStack' :: String

84− prettyPrintUnifyErrorStack'

75+ prettyPrintErrorStack'

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

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

86 | otherwise =

77 | otherwise =

87 let

78 let

88 es' = filter isErrorNonEmpty es

79 es' = filter isErrorNonEmpty es

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

90 1 -> showError (head es')

81 1 -> showError (head es')

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

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

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

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

86+

93isErrorNonEmpty :: CompileError -> Bool

87isErrorNonEmpty :: CompileError -> Bool

94isErrorNonEmpty = not . null . compileErrorMessage

88isErrorNonEmpty = not . null . compileErrorMessage

96showError :: CompileError -> String

90showError :: CompileError -> String

97showError (CompileError msg Nothing _) = msg

91showError (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

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

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

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

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

103

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

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

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

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

106

107positionError :: SourcePos -> ErrorStack

98positionError :: SourcePos -> ErrorStack

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

99positionError 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

18import Control.Monad

20import Language.PureScript.Declarations

21+import Language.PureScript.Errors

22import Language.PureScript.Sugar.Operators as S

23import Language.PureScript.Sugar.Operators as S

23import Language.PureScript.Sugar.DoNotation as S

24import Language.PureScript.Sugar.DoNotation as S

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

46--

47--

47-- * Qualify any unqualified names and types

48-- * Qualify any unqualified names and types

48--

49--

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

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

50desugar = removeSignedLiterals

51desugar = removeSignedLiterals

51 >>> desugarDo

52 >>> desugarDo

52 >=> desugarCasesModule

53 >=> desugarCasesModule

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

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

33import Language.PureScript.Names

34import Language.PureScript.Types

35import Language.PureScript.Environment

36+import Language.PureScript.Errors

37-- |

38-- |

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

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

39--

40--

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

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

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

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

43-- |

44-- |

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

49-- |

50-- |

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

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

51--

52--

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

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

53createBindingGroups moduleName ds = do

54createBindingGroups moduleName ds = do

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

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

55 let dataDecls = filter isDataDecl ds

56 let dataDecls = filter isDataDecl ds

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

68 filter isExternDecl ds ++

69 filter isExternDecl ds ++

69 bindingGroupDecls

70 bindingGroupDecls

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

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

72createBindingGroupsForValue moduleName = everywhereM' (mkM go)

73createBindingGroupsForValue moduleName = everywhereM' (mkM go)

73 where

74 where

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

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

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

124toBindingGroup (CyclicSCC [d]) = d

125toBindingGroup (CyclicSCC [d]) = d

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

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

126

127

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

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

128toDataBindingGroup (AcyclicSCC d) = return d

129toDataBindingGroup (AcyclicSCC d) = return d

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

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

131 _ -> return d

132 _ -> return d

132toDataBindingGroup (CyclicSCC ds')

133toDataBindingGroup (CyclicSCC ds')

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

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

134 | otherwise = return $ DataBindingGroupDeclaration ds'

135 | otherwise = return $ DataBindingGroupDeclaration ds'

135

136

136isTypeSynonym :: Declaration -> Maybe ProperName

137isTypeSynonym :: Declaration -> Maybe ProperName

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

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

31import Language.PureScript.Declarations

32import Language.PureScript.Scope

33import Language.PureScript.Environment

34+import Language.PureScript.Errors

35-- |

36-- |

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

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

37--

38--

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

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

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

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

41desugarAbs :: [Declaration] -> [Declaration]

42desugarAbs :: [Declaration] -> [Declaration]

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

51-- |

52-- |

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

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

53--

54--

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

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

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

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

56 where

57 where

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

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

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

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

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

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

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

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

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

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

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

75inSameGroup _ _ = False

76inSameGroup _ _ = False

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

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

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

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

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

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

80 body = foldr (Abs . Left) val args

81 body = foldr (Abs . Left) val args

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

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

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

83 let tuples = map toTuple ds

84 let tuples = map toTuple ds

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

85 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

86 return [makeCaseDeclaration ident tuples]

87 return [makeCaseDeclaration ident tuples]

87toDecls (PositionedDeclaration pos d : ds) = do

88toDecls (PositionedDeclaration pos d : ds) = do

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

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

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

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

24import Language.PureScript.Names

25import Language.PureScript.Scope

26import Language.PureScript.Declarations

27+import Language.PureScript.Errors

28import qualified Language.PureScript.Constants as C

29import qualified Language.PureScript.Constants as C

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

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

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

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

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

35--

36--

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

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

37desugarDo = everywhereM (mkM replace)

38desugarDo = everywhereM (mkM replace)

38 where

39 where

39 prelude :: ModuleName

40 prelude :: ModuleName

40 prelude = ModuleName [ProperName C.prelude]

41 prelude = ModuleName [ProperName C.prelude]

41 bind :: Value

42 bind :: Value

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

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

43− replace :: Value -> Either String Value

44+ replace :: Value -> Either ErrorStack Value

44 replace (Do els) = go els

45 replace (Do els) = go els

45 replace other = return other

46 replace other = return other

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

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

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

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

48 go [DoNotationValue val] = return val

49 go [DoNotationValue val] = return val

49 go (DoNotationValue val : rest) = do

50 go (DoNotationValue val : rest) = do

50 rest' <- go rest

51 rest' <- go rest

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

52 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

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

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

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

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

55 rest' <- go rest

56 rest' <- go rest

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

58 rest' <- go rest

59 rest' <- go rest

59 let ident = head $ unusedNames rest'

60 let ident = head $ unusedNames rest'

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

61 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

62 go (DoNotationLet binder val : rest) = do

63 go (DoNotationLet binder val : rest) = do

63 rest' <- go rest

64 rest' <- go rest

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

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

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

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

19import Data.Data

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

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

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

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

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

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

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

30import Language.PureScript.Names

31import Language.PureScript.Names

31import Language.PureScript.Types

32import Language.PureScript.Types

32import Language.PureScript.Environment

33import Language.PureScript.Environment

34+import Language.PureScript.Errors

34-- |

36-- |

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

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

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

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

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

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

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

82--

84--

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

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

84updateExportedModule env mn update = do

86updateExportedModule env mn update = do

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

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

86 exports' <- update exports

88 exports' <- update exports

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

89-- |

91-- |

90-- Adds an empty module to an ExportEnvironment.

92-- Adds an empty module to an ExportEnvironment.

91--

93--

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

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

93addEmptyModule env name =

95addEmptyModule env name =

94 if name `M.member` env

96 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

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

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

98-- |

100-- |

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

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

100--

102--

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

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

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

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

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

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

104 return $ m { exportedTypes = types' }

106 return $ m { exportedTypes = types' }

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

106-- |

108-- |

107-- Adds a class to the export environment.

109-- Adds a class to the export environment.

108--

110--

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

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

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

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

111 classes <- addExport (exportedTypeClasses m) name

113 classes <- addExport (exportedTypeClasses m) name

112 return $ m { exportedTypeClasses = classes }

114 return $ m { exportedTypeClasses = classes }

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

114-- |

116-- |

115-- Adds a class to the export environment.

117-- Adds a class to the export environment.

116--

118--

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

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

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

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

119 values <- addExport (exportedValues m) name

121 values <- addExport (exportedValues m) name

120 return $ m { exportedValues = values }

122 return $ m { exportedValues = values }

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

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

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

124-- returned.

126-- returned.

125--

127--

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

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

127addExport exports name =

129addExport exports name =

128 if name `elem` exports

130 if name `elem` exports

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

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

130 else return $ name : exports

132 else return $ name : exports

131

133

132-- |

134-- |

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

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

134--

136--

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

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

136desugarImports modules = do

138desugarImports modules = do

137 unfilteredExports <- findExports modules

139 unfilteredExports <- findExports modules

138 exports <- foldM filterModuleExports unfilteredExports modules

140 exports <- foldM filterModuleExports unfilteredExports modules

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

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

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

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

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

144 -- exported.

146 -- exported.

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

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

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

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

147 filterModuleExports env _ = return env

149 filterModuleExports env _ = return env

148

150

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

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

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

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

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

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

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

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

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

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

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

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

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

155− imports <- resolveImports env m

158+ imports <- resolveImports env m

156− renameInModule imports env (elaborateExports exps m)

159+ 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 ++ "'"

169

160

170-- |

161-- |

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

162-- 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 $

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

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

182-- qualified names are valid.

173-- qualified names are valid.

183--

174--

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

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

185renameInModule imports exports (Module mn decls exps) =

176renameInModule imports exports (Module mn decls exps) =

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

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

187 where

178 where

179+ go :: Declaration -> Either ErrorStack Declaration

188 go (DataDeclaration name args dctors) =

180 go (DataDeclaration name args dctors) =

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

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

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

190 go (DataBindingGroupDeclaration decls') =

183 go (DataBindingGroupDeclaration decls') =

191 DataBindingGroupDeclaration <$> mapM go decls'

184 DataBindingGroupDeclaration <$> mapM go decls'

192 go (TypeSynonymDeclaration name ps ty) =

185 go (TypeSynonymDeclaration name ps ty) =

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

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

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

194 go (TypeInstanceDeclaration name cs cn ts ds) =

188 go (TypeInstanceDeclaration name cs cn ts ds) =

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

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

196 go (ExternInstanceDeclaration name cs cn ts) =

190 go (ExternInstanceDeclaration name cs cn ts) =

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

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

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

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

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

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

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

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

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

201 where

196 where

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

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

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

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

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

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

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

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

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

213 bindFunctionArgs bound other = return (bound, other)

208 bindFunctionArgs bound other = return (bound, other)

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

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

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

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

216

211

217 letBoundVariable :: Declaration -> Maybe Ident

212 letBoundVariable :: Declaration -> Maybe Ident

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

220 letBoundVariable _ = Nothing

215 letBoundVariable _ = Nothing

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

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

222 go (ExternDeclaration fit name js ty) =

217 go (ExternDeclaration fit name js ty) =

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

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

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

224 go (BindingGroupDeclaration decls') = do

220 go (BindingGroupDeclaration decls') = do

225 BindingGroupDeclaration <$> mapM go' decls'

221 BindingGroupDeclaration <$> mapM go' decls'

222+ where

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

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

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

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

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

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

228 go d = updateAll d

227 go d = updateAll d

229

228

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

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

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

235

231

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

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

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

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

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

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

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

245 updateType t = return t

241 updateType t = return t

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

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

247 updateType' = everywhereM (mkM updateType)

243 updateType' = everywhereM (mkM updateType)

248

244

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

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

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

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

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

260 -> (Exports -> a -> Bool)

256 -> (Exports -> a -> Bool)

261 -> (Qualified a)

257 -> (Qualified a)

262− -> Either String (Qualified a)

258+ -> Either ErrorStack (Qualified a)

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

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

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

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

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

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

266 modExports <- getExports mn''

262 modExports <- getExports mn''

267 if checkE modExports name

263 if checkE modExports name

268 then return qname

264 then return qname

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

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

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

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

271

267

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

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

273− getExports :: ModuleName -> Either String Exports

269+ getExports :: ModuleName -> Either ErrorStack Exports

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

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

275

271

276-- |

272-- |

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

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

278--

274--

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

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

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

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

281 where

277 where

282

278

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

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

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

287

283

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

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

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

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

291 env' <- addEmptyModule env mn

287 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

293

289

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

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

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

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

297 env' <- addTypeClass env mn tcn

293 env' <- addTypeClass env mn tcn

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

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

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

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

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

309-- environment.

305-- environment.

310--

306--

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

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

312filterExports mn exps env = do

308filterExports mn exps env = do

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

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

314 moduleExports' <- filterModule moduleExports

310 moduleExports' <- filterModule moduleExports

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

316 where

312 where

317

313

318 -- Filter the exports for the specific module

314 -- Filter the exports for the specific module

319− filterModule :: Exports -> Either String Exports

315+ filterModule :: Exports -> Either ErrorStack Exports

320 filterModule exported = do

316 filterModule exported = do

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

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

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

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

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

325

321

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

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

327 -- exports

323 -- exports

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

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

329 filterTypes expTys result (TypeRef name expDcons) = do

325 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

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

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

332 return $ (name, dcons') : result

328 return $ (name, dcons') : result

333 filterTypes _ result _ = return result

329 filterTypes _ result _ = return result

334

330

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

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

337 filterDcons tcon exps' result name =

333 filterDcons tcon exps' result name =

338 if name `elem` exps'

334 if name `elem` exps'

339 then return $ name : result

335 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

341

337

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

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

344 filterClasses exps' result (TypeClassRef name) =

340 filterClasses exps' result (TypeClassRef name) =

345 if name `elem` exps'

341 if name `elem` exps'

346 then return $ name : result

342 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

348 filterClasses _ result _ = return result

344 filterClasses _ result _ = return result

349

345

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

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

352 filterValues exps' result (ValueRef name) =

348 filterValues exps' result (ValueRef name) =

353 if name `elem` exps'

349 if name `elem` exps'

354 then return $ name : result

350 then return $ name : result

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

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

356 filterValues _ result _ = return result

352 filterValues _ result _ = return result

357

353

358-- |

354-- |

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

374-- |

370-- |

375-- Constructs a local environment for a module.

371-- Constructs a local environment for a module.

376--

372--

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

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

378resolveImports env (Module currentModule decls _) =

374resolveImports env (Module currentModule decls _) =

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

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

380 where

376 where

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

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

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

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

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

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

380 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

386 resolveImport currentModule mn modExports imp impQual explImports

382 resolveImport currentModule mn modExports imp impQual explImports

387

383

388-- |

384-- |

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

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

390--

386--

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

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

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

393 where

389 where

394

390

395 -- Import everything from a module

391 -- Import everything from a module

396− importAll :: Either String ImportEnvironment

392+ importAll :: Either ErrorStack ImportEnvironment

397 importAll = do

393 importAll = do

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

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

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

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

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

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

401

397

402 -- Import something explicitly

398 -- Import something explicitly

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

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

404 importExplicit imp (ValueRef name) = do

400 importExplicit imp (ValueRef name) = do

405 _ <- checkImportExists "value" values name

401 _ <- checkImportExists "value" values name

406 values' <- updateImports (importedValues imp) name

402 values' <- updateImports (importedValues imp) name

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

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

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

424

420

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

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

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

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

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

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

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

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

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

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

427+ where

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

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

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

429+ 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) ++ "'"

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

434

431

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

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

436 values = exportedValues exps

433 values = exportedValues exps

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

439

436

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

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

441 -- from

438 -- from

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

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

443 checkDctorExists = checkImportExists "data constructor"

440 checkDctorExists = checkImportExists "data constructor"

444

441

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

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

447 checkImportExists t exports item =

444 checkImportExists t exports item =

448 if item `elem` exports

445 if item `elem` exports

449 then return item

446 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

451

448

452

449

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

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

27import Language.PureScript.Names

28import Language.PureScript.Declarations

29+import Language.PureScript.Errors

30import Control.Applicative

31import Control.Applicative

31import Control.Monad.State

32import Control.Monad.State

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

48-- |

49-- |

49-- Remove explicit parentheses and reorder binary operator applications

50-- Remove explicit parentheses and reorder binary operator applications

50--

51--

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

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

52rebracket ms = do

53rebracket ms = do

53 let fixities = concatMap collectFixities ms

54 let fixities = concatMap collectFixities ms

54 ensureNoDuplicates $ map fst fixities

55 ensureNoDuplicates $ map fst fixities

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

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

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

64 go other = other

65 go other = other

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

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

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

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

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

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

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

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

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

81 collect _ = []

82 collect _ = []

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

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

84ensureNoDuplicates m = go $ sort m

85ensureNoDuplicates m = go $ sort m

85 where

86 where

86 go [] = return ()

87 go [] = return ()

87 go [_] = return ()

88 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

89 go (_ : rest) = go rest

90 go (_ : rest) = go rest

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

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

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

100

101

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

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

102

103

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

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

104matchOperators ops = parseChains

105matchOperators ops = parseChains

105 where

106 where

106− parseChains :: Value -> Either String Value

107+ parseChains :: Value -> Either ErrorStack Value

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

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

108 parseChains other = return other

109 parseChains other = return other

109 extendChain :: Value -> Chain

110 extendChain :: Value -> Chain

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

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

111 extendChain other = [Left other]

112 extendChain other = [Left other]

112− bracketChain :: Chain -> Either String Value

113+ bracketChain :: Chain -> Either ErrorStack Value

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

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

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

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

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

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

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

117 ++ [[ 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

25import Language.PureScript.CodeGen.JS.AST

26import Language.PureScript.Sugar.CaseDeclarations

27import Language.PureScript.Environment

28+import Language.PureScript.Errors

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

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

30import Control.Applicative

31import Control.Applicative

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

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

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

39−type Desugar = StateT MemberMap (Either String)

40+type Desugar = StateT MemberMap (Either ErrorStack)

41-- |

42-- |

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

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

43-- instance dictionary expressions.

44-- instance dictionary expressions.

44--

45--

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

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

46desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

47desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

48desugarModule :: Module -> Desugar Module

49desugarModule :: Module -> Desugar Module

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

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

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

126typeInstanceDictionaryDeclaration name mn deps className tys decls = do

127typeInstanceDictionaryDeclaration name mn deps className tys decls = do

127 m <- get

128 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

129 $ M.lookup (qualify mn className) m

130 $ M.lookup (qualify mn className) m

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

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

131 let entryName = Escaped (show name)

132 let entryName = Escaped (show name)

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

144

145

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

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

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

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

148 memberName <- mkDictionaryEntryName name ident

149 memberName <- mkDictionaryEntryName name ident

149 return (identToJs ident, TypedValue False

150 return (identToJs ident, TypedValue False

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

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

164 return $ ValueDeclaration entryName TypeInstanceMember [] Nothing

165 return $ ValueDeclaration entryName TypeInstanceMember [] Nothing

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

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

166 where

167 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+ lookupTypeClass m = maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) 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

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

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

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

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

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

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

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

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

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

29import Language.PureScript.Declarations

30import Language.PureScript.Names

31import Language.PureScript.Environment

32+import Language.PureScript.Errors

33-- |

34-- |

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

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

35--

36--

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

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

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

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

39-- |

40-- |

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

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

41--

42--

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

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

43desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do

44desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do

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

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

45 return (PositionedDeclaration pos d' : ds')

46 return (PositionedDeclaration pos d' : ds')

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

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

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

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

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

49 where

50 where

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

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

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

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

52 fromValueDeclaration (PositionedDeclaration pos d') = do

53 fromValueDeclaration (PositionedDeclaration pos d') = do

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

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

54 return (ident, nameKind, PositionedValue pos val)

55 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

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

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

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

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

58 where

59 where

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

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

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

90 return ()

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

94-- |

95-- Type check all declarations in a module

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

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

61--

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

63kindOf _ ty =

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

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

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

66 where

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

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

130-- Infer a kind for a type

131--

132infer :: 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

134

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

136infer' (TypeVar v) = do

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

139infer' c@(TypeConstructor v) = do

140 env <- liftCheck getEnv

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

143 Just (kind, _) -> return kind

144infer' (TypeApp t1 t2) = do

145 k0 <- fresh

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

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

21import Language.PureScript.Types

22import Language.PureScript.Kinds

23import Language.PureScript.Names

24−import Language.PureScript.Declarations

25import Language.PureScript.Environment

24import Language.PureScript.Environment

26import Language.PureScript.TypeClassDictionaries

25import Language.PureScript.TypeClassDictionaries

27import Language.PureScript.Options

26import Language.PureScript.Options

28import Language.PureScript.Errors

27import Language.PureScript.Errors

30import Data.Maybe

29import Data.Maybe

31−import Data.Monoid

33import Control.Applicative

31import Control.Applicative

34import Control.Monad.State

32import Control.Monad.State

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

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

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

167--

165--

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

166runCheck' :: 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

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

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

171 return (a, checkEnv s)

169 return (a, checkEnv s)

172

170

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

177guardWith _ True = return ()

175guardWith _ True = return ()

178guardWith e False = throwError e

176guardWith e False = throwError e

179

177

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−

192-- |

178-- |

193-- Generate new type class dictionary name

179-- Generate new type class dictionary name

194--

180--

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

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

86-- Unify two types, updating the current substitution

87--

88unifyTypes :: 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 <>) $

90 unifyTypes' t1 t2

91 where

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

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

365 -- an escaped skolem variable.

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

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

369 where

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

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

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

384 where

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

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

388

389-- |

390-- Ensure a row contains no duplicate labels

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

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

494--

495infer :: 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

497

498-- |

499-- Infer a type for a value

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

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

722--

723check :: 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

725 where

726 errorMessage =

727 "Error checking type of term " ++

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

837 check val ty'

838check' (PositionedValue pos val) ty =

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

841

842containsTypeSynonyms :: Type -> Bool

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

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

856 return []

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

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

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

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

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

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

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

863 rest <- fresh

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

876 v' <- check v ty

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

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

880

881-- |

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

883--

884checkFunctionApplication :: 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

886 where

887 errorMessage = "Error applying function of type "

888 ++ prettyPrintType fnTy

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

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

925--

926subsumes :: 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

928 where

929 errorMessage = "Error checking that type "

930 ++ prettyPrintType ty1