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

[LIGO-17] Implementing CAMLligo dialect

Browse Source
This commit is contained in:
Kirill Andreev 2020-08-17 18:33:46 +04:00
parent 1a948bcae7
commit 6e2f592094
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
8 changed files with 468 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

248
tools/lsp/squirrel/grammar/camligo/grammar.js
View File

@ -1,11 +1,13 @@
let sepBy1 = (sep, p) => seq(p, repeat(seq(sep, p)))
let sepBy = (sep, p) => optional(sepBy1(sep, p))
let some = x => seq(x, repeat(x))
function mkOp($, opExpr) {
return seq(
field("arg1", $._expr),
field("left", $._expr),
field("op", opExpr),
field("arg2", $._expr)
field("right", $._expr)
);
}
@ -15,10 +17,11 @@ module.exports = grammar({
extras: $ => [$.ocaml_comment, $.comment, /\s/],
rules: {
contract: $ => repeat($._declaration),
contract: $ => repeat(field("declaration", $._declaration)),
_declaration: $ => choice(
$.let_decl,
$.fun_decl,
$.type_decl,
$.include,
),
@ -30,21 +33,31 @@ module.exports = grammar({
_attribute: $ => /\[@@[a-z]+\]/,
let_decl: $ => seq(
fun_decl: $ => seq(
"let",
field("name", $._binder),
optional(field("recursive", "rec")),
field("name", $.Name),
some(field("arg", $._paren_pattern)),
optional(seq(
":",
field("type", $.type_expr)
field("type", $._type_expr)
)),
"=",
field("body",$._program),
repeat(field("attribute", $._attribute))
),
_binder: $ => choice(
$.func_header,
$._pattern
let_decl: $ => seq(
"let",
optional(field("recursive", "rec")),
field("name", $._pattern),
optional(seq(
":",
field("type", $._type_expr)
)),
"=",
field("body",$._program),
repeat(field("attribute", $._attribute))
),
//========== EXPR ============
@ -54,42 +67,36 @@ module.exports = grammar({
$._expr
),
func_header: $ => prec(1, seq(
optional(field("recursive", "rec")),
field("name", $.Name),
repeat(field("arg", $.paren_pattern))
)),
let_expr1: $ => seq(
$.let_decl,
field("decl", $.let_decl),
"in",
field("innerExpr", $._program)
field("body", $._program)
),
// [1;2]
list_pattern: $ => seq(
"[",
sepBy(';', field("patternListItem", $._pattern)),
sepBy(';', field("item", $._pattern)),
"]"
),
// a :: b
list_con_pattern: $ => prec.right(9, seq(
field("patX", $._pattern),
field("x", $._pattern),
"::",
field("patXs", $._pattern)
field("xs", $._pattern)
)),
// a, b, c
tup_pattern: $ => prec.right(8,seq(
field("tuplePatternItem", $._pattern),
field("item", $._pattern),
",",
sepBy1(",", field("tuplePatternItem", $._pattern))
sepBy1(",", field("item", $._pattern))
)),
_pattern: $ => choice(
$.Name,
$.paren_pattern,
$._paren_pattern,
$.con_pattern,
$._literal,
$.list_pattern,
@ -100,65 +107,90 @@ module.exports = grammar({
con_pattern: $ => prec(10,
seq(
field("conPattern", $.data_con),
optional(field("conArgPattern",$._pattern))
field("ctor", $.data_con),
optional(field("args",$._pattern))
)
),
paren_pattern: $ => seq(
"(",
field("innerPattern", $._pattern),
optional(seq(
_paren_pattern: $ => choice(
$.annot_pattern,
$.paren_pattern,
),
paren_pattern: $ =>
seq(
"(",
field("pat", $._pattern),
")"
),
annot_pattern: $ =>
seq(
"(",
field("pat", $._pattern),
":",
$.type_expr,
)),
")"
),
field("type", $._type_expr),
")"
),
call: $ => choice(
_call: $ => choice(
$.unary_op_app,
$._mod_op_app,
$._mul_op_app,
$._add_op_app,
$._list_con_op_app,
$._string_cat_op_app,
$._bool_op_app,
$._comp_op_app
$.binary_op_app,
),
_mod_op_app: $ => prec.left(16, mkOp($, "mod")),
_mul_op_app: $ => prec.left(15, mkOp($, choice("/", "*"))),
_add_op_app: $ => prec.left(14, mkOp($, choice("-", "+"))),
_list_con_op_app: $ => prec.right(13, mkOp($, "::")),
_string_cat_op_app: $ => prec.right(12, mkOp($, "^")),
_bool_op_app: $ => prec.left(11, mkOp($, choice("&&", "||"))),
_comp_op_app: $ => prec.left(10, mkOp($, choice("=", "<>", "==", "<", "<=", ">", ">="))),
binary_op_app: $ => choice(
prec.left(16, mkOp($, "mod")),
prec.left(15, mkOp($, choice("/", "*"))),
prec.left(14, mkOp($, choice("-", "+"))),
prec.right(13, mkOp($, "::")),
prec.right(12, mkOp($, "^")),
prec.left(11, mkOp($, choice("&&", "||"))),
prec.left(10, mkOp($, choice("=", "<>", "==", "<", "<=", ">", ">="))),
),
// - a
unary_op_app: $ => prec(19, choice(
seq(field("unaryOp", "-"), field("arg", $._expr))),
),
unary_op_app: $ => prec(19, seq(
field("negate", "-"),
field("arg", $._expr)
)),
// f a
fun_app: $ => prec.left(20, seq(field("appF", $._sub_expr), field("appArg",$._sub_expr))),
fun_app: $ => prec.left(20, seq(
field("f", $._sub_expr),
field("x", $._sub_expr)
)),
// a.0
index_accessor: $ => prec.right(21, seq(field("exp", $._sub_expr), ".", field("ix", $._sub_expr))),
index_accessor: $ => prec.right(21, seq(
field("box", $._sub_expr),
".",
field("field", $._sub_expr)
)),
// { p with a = b; c = d }
rec_literal: $ => seq(
"{",
field("field", $.rec_assignment),
repeat(seq(";", field("field", $.rec_assignment))),
optional(";"),
"}"
),
// { p with a = b; c = d }
rec_expr: $ => seq(
"{",
optional(seq(field("updateTarget", $.Name), "with")),
field("assignment", $.rec_assignment),
repeat(seq(";", field("assignment", $.rec_assignment))),
field("subject", $.Name),
"with",
field("field", $.rec_assignment),
repeat(seq(";", field("field", $.rec_assignment))),
optional(";"),
"}"
),
// a = b;
rec_assignment: $ => seq(
field("assignmentLabel", $._expr),
field("field", $._expr),
"=",
field("assignmentExpr", $._expr),
field("value", $._expr),
),
// if a then b else c
@ -166,32 +198,32 @@ module.exports = grammar({
"if",
field("condition", $._expr),
"then",
field("thenBranch", $._program),
field("then", $._program),
optional(seq(
"else",
field("elseBranch", $._program)
field("else", $._program)
))
)),
// match x with ...
match_expr: $ => prec.right(1,seq(
"match",
field("matchTarget", $._expr),
field("subject", $._expr),
"with",
optional('|'),
sepBy('|', field("matching", $.matching))
sepBy('|', field("alt", $.matching))
)),
// Dog as x -> f x
matching: $ => seq(
field("pattern", $._pattern),
"->",
field("matchingExpr", $._program)
field("body", $._program)
),
lambda_expr: $ => seq(
"fun",
repeat1(field("arg", $.paren_pattern)),
repeat1(field("arg", $._paren_pattern)),
"->",
field("body", $._expr)
),
@ -203,13 +235,15 @@ module.exports = grammar({
),
tup_expr: $ => prec.right(9,seq(
field("fst", $._expr),
",",
field("snd", $._expr),
field("x", $._expr),
some(seq(
",",
field("x", $._expr),
)),
)),
_expr: $ => choice(
$.call,
$._call,
$._sub_expr,
$.tup_expr
),
@ -217,10 +251,12 @@ module.exports = grammar({
_sub_expr: $ => choice(
$.fun_app,
$.paren_expr,
$.annot_expr,
$.Name,
$.Name_Capital,
$._literal,
$.rec_expr,
$.rec_literal,
$.if_expr,
$.lambda_expr,
$.match_expr,
@ -231,20 +267,23 @@ module.exports = grammar({
block_expr: $ => seq(
"begin",
sepBy(";", field("elem", $._program)),
sepBy(";", field("item", $._program)),
"end",
),
paren_expr: $ => seq(
"(",
field("innerExpr", $._program),
optional(seq(
":",
field("annotExpr", $.type_expr)
)),
field("expr", $._program),
")"
),
annot_expr: $ => seq(
"(",
field("expr", $._program),
":",
field("type", $._type_expr),
")",
),
//========== TYPE_EXPR ============
// t, test, string, integer
@ -254,41 +293,40 @@ module.exports = grammar({
// a t, (a, b) t
type_app: $ => prec(10,seq(
choice(
field("argument", $.type_expr),
seq(
"(",
sepBy1(",", field("argument", choice($.type_expr, $.String))),
")"
)
field("x", $._type_expr),
field("x", $.type_tuple),
),
field("typeAppCon", $.type_con)
field("f", $.type_con)
)),
type_tuple: $ => seq(
"(",
sepBy1(",", field("x", choice($._type_expr, $.String))),
")"
),
// string * integer
type_product: $ => prec.right(5, seq(
field("fst", $.type_expr),
"*",
field("snd", $.type_expr)
field("x", $._type_expr),
some(seq(
"*",
field("x", $._type_expr)
))
)),
// int -> string
type_fun: $ => prec.right(8, seq(
field("domain", $.type_expr),
field("domain", $._type_expr),
"->",
field("codomain", $.type_expr)
field("codomain", $._type_expr)
)),
type_expr: $ => choice(
_type_expr: $ => choice(
$.type_fun,
$.type_product,
$.type_app,
$.type_con,
$.paren_type_expr,
),
paren_type_expr: $ => seq(
"(",
field("innerTypeExpr", $.type_expr),
")"
$.type_tuple,
),
// Cat of string, Person of string * string
@ -296,7 +334,7 @@ module.exports = grammar({
field("constructor", $.data_con),
optional(seq(
"of",
field("constructor_data", $.type_expr)
field("type", $._type_expr)
))
),
@ -310,34 +348,30 @@ module.exports = grammar({
_label: $ => $.FieldName,
type_rec_field: $ => seq(
field("recLabel", $._label),
field("field", $._label),
":",
field("labelType", $.type_expr)
field("type", $._type_expr)
),
// { field1 : a; field2 : b }
type_rec: $ => seq(
"{",
sepBy(";", field("recField", $.type_rec_field)),
sepBy(";", field("field", $.type_rec_field)),
optional(";"),
"}"
),
type_def_body: $ => choice(
_type_def_body: $ => choice(
$.type_sum,
$.type_expr,
$._type_expr,
$.type_rec
),
type_def: $ => seq(
field("typeName", $.type_con),
"=",
field("typeValue", $.type_def_body)
),
type_decl: $ => seq(
"type",
field("typeDef", $.type_def)
field("name", $.type_con),
"=",
field("type", $._type_def_body)
),
_literal: $ => choice(

287
tools/lsp/squirrel/src/AST/Camligo/Parser.hs
View File

@ -1,7 +1,7 @@
module AST.Camligo.Parser where
import Data.Maybe (isJust)
-- import Data.Maybe (isJust)
import AST.Skeleton
@ -16,14 +16,287 @@ import ParseTree
-- import Debug.Trace
example :: FilePath
example = "../../../src/test/contracts/address.mligo"
-- example = "../../../src/test/contracts/address.mligo"
-- example = "../../../src/test/contracts/amount_lambda.mligo"
-- example = "../../../src/test/contracts/attributes.mligo"
-- example = "../../../src/test/contracts/assert.mligo"
-- example = "../../../src/test/contracts/amount.mligo"
-- example = "../../../src/test/contracts/arithmetic.mligo"
-- example = "../../../src/test/contracts/basic.mligo"
-- example = "../../../src/test/contracts/bytes_arithmetic.mligo"
-- example = "../../../src/test/contracts/bitwise_arithmetic.mligo"
-- example = "../../../src/test/contracts/big_map.mligo"
-- example = "../../../src/test/contracts/boolean_operators.mligo"
-- example = "../../../src/test/contracts/balance_constant.mligo"
-- example = "../../../src/test/contracts/closure.mligo"
-- example = "../../../src/test/contracts/counter.mligo"
-- example = "../../../src/test/contracts/condition.mligo"
-- example = "../../../src/test/contracts/crypto.mligo"
-- example = "../../../src/test/contracts/condition-annot.mligo"
-- example = "../../../src/test/contracts/curry.mligo"
-- example = "../../../src/test/contracts/condition-shadowing.mligo"
-- example = "../../../src/test/contracts/create_contract.mligo"
-- example = "../../../src/test/contracts/comparable.mligo"
-- example = "../../../src/test/contracts/check_signature.mligo"
-- example = "../../../src/test/contracts/double_michelson_or.mligo"
-- example = "../../../src/test/contracts/eq_bool.mligo"
-- example = "../../../src/test/contracts/empty_case.mligo"
-- example = "../../../src/test/contracts/fibo4.mligo"
-- example = "../../../src/test/contracts/fibo3.mligo"
-- example = "../../../src/test/contracts/fibo2.mligo"
-- example = "../../../src/test/contracts/fibo.mligo"
-- example = "../../../src/test/contracts/function-shared.mligo"
-- example = "../../../src/test/contracts/failwith.mligo"
-- example = "../../../src/test/contracts/guess_string.mligo"
-- example = "../../../src/test/contracts/high-order.mligo"
-- example = "../../../src/test/contracts/hashlock.mligo"
-- example = "../../../src/test/contracts/includer.mligo"
-- example = "../../../src/test/contracts/incr_decr.mligo"
-- example = "../../../src/test/contracts/issue-184-combs.mligo"
-- example = "../../../src/test/contracts/implicit.mligo"
-- example = "../../../src/test/contracts/included.mligo"
-- example = "../../../src/test/contracts/implicit_account.mligo"
-- example = "../../../src/test/contracts/interpret_test.mligo"
-- example = "../../../src/test/contracts/isnat.mligo"
-- example = "../../../src/test/contracts/id.mligo"
-- example = "../../../src/test/contracts/key_hash.mligo"
-- example = "../../../src/test/contracts/letin.mligo"
-- example = "../../../src/test/contracts/lambda.mligo"
-- example = "../../../src/test/contracts/let_multiple.mligo"
-- example = "../../../src/test/contracts/lambda2.mligo"
-- example = "../../../src/test/contracts/loop.mligo"
-- example = "../../../src/test/contracts/let_in_multi_bind.mligo"
example = "../../../src/test/contracts/list.mligo"
raw :: IO ()
raw = toParseTree (Path example)
>>= print . pp
-- sample :: IO ()
-- sample
-- = toParseTree (Path example)
-- >>= runParserM . recognise
-- >>= print . pp . fst
raw' :: FilePath -> IO ()
raw' example = toParseTree (Path example)
>>= print . pp
sample :: IO ()
sample
= toParseTree (Path example)
>>= runParserM . recognise
>>= print . pp . fst
sample' :: FilePath -> IO ()
sample' example
= toParseTree (Path example)
>>= runParserM . recognise
>>= print . pp . fst
recognise :: RawTree -> ParserM (LIGO Info)
recognise = descent (\_ -> error . show . pp) $ map usingScope
[ -- Contract
Descent do
boilerplate $ \case
"contract" -> RawContract <$> fields "declaration"
_ -> fallthrough
, Descent do
boilerplate $ \case
"fun_decl" -> Function <$> flag "recursive" <*> field "name" <*> fields "arg" <*> fieldOpt "type" <*> field "body"
"let_decl" -> Const <$> field "name" <*> fieldOpt "type" <*> field "body"
"include" -> Include <$> field "filename"
_ -> fallthrough
, Descent do
boilerplate $ \case
"let_expr1" -> Let <$> field "decl" <*> field "body"
_ -> fallthrough
-- -- ReasonExpr
-- , Descent do
-- boilerplate $ \case
-- "bracket_block" -> Block <$> fields "statement" <*> fieldOpt "return"
-- _ -> fallthrough
-- -- Expr
, Descent do
boilerplate $ \case
"fun_app" -> Apply <$> field "f" <*> field "x"
"index_accessor" -> ListAccess <$> field "box" <*> fields "field"
"rec_expr" -> RecordUpd <$> field "subject" <*> fields "field"
"rec_literal" -> Record <$> fields "field"
"if_expr" -> If <$> field "condition" <*> field "then" <*> fieldOpt "else"
"match_expr" -> Case <$> field "subject" <*> fields "alt"
"lambda_expr" -> Lambda <$> fields "arg" <*> pure Nothing <*> field "body"
"list_expr" -> List <$> fields "item"
"tup_expr" -> Tuple <$> fields "x"
"paren_expr" -> Tuple <$> fields "expr"
"block_expr" -> Seq <$> fields "item"
"annot_expr" -> Annot <$> field "expr" <*> field "type"
"binary_op_app" -> BinOp <$> field "left" <*> field "op" <*> field "right"
"unary_op_app" -> UnOp <$> field "negate" <*> field "arg"
-- "lambda_call" -> Apply <$> field "lambda" <*> field "arguments" -- TODO: maybe a separate apply?
-- "arguments" -> Tuple <$> fields "argument"
-- "constructor_call" -> Apply <$> field "constructor" <*> field "parameters"
-- "list_access" -> ListAccess <$> field "name" <*> fields "indexes"
-- "conditional" -> If <$> field "selector" <*> field "then" <*> field "else"
-- "switch_instr" -> Case <$> field "subject" <*> fields "case"
_ -> fallthrough
-- Pattern
, Descent do
boilerplate $ \case
"list_pattern" -> IsList <$> fields "item"
"list_con_pattern" -> IsCons <$> field "x" <*> field "xs"
"tup_pattern" -> IsTuple <$> fields "item"
"con_pattern" -> IsConstr <$> field "ctor" <*> fieldOpt "args"
"annot_pattern" -> IsAnnot <$> field "pat" <*> field "type"
"paren_pattern" -> IsTuple <$> fields "pat"
"_" -> pure IsWildcard
_ -> fallthrough
-- Alt
, Descent do
boilerplate $ \case
"matching" -> Alt <$> field "pattern" <*> field "body"
_ -> fallthrough
-- Record fields
, Descent do
boilerplate $ \case
"rec_assignment" -> FieldAssignment <$> field "field" <*> field "value"
_ -> fallthrough
-- -- MapBinding
-- , Descent do
-- boilerplate $ \case
-- "binding" -> MapBinding <$> field "key" <*> field "value"
-- _ -> fallthrough
, Descent do
boilerplate' $ \case
("+", _) -> return $ Op "+"
("-", _) -> return $ Op "-"
("mod", _) -> return $ Op "mod"
("/", _) -> return $ Op "/"
("*", _) -> return $ Op "*"
("^", _) -> return $ Op "^"
("::", _) -> return $ Op "::"
(">", _) -> return $ Op ">"
("<", _) -> return $ Op "<"
(">=", _) -> return $ Op ">="
("<=", _) -> return $ Op "<="
("=", _) -> return $ Op "=="
("!=", _) -> return $ Op "!="
("<>", _) -> return $ Op "!="
("||", _) -> return $ Op "||"
("&&", _) -> return $ Op "&&"
("negate", n) -> return $ Op n
_ -> fallthrough
-- , Descent do
-- boilerplate $ \case
-- "module_qualified" -> QualifiedName <$> field "module" <*> fields "method"
-- "struct_qualified" -> QualifiedName <$> field "struct" <*> fields "method"
-- _ -> fallthrough
-- Literal
, Descent do
boilerplate' $ \case
("Int", i) -> return $ Int i
("Nat", i) -> return $ Nat i
("Bytes", i) -> return $ Bytes i
("String", i) -> return $ String i
("Tez", i) -> return $ Tez i
_ -> fallthrough
-- Declaration
, Descent do
boilerplate $ \case
-- TODO: Current `Let` in ast is untyped
-- "let_declaration" -> Var <$> field "binding" <*> fieldOpt "let_type" <*> field "let_value"
"type_decl" -> TypeDecl <$> field "name" <*> field "type"
-- "attr_decl" -> Attribute <$> field "name"
_ -> fallthrough
-- -- Parameters
-- , Descent do
-- boilerplate $ \case
-- "parameters" -> Parameters <$> fields "parameter"
-- _ -> fallthrough
-- -- VarDecl
-- , Descent do
-- boilerplate $ \case
-- "param_decl" -> Decl <$> field "access" <*> field "name" <*> field "type"
-- _ -> fallthrough
-- Name
, Descent do
boilerplate' $ \case
("Name", n) -> return $ Name n
-- ("and", _) -> return $ Name "and"
-- ("or", _) -> return $ Name "or"
_ -> fallthrough
-- FieldName
, Descent do
boilerplate' $ \case
("FieldName", n) -> return $ FieldName n
_ -> fallthrough
-- Type
, Descent do
boilerplate $ \case
"type_fun" -> TArrow <$> field "domain" <*> field "codomain"
"type_app" -> TApply <$> field "f" <*> fields "x"
"type_product" -> TProduct <$> fields "x"
"type_tuple" -> TTuple <$> fields "x"
"type_rec" -> TRecord <$> fields "field"
"type_sum" -> TSum <$> fields "variant"
_ -> fallthrough
-- Variant
, Descent do
boilerplate $ \case
"variant" -> Variant <$> field "constructor" <*> fieldOpt "type"
_ -> fallthrough
-- TField
, Descent do
boilerplate $ \case
"type_rec_field" -> TField <$> field "field" <*> field "type"
_ -> fallthrough
-- TypeName
, Descent do
boilerplate' $ \case
("type_con", name) -> return $ TypeName name
_ -> fallthrough
-- Ctor
, Descent do
boilerplate' $ \case
("Name_Capital", name) -> return $ Ctor name
("data_con", name) -> return $ Ctor name
-- ("Some", _) -> return $ Ctor "Some"
-- ("None", _) -> return $ Ctor "None"
-- ("Bool", b) -> return $ Ctor b
("False", _) -> return $ Ctor "False"
("True", _) -> return $ Ctor "True"
("Unit", _) -> return $ Ctor "Unit"
-- ("Nil", _) -> return $ Ctor "Nil"
_ -> fallthrough
-- Err
, Descent do
\(r :> _, ParseTree _ _ msg) -> do
withComments do
return (r :> N :> Nil, Err msg)
, Descent do
\case
(r :> _, ParseTree "ERROR" _ msg) -> do
return ([] :> r :> Y :> Nil, Err msg)
_ -> fallthrough
]

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

@ -6,6 +6,7 @@ module AST.Parser
import qualified AST.Pascaligo.Parser as Pascal
import qualified AST.Reasonligo.Parser as Reason
import qualified AST.Camligo.Parser as CAML
import AST.Skeleton
import ParseTree
@ -16,7 +17,7 @@ parse :: Source -> IO (LIGO Info, [Msg])
parse src = do
recogniser <- onExt ElimExt
{ eePascal = Pascal.recognise
, eeCaml = error "TODO: caml recogniser"
, eeCaml = CAML.recognise
, eeReason = Reason.recognise
} (srcPath src)
toParseTree src >>= runParserM . recogniser

24
tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs
View File

@ -37,11 +37,11 @@ import ParseTree
-- example = "../../../src/test/contracts/chain_id.ligo"
-- example = "../../../src/test/contracts/closure-3.ligo"
sample' :: FilePath -> IO (LIGO Info)
sample' f
= toParseTree (Path f)
>>= runParserM . recognise
>>= return . fst
-- sample' :: FilePath -> IO (LIGO Info)
-- sample' f
-- = toParseTree (Path f)
-- >>= runParserM . recognise
-- >>= return . fst
source' :: FilePath -> IO ()
source' f
@ -83,8 +83,8 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
"clause_block" -> Seq <$> fields "statement"
"list_expr" -> List <$> fields "element"
"annot_expr" -> Annot <$> field "subject" <*> field "type"
"conditional" -> If <$> field "selector" <*> field "then" <*> field "else"
"cond_expr" -> If <$> field "selector" <*> field "then" <*> field "else"
"conditional" -> If <$> field "selector" <*> field "then" <*> fieldOpt "else"
"cond_expr" -> If <$> field "selector" <*> field "then" <*> fieldOpt "else"
"assignment" -> Assign <$> field "LHS" <*> field "RHS"
"attr_decl" -> Attrs <$> fields "attribute"
"record_expr" -> Record <$> fields "assignment"
@ -94,7 +94,7 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
"skip" -> return Skip
"case_expr" -> Case <$> field "subject" <*> fields "case"
"case_instr" -> Case <$> field "subject" <*> fields "case"
"fun_expr" -> Lambda <$> field "parameters" <*> fieldOpt "type" <*> field "body"
"fun_expr" -> Lambda <$> fields "parameters" <*> fieldOpt "type" <*> field "body"
"for_cycle" -> ForLoop <$> field "name" <*> field "begin" <*> field "end" <*> fieldOpt "step" <*> field "body"
"for_box" -> ForBox <$> field "key" <*> fieldOpt "value" <*> field "kind" <*> field "collection" <*> field "body"
"while_loop" -> WhileLoop <$> field "breaker" <*> field "body"
@ -167,8 +167,8 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
-- Declaration
, Descent do
boilerplate \case
"fun_decl" -> Function <$> (isJust <$> fieldOpt "recursive") <*> field "name" <*> field "parameters" <*> field "type" <*> field "body"
"const_decl" -> Const <$> field "name" <*> field "type" <*> field "value"
"fun_decl" -> Function <$> flag "recursive" <*> field "name" <*> fields "parameters" <*> fieldOpt "type" <*> field "body"
"const_decl" -> Const <$> field "name" <*> fieldOpt "type" <*> field "value"
"var_decl" -> Var <$> field "name" <*> fieldOpt "type" <*> field "value"
"type_decl" -> TypeDecl <$> field "typeName" <*> field "typeValue"
"include" -> Include <$> field "filename"
@ -206,8 +206,8 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
boilerplate \case
"fun_type" -> TArrow <$> field "domain" <*> field "codomain"
"cartesian" -> TProduct <$> fields "element"
"invokeBinary" -> TApply <$> field "typeConstr" <*> field "arguments"
"invokeUnary" -> TApply <$> field "typeConstr" <*> field "arguments"
"invokeBinary" -> TApply <$> field "typeConstr" <*> fields "arguments"
"invokeUnary" -> TApply <$> field "typeConstr" <*> fields "arguments"
"type_tuple" -> TTuple <$> fields "element"
"record_type" -> TRecord <$> fields "field"
"sum_type" -> TSum <$> fields "variant"

24
tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs
View File

@ -12,11 +12,11 @@ import Parser
import ParseTree
import Product
example :: FilePath
-- example :: FilePath
-- example = "../../../src/test/contracts/counter.religo"
-- example = "./contracts/variant.religo"
-- example = "./contracts/amount.religo"
example = "./contracts/multisig.religo"
-- example = "./contracts/multisig.religo"
-- example = "../../../src/test/contracts/FA1.2.religo"
-- example = "../../../src/test/contracts/multisig.religo"
-- example = "../../../src/test/contracts/lambda.religo"
@ -34,14 +34,14 @@ example = "./contracts/multisig.religo"
-- example = "./contracts/arithmetic.religo"
-- example = "./contracts/letin.religo"
raw :: IO ()
raw = toParseTree (Path example)
>>= print . pp
-- raw :: IO ()
-- raw = toParseTree (Path example)
-- >>= print . pp
sample :: IO ()
sample = toParseTree (Path example)
>>= runParserM . recognise
>>= print . pp . fst
-- sample :: IO ()
-- sample = toParseTree (Path example)
-- >>= runParserM . recognise
-- >>= print . pp . fst
recognise :: RawTree -> ParserM (LIGO Info)
recognise = descent (\_ -> error . show . pp) $ map usingScope
@ -71,12 +71,12 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
"list_expr" -> List <$> fields "element"
"list_access" -> ListAccess <$> field "name" <*> fields "indexes"
"annot_expr" -> Annot <$> field "subject" <*> field "type"
"conditional" -> If <$> field "selector" <*> field "then" <*> field "else"
"conditional" -> If <$> field "selector" <*> field "then" <*> fieldOpt "else"
"record_expr" -> Record <$> fields "assignment"
"tuple_expr" -> Tuple <$> fields "element"
"switch_instr" -> Case <$> field "subject" <*> fields "case"
"lambda" -> Lambda <$> field "arguments" <*> fieldOpt "lambda_type" <*> field "lambda_body"
"lambda" -> Lambda <$> fields "arguments" <*> fieldOpt "lambda_type" <*> field "lambda_body"
_ -> fallthrough
-- Pattern
@ -175,7 +175,7 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
boilerplate $ \case
"fun_type" -> TArrow <$> field "domain" <*> field "codomain"
-- TODO: maybe only one argument of parameter list is considered
"type_application" -> TApply <$> field "functor" <*> field "parameter"
"type_application" -> TApply <$> field "functor" <*> fields "parameter"
"type_tuple" -> TTuple <$> fields "element"
"record_type" -> TRecord <$> fields "field"
"sum_type" -> TSum <$> fields "variant"

10
tools/lsp/squirrel/src/AST/Scope.hs
View File

@ -339,7 +339,7 @@ instance Collectable xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Bind
before r = \case
Function recur name _args ty body -> do
when recur do
def name (Just ty) (Just body) (getElem r)
def name ty (Just body) (getElem r)
enter r
TypeDecl ty body -> defType ty Star body (getElem r)
@ -347,13 +347,13 @@ instance Collectable xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Bind
after r = \case
Irrefutable name body -> do leave; def name Nothing (Just body) (getElem r)
Var name ty body -> do leave; def name ty (Just body) (getElem r) -- TODO: may be the source of bugs
Const name ty body -> do leave; def name (Just ty) (Just body) (getElem r)
Var name ty body -> do leave; def name ty (Just body) (getElem r) -- TODO: may be the source of bugs
Const name ty body -> do leave; def name ty (Just body) (getElem r)
Function recur name _args ty body -> do
leave
unless recur do
def name (Just ty) (Just body) (getElem r)
def name ty (Just body) (getElem r)
_ -> skip
@ -411,5 +411,5 @@ instance Scoped a CollectM (LIGO a) FieldName
instance Scoped a CollectM (LIGO a) (Err Text)
instance Scoped a CollectM (LIGO a) Language
instance Scoped a CollectM (LIGO a) Parameters
instance Scoped a CollectM (LIGO a) Ctor
instance Scoped a CollectM (LIGO a) Ctor
instance Scoped a CollectM (LIGO a) ReasonExpr

25
tools/lsp/squirrel/src/AST/Skeleton.hs
View File

@ -63,9 +63,9 @@ data RawContract it
data Binding it
= Irrefutable it it -- ^ (Pattern) (Expr)
| Function Bool it it it it -- ^ (Name) (Parameters) (Type) (Expr)
| Function Bool it [it] (Maybe it) it -- ^ (Name) (Parameters) (Type) (Expr)
| Var it (Maybe it) it -- ^ (Name) (Type) (Expr)
| Const it it it -- ^ (Name) (Type) (Expr)
| Const it (Maybe it) it -- ^ (Name) (Type) (Expr)
| TypeDecl it it -- ^ (Name) (Type)
| Attribute it -- ^ (Name)
| Include it
@ -95,7 +95,7 @@ data Type it
| TVar it -- ^ (Name)
| TSum [it] -- ^ [Variant]
| TProduct [it] -- ^ [Type]
| TApply it it -- (Name) [Type]
| TApply it [it] -- (Name) [Type]
| TTuple [it]
| TOr it it it it
| TAnd it it it it
@ -122,7 +122,7 @@ data Expr it
| UnOp it it -- (Expr)
| Op Text
| Record [it] -- [Assignment]
| If it it it -- (Expr) (Expr) (Expr)
| If it it (Maybe it) -- (Expr) (Expr) (Expr)
| Assign it it -- (LHS) (Expr)
| List [it] -- [Expr]
| ListAccess it [it] -- (Name) [Indexes]
@ -140,7 +140,7 @@ data Expr it
| ForLoop it it it (Maybe it) it -- (Name) (Expr) (Expr) (Expr)
| WhileLoop it it -- (Expr) (Expr)
| Seq [it] -- [Declaration]
| Lambda it (Maybe it) it -- [VarDecl] (Maybe (Type)) (Expr)
| Lambda [it] (Maybe it) it -- [VarDecl] (Maybe (Type)) (Expr)
| ForBox it (Maybe it) it it it -- (Name) (Maybe (Name)) Text (Expr) (Expr)
| MapPatch it [it] -- (QualifiedName) [MapBinding]
| SetPatch it [it] -- (QualifiedName) [Expr]
@ -251,7 +251,7 @@ instance Pretty1 Binding where
TypeDecl n ty -> "type" <+> n <+> "=" `indent` ty
-- TODO
Var name ty value -> "var" <+> name <+> ":" <+> fromMaybe "<unnanotated>" ty <+> ":=" `indent` value
Const name ty body -> "const" <+> name <+> ":" <+> ty <+> "=" `indent` body
Const name ty body -> "const" <+> name <+> ":" <+> pp ty <+> "=" `indent` body
Attribute name -> "[@" <.> name <.> "]"
Include fname -> "#include" <+> fname
@ -262,9 +262,9 @@ instance Pretty1 Binding where
<+> "function"
<+> name
)
`indent` params
`indent` pp params
)
`indent` (":" <+> ty `above` "is")
`indent` (":" <+> pp ty `above` "is")
)
`indent` body
@ -288,7 +288,7 @@ instance Pretty1 Type where
TVar name -> name
TSum variants -> block variants
TProduct elements -> train " *" elements
TApply f xs -> f <+> xs
TApply f xs -> f <+> tuple xs
TTuple xs -> tuple xs
TOr l n r m -> "michelson_or" <+> tuple [l, n, r, m]
TAnd l n r m -> "michelson_pair" <+> tuple [l, n, r, m]
@ -309,14 +309,14 @@ instance Pretty1 ReasonExpr where
instance Pretty1 Expr where
pp1 = \case
Let decl body -> "let" <+> decl `above` body
Apply f xs -> "(" <.> f <.> ")" <+> xs
Apply f xs -> "(" <.> f <.> ")" `indent` xs
Constant constant -> constant
Ident qname -> qname
BinOp l o r -> parens (l <+> pp o <+> r)
UnOp o r -> parens (pp o <+> r)
Op o -> pp o
Record az -> "record" <+> list az
If b t e -> fsep ["if" `indent` b, "then" `indent` t, "else" `indent` e]
If b t e -> fsep ["if" `indent` b, "then" `indent` t, "else" `indent` pp e]
Assign l r -> l <+> ":=" `indent` r
List l -> "list" <+> list l
ListAccess l ids -> l <.> cat ((("[" <.>) . (<.> "]") . pp) <$> ids)
@ -335,7 +335,7 @@ instance Pretty1 Expr where
ForBox k mv t z b -> "for" <+> k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> z `indent` b
WhileLoop f b -> "while" <+> f `indent` b
Seq es -> "block {" `indent` block es `above` "}"
Lambda ps ty b -> (("lam" `indent` ps) `indent` (":" <+> fromMaybe "<unnanotated>" ty)) `indent` "=>" `indent` b
Lambda ps ty b -> (("lam" `indent` pp ps) `indent` (":" <+> fromMaybe "<unnanotated>" ty)) `indent` "=>" `indent` b
MapPatch z bs -> "patch" `indent` z `above` "with" <+> "map" `indent` list bs
SetPatch z bs -> "patch" `indent` z `above` "with" <+> "set" `indent` list bs
RecordUpd r up -> r `indent` "with" <+> "record" `indent` list up
@ -381,7 +381,6 @@ instance Pretty1 Pattern where
IsList l -> list l
IsTuple t -> tuple t
instance Pretty1 Name where
pp1 = \case
Name raw -> pp raw

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

@ -6,6 +6,7 @@ import Control.Arrow
import Control.Monad.Catch
import Control.Monad.RWS hiding (Product)
import Data.Functor
import Data.String.Interpolate (i)
import Data.Text (Text)
import qualified Data.Text as Text
@ -77,6 +78,9 @@ allErrors = map getBody . filter isUnnamedError
getBody :: RawTree -> Text
getBody (gist -> f) = ptSource f
flag :: Text -> ParserM Bool
flag name = fieldOpt name <&> maybe False (const True)
field :: Text -> ParserM RawTree
field name =
fieldOpt name