Fix bulk of function header parser
This commit is contained in:
parent
cb40392554
commit
017db45f8d
@ -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: $ =>
|
||||||
|
@ -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"
|
@ -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
|
Loading…
Reference in New Issue
Block a user