fb94ed4 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #335 from garyb/sourcepos-errors

fb94ed4Phil Freeman13 years ago

RELEASE-0.5.md+4−1

compare with golang

unifiedsplit

@@ -11,7 +11,7 @@

11- Prelude modules now follow a naming scheme similar to haskell (e.g. `Data.Maybe`, `Control.Monad`) (garyb)

12- Multiple modules with the same name are now disallowed rather than merged (garyb)

13- The `--runtime-type-checks` flag has been removed. Runtime type checks have been superceded by the `purescript-foreign` library (paf31)

14−- The `Prelude` module is now imported automatically. Conflicts can be avoided by using qualified imports or a specific import list. (garyb/paf31)

14+- The `Prelude` module is now imported automatically. Conflicts can be avoided by using qualified imports or a specific import list. (garyb, paf31)

16### New Features

@@ -47,6 +47,8 @@

47- The Object type constructor can now be referenced explicitly as `Prim.Object` (with kind `# * -> *`) (paf31)

48- Optimizations are now enabled by default and can be disabled with the `--no-tco` and `--no-magic-do` flags (garyb)

49- Unary minus and signed numeric literals are now supported again (paf31, garyb)

50+- Type errors have been simplified, the full trace can be enabled with `--verbose-errors` or `-v` (paf31)

51+- Error messages now display source positions (paf31, garyb)

51### Bug Fixes

53### Bug Fixes

@@ -64,6 +66,7 @@

64- If a type defined in a module appears in an exported declaration it must also be exported from the module (garyb)

66- If a type defined in a module appears in an exported declaration it must also be exported from the module (garyb)

65- Error messages for unresolvable types or values include the declaration name again (garyb)

67- Error messages for unresolvable types or values include the declaration name again (garyb)

66- Characters in string literals are now properly escaped (garyb)

68- Characters in string literals are now properly escaped (garyb)

69+- A module containing a single orphan type declaration and no other declarations now fails to compile (garyb)

68### Libraries

71### Libraries

examples/manual/failing/ArgLengthMismatch.pursnew file+4

@@ -0,0 +1,4 @@

1+module ArgLengthMismatch where

3+ f x y = true

4+ f = false

examples/manual/failing/OrphanTypeDecl.pursnew file+3

@@ -0,0 +1,3 @@

1+module OrphanTypeDecl where

3+ fn :: Number -> Boolean

examples/manual/failing/RedefinedFixity.pursnew file+6

@@ -0,0 +1,6 @@

1+module RedefinedFixity where

3+ (!?) x y = x + y

5+ infix 2 !?

6+ infix 2 !?

purescript.cabal+1

@@ -30,6 +30,7 @@ library

30 Language.PureScript.Options

31 Language.PureScript.Declarations

32 Language.PureScript.Environment

33+ Language.PureScript.Errors

33 Language.PureScript.Kinds

34 Language.PureScript.Kinds

34 Language.PureScript.Names

35 Language.PureScript.Names

35 Language.PureScript.Types

36 Language.PureScript.Types

src/Language/PureScript.hs+5−4

@@ -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/Declarations.hs+6−3

@@ -45,11 +45,14 @@ instance Show Associativity where

45-- Source position information

46--

47data SourcePos = SourcePos

48− {

48+ { -- |

49+ -- Source name

50+ --

51+ sourceName :: String

49 -- |

52 -- |

50 -- Line number

53 -- Line number

51 --

54 --

52− sourcePosLine :: Int

55+ , sourcePosLine :: Int

53 -- |

56 -- |

54 -- Column number

57 -- Column number

55 --

58 --

@@ -57,7 +60,7 @@ data SourcePos = SourcePos

57 } deriving (D.Data, D.Typeable)

60 } deriving (D.Data, D.Typeable)

59instance Show SourcePos where

62instance Show SourcePos where

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

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

62-- |

65-- |

63-- Fixity data for infix operators

66-- Fixity data for infix operators

src/Language/PureScript/Errors.hsnew file+111

@@ -0,0 +1,111 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Error

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

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

16+

17+module Language.PureScript.Errors where

18+

19+import Data.List (intercalate)

20+import Data.Monoid

21+

22+import Control.Monad.Error

23+

24+import Language.PureScript.Declarations

25+import Language.PureScript.Pretty

26+import Language.PureScript.Types

27+

28+-- |

29+-- Type for sources of type checking errors

30+--

31+data ErrorSource

32+ -- |

33+ -- An error which originated at a Value

34+ --

35+ = ValueError Value

36+ -- |

37+ -- An error which originated at a Type

38+ --

39+ | TypeError Type deriving (Show)

40+

41+-- |

42+-- Compilation errors

43+--

44+data CompileError = CompileError {

45+ -- |

46+ -- Error message

47+ --

48+ compileErrorMessage :: String

49+ -- |

50+ -- The value where the error occurred

51+ --

52+ , compileErrorValue :: Maybe ErrorSource

53+ -- |

54+ -- Optional source position information

55+ --

56+ , compileErrorPosition :: Maybe SourcePos

57+ } deriving (Show)

58+

59+-- |

60+-- A stack trace for an error

61+--

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

63+

64+instance Error ErrorStack where

65+ strMsg s = ErrorStack [CompileError s Nothing Nothing]

66+ noMsg = ErrorStack []

67+

68+prettyPrintErrorStack :: Bool -> ErrorStack -> String

69+prettyPrintErrorStack printFullStack (ErrorStack es) =

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

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

72+ _ -> prettyPrintErrorStack'

73+ where

74+ prettyPrintErrorStack' :: String

75+ prettyPrintErrorStack'

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

77+ | otherwise =

78+ let

79+ es' = filter isErrorNonEmpty es

80+ in case length es' of

81+ 1 -> showError (head es')

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

83+

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

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

86+

87+isErrorNonEmpty :: CompileError -> Bool

88+isErrorNonEmpty = not . null . compileErrorMessage

89+

90+showError :: CompileError -> String

91+showError (CompileError msg Nothing _) = msg

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

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

94+

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

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

97+

98+positionError :: SourcePos -> ErrorStack

99+positionError 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/Parser/Declarations.hs+1−1

@@ -44,7 +44,7 @@ import qualified Text.Parsec.Expr as P

44sourcePos :: P.Parsec s u SourcePos

45sourcePos = toSourcePos <$> P.getPosition

46 where

47− toSourcePos p = SourcePos (P.sourceLine p) (P.sourceColumn p)

47+ toSourcePos p = SourcePos (P.sourceName p) (P.sourceLine p) (P.sourceColumn p)

49parseDataDeclaration :: P.Parsec String ParseState Declaration

50parseDataDeclaration = do

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+11−7

@@ -19,6 +19,7 @@ module Language.PureScript.Sugar.CaseDeclarations (

19 desugarCasesModule

20) where

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

22import Data.List (groupBy)

23import Data.List (groupBy)

23import Data.Generics (mkM, mkT, everywhere)

24import Data.Generics (mkM, mkT, everywhere)

24import Data.Generics.Extras

25import Data.Generics.Extras

@@ -31,12 +32,15 @@ import Language.PureScript.Names

31import Language.PureScript.Declarations

32import Language.PureScript.Declarations

32import Language.PureScript.Scope

33import Language.PureScript.Scope

33import Language.PureScript.Environment

34import Language.PureScript.Environment

35+import Language.PureScript.Errors

35-- |

37-- |

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

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

37--

39--

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

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

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

41+desugarCasesModule ms = forM ms $ \(Module name ds exps) ->

42+ rethrow (strMsg ("Error in module " ++ show name) <>) $

43+ Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps

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

45desugarAbs :: [Declaration] -> [Declaration]

42desugarAbs = everywhere (mkT replace)

46desugarAbs = everywhere (mkT replace)

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

51-- |

55-- |

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

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

53--

57--

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

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

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

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

56 where

60 where

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

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

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

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

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

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

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

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

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

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

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

75inSameGroup _ _ = False

79inSameGroup _ _ = False

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

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

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

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

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

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

80 body = foldr (Abs . Left) val args

84 body = foldr (Abs . Left) val args

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

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

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

83 let tuples = map toTuple ds

87 let tuples = map toTuple ds

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

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

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

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

86 return [makeCaseDeclaration ident tuples]

90 return [makeCaseDeclaration ident tuples]

87toDecls (PositionedDeclaration pos d : ds) = do

91toDecls (PositionedDeclaration pos d : ds) = do

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

92+ (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)

89 return (PositionedDeclaration pos d' : ds')

93 return (PositionedDeclaration pos d' : ds')

90toDecls ds = return ds

94toDecls ds = return 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+21−16

@@ -26,14 +26,16 @@ 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

32import Control.Monad.Error.Class

33import Control.Monad.Error.Class

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

34import Data.Function (on)

36import Data.Function (on)

35import Data.Functor.Identity

37import Data.Functor.Identity

36−import Data.List (sort, groupBy, sortBy)

38+import Data.List (groupBy, sortBy)

38import qualified Data.Data as D

40import qualified Data.Data as D

39import qualified Data.Generics as G

41import qualified Data.Generics as G

@@ -48,11 +50,11 @@ import qualified Language.PureScript.Constants as C

48-- |

50-- |

49-- Remove explicit parentheses and reorder binary operator applications

51-- Remove explicit parentheses and reorder binary operator applications

50--

52--

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

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

52rebracket ms = do

54rebracket ms = do

53 let fixities = concatMap collectFixities ms

55 let fixities = concatMap collectFixities ms

54− ensureNoDuplicates $ map fst fixities

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

55− let opTable = customOperatorTable fixities

57+ let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities

56 mapM (rebracketModule opTable) ms

58 mapM (rebracketModule opTable) ms

58removeSignedLiterals :: (D.Data d) => d -> d

60removeSignedLiterals :: (D.Data d) => d -> d

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

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

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

64 go other = other

66 go other = other

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

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

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

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

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

@@ -72,20 +74,23 @@ removeParens = G.everywhere (G.mkT go)

72 go (Parens val) = val

74 go (Parens val) = val

73 go val = val

75 go val = val

75−collectFixities :: Module -> [(Qualified Ident, Fixity)]

77+collectFixities :: Module -> [(Qualified Ident, SourcePos, Fixity)]

76collectFixities (Module moduleName ds _) = concatMap collect ds

78collectFixities (Module moduleName ds _) = concatMap collect ds

77 where

79 where

78− collect :: Declaration -> [(Qualified Ident, Fixity)]

80+ collect :: Declaration -> [(Qualified Ident, SourcePos, Fixity)]

79− collect (PositionedDeclaration _ d) = collect d

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

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

82+ collect FixityDeclaration{} = error "Fixity without srcpos info"

81 collect _ = []

83 collect _ = []

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

85+ensureNoDuplicates :: [(Qualified Ident, SourcePos)] -> Either ErrorStack ()

84−ensureNoDuplicates m = go $ sort m

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

85 where

87 where

86 go [] = return ()

88 go [] = return ()

87 go [_] = return ()

89 go [_] = return ()

90+ go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =

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

92+ rethrowWithPosition pos $

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

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

89 go (_ : rest) = go rest

94 go (_ : rest) = go rest

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

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

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

100

105

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

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

102

107

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

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

104matchOperators ops = parseChains

109matchOperators ops = parseChains

105 where

110 where

106− parseChains :: Value -> Either String Value

111+ parseChains :: Value -> Either ErrorStack Value

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

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

108 parseChains other = return other

113 parseChains other = return other

109 extendChain :: Value -> Chain

114 extendChain :: Value -> Chain

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

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

111 extendChain other = [Left other]

116 extendChain other = [Left other]

112− bracketChain :: Chain -> Either String Value

117+ bracketChain :: Chain -> Either ErrorStack Value

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

118+ 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]

119 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

120 : 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 ]]

121 ++ [[ 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+12−7

@@ -21,6 +21,7 @@ module Language.PureScript.Sugar.TypeDeclarations (

22import Data.Generics (mkM)

23import Data.Generics.Extras

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

25import Control.Applicative

26import Control.Applicative

26import Control.Monad.Error.Class

27import Control.Monad.Error.Class

@@ -29,30 +30,34 @@ import Control.Monad (forM)

29import Language.PureScript.Declarations

30import Language.PureScript.Declarations

30import Language.PureScript.Names

31import Language.PureScript.Names

31import Language.PureScript.Environment

32import Language.PureScript.Environment

33+import Language.PureScript.Errors

33-- |

35-- |

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

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

35--

37--

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

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

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

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

40+ rethrow (strMsg ("Error in module " ++ show name) <>) $

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

39-- |

43-- |

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

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

41--

45--

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

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

43desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do

47desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do

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

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

45 return (PositionedDeclaration pos d' : ds')

49 return (PositionedDeclaration pos d' : ds')

46desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

50desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

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

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

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

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

49 where

53 where

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

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

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

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

52 fromValueDeclaration (PositionedDeclaration pos d') = do

56 fromValueDeclaration (PositionedDeclaration pos d') = do

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

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

54 return (ident, nameKind, PositionedValue pos val)

58 return (ident, nameKind, PositionedValue pos val)

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

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

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

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

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

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

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

58 where

63 where

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

@@ -37,6 +37,7 @@ import Language.PureScript.Kinds

37import Language.PureScript.Declarations

38import Language.PureScript.TypeClassDictionaries

39import Language.PureScript.Environment

40+import Language.PureScript.Errors

41addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

42addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

42addDataType moduleName name args dctors ctorKind = do

43addDataType moduleName name args dctors ctorKind = do

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

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

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

89 return ()

90 return ()

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

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

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

93-- |

94-- |

94-- Type check all declarations in a module

95-- Type check all declarations in a module

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

@@ -28,6 +28,7 @@ import Language.PureScript.Names

28import Language.PureScript.TypeChecker.Monad

29import Language.PureScript.Pretty

30import Language.PureScript.Environment

31+import Language.PureScript.Errors

32import Control.Monad.State

33import Control.Monad.State

33import Control.Monad.Error

34import Control.Monad.Error

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

60--

61--

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

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

62kindOf _ ty =

63kindOf _ ty =

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

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

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

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

65 where

66 where

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

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

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

129-- Infer a kind for a type

130-- Infer a kind for a type

130--

131--

131infer :: Type -> UnifyT Kind Check Kind

132infer :: Type -> UnifyT Kind Check Kind

132−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

133

134

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

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

135infer' (TypeVar v) = do

136infer' (TypeVar v) = do

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

138infer' c@(TypeConstructor v) = do

139infer' c@(TypeConstructor v) = do

139 env <- liftCheck getEnv

140 env <- liftCheck getEnv

140 case M.lookup v (types env) of

141 case M.lookup v (types env) of

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

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

142 Just (kind, _) -> return kind

143 Just (kind, _) -> return kind

143infer' (TypeApp t1 t2) = do

144infer' (TypeApp t1 t2) = do

144 k0 <- fresh

145 k0 <- fresh

src/Language/PureScript/TypeChecker/Monad.hs+4−90

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

27−import Language.PureScript.Pretty

28import Language.PureScript.Options

26import Language.PureScript.Options

27+import 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

@@ -36,78 +34,6 @@ import Control.Monad.Error

36import Control.Monad.Unify

34import Control.Monad.Unify

38import qualified Data.Map as M

36import qualified Data.Map as M

39−import Data.List (intercalate)

40−

41−-- |

42−-- Type for sources of type checking errors

43−--

44−data UnifyErrorSource

45− -- |

46− -- An error which originated at a Value

47− --

48− = ValueError Value

49− -- |

50− -- An error which originated at a Type

51− --

52− | TypeError Type deriving (Show)

53−

54−-- |

55−-- Unification errors

56−--

57−data UnifyError = UnifyError {

58− -- |

59− -- Error message

60− --

61− unifyErrorMessage :: String

62− -- |

63− -- The value where the error occurred

64− --

65− , unifyErrorValue :: Maybe UnifyErrorSource

66− -- |

67− -- Optional source position information

68− --

69− , unifyErrorPosition :: Maybe SourcePos

70− } deriving (Show)

71−

72−-- |

73−-- A stack trace for an error

74−--

75−newtype UnifyErrorStack = UnifyErrorStack { runUnifyErrorStack :: [UnifyError] } deriving (Show, Monoid)

76−

77−instance Error UnifyErrorStack where

78− strMsg s = UnifyErrorStack [UnifyError s Nothing Nothing]

79− noMsg = UnifyErrorStack []

80−

81−prettyPrintUnifyErrorStack :: Options -> UnifyErrorStack -> String

82−prettyPrintUnifyErrorStack opts (UnifyErrorStack es) =

83− case mconcat $ map (Last . unifyErrorPosition) es of

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

85− _ -> prettyPrintUnifyErrorStack'

86− where

87− prettyPrintUnifyErrorStack' :: String

88− prettyPrintUnifyErrorStack'

89− | optionsVerboseErrors opts =

90− intercalate "\n" (map showError (filter isErrorNonEmpty es))

91− | otherwise =

92− let

93− es' = filter isErrorNonEmpty es

94− in case length es' of

95− 1 -> showError (head es')

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

97−

98−isErrorNonEmpty :: UnifyError -> Bool

99−isErrorNonEmpty = not . null . unifyErrorMessage

100−

101−showError :: UnifyError -> String

102−showError (UnifyError msg Nothing _) = msg

103−showError (UnifyError msg (Just (ValueError val)) _) = "Error in value " ++ prettyPrintValue val ++ "\n" ++ msg

104−showError (UnifyError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ "\n" ++ msg

105−

106−mkUnifyErrorStack :: String -> Maybe UnifyErrorSource -> UnifyErrorStack

107−mkUnifyErrorStack msg t = UnifyErrorStack [UnifyError msg t Nothing]

108−

109−positionError :: SourcePos -> UnifyErrorStack

110−positionError pos = UnifyErrorStack [UnifyError "" Nothing (Just pos)]

111

112-- |

38-- |

113-- Temporarily bind a collection of names to values

39-- Temporarily bind a collection of names to values

@@ -207,8 +133,8 @@ data CheckState = CheckState {

207-- |

133-- |

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

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

209--

135--

210−newtype Check a = Check { unCheck :: StateT CheckState (Either UnifyErrorStack) a }

136+newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a }

211− deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError UnifyErrorStack)

137+ deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError ErrorStack)

212

138

213-- |

139-- |

214-- Get the current @Environment@

140-- Get the current @Environment@

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

238-- 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@.

239--

165--

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

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

241−runCheck' opts env c = either (Left . prettyPrintUnifyErrorStack opts) Right $ do

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

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

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

243 return (a, checkEnv s)

169 return (a, checkEnv s)

244

170

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

249guardWith _ True = return ()

175guardWith _ True = return ()

250guardWith e False = throwError e

176guardWith e False = throwError e

251

177

252−-- |

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

254−--

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

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

257−

258−-- |

259−-- Rethrow an error with source position information

260−--

261−rethrowWithPosition :: (MonadError UnifyErrorStack m) => SourcePos -> m a -> m a

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

263−

264-- |

178-- |

265-- Generate new type class dictionary name

179-- Generate new type class dictionary name

266--

180--

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

@@ -59,6 +59,7 @@ import Language.PureScript.TypeChecker.Kinds

59import Language.PureScript.TypeChecker.Synonyms

60import Language.PureScript.Pretty

61import Language.PureScript.Environment

62+import Language.PureScript.Errors

62import qualified Language.PureScript.Constants as C

63import qualified Language.PureScript.Constants as C

64import Control.Monad.State

65import Control.Monad.State

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

85-- Unify two types, updating the current substitution

86-- Unify two types, updating the current substitution

86--

87--

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

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

88−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 <>) $

89 unifyTypes' t1 t2

90 unifyTypes' t1 t2

90 where

91 where

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

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

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

364 -- an escaped skolem variable.

365 -- an escaped skolem variable.

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

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

366 [] -> return ()

367 [] -> return ()

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

368 where

369 where

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

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

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

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

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

383 where

384 where

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

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

385 go' _ = Nothing

386 go' _ = Nothing

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

387

388

388-- |

389-- |

389-- Ensure a row contains no duplicate labels

390-- Ensure a row contains no duplicate labels

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

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

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

493--

494--

494infer :: Value -> UnifyT Type Check Value

495infer :: Value -> UnifyT Type Check Value

495−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

496

497

497-- |

498-- |

498-- Infer a type for a value

499-- Infer a type for a value

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

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

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

721--

722--

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

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

723−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

724 where

725 where

725 errorMessage =

726 errorMessage =

726 "Error checking type of term " ++

727 "Error checking type of term " ++

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

836 check val ty'

837 check val ty'

837check' (PositionedValue pos val) ty =

838check' (PositionedValue pos val) ty =

838 rethrowWithPosition pos $ check val ty

839 rethrowWithPosition pos $ check val ty

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

840

841

841containsTypeSynonyms :: Type -> Bool

842containsTypeSynonyms :: Type -> Bool

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

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

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

855 return []

856 return []

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

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

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

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

858− | 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)))

859− 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)))

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

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

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

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

862 rest <- fresh

863 rest <- fresh

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

875 v' <- check v ty

876 v' <- check v ty

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

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

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

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

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

879

880

880-- |

881-- |

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

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

882--

883--

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

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

884−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

885 where

886 where

886 errorMessage = "Error applying function of type "

887 errorMessage = "Error applying function of type "

887 ++ prettyPrintType fnTy

888 ++ prettyPrintType fnTy

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

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

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

924--

925--

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

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

926−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

927 where

928 where

928 errorMessage = "Error checking that type "

929 errorMessage = "Error checking that type "

929 ++ prettyPrintType ty1

930 ++ prettyPrintType ty1