git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Add position info to most errors
commitd712dc1f7ef49f95a6382ea72d32aabd7bfaa268 authorGary Burgess <gary.burgess@gmail.com> dateSat 29 Mar 2014, 19:09 (13 years ago) parentd7f4923
6 files changed+39−15
compare with golang
unifiedsplit
examples/manual/failing/ArgLengthMismatch.purs+4 examples/manual/failing/OrphanTypeDecl.purs+3 examples/manual/failing/RedefinedFixity.purs+6 src/Language/PureScript/Sugar/CaseDeclarations.hs+5−2 src/Language/PureScript/Sugar/Operators.hs+14−10 src/Language/PureScript/Sugar/TypeDeclarations.hs+7−3
examples/manual/failing/ArgLengthMismatch.pursnew file+4
@@ -0,0 +1,4 @@
1+module ArgLengthMismatch where
2+
3+ f x y = true
4+ f = false
examples/manual/failing/OrphanTypeDecl.pursnew file+3
@@ -0,0 +1,3 @@
1+module OrphanTypeDecl where
2+
3+ fn :: Number -> Boolean
examples/manual/failing/RedefinedFixity.pursnew file+6
@@ -0,0 +1,6 @@
1+module RedefinedFixity where
2+
3+ (!?) x y = x + y
4+
5+ infix 2 !?
6+ infix 2 !?
src/Language/PureScript/Sugar/CaseDeclarations.hs+5−2
@@ -19,6 +19,7 @@ module Language.PureScript.Sugar.CaseDeclarations (
1919 desugarCasesModule
2020) where
2121
22+import Data.Monoid ((<>))
2223import Data.List (groupBy)
2324import Data.Generics (mkM, mkT, everywhere)
2425import Data.Generics.Extras
@@ -37,7 +38,9 @@ import Language.PureScript.Errors
3738-- Replace all top-level binders in a module with case expressions.
3839--
3940desugarCasesModule :: [Module] -> Either ErrorStack [Module]
40−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
4144
4245desugarAbs :: [Declaration] -> [Declaration]
4346desugarAbs = everywhere (mkT replace)
@@ -86,7 +89,7 @@ toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do
8689 throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing
8790 return [makeCaseDeclaration ident tuples]
8891toDecls (PositionedDeclaration pos d : ds) = do
89− (d' : ds') <- toDecls (d : ds)
92+ (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)
9093 return (PositionedDeclaration pos d' : ds')
9194toDecls ds = return ds
9295
src/Language/PureScript/Sugar/Operators.hs+14−10
@@ -32,9 +32,10 @@ import Control.Applicative
3232import Control.Monad.State
3333import Control.Monad.Error.Class
3434
35+import Data.Monoid ((<>))
3536import Data.Function (on)
3637import Data.Functor.Identity
37−import Data.List (sort, groupBy, sortBy)
38+import Data.List (groupBy, sortBy)
3839
3940import qualified Data.Data as D
4041import qualified Data.Generics as G
@@ -52,8 +53,8 @@ import qualified Language.PureScript.Constants as C
5253rebracket :: [Module] -> Either ErrorStack [Module]
5354rebracket ms = do
5455 let fixities = concatMap collectFixities ms
55− ensureNoDuplicates $ map fst fixities
56− let opTable = customOperatorTable fixities
56+ ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities
57+ let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities
5758 mapM (rebracketModule opTable) ms
5859
5960removeSignedLiterals :: (D.Data d) => d -> d
@@ -73,20 +74,23 @@ removeParens = G.everywhere (G.mkT go)
7374 go (Parens val) = val
7475 go val = val
7576
76−collectFixities :: Module -> [(Qualified Ident, Fixity)]
77+collectFixities :: Module -> [(Qualified Ident, SourcePos, Fixity)]
7778collectFixities (Module moduleName ds _) = concatMap collect ds
7879 where
79− collect :: Declaration -> [(Qualified Ident, Fixity)]
80− collect (PositionedDeclaration _ d) = collect d
81− collect (FixityDeclaration fixity name) = [(Qualified (Just moduleName) (Op name), fixity)]
80+ collect :: Declaration -> [(Qualified Ident, SourcePos, Fixity)]
81+ collect (PositionedDeclaration pos (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
82+ collect FixityDeclaration{} = error "Fixity without srcpos info"
8283 collect _ = []
8384
84−ensureNoDuplicates :: [Qualified Ident] -> Either ErrorStack ()
85−ensureNoDuplicates m = go $ sort m
85+ensureNoDuplicates :: [(Qualified Ident, SourcePos)] -> Either ErrorStack ()
86+ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
8687 where
8788 go [] = return ()
8889 go [_] = return ()
89− go (x : y : _) | x == y = throwError $ mkErrorStack ("Redefined fixity for " ++ show x) Nothing
90+ go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =
91+ rethrow (strMsg ("Error in module " ++ show mn) <>) $
92+ rethrowWithPosition pos $
93+ throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing
9094 go (_ : rest) = go rest
9195
9296customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
src/Language/PureScript/Sugar/TypeDeclarations.hs+7−3
@@ -21,6 +21,7 @@ module Language.PureScript.Sugar.TypeDeclarations (
2121
2222import Data.Generics (mkM)
2323import Data.Generics.Extras
24+import Data.Monoid ((<>))
2425
2526import Control.Applicative
2627import Control.Monad.Error.Class
@@ -35,14 +36,16 @@ import Language.PureScript.Errors
3536-- Replace all top level type declarations in a module with type annotations
3637--
3738desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module]
38−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
3942
4043-- |
4144-- Replace all top level type declarations with type annotations
4245--
4346desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration]
4447desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do
45− (d' : ds') <- desugarTypeDeclarations (d : ds)
48+ (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
4649 return (PositionedDeclaration pos d' : ds')
4750desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
4851 (_, nameKind, val) <- fromValueDeclaration d
@@ -51,9 +54,10 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
5154 fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Value)
5255 fromValueDeclaration (ValueDeclaration name' nameKind [] Nothing val) | name == name' = return (name', nameKind, val)
5356 fromValueDeclaration (PositionedDeclaration pos d') = do
54− (ident, nameKind, val) <- fromValueDeclaration d'
57+ (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
5558 return (ident, nameKind, PositionedValue pos val)
5659 fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
60+desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
5761desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do
5862 (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest
5963 where