diff --git a/.gitignore b/.gitignore index efddb985..b96f0af0 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,4 @@ lambdacube-compiler-test-suite.tix .ghc.environment.* .dir-locals.el .stack-work +cabal.project diff --git a/src/LambdaCube/Compiler/Lexer.hs b/src/LambdaCube/Compiler/Lexer.hs index 29b88930..15f34a31 100644 --- a/src/LambdaCube/Compiler/Lexer.hs +++ b/src/LambdaCube/Compiler/Lexer.hs @@ -14,7 +14,7 @@ module LambdaCube.Compiler.Lexer ) where import Data.List -import Data.List.NonEmpty (fromList) +import Data.List.NonEmpty (NonEmpty, fromList) import Data.Char import qualified Data.Set as Set import Data.Void @@ -34,6 +34,7 @@ import LambdaCube.Compiler.DesugaredSource -------------------------------------------------------------------------------- utils + -- try with error handling -- see http://blog.ezyang.com/2014/05/parsec-try-a-or-b-considered-harmful/comment-page-1/#comment-6602 try_ :: String -> Parse r w a -> Parse r w a @@ -43,7 +44,7 @@ toSPos :: SourcePos -> SPos toSPos p = SPos (fromIntegral $ unPos $ sourceLine p) (fromIntegral $ unPos $ sourceColumn p) getSPos :: Parse r w SPos -getSPos = toSPos <$> getPosition +getSPos = toSPos <$> getSourcePos -------------------------------------------------------------------------------- literals @@ -113,21 +114,26 @@ data ParseEnv r = ParseEnv , indentationLevel :: SPos } -type ParseState r = (ParseEnv r, P.State String) +type ParseState r = (ParseEnv r, P.State String (ErrorFancy Void)) parseState :: FileInfo -> r -> ParseState r -parseState fi di = (ParseEnv fi di ExpNS (SPos 0 0), either (error "impossible") id $ runParser (getParserState :: Parsec (ErrorFancy Void) String (P.State String)) (filePath fi) (fileContent fi)) +parseState fi di = (ParseEnv fi di ExpNS (SPos 0 0), either (error "impossible") id $ runParser (getParserState :: Parsec (ErrorFancy Void) String (P.State String (ErrorFancy Void))) (filePath fi) (fileContent fi)) --type Parse r w = ReaderT (ParseEnv r) (WriterT [w] (StateT SPos (Parsec String))) type Parse r w = RWST (ParseEnv r) [w] SPos (Parsec (ErrorFancy Void) String) -newtype ParseError = ParseErr (P.ParseError (Token String) (ErrorFancy Void)) +newtype ParseError = ParseErr (P.ParseError String (ErrorFancy Void)) + +instance (ShowErrorComponent v, Show v) => + ShowErrorComponent (ErrorFancy v) where + showErrorComponent (ErrorCustom e) = showErrorComponent e + showErrorComponent x = show x instance Show ParseError where show (ParseErr e) = parseErrorPretty e -runParse :: Parse r w a -> ParseState r -> Either ParseError (a, [w]) -runParse p (env, st) = left ParseErr . snd . flip runParser' st $ evalRWST p env (error "spos") +runParse :: Parse r w a -> ParseState r -> Either (NonEmpty ParseError) (a, [w]) +runParse p (env, st) = left (fmap ParseErr . bundleErrors) . snd . flip runParser' st $ evalRWST p env (error "spos") getParseState :: Parse r w (ParseState r) getParseState = (,) <$> ask <*> getParserState diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs index 752d7957..794fd151 100644 --- a/src/LambdaCube/Compiler/Parser.hs +++ b/src/LambdaCube/Compiler/Parser.hs @@ -20,6 +20,7 @@ module LambdaCube.Compiler.Parser import Data.Monoid import Data.Maybe import Data.List +import Data.List.NonEmpty (NonEmpty, fromList) import Data.Char import qualified Data.Map as Map import qualified Data.Set as Set @@ -53,7 +54,7 @@ data LCParseError = MultiplePatternVars [[SIName]] | OperatorMismatch SIName SIName | UndefinedConstructor SIName - | ParseError ParseError + | ParseError (NonEmpty ParseError) data ParseWarning = Unreachable Range @@ -621,7 +622,7 @@ parseExtensions type Module = Module_ DefParser -type DefParser = DesugarInfo -> Either ParseError ([Stmt], [PostponedCheck]) +type DefParser = DesugarInfo -> Either (NonEmpty ParseError) ([Stmt], [PostponedCheck]) type HeaderParser = Parse () () @@ -655,7 +656,7 @@ parseModule = do , definitions = \ge -> runParse (parseDefs SLHS <* eof) (env { desugarInfo = ge }, st) } -parseLC :: FileInfo -> Either ParseError Module +parseLC :: FileInfo -> Either (NonEmpty ParseError) Module parseLC fi = fmap fst $ runParse parseModule $ parseState fi () @@ -663,7 +664,7 @@ runDefParser :: (MonadFix m, MonadError LCParseError m) => DesugarInfo -> DefPar runDefParser ds_ dp = do (defs, dns, ds) <- mfix $ \ ~(_, _, ds) -> do - let x :: Either ParseError ([Stmt], [PostponedCheck]) + let x :: Either (NonEmpty ParseError) ([Stmt], [PostponedCheck]) x = dp (ds <> ds_) (defs, dns) <- either (throwError . ParseError) return x return (defs, dns, mkDesugarInfo defs)