git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Add position info to most errors
d712dc1Gary Burgess
examples/manual/failing/ArgLengthMismatch.pursnew file+4
compare with golang
unifiedsplit
@@ -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 (
19 desugarCasesModule
19 desugarCasesModule
20) where
20) where
21
21
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
@@ -37,7 +38,9 @@ import Language.PureScript.Errors
37-- Replace all top-level binders in a module with case expressions.
38-- Replace all top-level binders in a module with case expressions.
38--
39--
39desugarCasesModule :: [Module] -> Either ErrorStack [Module]
40desugarCasesModule :: [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
41
44
42desugarAbs :: [Declaration] -> [Declaration]
45desugarAbs :: [Declaration] -> [Declaration]
43desugarAbs = everywhere (mkT replace)
46desugarAbs = everywhere (mkT replace)
@@ -86,7 +89,7 @@ toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do
86 throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing
89 throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing
87 return [makeCaseDeclaration ident tuples]
90 return [makeCaseDeclaration ident tuples]
88toDecls (PositionedDeclaration pos d : ds) = do
91toDecls (PositionedDeclaration pos d : ds) = do
89− (d' : ds') <- toDecls (d : ds)
92+ (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)
90 return (PositionedDeclaration pos d' : ds')
93 return (PositionedDeclaration pos d' : ds')
91toDecls ds = return ds
94toDecls ds = return ds
92
95
src/Language/PureScript/Sugar/Operators.hs+14−10
@@ -32,9 +32,10 @@ import Control.Applicative
32import Control.Monad.State
32import Control.Monad.State
33import Control.Monad.Error.Class
33import Control.Monad.Error.Class
34
34
35+import Data.Monoid ((<>))
35import Data.Function (on)
36import Data.Function (on)
36import Data.Functor.Identity
37import Data.Functor.Identity
37−import Data.List (sort, groupBy, sortBy)
38+import Data.List (groupBy, sortBy)
38
39
39import qualified Data.Data as D
40import qualified Data.Data as D
40import qualified Data.Generics as G
41import qualified Data.Generics as G
@@ -52,8 +53,8 @@ import qualified Language.PureScript.Constants as C
52rebracket :: [Module] -> Either ErrorStack [Module]
53rebracket :: [Module] -> Either ErrorStack [Module]
53rebracket ms = do
54rebracket ms = do
54 let fixities = concatMap collectFixities ms
55 let fixities = concatMap collectFixities ms
55− ensureNoDuplicates $ map fst fixities
56+ ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities
56− let opTable = customOperatorTable fixities
57+ let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities
57 mapM (rebracketModule opTable) ms
58 mapM (rebracketModule opTable) ms
58
59
59removeSignedLiterals :: (D.Data d) => d -> d
60removeSignedLiterals :: (D.Data d) => d -> d
@@ -73,20 +74,23 @@ removeParens = G.everywhere (G.mkT go)
73 go (Parens val) = val
74 go (Parens val) = val
74 go val = val
75 go val = val
75
76
76−collectFixities :: Module -> [(Qualified Ident, Fixity)]
77+collectFixities :: Module -> [(Qualified Ident, SourcePos, Fixity)]
77collectFixities (Module moduleName ds _) = concatMap collect ds
78collectFixities (Module moduleName ds _) = concatMap collect ds
78 where
79 where
79− collect :: Declaration -> [(Qualified Ident, Fixity)]
80+ collect :: Declaration -> [(Qualified Ident, SourcePos, Fixity)]
80− collect (PositionedDeclaration _ d) = collect d
81− 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"
82 collect _ = []
83 collect _ = []
83
84
84−ensureNoDuplicates :: [Qualified Ident] -> Either ErrorStack ()
85+ensureNoDuplicates :: [(Qualified Ident, SourcePos)] -> Either ErrorStack ()
85−ensureNoDuplicates m = go $ sort m
86+ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
86 where
87 where
87 go [] = return ()
88 go [] = return ()
88 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 $
89− go (x : y : _) | x == y = throwError $ mkErrorStack ("Redefined fixity for " ++ show x) Nothing
93+ throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing
90 go (_ : rest) = go rest
94 go (_ : rest) = go rest
91
95
92customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
96customOperatorTable :: [(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 (
21
21
22import Data.Generics (mkM)
22import Data.Generics (mkM)
23import Data.Generics.Extras
23import Data.Generics.Extras
24+import Data.Monoid ((<>))
24
25
25import Control.Applicative
26import Control.Applicative
26import Control.Monad.Error.Class
27import Control.Monad.Error.Class
@@ -35,14 +36,16 @@ import Language.PureScript.Errors
35-- 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
36--
37--
37desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module]
38desugarTypeDeclarationsModule :: [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
39
42
40-- |
43-- |
41-- Replace all top level type declarations with type annotations
44-- Replace all top level type declarations with type annotations
42--
45--
43desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration]
46desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration]
44desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do
47desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do
45− (d' : ds') <- desugarTypeDeclarations (d : ds)
48+ (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
46 return (PositionedDeclaration pos d' : ds')
49 return (PositionedDeclaration pos d' : ds')
47desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
50desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
48 (_, nameKind, val) <- fromValueDeclaration d
51 (_, nameKind, val) <- fromValueDeclaration d
@@ -51,9 +54,10 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
51 fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Value)
54 fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Value)
52 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)
53 fromValueDeclaration (PositionedDeclaration pos d') = do
56 fromValueDeclaration (PositionedDeclaration pos d') = do
54− (ident, nameKind, val) <- fromValueDeclaration d'
57+ (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
55 return (ident, nameKind, PositionedValue pos val)
58 return (ident, nameKind, PositionedValue pos val)
56 fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
59 fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
60+desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
57desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do
61desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do
58 (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest
62 (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest
59 where
63 where