From 6e2f592094088a5b6db401897979902d48009d0d Mon Sep 17 00:00:00 2001 From: Kirill Andreev Date: Mon, 17 Aug 2020 18:33:46 +0400 Subject: [PATCH] [LIGO-17] Implementing CAMLligo dialect --- tools/lsp/squirrel/grammar/camligo/grammar.js | 248 ++++++++------- tools/lsp/squirrel/src/AST/Camligo/Parser.hs | 287 +++++++++++++++++- tools/lsp/squirrel/src/AST/Parser.hs | 3 +- .../lsp/squirrel/src/AST/Pascaligo/Parser.hs | 24 +- .../lsp/squirrel/src/AST/Reasonligo/Parser.hs | 24 +- tools/lsp/squirrel/src/AST/Scope.hs | 10 +- tools/lsp/squirrel/src/AST/Skeleton.hs | 25 +- tools/lsp/squirrel/src/Parser.hs | 4 + 8 files changed, 468 insertions(+), 157 deletions(-) diff --git a/tools/lsp/squirrel/grammar/camligo/grammar.js b/tools/lsp/squirrel/grammar/camligo/grammar.js index c11c94315..1f29212c3 100644 --- a/tools/lsp/squirrel/grammar/camligo/grammar.js +++ b/tools/lsp/squirrel/grammar/camligo/grammar.js @@ -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( diff --git a/tools/lsp/squirrel/src/AST/Camligo/Parser.hs b/tools/lsp/squirrel/src/AST/Camligo/Parser.hs index 3df1b998d..20b290d23 100644 --- a/tools/lsp/squirrel/src/AST/Camligo/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Camligo/Parser.hs @@ -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 + ] + diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs index 4412e806d..423817d4e 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Parser.hs @@ -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 diff --git a/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs b/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs index 7cf3e7d04..c0b88e423 100644 --- a/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs @@ -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" diff --git a/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs b/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs index be30bb9cc..af584baef 100644 --- a/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs @@ -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" diff --git a/tools/lsp/squirrel/src/AST/Scope.hs b/tools/lsp/squirrel/src/AST/Scope.hs index be18fc517..ea463b027 100644 --- a/tools/lsp/squirrel/src/AST/Scope.hs +++ b/tools/lsp/squirrel/src/AST/Scope.hs @@ -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 \ No newline at end of file diff --git a/tools/lsp/squirrel/src/AST/Skeleton.hs b/tools/lsp/squirrel/src/AST/Skeleton.hs index ea7704f57..3dc39f1b6 100644 --- a/tools/lsp/squirrel/src/AST/Skeleton.hs +++ b/tools/lsp/squirrel/src/AST/Skeleton.hs @@ -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 "" 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 "" ty)) `indent` "=>" `indent` b + Lambda ps ty b -> (("lam" `indent` pp ps) `indent` (":" <+> fromMaybe "" 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 diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index 1ec0f2bd8..b2885902a 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/tools/lsp/squirrel/src/Parser.hs @@ -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