Convert parsers to applicative interface
Problem: The aquisition of current range is manual, and therefore
error-prone. The names in do-syntax create visual clutter.
Solution: Hide range aquisition (which makes it possible to do automatic
comment aquisition as well).
This commit is contained in:
Kirill Andreev
parent
a8b898d396
commit
1ed617c7d0
@ -11,93 +11,78 @@ import Range
|
||||
import Debug.Trace
|
||||
|
||||
name :: Parser (Name Range)
|
||||
name = do
|
||||
(raw, info) <- range (token "Name")
|
||||
return Name {info, raw}
|
||||
name = ctor Name <*> token "Name"
|
||||
|
||||
capitalName :: Parser (Name Range)
|
||||
capitalName = do
|
||||
(raw, info) <- range (token "Name_Capital")
|
||||
return Name {info, raw}
|
||||
capitalName = ctor Name <*> token "Name_Capital"
|
||||
|
||||
contract :: Parser (Contract Range)
|
||||
contract = subtree "contract" do
|
||||
(decls, info) <- range do
|
||||
many "declaration" do
|
||||
inside "declaration:" do
|
||||
declaration
|
||||
|
||||
return (Contract info decls)
|
||||
contract =
|
||||
ctor Contract
|
||||
<*> subtree "contract" do
|
||||
many "declaration" do
|
||||
inside "declaration:" do
|
||||
declaration
|
||||
|
||||
declaration :: Parser (Declaration Range)
|
||||
declaration = do
|
||||
(b, info) <- range binding
|
||||
return (ValueDecl info b)
|
||||
<|> do
|
||||
(b, info) <- range vardecl
|
||||
return (ValueDecl info b)
|
||||
<|> do
|
||||
(b, info) <- range constdecl
|
||||
return (ValueDecl info b)
|
||||
<|>
|
||||
typedecl
|
||||
declaration
|
||||
= do ctor ValueDecl <*> binding
|
||||
<|> do ctor ValueDecl <*> vardecl
|
||||
<|> do ctor ValueDecl <*> constdecl
|
||||
<|> typedecl
|
||||
|
||||
typedecl :: Parser (Declaration Range)
|
||||
typedecl = do
|
||||
subtree "type_decl" do
|
||||
r <- getRange
|
||||
n <- inside "typeName:" name
|
||||
t <- inside "typeValue:" newtype_
|
||||
return $ TypeDecl r n t
|
||||
ctor TypeDecl
|
||||
<*> inside "typeName:" name
|
||||
<*> inside "typeValue:" newtype_
|
||||
|
||||
vardecl :: Parser (Binding Range)
|
||||
vardecl = do
|
||||
subtree "var_decl" do
|
||||
r <- getRange
|
||||
n <- inside "name:" name
|
||||
ty <- inside "type:" type_
|
||||
b <- inside "value:" expr
|
||||
return (Var r n ty b)
|
||||
ctor Var
|
||||
<*> inside "name:" name
|
||||
<*> inside "type:" type_
|
||||
<*> inside "value:" expr
|
||||
|
||||
constdecl :: Parser (Binding Range)
|
||||
constdecl = do
|
||||
subtree "const_decl" do
|
||||
r <- getRange
|
||||
n <- inside "name" name
|
||||
ty <- inside "type" type_
|
||||
b <- inside "value" expr
|
||||
return (Const r n ty b)
|
||||
|
||||
par x = do
|
||||
consume "("
|
||||
a <- x
|
||||
consume ")"
|
||||
return a
|
||||
ctor Const
|
||||
<*> inside "name" name
|
||||
<*> inside "type" type_
|
||||
<*> inside "value" expr
|
||||
|
||||
binding :: Parser (Binding Range)
|
||||
binding = do
|
||||
info <- getRange
|
||||
inside ":fun_decl" do
|
||||
recur <- optional $ inside "recursive" $ token "recursive"
|
||||
name <- inside "name:" name
|
||||
params <-
|
||||
inside "parameters:parameters" do
|
||||
many "param" do
|
||||
notFollowedBy do
|
||||
consumeOrDie ")"
|
||||
ctor Function
|
||||
<*> recursive
|
||||
<*> inside "name:" name
|
||||
<*> inside "parameters:parameters" do
|
||||
many "param" do
|
||||
notFollowedBy do
|
||||
consumeOrDie ")"
|
||||
|
||||
stubbed "parameters" paramDecl
|
||||
ty <- inside "type:" type_
|
||||
exp <- inside "body:" letExpr
|
||||
return (Function info (recur == Just "recursive") name params ty exp)
|
||||
stubbed "parameters" paramDecl
|
||||
<*> inside "type:" type_
|
||||
<*> inside "body:" letExpr
|
||||
|
||||
recursive = do
|
||||
mr <- optional do
|
||||
inside "recursive" do
|
||||
token "recursie"
|
||||
|
||||
return $ maybe False (== "recursive") mr
|
||||
|
||||
expr :: Parser (Expr Range)
|
||||
expr = stubbed "expr" do
|
||||
select
|
||||
[ Ident <$> getRange <*> do
|
||||
r <- getRange
|
||||
n <- name
|
||||
return $ QualifiedName r n []
|
||||
ctor QualifiedName
|
||||
<*> name
|
||||
<*> pure []
|
||||
, opCall
|
||||
, fun_call
|
||||
, record_expr
|
||||
@ -116,64 +101,51 @@ expr = stubbed "expr" do
|
||||
method_call :: Parser (Expr Range)
|
||||
method_call = do
|
||||
subtree "projection_call" do
|
||||
r <- getRange
|
||||
(f, r') <- field "f" $ range projection
|
||||
xs <- inside "arguments" arguments
|
||||
return $ Apply r (Ident r' f) xs
|
||||
ctor Apply
|
||||
<*> do ctor Ident <*> field "f" projection
|
||||
<*> inside "arguments" arguments
|
||||
|
||||
projection :: Parser (QualifiedName Range)
|
||||
projection = do
|
||||
subtree "data_projection" do
|
||||
r <- getRange
|
||||
s <- inside "struct" name
|
||||
is <- many "selection" selection
|
||||
return $ QualifiedName r s is
|
||||
ctor QualifiedName
|
||||
<*> inside "struct" name
|
||||
<*> many "selection" selection
|
||||
|
||||
selection :: Parser (Path Range)
|
||||
selection = do
|
||||
inside "index:selection" $ do
|
||||
r <- getRange
|
||||
n <- name
|
||||
return $ At r n
|
||||
<|> do
|
||||
r <- getRange
|
||||
n <- token "Int"
|
||||
return $ Ix r n
|
||||
inside "index:selection"
|
||||
$ do ctor At <*> name
|
||||
<|> do ctor Ix <*> token "Int"
|
||||
|
||||
par_call :: Parser (Expr Range)
|
||||
par_call = do
|
||||
subtree "par_call" do
|
||||
r <- getRange
|
||||
f <- inside "f" expr
|
||||
az <- inside "arguments" arguments
|
||||
return $ Apply r f az
|
||||
ctor Apply
|
||||
<*> inside "f" expr
|
||||
<*> inside "arguments" arguments
|
||||
|
||||
int_literal :: Parser (Expr Range)
|
||||
int_literal = do
|
||||
r <- getRange
|
||||
i <- token "Int"
|
||||
return $ Constant r (Int r i)
|
||||
ctor Constant
|
||||
<*> do ctor Int <*> token "Int"
|
||||
|
||||
record_expr :: Parser (Expr Range)
|
||||
record_expr = do
|
||||
subtree "record_expr" do
|
||||
r <- getRange
|
||||
az <- many "assignment" do
|
||||
inside "assignment:field_assignment" do
|
||||
r <- getRange
|
||||
n <- inside "name" name
|
||||
e <- inside "_rhs" expr
|
||||
return $ Assignment r n e
|
||||
return $ Record r az
|
||||
ctor Record <*> do
|
||||
many "assignment" do
|
||||
inside "assignment:field_assignment" do
|
||||
ctor Assignment
|
||||
<*> inside "name" name
|
||||
<*> inside "_rhs" expr
|
||||
|
||||
fun_call :: Parser (Expr Range)
|
||||
fun_call = do
|
||||
subtree "fun_call" do
|
||||
r <- getRange
|
||||
(f, r') <- range $ inside "f" function_id
|
||||
xs <- inside "arguments" do
|
||||
arguments
|
||||
return $ Apply r (Ident r' f) xs
|
||||
ctor Apply
|
||||
<*> do ctor Ident <*> inside "f" function_id
|
||||
<*> inside "arguments" arguments
|
||||
|
||||
arguments =
|
||||
subtree "arguments" do
|
||||
@ -182,64 +154,55 @@ arguments =
|
||||
|
||||
function_id :: Parser (QualifiedName Range)
|
||||
function_id = select
|
||||
[ do
|
||||
r <- getRange
|
||||
n <- name
|
||||
return $ QualifiedName r n []
|
||||
[ ctor QualifiedName
|
||||
<*> name
|
||||
<*> pure []
|
||||
, do
|
||||
subtree "module_field" do
|
||||
r <- getRange
|
||||
whole <- inside "module" capitalName
|
||||
path <- inside "method" name
|
||||
return $ QualifiedName r whole [At r path]
|
||||
ctor QualifiedName
|
||||
<*> inside "module" capitalName
|
||||
<*> do pure <$> do ctor At <*> inside "method" name
|
||||
]
|
||||
|
||||
opCall :: Parser (Expr Range)
|
||||
opCall = do
|
||||
subtree "op_expr" $ do
|
||||
inside "the" do
|
||||
expr
|
||||
<|> do
|
||||
i <- getRange
|
||||
l <- inside "arg1" expr
|
||||
o <- inside "op" anything
|
||||
r <- inside "arg2" expr
|
||||
return $ BinOp i l o r
|
||||
subtree "op_expr"
|
||||
$ do inside "the" expr
|
||||
<|> do ctor BinOp
|
||||
<*> inside "arg1" expr
|
||||
<*> inside "op" anything
|
||||
<*> inside "arg2" expr
|
||||
|
||||
letExpr = do
|
||||
subtree "let_expr" do
|
||||
r <- getRange
|
||||
decls <- optional do
|
||||
inside "locals:block" do
|
||||
many "decl" do
|
||||
inside "statement" do
|
||||
declaration <|> statement
|
||||
body <- inside "body"expr
|
||||
ctor let'
|
||||
<*> optional do
|
||||
inside "locals:block" do
|
||||
many "decl" do
|
||||
inside "statement" do
|
||||
declaration <|> statement
|
||||
<*> inside "body"expr
|
||||
|
||||
return case decls of
|
||||
where
|
||||
let' r decls body = case decls of
|
||||
Just them -> Let r them body
|
||||
Nothing -> body
|
||||
|
||||
statement :: Parser (Declaration Range)
|
||||
statement = do
|
||||
r <- getRange
|
||||
e <- expr
|
||||
return $ Action r e
|
||||
statement = ctor Action <*> expr
|
||||
|
||||
paramDecl :: Parser (VarDecl Range)
|
||||
paramDecl = do
|
||||
info <- getRange
|
||||
inside "parameter:param_decl" do
|
||||
info' <- getRange
|
||||
mutable <- do
|
||||
inside ":access" do
|
||||
select
|
||||
[ consume "var" >> return (Mutable info')
|
||||
, consume "const" >> return (Immutable info')
|
||||
]
|
||||
name <- inside "name" name
|
||||
ty <- inside "type" type_
|
||||
return (Decl info mutable name ty)
|
||||
ctor Decl
|
||||
<*> do inside ":access" do
|
||||
select
|
||||
[ ctor Mutable <* consumeOrDie "var"
|
||||
, ctor Immutable <* consumeOrDie "const"
|
||||
]
|
||||
<*> inside "name" name
|
||||
<*> inside "type" type_
|
||||
|
||||
newtype_ = select
|
||||
[ record_type
|
||||
@ -249,19 +212,16 @@ newtype_ = select
|
||||
|
||||
record_type = do
|
||||
subtree "record_type" do
|
||||
r <- getRange
|
||||
fs <- many "field" do
|
||||
inside "field" do
|
||||
field_decl
|
||||
traceShowM fs
|
||||
return $ TRecord r fs
|
||||
ctor TRecord
|
||||
<*> many "field" do
|
||||
inside "field" do
|
||||
field_decl
|
||||
|
||||
field_decl = do
|
||||
subtree "field_decl" do
|
||||
r <- getRange
|
||||
n <- inside "fieldName" name
|
||||
t <- inside "fieldType" type_
|
||||
return $ TField r n t
|
||||
ctor TField
|
||||
<*> inside "fieldName" name
|
||||
<*> inside "fieldType" type_
|
||||
|
||||
type_ :: Parser (Type Range)
|
||||
type_ =
|
||||
@ -270,48 +230,40 @@ type_ =
|
||||
fun_type :: Parser (Type Range)
|
||||
fun_type = do
|
||||
inside ":fun_type" do
|
||||
info <- getRange
|
||||
domain <- inside "domain" cartesian
|
||||
codomain <- optional do
|
||||
consume "->"
|
||||
fun_type
|
||||
ctor tarrow
|
||||
<*> inside "domain" cartesian
|
||||
<*> optional do inside "codomain" fun_type
|
||||
|
||||
return case codomain of
|
||||
Just co -> TArrow info domain co
|
||||
Nothing -> domain
|
||||
where
|
||||
tarrow info domain codomain =
|
||||
case codomain of
|
||||
Just co -> TArrow info domain co
|
||||
Nothing -> domain
|
||||
|
||||
cartesian = do
|
||||
inside ":cartesian" do
|
||||
info <- getRange
|
||||
TProduct info <$> some "corety" do
|
||||
ctor TProduct <*> some "corety" do
|
||||
inside "element" do
|
||||
core_type
|
||||
|
||||
core_type = do
|
||||
info <- getRange
|
||||
select
|
||||
[ TVar info <$> typename
|
||||
[ ctor TVar <*> name
|
||||
, subtree "invokeBinary" do
|
||||
r <- getRange
|
||||
f <- inside "typeConstr" name
|
||||
xs <- inside "arguments" typeTuple
|
||||
return $ TApply r f xs
|
||||
ctor TApply
|
||||
<*> inside "typeConstr" name
|
||||
<*> inside "arguments" typeTuple
|
||||
]
|
||||
|
||||
typename = name
|
||||
|
||||
typeTuple :: Parser [Type Range]
|
||||
typeTuple = do
|
||||
subtree "type_tuple" do
|
||||
many "type tuple element" do
|
||||
inside "element" type_
|
||||
|
||||
tuple :: Text -> Parser a -> Parser [a]
|
||||
tuple msg = par . some msg
|
||||
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
example = "../../../src/test/contracts/application.ligo"
|
||||
-- example = "../../../src/test/contracts/address.ligo"
|
||||
example = "../../../src/test/contracts/amount.ligo"
|
||||
-- example = "../../../src/test/contracts/amount.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
|
||||
@ -295,20 +295,18 @@ inside sig parser = do
|
||||
let st = Text.drop 1 st'
|
||||
if Text.null f
|
||||
then do
|
||||
traceShowM ("subtree", st)
|
||||
subtree st do
|
||||
traceShowM ("stubbed", st)
|
||||
stubbed f do
|
||||
parser
|
||||
else do
|
||||
traceShowM ("field", f)
|
||||
field f do
|
||||
traceShowM ("stubbed", f)
|
||||
stubbed f do
|
||||
if Text.null st
|
||||
then do
|
||||
parser
|
||||
else do
|
||||
traceShowM ("subtree", st)
|
||||
subtree st do
|
||||
parser
|
||||
|
||||
ctor :: (Range -> a) -> Parser a
|
||||
ctor = (<$> getRange)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user