balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Convert parsers to applicative interface

Browse Source 
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 2020-05-06 21:59:34 +04:00
parent a8b898d396
commit 1ed617c7d0
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
2 changed files with 122 additions and 172 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

250
tools/lsp/squirrel/src/AST/Parser.hs
View File

@ -11,93 +11,78 @@ import Range
import Debug.Trace import Debug.Trace
name :: Parser (Name Range) name :: Parser (Name Range)
name = do name = ctor Name <*> token "Name"
(raw, info) <- range (token "Name")
return Name {info, raw}
capitalName :: Parser (Name Range) capitalName :: Parser (Name Range)
capitalName = do capitalName = ctor Name <*> token "Name_Capital"
(raw, info) <- range (token "Name_Capital")
return Name {info, raw}
contract :: Parser (Contract Range) contract :: Parser (Contract Range)
contract = subtree "contract" do contract =
(decls, info) <- range do ctor Contract
<*> subtree "contract" do
many "declaration" do many "declaration" do
inside "declaration:" do inside "declaration:" do
declaration declaration
return (Contract info decls)
declaration :: Parser (Declaration Range) declaration :: Parser (Declaration Range)
declaration = do declaration
(b, info) <- range binding = do ctor ValueDecl <*> binding
return (ValueDecl info b) <|> do ctor ValueDecl <*> vardecl
<|> do <|> do ctor ValueDecl <*> constdecl
(b, info) <- range vardecl <|> typedecl
return (ValueDecl info b)
<|> do
(b, info) <- range constdecl
return (ValueDecl info b)
<|>
typedecl
typedecl :: Parser (Declaration Range) typedecl :: Parser (Declaration Range)
typedecl = do typedecl = do
subtree "type_decl" do subtree "type_decl" do
r <- getRange ctor TypeDecl
n <- inside "typeName:" name <*> inside "typeName:" name
t <- inside "typeValue:" newtype_ <*> inside "typeValue:" newtype_
return $ TypeDecl r n t
vardecl :: Parser (Binding Range) vardecl :: Parser (Binding Range)
vardecl = do vardecl = do
subtree "var_decl" do subtree "var_decl" do
r <- getRange ctor Var
n <- inside "name:" name <*> inside "name:" name
ty <- inside "type:" type_ <*> inside "type:" type_
b <- inside "value:" expr <*> inside "value:" expr
return (Var r n ty b)
constdecl :: Parser (Binding Range) constdecl :: Parser (Binding Range)
constdecl = do constdecl = do
subtree "const_decl" do subtree "const_decl" do
r <- getRange ctor Const
n <- inside "name" name <*> inside "name" name
ty <- inside "type" type_ <*> inside "type" type_
b <- inside "value" expr <*> inside "value" expr
return (Const r n ty b)
par x = do
consume "("
a <- x
consume ")"
return a
binding :: Parser (Binding Range) binding :: Parser (Binding Range)
binding = do binding = do
info <- getRange
inside ":fun_decl" do inside ":fun_decl" do
recur <- optional $ inside "recursive" $ token "recursive" ctor Function
name <- inside "name:" name <*> recursive
params <- <*> inside "name:" name
inside "parameters:parameters" do <*> inside "parameters:parameters" do
many "param" do many "param" do
notFollowedBy do notFollowedBy do
consumeOrDie ")" consumeOrDie ")"
stubbed "parameters" paramDecl stubbed "parameters" paramDecl
ty <- inside "type:" type_ <*> inside "type:" type_
exp <- inside "body:" letExpr <*> inside "body:" letExpr
return (Function info (recur == Just "recursive") name params ty exp)
recursive = do
mr <- optional do
inside "recursive" do
token "recursie"
return $ maybe False (== "recursive") mr
expr :: Parser (Expr Range) expr :: Parser (Expr Range)
expr = stubbed "expr" do expr = stubbed "expr" do
select select
[ Ident <$> getRange <*> do [ Ident <$> getRange <*> do
r <- getRange ctor QualifiedName
n <- name <*> name
return $ QualifiedName r n [] <*> pure []
, opCall , opCall
, fun_call , fun_call
, record_expr , record_expr
@ -116,64 +101,51 @@ expr = stubbed "expr" do
method_call :: Parser (Expr Range) method_call :: Parser (Expr Range)
method_call = do method_call = do
subtree "projection_call" do subtree "projection_call" do
r <- getRange ctor Apply
(f, r') <- field "f" $ range projection <*> do ctor Ident <*> field "f" projection
xs <- inside "arguments" arguments <*> inside "arguments" arguments
return $ Apply r (Ident r' f) xs
projection :: Parser (QualifiedName Range) projection :: Parser (QualifiedName Range)
projection = do projection = do
subtree "data_projection" do subtree "data_projection" do
r <- getRange ctor QualifiedName
s <- inside "struct" name <*> inside "struct" name
is <- many "selection" selection <*> many "selection" selection
return $ QualifiedName r s is
selection :: Parser (Path Range) selection :: Parser (Path Range)
selection = do selection = do
inside "index:selection" $ do inside "index:selection"
r <- getRange $ do ctor At <*> name
n <- name <|> do ctor Ix <*> token "Int"
return $ At r n
<|> do
r <- getRange
n <- token "Int"
return $ Ix r n
par_call :: Parser (Expr Range) par_call :: Parser (Expr Range)
par_call = do par_call = do
subtree "par_call" do subtree "par_call" do
r <- getRange ctor Apply
f <- inside "f" expr <*> inside "f" expr
az <- inside "arguments" arguments <*> inside "arguments" arguments
return $ Apply r f az
int_literal :: Parser (Expr Range) int_literal :: Parser (Expr Range)
int_literal = do int_literal = do
r <- getRange ctor Constant
i <- token "Int" <*> do ctor Int <*> token "Int"
return $ Constant r (Int r i)
record_expr :: Parser (Expr Range) record_expr :: Parser (Expr Range)
record_expr = do record_expr = do
subtree "record_expr" do subtree "record_expr" do
r <- getRange ctor Record <*> do
az <- many "assignment" do many "assignment" do
inside "assignment:field_assignment" do inside "assignment:field_assignment" do
r <- getRange ctor Assignment
n <- inside "name" name <*> inside "name" name
e <- inside "_rhs" expr <*> inside "_rhs" expr
return $ Assignment r n e
return $ Record r az
fun_call :: Parser (Expr Range) fun_call :: Parser (Expr Range)
fun_call = do fun_call = do
subtree "fun_call" do subtree "fun_call" do
r <- getRange ctor Apply
(f, r') <- range $ inside "f" function_id <*> do ctor Ident <*> inside "f" function_id
xs <- inside "arguments" do <*> inside "arguments" arguments
arguments
return $ Apply r (Ident r' f) xs
arguments = arguments =
subtree "arguments" do subtree "arguments" do
@ -182,64 +154,55 @@ arguments =
function_id :: Parser (QualifiedName Range) function_id :: Parser (QualifiedName Range)
function_id = select function_id = select
[ do [ ctor QualifiedName
r <- getRange <*> name
n <- name <*> pure []
return $ QualifiedName r n []
, do , do
subtree "module_field" do subtree "module_field" do
r <- getRange ctor QualifiedName
whole <- inside "module" capitalName <*> inside "module" capitalName
path <- inside "method" name <*> do pure <$> do ctor At <*> inside "method" name
return $ QualifiedName r whole [At r path]
] ]
opCall :: Parser (Expr Range) opCall :: Parser (Expr Range)
opCall = do opCall = do
subtree "op_expr" $ do subtree "op_expr"
inside "the" do $ do inside "the" expr
expr <|> do ctor BinOp
<|> do <*> inside "arg1" expr
i <- getRange <*> inside "op" anything
l <- inside "arg1" expr <*> inside "arg2" expr
o <- inside "op" anything
r <- inside "arg2" expr
return $ BinOp i l o r
letExpr = do letExpr = do
subtree "let_expr" do subtree "let_expr" do
r <- getRange ctor let'
decls <- optional do <*> optional do
inside "locals:block" do inside "locals:block" do
many "decl" do many "decl" do
inside "statement" do inside "statement" do
declaration <|> statement declaration <|> statement
body <- inside "body"expr <*> inside "body"expr
return case decls of where
let' r decls body = case decls of
Just them -> Let r them body Just them -> Let r them body
Nothing -> body Nothing -> body
statement :: Parser (Declaration Range) statement :: Parser (Declaration Range)
statement = do statement = ctor Action <*> expr
r <- getRange
e <- expr
return $ Action r e
paramDecl :: Parser (VarDecl Range) paramDecl :: Parser (VarDecl Range)
paramDecl = do paramDecl = do
info <- getRange info <- getRange
inside "parameter:param_decl" do inside "parameter:param_decl" do
info' <- getRange ctor Decl
mutable <- do <*> do inside ":access" do
inside ":access" do
select select
[ consume "var" >> return (Mutable info') [ ctor Mutable <* consumeOrDie "var"
, consume "const" >> return (Immutable info') , ctor Immutable <* consumeOrDie "const"
] ]
name <- inside "name" name <*> inside "name" name
ty <- inside "type" type_ <*> inside "type" type_
return (Decl info mutable name ty)
newtype_ = select newtype_ = select
[ record_type [ record_type
@ -249,19 +212,16 @@ newtype_ = select
record_type = do record_type = do
subtree "record_type" do subtree "record_type" do
r <- getRange ctor TRecord
fs <- many "field" do <*> many "field" do
inside "field" do inside "field" do
field_decl field_decl
traceShowM fs
return $ TRecord r fs
field_decl = do field_decl = do
subtree "field_decl" do subtree "field_decl" do
r <- getRange ctor TField
n <- inside "fieldName" name <*> inside "fieldName" name
t <- inside "fieldType" type_ <*> inside "fieldType" type_
return $ TField r n t
type_ :: Parser (Type Range) type_ :: Parser (Type Range)
type_ = type_ =
@ -270,48 +230,40 @@ type_ =
fun_type :: Parser (Type Range) fun_type :: Parser (Type Range)
fun_type = do fun_type = do
inside ":fun_type" do inside ":fun_type" do
info <- getRange ctor tarrow
domain <- inside "domain" cartesian <*> inside "domain" cartesian
codomain <- optional do <*> optional do inside "codomain" fun_type
consume "->"
fun_type
return case codomain of where
tarrow info domain codomain =
case codomain of
Just co -> TArrow info domain co Just co -> TArrow info domain co
Nothing -> domain Nothing -> domain
cartesian = do cartesian = do
inside ":cartesian" do inside ":cartesian" do
info <- getRange ctor TProduct <*> some "corety" do
TProduct info <$> some "corety" do
inside "element" do inside "element" do
core_type core_type
core_type = do core_type = do
info <- getRange
select select
[ TVar info <$> typename [ ctor TVar <*> name
, subtree "invokeBinary" do , subtree "invokeBinary" do
r <- getRange ctor TApply
f <- inside "typeConstr" name <*> inside "typeConstr" name
xs <- inside "arguments" typeTuple <*> inside "arguments" typeTuple
return $ TApply r f xs
] ]
typename = name
typeTuple :: Parser [Type Range] typeTuple :: Parser [Type Range]
typeTuple = do typeTuple = do
subtree "type_tuple" do subtree "type_tuple" do
many "type tuple element" do many "type tuple element" do
inside "element" type_ inside "element" type_
tuple :: Text -> Parser a -> Parser [a] example = "../../../src/test/contracts/application.ligo"
tuple msg = par . some msg
-- example = "../../../src/test/contracts/application.ligo"
-- example = "../../../src/test/contracts/address.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" -- example = "../../../src/test/contracts/application.ligo"
-- example = "../../../src/test/contracts/application.ligo" -- example = "../../../src/test/contracts/application.ligo"

8
tools/lsp/squirrel/src/Parser.hs
View File

@ -295,20 +295,18 @@ inside sig parser = do
let st = Text.drop 1 st' let st = Text.drop 1 st'
if Text.null f if Text.null f
then do then do
traceShowM ("subtree", st)
subtree st do subtree st do
traceShowM ("stubbed", st)
stubbed f do stubbed f do
parser parser
else do else do
traceShowM ("field", f)
field f do field f do
traceShowM ("stubbed", f)
stubbed f do stubbed f do
if Text.null st if Text.null st
then do then do
parser parser
else do else do
traceShowM ("subtree", st)
subtree st do subtree st do
parser parser
ctor :: (Range -> a) -> Parser a
ctor = (<$> getRange)