GaloisInc/cryptol
1
1
Fork 0
mirror of https://github.com/GaloisInc/cryptol.git synced 2025-01-08 08:49:44 +03:00
Code Issues Projects Releases Wiki Activity

Slightly better parser messages.

Browse Source
This commit is contained in:
Iavor Diatchki 2017-11-15 15:36:45 -08:00
parent 951eebb8e2
commit 9de90e5752
2 changed files with 78 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Cryptol/Parser.y
View File

@ -321,6 +321,7 @@ decl :: { Decl PName }
| 'infixl' NUM ops {% mkFixity LeftAssoc $2 (reverse $3) }
| 'infixr' NUM ops {% mkFixity RightAssoc $2 (reverse $3) }
| 'infix' NUM ops {% mkFixity NonAssoc $2 (reverse $3) }
| error {% expected "a declaration" }
let_decl :: { Decl PName }
: 'let' ipat '=' expr { at ($2,$4) $ DPatBind $2 $4 }
@ -389,6 +390,7 @@ expr :: { Expr PName }
| expr 'where' '{' decls '}' { at ($1,$5) $ EWhere $1 (reverse $4) }
| expr 'where' 'v{' 'v}' { at ($1,$2) $ EWhere $1 [] }
| expr 'where' 'v{' vdecls 'v}' { at ($1,$4) $ EWhere $1 (reverse $4) }
| error {% expected "an expression" }
ifBranches :: { [(Expr PName, Expr PName)] }
: ifBranch { [$1] }

110
src/Cryptol/Parser/ParserUtils.hs
View File

@ -23,7 +23,7 @@ import Cryptol.Utils.Ident(packModName)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic
import Data.Maybe(listToMaybe,fromMaybe)
import Data.Maybe(fromMaybe)
import Data.Bits(testBit,setBit)
import Control.Monad(liftM,ap,unless)
import Data.Text(Text)
@ -40,7 +40,7 @@ parseString :: Config -> ParseM a -> String -> Either ParseError a
parseString cfg p cs = parse cfg p (T.pack cs)
parse :: Config -> ParseM a -> Text -> Either ParseError a
parse cfg p cs = case unP p cfg eofPos (S toks) of
parse cfg p cs = case unP p cfg eofPos (S Nothing toks) of
Left err -> Left err
Right (a,_) -> Right a
where (toks,eofPos) = lexer cfg cs
@ -51,7 +51,7 @@ data ParseM a = P { unP :: Config -> Position -> S -> Either ParseError (a,S)
lexerP :: (Located Token -> ParseM a) -> ParseM a
lexerP k = P $ \cfg p (S ts) ->
lexerP k = P $ \cfg p (S _ ts) ->
case ts of
t : _ | Err e <- tokenType it ->
Left $ HappyErrorMsg (srcRange t) $
@ -59,43 +59,66 @@ lexerP k = P $ \cfg p (S ts) ->
UnterminatedComment -> "unterminated comment"
UnterminatedString -> "unterminated string"
UnterminatedChar -> "unterminated character"
InvalidString -> "invalid string literal: " ++ T.unpack (tokenText it)
InvalidChar -> "invalid character literal: " ++ T.unpack (tokenText it)
LexicalError -> "unrecognized character: " ++ T.unpack (tokenText it)
InvalidString -> "invalid string literal:" ++
T.unpack (tokenText it)
InvalidChar -> "invalid character literal:" ++
T.unpack (tokenText it)
LexicalError -> "unrecognized character:" ++
T.unpack (tokenText it)
where it = thing t
t : more -> unP (k t) cfg p (S more)
[] -> Left (HappyError (cfgSource cfg) p Nothing)
t : more -> unP (k t) cfg p (S (Just t) more)
[] -> Left (HappyOutOfTokens (cfgSource cfg) p)
data ParseError = HappyError FilePath Position (Maybe Token)
data ParseError = HappyError FilePath {- Name of source file -}
(Located Token) {- Offending token -}
| HappyErrorMsg Range String
| HappyUnexpected FilePath (Maybe (Located Token)) String
| HappyOutOfTokens FilePath Position
deriving (Show, Generic, NFData)
newtype S = S [Located Token]
instance PP ParseError where
ppPrec _ (HappyError _ _ tok) = case tok of
Nothing -> text "end of input"
Just t -> pp t
ppPrec _ (HappyErrorMsg _ x) = text x
data S = S { sPrevTok :: Maybe (Located Token), sTokens :: [Located Token] }
ppError :: ParseError -> Doc
ppError (HappyError path pos (Just tok))
| Err _ <- tokenType tok = text "Parse error at" <+>
text path <> char ':' <> pp pos <> comma <+>
pp tok
ppError e@(HappyError path pos _) =
text "Parse error at" <+>
text path <> char ':' <> pp pos <> comma <+>
text "unexpected" <+> pp e
ppError (HappyError path ltok)
| Err _ <- tokenType tok =
text "Parse error at" <+>
text path <> char ':' <> pp pos <> comma <+>
pp tok
| White DocStr <- tokenType tok =
"Unexpected documentation (/**) comment at" <+>
text path <> char ':' <> pp pos <> colon $$
nest 2
"Documentation comments need to be followed by something to document."
| otherwise =
text "Parse error at" <+>
text path <> char ':' <> pp pos <> comma $$
nest 2 (text "unexpected:" <+> pp tok)
where
pos = from (srcRange ltok)
tok = thing ltok
ppError (HappyOutOfTokens path pos) =
text "Unexpected end of file at:" <+>
text path <> char ':' <> pp pos
ppError (HappyErrorMsg p x) = text "Parse error at" <+> pp p $$ nest 2 (text x)
instance Monad ParseM where
return a = P (\_ _ s -> Right (a,s))
fail s = panic "[Parser] fail" [s]
m >>= k = P (\cfg p s1 -> case unP m cfg p s1 of
Left e -> Left e
Right (a,s2) -> unP (k a) cfg p s2)
ppError (HappyUnexpected path ltok e) =
text "Parse error at" <+>
text path <> char ':' <> pp pos <> comma $$
nest 2 unexp $$
nest 2 ("expected:" <+> text e)
where
(unexp,pos) =
case ltok of
Nothing -> (empty,start)
Just t -> ( "unexpected:" <+> text (T.unpack (tokenText (thing t)))
, from (srcRange t)
)
instance Functor ParseM where
fmap = liftM
@ -104,11 +127,19 @@ instance Applicative ParseM where
pure = return
(<*>) = ap
instance Monad ParseM where
return a = P (\_ _ s -> Right (a,s))
fail s = panic "[Parser] fail" [s]
m >>= k = P (\cfg p s1 -> case unP m cfg p s1 of
Left e -> Left e
Right (a,s2) -> unP (k a) cfg p s2)
happyError :: ParseM a
happyError = P $ \cfg p (S ls) ->
Left $ case listToMaybe ls of
Nothing -> HappyError (cfgSource cfg) p Nothing
Just l -> HappyError (cfgSource cfg) (from (srcRange l)) (Just (thing l))
happyError = P $ \cfg _ (S p _) ->
case p of
Just t -> Left (HappyError (cfgSource cfg) t)
Nothing ->
Left (HappyErrorMsg emptyRange "Parse error at the beginning of the file")
errorMessage :: Range -> String -> ParseM a
errorMessage r x = P $ \_ _ _ -> Left (HappyErrorMsg r x)
@ -116,6 +147,17 @@ errorMessage r x = P $ \_ _ _ -> Left (HappyErrorMsg r x)
customError :: String -> Located Token -> ParseM a
customError x t = P $ \_ _ _ -> Left (HappyErrorMsg (srcRange t) x)
expected :: String -> ParseM a
expected x = P $ \cfg _ (S pt _) -> Left (HappyUnexpected (cfgSource cfg) pt x)
mkModName :: [Text] -> ModName
mkModName = packModName