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

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

@ -1,7 +1,7 @@
module AST.Camligo.Parser where module AST.Camligo.Parser where
import Data.Maybe (isJust) -- import Data.Maybe (isJust)
import AST.Skeleton import AST.Skeleton
@ -16,14 +16,287 @@ import ParseTree
-- import Debug.Trace -- import Debug.Trace
example :: FilePath 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 :: IO ()
raw = toParseTree (Path example) raw = toParseTree (Path example)
>>= print . pp >>= print . pp
-- sample :: IO () raw' :: FilePath -> IO ()
-- sample raw' example = toParseTree (Path example)
-- = toParseTree (Path example) >>= print . pp
-- >>= runParserM . recognise
-- >>= print . pp . fst 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.Pascaligo.Parser as Pascal
import qualified AST.Reasonligo.Parser as Reason import qualified AST.Reasonligo.Parser as Reason
import qualified AST.Camligo.Parser as CAML
import AST.Skeleton import AST.Skeleton
import ParseTree import ParseTree
@ -16,7 +17,7 @@ parse :: Source -> IO (LIGO Info, [Msg])
parse src = do parse src = do
recogniser <- onExt ElimExt recogniser <- onExt ElimExt
{ eePascal = Pascal.recognise { eePascal = Pascal.recognise
, eeCaml = error "TODO: caml recogniser" , eeCaml = CAML.recognise
, eeReason = Reason.recognise , eeReason = Reason.recognise
} (srcPath src) } (srcPath src)
toParseTree src >>= runParserM . recogniser 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/chain_id.ligo"
-- example = "../../../src/test/contracts/closure-3.ligo" -- example = "../../../src/test/contracts/closure-3.ligo"
sample' :: FilePath -> IO (LIGO Info) -- sample' :: FilePath -> IO (LIGO Info)
sample' f -- sample' f
= toParseTree (Path f) -- = toParseTree (Path f)
>>= runParserM . recognise -- >>= runParserM . recognise
>>= return . fst -- >>= return . fst
source' :: FilePath -> IO () source' :: FilePath -> IO ()
source' f source' f
@ -83,8 +83,8 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
"clause_block" -> Seq <$> fields "statement" "clause_block" -> Seq <$> fields "statement"
"list_expr" -> List <$> fields "element" "list_expr" -> List <$> fields "element"
"annot_expr" -> Annot <$> field "subject" <*> field "type" "annot_expr" -> Annot <$> field "subject" <*> field "type"
"conditional" -> If <$> field "selector" <*> field "then" <*> field "else" "conditional" -> If <$> field "selector" <*> field "then" <*> fieldOpt "else"
"cond_expr" -> If <$> field "selector" <*> field "then" <*> field "else" "cond_expr" -> If <$> field "selector" <*> field "then" <*> fieldOpt "else"
"assignment" -> Assign <$> field "LHS" <*> field "RHS" "assignment" -> Assign <$> field "LHS" <*> field "RHS"
"attr_decl" -> Attrs <$> fields "attribute" "attr_decl" -> Attrs <$> fields "attribute"
"record_expr" -> Record <$> fields "assignment" "record_expr" -> Record <$> fields "assignment"
@ -94,7 +94,7 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
"skip" -> return Skip "skip" -> return Skip
"case_expr" -> Case <$> field "subject" <*> fields "case" "case_expr" -> Case <$> field "subject" <*> fields "case"
"case_instr" -> 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_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" "for_box" -> ForBox <$> field "key" <*> fieldOpt "value" <*> field "kind" <*> field "collection" <*> field "body"
"while_loop" -> WhileLoop <$> field "breaker" <*> field "body" "while_loop" -> WhileLoop <$> field "breaker" <*> field "body"
@ -167,8 +167,8 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
-- Declaration -- Declaration
, Descent do , Descent do
boilerplate \case boilerplate \case
"fun_decl" -> Function <$> (isJust <$> fieldOpt "recursive") <*> field "name" <*> field "parameters" <*> field "type" <*> field "body" "fun_decl" -> Function <$> flag "recursive" <*> field "name" <*> fields "parameters" <*> fieldOpt "type" <*> field "body"
"const_decl" -> Const <$> field "name" <*> field "type" <*> field "value" "const_decl" -> Const <$> field "name" <*> fieldOpt "type" <*> field "value"
"var_decl" -> Var <$> field "name" <*> fieldOpt "type" <*> field "value" "var_decl" -> Var <$> field "name" <*> fieldOpt "type" <*> field "value"
"type_decl" -> TypeDecl <$> field "typeName" <*> field "typeValue" "type_decl" -> TypeDecl <$> field "typeName" <*> field "typeValue"
"include" -> Include <$> field "filename" "include" -> Include <$> field "filename"
@ -206,8 +206,8 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
boilerplate \case boilerplate \case
"fun_type" -> TArrow <$> field "domain" <*> field "codomain" "fun_type" -> TArrow <$> field "domain" <*> field "codomain"
"cartesian" -> TProduct <$> fields "element" "cartesian" -> TProduct <$> fields "element"
"invokeBinary" -> TApply <$> field "typeConstr" <*> field "arguments" "invokeBinary" -> TApply <$> field "typeConstr" <*> fields "arguments"
"invokeUnary" -> TApply <$> field "typeConstr" <*> field "arguments" "invokeUnary" -> TApply <$> field "typeConstr" <*> fields "arguments"
"type_tuple" -> TTuple <$> fields "element" "type_tuple" -> TTuple <$> fields "element"
"record_type" -> TRecord <$> fields "field" "record_type" -> TRecord <$> fields "field"
"sum_type" -> TSum <$> fields "variant" "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 ParseTree
import Product import Product
example :: FilePath -- example :: FilePath
-- example = "../../../src/test/contracts/counter.religo" -- example = "../../../src/test/contracts/counter.religo"
-- example = "./contracts/variant.religo" -- example = "./contracts/variant.religo"
-- example = "./contracts/amount.religo" -- example = "./contracts/amount.religo"
example = "./contracts/multisig.religo" -- example = "./contracts/multisig.religo"
-- example = "../../../src/test/contracts/FA1.2.religo" -- example = "../../../src/test/contracts/FA1.2.religo"
-- example = "../../../src/test/contracts/multisig.religo" -- example = "../../../src/test/contracts/multisig.religo"
-- example = "../../../src/test/contracts/lambda.religo" -- example = "../../../src/test/contracts/lambda.religo"
@ -34,14 +34,14 @@ example = "./contracts/multisig.religo"
-- example = "./contracts/arithmetic.religo" -- example = "./contracts/arithmetic.religo"
-- example = "./contracts/letin.religo" -- example = "./contracts/letin.religo"
raw :: IO () -- raw :: IO ()
raw = toParseTree (Path example) -- raw = toParseTree (Path example)
>>= print . pp -- >>= print . pp
sample :: IO () -- sample :: IO ()
sample = toParseTree (Path example) -- sample = toParseTree (Path example)
>>= runParserM . recognise -- >>= runParserM . recognise
>>= print . pp . fst -- >>= print . pp . fst
recognise :: RawTree -> ParserM (LIGO Info) recognise :: RawTree -> ParserM (LIGO Info)
recognise = descent (\_ -> error . show . pp) $ map usingScope recognise = descent (\_ -> error . show . pp) $ map usingScope
@ -71,12 +71,12 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
"list_expr" -> List <$> fields "element" "list_expr" -> List <$> fields "element"
"list_access" -> ListAccess <$> field "name" <*> fields "indexes" "list_access" -> ListAccess <$> field "name" <*> fields "indexes"
"annot_expr" -> Annot <$> field "subject" <*> field "type" "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" "record_expr" -> Record <$> fields "assignment"
"tuple_expr" -> Tuple <$> fields "element" "tuple_expr" -> Tuple <$> fields "element"
"switch_instr" -> Case <$> field "subject" <*> fields "case" "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 _ -> fallthrough
-- Pattern -- Pattern
@ -175,7 +175,7 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
boilerplate $ \case boilerplate $ \case
"fun_type" -> TArrow <$> field "domain" <*> field "codomain" "fun_type" -> TArrow <$> field "domain" <*> field "codomain"
-- TODO: maybe only one argument of parameter list is considered -- 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" "type_tuple" -> TTuple <$> fields "element"
"record_type" -> TRecord <$> fields "field" "record_type" -> TRecord <$> fields "field"
"sum_type" -> TSum <$> fields "variant" "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 before r = \case
Function recur name _args ty body -> do Function recur name _args ty body -> do
when recur do when recur do
def name (Just ty) (Just body) (getElem r) def name ty (Just body) (getElem r)
enter r enter r
TypeDecl ty body -> defType ty Star body (getElem 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 after r = \case
Irrefutable name body -> do leave; def name Nothing (Just body) (getElem r) 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 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) Const name ty body -> do leave; def name ty (Just body) (getElem r)
Function recur name _args ty body -> do Function recur name _args ty body -> do
leave leave
unless recur do unless recur do
def name (Just ty) (Just body) (getElem r) def name ty (Just body) (getElem r)
_ -> skip _ -> 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) (Err Text)
instance Scoped a CollectM (LIGO a) Language instance Scoped a CollectM (LIGO a) Language
instance Scoped a CollectM (LIGO a) Parameters 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 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 data Binding it
= Irrefutable it it -- ^ (Pattern) (Expr) = 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) | 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) | TypeDecl it it -- ^ (Name) (Type)
| Attribute it -- ^ (Name) | Attribute it -- ^ (Name)
| Include it | Include it
@ -95,7 +95,7 @@ data Type it
| TVar it -- ^ (Name) | TVar it -- ^ (Name)
| TSum [it] -- ^ [Variant] | TSum [it] -- ^ [Variant]
| TProduct [it] -- ^ [Type] | TProduct [it] -- ^ [Type]
| TApply it it -- (Name) [Type] | TApply it [it] -- (Name) [Type]
| TTuple [it] | TTuple [it]
| TOr it it it it | TOr it it it it
| TAnd it it it it | TAnd it it it it
@ -122,7 +122,7 @@ data Expr it
| UnOp it it -- (Expr) | UnOp it it -- (Expr)
| Op Text | Op Text
| Record [it] -- [Assignment] | Record [it] -- [Assignment]
| If it it it -- (Expr) (Expr) (Expr) | If it it (Maybe it) -- (Expr) (Expr) (Expr)
| Assign it it -- (LHS) (Expr) | Assign it it -- (LHS) (Expr)
| List [it] -- [Expr] | List [it] -- [Expr]
| ListAccess it [it] -- (Name) [Indexes] | ListAccess it [it] -- (Name) [Indexes]
@ -140,7 +140,7 @@ data Expr it
| ForLoop it it it (Maybe it) it -- (Name) (Expr) (Expr) (Expr) | ForLoop it it it (Maybe it) it -- (Name) (Expr) (Expr) (Expr)
| WhileLoop it it -- (Expr) (Expr) | WhileLoop it it -- (Expr) (Expr)
| Seq [it] -- [Declaration] | 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) | ForBox it (Maybe it) it it it -- (Name) (Maybe (Name)) Text (Expr) (Expr)
| MapPatch it [it] -- (QualifiedName) [MapBinding] | MapPatch it [it] -- (QualifiedName) [MapBinding]
| SetPatch it [it] -- (QualifiedName) [Expr] | SetPatch it [it] -- (QualifiedName) [Expr]
@ -251,7 +251,7 @@ instance Pretty1 Binding where
TypeDecl n ty -> "type" <+> n <+> "=" `indent` ty TypeDecl n ty -> "type" <+> n <+> "=" `indent` ty
-- TODO -- TODO
Var name ty value -> "var" <+> name <+> ":" <+> fromMaybe "<unnanotated>" ty <+> ":=" `indent` value 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 <.> "]" Attribute name -> "[@" <.> name <.> "]"
Include fname -> "#include" <+> fname Include fname -> "#include" <+> fname
@ -262,9 +262,9 @@ instance Pretty1 Binding where
<+> "function" <+> "function"
<+> name <+> name
) )
`indent` params `indent` pp params
) )
`indent` (":" <+> ty `above` "is") `indent` (":" <+> pp ty `above` "is")
) )
`indent` body `indent` body
@ -288,7 +288,7 @@ instance Pretty1 Type where
TVar name -> name TVar name -> name
TSum variants -> block variants TSum variants -> block variants
TProduct elements -> train " *" elements TProduct elements -> train " *" elements
TApply f xs -> f <+> xs TApply f xs -> f <+> tuple xs
TTuple xs -> tuple xs TTuple xs -> tuple xs
TOr l n r m -> "michelson_or" <+> tuple [l, n, r, m] TOr l n r m -> "michelson_or" <+> tuple [l, n, r, m]
TAnd l n r m -> "michelson_pair" <+> 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 instance Pretty1 Expr where
pp1 = \case pp1 = \case
Let decl body -> "let" <+> decl `above` body Let decl body -> "let" <+> decl `above` body
Apply f xs -> "(" <.> f <.> ")" <+> xs Apply f xs -> "(" <.> f <.> ")" `indent` xs
Constant constant -> constant Constant constant -> constant
Ident qname -> qname Ident qname -> qname
BinOp l o r -> parens (l <+> pp o <+> r) BinOp l o r -> parens (l <+> pp o <+> r)
UnOp o r -> parens (pp o <+> r) UnOp o r -> parens (pp o <+> r)
Op o -> pp o Op o -> pp o
Record az -> "record" <+> list az 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 Assign l r -> l <+> ":=" `indent` r
List l -> "list" <+> list l List l -> "list" <+> list l
ListAccess l ids -> l <.> cat ((("[" <.>) . (<.> "]") . pp) <$> ids) 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 ForBox k mv t z b -> "for" <+> k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> z `indent` b
WhileLoop f b -> "while" <+> f `indent` b WhileLoop f b -> "while" <+> f `indent` b
Seq es -> "block {" `indent` block es `above` "}" 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 MapPatch z bs -> "patch" `indent` z `above` "with" <+> "map" `indent` list bs
SetPatch z bs -> "patch" `indent` z `above` "with" <+> "set" `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 RecordUpd r up -> r `indent` "with" <+> "record" `indent` list up
@ -381,7 +381,6 @@ instance Pretty1 Pattern where
IsList l -> list l IsList l -> list l
IsTuple t -> tuple t IsTuple t -> tuple t
instance Pretty1 Name where instance Pretty1 Name where
pp1 = \case pp1 = \case
Name raw -> pp raw 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.Catch
import Control.Monad.RWS hiding (Product) import Control.Monad.RWS hiding (Product)
import Data.Functor
import Data.String.Interpolate (i) import Data.String.Interpolate (i)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
@ -77,6 +78,9 @@ allErrors = map getBody . filter isUnnamedError
getBody :: RawTree -> Text getBody :: RawTree -> Text
getBody (gist -> f) = ptSource f getBody (gist -> f) = ptSource f
flag :: Text -> ParserM Bool
flag name = fieldOpt name <&> maybe False (const True)
field :: Text -> ParserM RawTree field :: Text -> ParserM RawTree
field name = field name =
fieldOpt name fieldOpt name