Skip to content

Commit d712dc1

Browse files
garybgaryb
committed
Add position info to most errors
1 parent d7f4923 commit d712dc1

File tree

6 files changed

+39
-15
lines changed

6 files changed

+39
-15
lines changed

‎examples/manual/failing/ArgLengthMismatch.purs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
module ArgLengthMismatch where
2+
3+
f x y = true
4+
f = false

‎examples/manual/failing/OrphanTypeDecl.purs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
module OrphanTypeDecl where
2+
3+
fn :: Number -> Boolean

‎examples/manual/failing/RedefinedFixity.purs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -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‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ module Language.PureScript.Sugar.CaseDeclarations (
1919
desugarCasesModule
2020
) where
2121

22+
import Data.Monoid ((<>))
2223
import Data.List (groupBy)
2324
import Data.Generics (mkM, mkT, everywhere)
2425
import Data.Generics.Extras
@@ -37,7 +38,9 @@ import Language.PureScript.Errors
3738
-- Replace all top-level binders in a module with case expressions.
3839
--
3940
desugarCasesModule :: [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

4245
desugarAbs :: [Declaration] -> [Declaration]
4346
desugarAbs = 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]
8891
toDecls (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')
9194
toDecls ds = return ds
9295

‎src/Language/PureScript/Sugar/Operators.hs‎

Lines changed: 14 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -32,9 +32,10 @@ import Control.Applicative
3232
import Control.Monad.State
3333
import Control.Monad.Error.Class
3434

35+
import Data.Monoid ((<>))
3536
import Data.Function (on)
3637
import Data.Functor.Identity
37-
import Data.List (sort, groupBy, sortBy)
38+
import Data.List (groupBy, sortBy)
3839

3940
import qualified Data.Data as D
4041
import qualified Data.Generics as G
@@ -52,8 +53,8 @@ import qualified Language.PureScript.Constants as C
5253
rebracket :: [Module] -> Either ErrorStack [Module]
5354
rebracket 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

5960
removeSignedLiterals :: (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)]
7778
collectFixities (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

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

‎src/Language/PureScript/Sugar/TypeDeclarations.hs‎

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ module Language.PureScript.Sugar.TypeDeclarations (
2121

2222
import Data.Generics (mkM)
2323
import Data.Generics.Extras
24+
import Data.Monoid ((<>))
2425

2526
import Control.Applicative
2627
import 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
--
3738
desugarTypeDeclarationsModule :: [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
--
4346
desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration]
4447
desugarTypeDeclarations (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')
4750
desugarTypeDeclarations (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
5761
desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do
5862
(:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest
5963
where

0 commit comments

Comments
 (0)