Fix bulk of function header parser

This commit is contained in:
Kirill Andreev 2020-04-30 17:46:39 +04:00
parent cb40392554
commit 017db45f8d
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
3 changed files with 116 additions and 68 deletions

View File

@ -179,7 +179,8 @@ module.exports = grammar({
field("body", $._expr), field("body", $._expr),
), ),
_open_fun_decl: $ => fun_decl: $ =>
prec.right(0,
seq( seq(
field("recursive", optional($.recursive)), field("recursive", optional($.recursive)),
'function', 'function',
@ -193,13 +194,9 @@ module.exports = grammar({
'with', 'with',
)), )),
field("body", $._expr), field("body", $._expr),
),
fun_decl: $ =>
seq(
field("_open_fun_decl", $._open_fun_decl),
optional(';'), optional(';'),
), ),
),
parameters: $ => par(sepBy(';', field("parameter", $.param_decl))), parameters: $ => par(sepBy(';', field("parameter", $.param_decl))),
@ -226,7 +223,7 @@ module.exports = grammar({
choice( choice(
$.open_const_decl, $.open_const_decl,
$.open_var_decl, $.open_var_decl,
$._open_fun_decl, $.fun_decl,
), ),
open_const_decl: $ => open_const_decl: $ =>

View File

@ -123,11 +123,13 @@ name = do
contract :: Parser (Contract Range) contract :: Parser (Contract Range)
contract = subtree "contract" do contract = subtree "contract" do
(decls, info) <- range $ many "declaration" declaration (decls, info) <- range do
many "declaration" declaration
return (Contract info decls) return (Contract info decls)
declaration :: Parser (Declaration Range) declaration :: Parser (Declaration Range)
declaration = declaration =
stubbed "declaration" do
field "declaration" do field "declaration" do
(b, info) <- range binding (b, info) <- range binding
return (ValueDecl info b) return (ValueDecl info b)
@ -146,31 +148,50 @@ binding = do
field "recursive" do field "recursive" do
token "recursive" token "recursive"
consume "function" consume "function"
name <- field "name" do name <- stubbed "name" do
field "name" do
name name
params <- field "parameters" $ par (many "param" paramDecl) params <-
field "parameters" do
subtree "parameters" do
par do
many "param" do
notFollowedBy do
consumeOrDie ")"
stubbed "parameters" do
paramDecl
consume ":" consume ":"
ty <- field "type" type_ ty <-
stubbed "type" do
field "type" type_
consume "is" consume "is"
get >>= traceShowM expr <- stubbed "body" do
expr <- field "locals" anything field "locals" anything
return (Function info (recur == Just "recursive") name params ty expr) return (Function info (recur == Just "recursive") name params ty expr)
paramDecl :: Parser (VarDecl Range) paramDecl :: Parser (VarDecl Range)
paramDecl = do paramDecl = do
info <- getRange info <- getRange
"parameter" `field` do "parameter" `field` do
subtree "param_decl" do
info' <- getRange info' <- getRange
mutable <- do mutable <- do
"access" `subtree` select traceM "paramDecl"
[ do consume "var" stubbed "access" do
return $ Mutable info' "access" `subtree` do
, do consume "const" traceM "paramDecl"
return $ Immutable info' select
[ consume "var" >> return (Mutable info')
, consume "const" >> return (Immutable info')
] ]
name <- field "name" name name <-
stubbed "name" do
field "name" name
consume ":" consume ":"
ty <- field "type" type_ ty <-
stubbed "type" do
field "type" type_
return (Decl info mutable name ty) return (Decl info mutable name ty)
newtype_ = do newtype_ = do
@ -182,8 +203,11 @@ type_ =
where where
fun_type :: Parser (Type Range) fun_type :: Parser (Type Range)
fun_type = do fun_type = do
stubbed "type" do
subtree "fun_type" do
info <- getRange info <- getRange
domain <- field "domain" cartesian domain <- stubbed "domain" do
field "domain" cartesian
codomain <- optional do codomain <- optional do
consume "->" consume "->"
fun_type fun_type
@ -192,8 +216,12 @@ type_ =
Nothing -> domain Nothing -> domain
cartesian = do cartesian = do
stubbed "cartesian" do
subtree "cartesian" do
info <- getRange info <- getRange
Product info <$> some "corety" core_type Product info <$> some "corety" do
field "element" do
core_type
core_type = do core_type = do
info <- getRange info <- getRange
@ -206,4 +234,4 @@ type_ =
tuple :: Text -> Parser a -> Parser [a] tuple :: Text -> Parser a -> Parser [a]
tuple msg = par . some msg tuple msg = par . some msg
example = "../../ligo/src/test/contracts/address.ligo" example = "../../../src/test/contracts/address.ligo"

View File

@ -8,7 +8,6 @@ import Control.Monad.Except
import Control.Monad.Identity import Control.Monad.Identity
import Data.Text.Encoding import Data.Text.Encoding
-- import Data.Traversable (for)
import Data.Text (Text, pack, unpack) import Data.Text (Text, pack, unpack)
import qualified Data.ByteString as ByteString import qualified Data.ByteString as ByteString
@ -16,7 +15,7 @@ import Data.ByteString (ByteString)
import ParseTree import ParseTree
-- import Debug.Trace import Debug.Trace
data Error data Error
= Expected Text Range = Expected Text Range
@ -54,7 +53,7 @@ takeNext msg = do
} }
return t return t
field :: Stubbed a => Text -> Parser a -> Parser a field :: Text -> Parser a -> Parser a
field name parser = do field name parser = do
grove <- gets pfGrove grove <- gets pfGrove
case grove of case grove of
@ -77,7 +76,7 @@ field name parser = do
, pfRange = ptRange , pfRange = ptRange
} }
stubbed name parser <* put st parser <* put st
{ pfGrove = grove' { pfGrove = grove'
, pfRange = if firstOne then diffRange rng ptRange else rng , pfRange = if firstOne then diffRange rng ptRange else rng
} }
@ -116,13 +115,25 @@ many :: Text -> Parser a -> Parser [a]
many msg p = many' many msg p = many'
where where
many' = some' <|> pure [] many' = some' <|> pure []
some' = (:) <$> (productive msg p) <*> many' some' = do
(x, consumed) <- productive p
if consumed then do
xs <- many'
return (x : xs)
else do
return [x]
some :: Text -> Parser a -> Parser [a] some :: Text -> Parser a -> Parser [a]
some msg p = some' some msg p = some'
where where
many' = some' <|> pure [] many' = some' <|> pure []
some' = (:) <$> (productive msg p) <*> many' some' = do
(x, consumed) <- productive p
if consumed then do
xs <- many'
return (x : xs)
else do
return [x]
getTreeID :: Parser (Maybe Int) getTreeID :: Parser (Maybe Int)
getTreeID = Parser do getTreeID = Parser do
@ -130,14 +141,12 @@ getTreeID = Parser do
[] -> Nothing [] -> Nothing
(_, tree) : _ -> Just (ptID tree) (_, tree) : _ -> Just (ptID tree)
productive :: Text -> Parser a -> Parser a productive :: Parser a -> Parser (a, Bool)
productive msg p = do productive p = do
was <- getTreeID was <- getTreeID
res <- p res <- p
now <- getTreeID now <- getTreeID
unless (was /= now) do return (res, was /= now)
error ("unproductive: " ++ unpack msg)
return res
data ParserEnv = ParserEnv data ParserEnv = ParserEnv
{ peRange :: Range { peRange :: Range
@ -182,6 +191,12 @@ consume node = do
when (ptName /= node) do when (ptName /= node) do
tell [Expected node ptRange] tell [Expected node ptRange]
consumeOrDie :: Text -> Parser ()
consumeOrDie node = do
ParseTree {ptName, ptRange} <- takeNext node
when (ptName /= node) do
throwError $ Expected node ptRange
cutOut :: ByteString -> ParseTree -> Text cutOut :: ByteString -> ParseTree -> Text
cutOut bs (ParseTree _ _ s f _ _) = cutOut bs (ParseTree _ _ s f _ _) =
decodeUtf8 $ ByteString.take (f - s) (ByteString.drop s bs) decodeUtf8 $ ByteString.take (f - s) (ByteString.drop s bs)
@ -207,11 +222,19 @@ delete k ((k', v) : rest) =
then rest then rest
else (k', v) : delete k rest else (k', v) : delete k rest
notFollowedBy :: Parser a -> Parser ()
notFollowedBy parser = do
good <- do
parser
return False
<|> do
return True
unless good do
die "notFollowedBy"
class Stubbed a where class Stubbed a where
stub :: Error -> a stub :: Error -> a
instance Stubbed [a] where
stub _ = []
instance Stubbed Text where instance Stubbed Text where
stub e = pack ("<" <> show e <> ">") stub = pack . show