From 372c488dd7d40b590cf501b751393937e01a1591 Mon Sep 17 00:00:00 2001 From: Galfour Date: Thu, 11 Apr 2019 23:16:14 +0000 Subject: [PATCH] parse sample file --- src/ligo/contracts/new-syntax.mligo | 83 ++++- src/ligo/dune | 4 +- src/ligo/meta_michelson/meta_michelson.ml | 14 +- src/ligo/meta_michelson/michelson_wrap.ml | 2 +- src/ligo/mini_c/compiler.ml | 4 +- src/ligo/mini_c/compiler_environment.ml | 2 +- src/ligo/mini_c/compiler_type.ml | 2 +- src/ligo/mini_c/run.ml | 1 - src/ligo/multifix/dune | 2 +- src/ligo/multifix/generator.ml | 373 +++++++++++++++++++--- src/ligo/multifix/lex/generator.ml | 67 +++- src/ligo/multifix/pre_parser.mly | 33 +- src/ligo/multifix/user.ml | 4 +- src/ligo/operators/dune | 4 + 14 files changed, 523 insertions(+), 72 deletions(-) create mode 100644 src/ligo/operators/dune diff --git a/src/ligo/contracts/new-syntax.mligo b/src/ligo/contracts/new-syntax.mligo index 062f2e7f0..f91896912 100644 --- a/src/ligo/contracts/new-syntax.mligo +++ b/src/ligo/contracts/new-syntax.mligo @@ -1,5 +1,80 @@ -const foo = - let toto = at * bo in list [ toto ; tata ; titi ] ; +(* Smart contract for voting. Winners of vote split the contract + balance at the end of the voting period. *) -const bar = - cat + maow ; +(** Type of storage for this contract *) +type storage = { + voters : (address, unit) big_map; (** Used to register voters *) + votes : (string, nat) map; (** Keep track of vote counts *) + addresses : (string, key_hash) map; (** Addresses for payout *) + deadline : timestamp; (** Deadline after which vote closes *) +} + +(** Initial storage *) +let%init storage addresses = { + (* Initialize vote counts to zero *) + votes = Map.fold (fun ((name, _kh), votes) -> + Map.add name 0p votes + ) addresses Map; + addresses; + voters = BigMap ; (* No voters *) + deadline = Current.time () + 3600 * 24 (* 1 day from now *) +} + +(** Entry point for voting. + @param choice A string corresponding to the candidate *) +let%entry vote choice storage = + (* Only allowed while voting period is ongoing *) + if Current.time () > storage.deadline then failwith "Voting closed"; + (* Voter must send at least 5tz to vote *) + if Current.amount () < 5.00tz then + failwith "Not enough money, at least 5tz to vote"; + (* Voter cannot vote twice *) + if Map.mem (Current.sender ()) storage.voters then + failwith ("Has already voted", Current.sender ()); + let votes = storage.votes in + match Map.find choice votes with + | None -> + (* Vote must be for an existing candidate *) + failwith ("Bad vote", choice) + | Some x -> + (* Increase vote count for candidate *) + let storage = storage.votes <- Map.add choice (x + 1p) votes in + (* Register voter *) + let storage = + storage.voters <- Map.add (Current.sender ()) () storage.voters in + (* Return updated storage *) + ([], storage) + +(* Auxiliary function : returns the list of candidates with the + maximum number of votes (there can be more than one in case of + draw). *) +let find_winners votes = + let winners, _max = + Map.fold (fun ((name, nb), (winners, max)) -> + if nb = max then + name :: winners, max + else if nb > max then + [name], nb + else winners, max + ) votes ([], 0p) in + winners + +(** Entry point for paying winning candidates. *) +let%entry payout () storage = + (* Only allowed once voting period is over *) + if Current.time () <= storage.deadline then failwith "Voting ongoing"; + (* Indentify winners of vote *) + let winners = find_winners storage.votes in + (* Balance of contract is split equally between winners *) + let amount = match Current.balance () / List.length winners with + | None -> failwith "No winners" + | Some (v, _rem) -> v in + (* Generate transfer operations *) + let operations = List.map (fun name -> + let dest = match Map.find name storage.addresses with + | None -> failwith () (* This cannot happen *) + | Some d -> d in + Account.transfer ~amount ~dest + ) winners in + (* Return list of operations. Storage is unchanged *) + operations, storage diff --git a/src/ligo/dune b/src/ligo/dune index bbb951a7e..01f23cc07 100644 --- a/src/ligo/dune +++ b/src/ligo/dune @@ -24,12 +24,12 @@ ) (alias - (name ligo-test) +( name ligo-test) (action (run test/test.exe)) (deps (glob_files contracts/*)) ) (alias (name runtest) - (deps ligo-test) + (deps (alias ligo-test)) ) diff --git a/src/ligo/meta_michelson/meta_michelson.ml b/src/ligo/meta_michelson/meta_michelson.ml index f9cba1a8d..7e80979ed 100644 --- a/src/ligo/meta_michelson/meta_michelson.ml +++ b/src/ligo/meta_michelson/meta_michelson.ml @@ -1,4 +1,12 @@ -module Wrap = Michelson_wrap -module Contract = Contract +module Run = struct + open Contract + let run_lwt_full = run_lwt_full + let run_lwt = run_lwt + let run_str = run_str + let run_node = run_node + let run = run +end +module Stack = Michelson_wrap.Stack +module Values = Contract.Values +module Types = Contract.Types -let init_environment = Misc.init_environment diff --git a/src/ligo/meta_michelson/michelson_wrap.ml b/src/ligo/meta_michelson/michelson_wrap.ml index 63d43a369..c465209e1 100644 --- a/src/ligo/meta_michelson/michelson_wrap.ml +++ b/src/ligo/meta_michelson/michelson_wrap.ml @@ -495,7 +495,7 @@ module Misc = struct open Stack_ops open Stack_shortcuts open Comparison_ops - let min_nat : (nat * (nat * 'r), nat * 'r) code = fun s -> + let min_nat : (nat * (nat * 'r), nat * 'r) code = fun s -> s <. keep_2 cmp_ge_nat <: bubble_2 <: Boolean.cond drop (dip drop) diff --git a/src/ligo/mini_c/compiler.ml b/src/ligo/mini_c/compiler.ml index 0ef9db8df..387e6d767 100644 --- a/src/ligo/mini_c/compiler.ml +++ b/src/ligo/mini_c/compiler.ml @@ -4,8 +4,8 @@ open Types module Michelson = Micheline.Michelson open Michelson module Environment = Compiler_environment -module Stack = Meta_michelson.Wrap.Stack -module Contract_types = Meta_michelson.Contract.Types +module Stack = Meta_michelson.Stack +module Contract_types = Meta_michelson.Types open Memory_proto_alpha.Script_ir_translator diff --git a/src/ligo/mini_c/compiler_environment.ml b/src/ligo/mini_c/compiler_environment.ml index df6650f4f..9c3a61468 100644 --- a/src/ligo/mini_c/compiler_environment.ml +++ b/src/ligo/mini_c/compiler_environment.ml @@ -3,7 +3,7 @@ open Types open Micheline open Memory_proto_alpha.Script_ir_translator -module Stack = Meta_michelson.Wrap.Stack +module Stack = Meta_michelson.Stack type element = environment_element diff --git a/src/ligo/mini_c/compiler_type.ml b/src/ligo/mini_c/compiler_type.ml index be0852e5e..90636b3a0 100644 --- a/src/ligo/mini_c/compiler_type.ml +++ b/src/ligo/mini_c/compiler_type.ml @@ -5,7 +5,7 @@ open Tezos_utils.Memory_proto_alpha open Script_ir_translator module O = Tezos_utils.Micheline.Michelson -module Contract_types = Meta_michelson.Contract.Types +module Contract_types = Meta_michelson.Types module Ty = struct diff --git a/src/ligo/mini_c/run.ml b/src/ligo/mini_c/run.ml index 9f2a3b5da..a82df2684 100644 --- a/src/ligo/mini_c/run.ml +++ b/src/ligo/mini_c/run.ml @@ -4,7 +4,6 @@ open Compiler open Memory_proto_alpha.Script_ir_translator let run_aux (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result = - let open Meta_michelson.Wrap in let Compiler.{input;output;body} : compiled_program = program in let (Ex_ty input_ty) = input in let (Ex_ty output_ty) = output in diff --git a/src/ligo/multifix/dune b/src/ligo/multifix/dune index 6563a26a9..31e067ec1 100644 --- a/src/ligo/multifix/dune +++ b/src/ligo/multifix/dune @@ -17,7 +17,7 @@ (rule (targets parser.ml parser.mli) (deps parser.mly ast.ml) - (action (system "menhir --external-tokens Lex.Token lex/token.mly parser.mly --base parser")) + (action (system "menhir --explain --external-tokens Lex.Token lex/token.mly parser.mly --base parser")) ) (rule diff --git a/src/ligo/multifix/generator.ml b/src/ligo/multifix/generator.ml index 8f3353af7..4eeecb4c5 100644 --- a/src/ligo/multifix/generator.ml +++ b/src/ligo/multifix/generator.ml @@ -13,19 +13,27 @@ type token = Token.token module O = struct - type 'a list_element = [`Trail | `Lead | `Separator] * token * 'a - type basic_rhs_element = [ - | `Named of string - | `Token of token - ] + type list_mode = + | Trail of token + | Trail_option of token + | Trail_force of token + | Trail_force_ne of token + | Lead of token + | Lead_ne of token + | Separator of token + | Naked + | Naked_ne + + type 'a list_element = list_mode * 'a type rhs_element = [ - | basic_rhs_element + | `Named of string + | `Token of token | `List of string list_element ] - type rhs = rhs_element list + type rhs = rhs_element list name type rule = rhs list name type manual_rule_content = { @@ -144,16 +152,16 @@ module Print_AST = struct let aux : O.rhs_element -> string option = fun e -> match e with | `Named s -> Some (s ^ " Location.wrap") - | `List (_, _, s) -> Some ("(" ^ s ^ " Location.wrap list)") + | `List ( _, s) -> Some ("(" ^ s ^ " Location.wrap list)") | `Token _ -> None in - List.filter_map aux rhs in + List.filter_map aux rhs.content in let type_element = fun ppf te -> fprintf ppf "%s" te in - fprintf ppf "| %s of (%a)" - (String.capitalize_ascii gr.name) + fprintf ppf "| `%s_%s of (%a)" + (String.capitalize_ascii gr.name) rhs.name (list_sep type_element (const " * ")) type_elements in - fprintf ppf "%s = @. @[%a@]" gr.name + fprintf ppf "%s = [@. @[%a@]]" gr.name (list_sep aux new_line) gr.content let singleton : _ -> O.singleton -> _ = fun ppf s -> @@ -173,12 +181,14 @@ module Print_AST = struct let aux : O.element -> string option = fun e -> match e with | `Named s -> Some (s ^ " Location.wrap") - | `List _ -> Some ("(" ^ level_name ^ " Location.wrap list)") + | `List ( _, s) -> Some ("(" ^ (match s with + | `Lower | `Current -> level_name |`Named s -> s + ) ^ " Location.wrap list)") | `Token _ -> None | `Current | `Lower -> Some (level_name ^ " Location.wrap") in List.filter_map aux (get_content nop) in let type_element = fun ppf te -> fprintf ppf "%s" te in - fprintf ppf "| %s of (%a)" + fprintf ppf "| `%s of (%a)" (get_name nop) (list_sep type_element (const " * ")) type_elements @@ -186,7 +196,7 @@ module Print_AST = struct let levels = List.Ne.map get_content ((get_content nh).levels) in let nops = List.Ne.concat levels in let name = get_name nh in - fprintf ppf "%s %s =@.@[%a@]" t + fprintf ppf "%s %s = [@.@[%a@]]" t name (list_sep (n_operator name) new_line) nops @@ -195,7 +205,7 @@ module Print_AST = struct | [] -> () | hd :: tl -> fprintf ppf "%a\n" (n_hierarchy (if first then "type" else "and")) hd ; - fprintf ppf "%a" (list_sep (prepend "and " (n_hierarchy "and")) (const "\n")) tl + fprintf ppf "%a" (list_sep (n_hierarchy "and") (const "\n")) tl let language : _ -> O.language -> _ = fun ppf l -> fprintf ppf "%a@.@." comment "Language" ; @@ -223,16 +233,24 @@ module Print_Grammar = struct let aux : _ -> O.rhs_element -> _ = fun ppf e -> (match e with | `Named s -> fprintf ppf "%s = wrap(%s)" letters.(!i) s - | `List (mode, sep, s) -> - fprintf ppf "%s = %s(%s, wrap(%s))" + | `List (mode, s) -> + fprintf ppf "%s = %swrap(%s))" letters.(!i) - (match mode with | `Lead -> "lead_list" | `Trail -> "trail_list" | `Separator -> "separated_list") - (Token.to_string sep) + (match mode with + | Naked -> "naked_list(" + | Naked_ne -> "naked_list_ne(" + | Lead s -> "lead_list(" ^ (Token.to_string s) ^ "," + | Lead_ne s -> "lead_list_ne(" ^ (Token.to_string s) ^ "," + | Trail s -> "trail_list(" ^ (Token.to_string s) ^ "," + | Trail_option s -> "trail_option_list(" ^ (Token.to_string s) ^ "," + | Trail_force s -> "trail_force_list(" ^ (Token.to_string s) ^ "," + | Trail_force_ne s -> "trail_force_list_ne(" ^ (Token.to_string s) ^ "," + | Separator s -> "separated_list(" ^ (Token.to_string s) ^ ",") s | `Token t -> i := !i - 1 ; string ppf @@ Token.to_string t) ; i := !i + 1 in - fprintf ppf "%a" (list_sep aux (const " ")) rhs in + fprintf ppf "%a" (list_sep aux (const " ")) rhs.content in let aux_code : _ -> O.rhs -> _ = fun ppf rhs -> let i = ref 0 in let aux : O.rhs_element -> _ = fun e -> @@ -241,8 +259,8 @@ module Print_Grammar = struct | `Token _ -> i := !i - 1 ; None) in i := !i + 1 ; s in - let content = List.filter_map aux rhs in - fprintf ppf "%s (%a)" (String.capitalize_ascii gr.name) (list_sep string (const " , ")) content + let content = List.filter_map aux rhs.content in + fprintf ppf "`%s_%s (%a)" (String.capitalize_ascii gr.name) rhs.name (list_sep string (const " , ")) content in let aux : _ -> O.rhs -> _ = fun ppf rhs -> fprintf ppf "| %a { %a }" @@ -261,11 +279,19 @@ module Print_Grammar = struct let element : _ -> O.element -> _ = fun ppf element -> (match element with | `Token t -> i := !i - 1 ; string ppf @@ Token.to_string t - | `List (mode, sep, content) -> - fprintf ppf "%s = %s(%s, wrap(%s))" + | `List (mode, content) -> + fprintf ppf "%s = %swrap(%s))" letters.(!i) - (match mode with | `Lead -> "lead_list" | `Trail -> "trail_list" | `Separator -> "separated_list") - (Token.to_string sep) + (match mode with + | Naked -> "naked_list(" + | Naked_ne -> "naked_list_ne(" + | Lead s -> "lead_list(" ^ (Token.to_string s) ^ "," + | Lead_ne s -> "lead_list_ne(" ^ (Token.to_string s) ^ "," + | Trail s -> "trail_list(" ^ (Token.to_string s) ^ "," + | Trail_option s -> "trail_option_list(" ^ (Token.to_string s) ^ "," + | Trail_force s -> "trail_force_list(" ^ (Token.to_string s) ^ "," + | Trail_force_ne s -> "trail_force_list_ne(" ^ (Token.to_string s) ^ "," + | Separator s -> "separated_list(" ^ (Token.to_string s) ^ ",") (match content with | `Lower -> prev_lvl_name | `Named s -> s | `Current -> cur_lvl_name) | `Named n -> fprintf ppf "%s = wrap(%s)" letters.(!i) n @@ -290,7 +316,7 @@ module Print_Grammar = struct in i := !i + 1 ; r in List.filter_map aux elements in - fprintf ppf "%s (%a)" name (list_sep string (const " , ")) elements' + fprintf ppf "`%s (%a)" name (list_sep string (const " , ")) elements' let n_operator prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop -> let name = get_name nop in @@ -340,65 +366,316 @@ let infix : string -> [`Left | `Right] -> token -> O.n_operator = fun name assoc | `Left -> make_name name [`Current ; `Token t ; `Lower] | `Right -> make_name name [`Current ; `Token t ; `Lower] +(* Ocaml is bad *) +let empty_infix : string -> [`Left | `Right] -> O.n_operator = fun name assoc -> + match assoc with + | `Left -> make_name name [`Current ; `Lower] + | `Right -> make_name name [`Current ; `Lower] + + +let paren : string -> string -> O.n_operator = fun constructor_name name -> + make_name constructor_name [`Token Token.LPAREN ; `Named name ; `Token Token.RPAREN] + let expression_name = "expression" let type_expression_name = "type_expression" let program_name = "program" let variable_name = "variable" +let pattern_name = "pattern" +let constructor_name = "constructor" +let int_name = "int_" +let tz_name = "tz_" +let unit_name = "unit_" +let string_name = "string_" let variable = O.manual_singleton variable_name ["| NAME { $1 }"] "string" +let int = O.manual_singleton int_name ["| INT { $1 }"] "int" +let tz = O.manual_singleton tz_name ["| TZ { $1 }"] "int" +let unit = O.manual_singleton unit_name ["| UNIT { () }"] "unit" +let string = O.manual_singleton string_name ["| STRING { $1 }"] "string" +let constructor = O.manual_singleton constructor_name ["| CONSTRUCTOR_NAME { $1 }"] "string" +module Pattern = struct + + open Token + open O + + let application = empty_infix "P_application" `Left + + let list : O.n_operator = make_name "P_list" [ + `Token LIST ; `Token LSQUARE ; `List (Lead SEMICOLON, `Current) ; `Token RSQUARE ; + ] + + let record_element : O.rule = make_name "p_record_element" [ + make_name "" [`Named variable_name ; `Token EQUAL ; `Named pattern_name] + ] + + let record : O.n_operator = make_name "P_record" [ + `Token LBRACKET ; + `List (Trail SEMICOLON, `Named record_element.name) ; + `Token RBRACKET ; + ] + + let pair = infix "P_pair" `Left COMMA + + let variable : O.n_operator = make_name "P_variable" [ `Named variable_name ] + let constructor : O.n_operator = make_name "P_constructor" [ `Named constructor_name ] + + let module_ident : O.n_operator = make_name "P_module_ident" [ + `List (Trail_force_ne DOT, `Named constructor_name) ; `Named variable_name ; + ] + + let unit : O.n_operator = make_name "P_unit" [ `Named unit_name ] + + let restricted_pattern_name = "resitrcted_pattern" + + let restricted_pattern = O.name_hierarchy restricted_pattern_name [ + [variable ; unit] ; + [paren "P_restrict" pattern_name] + ] [] + + let main = O.name_hierarchy pattern_name [ + [record] ; + [application] ; + [pair] ; + [list] ; + [variable ; constructor ; module_ident ; unit] ; + [paren "P_paren" pattern_name] + ] [] + + let singletons = [O.rule_singleton record_element] +end module Expression = struct open Token + open O - let list : O.n_operator = make_name "List" [ - `Token LIST ; `Token LSQUARE ; `List (`Lead, SEMICOLON, `Current) ; `Token RSQUARE ; + let application = empty_infix "E_application" `Right + + let list : O.n_operator = make_name "E_list" [ + `Token LSQUARE ; `List (Trail SEMICOLON, `Current) ; `Token RSQUARE ; ] - let let_in : O.n_operator = make_name "Let_in" [ - `Token Token.LET ; `Named "variable" ; - `Token Token.EQUAL ; `Current ; - `Token Token.IN ; `Current ; + let fun_ : O.n_operator = make_name "E_fun" [ + `Token FUN ; `Named pattern_name ; + `Token ARROW ; `Current ; ] - let addition = infix "Addition" `Left Token.PLUS - let substraction = infix "Substraction" `Left Token.MINUS + let let_in : O.n_operator = make_name "E_let_in" [ + `Token LET ; `Named pattern_name ; + `Token EQUAL ; `Current ; + `Token IN ; `Current ; + ] - let multiplication = infix "Multiplication" `Left Token.TIMES - let division = infix "Division" `Left Token.DIV + let no_seq_name = "expression_no_seq" + let no_match_name = "expression_no_match" - let arith_variable : O.n_operator = make_name "Arith_variable" [ `Named "variable" ] + let record_element : O.rule = make_name "e_record_element" [ + make_name "record_explicit" [`Named variable_name ; `Token EQUAL ; `Named no_seq_name] ; + make_name "record_implicit" [`Named variable_name ] ; + ] - let arith = O.name_hierarchy "expression" [ - [let_in] ; + let record : O.n_operator = make_name "E_record" [ + `Token LBRACKET ; + `List (Trail SEMICOLON, `Named record_element.name) ; + `Token RBRACKET ; + ] + + let ite : O.n_operator = make_name "E_ifthenelse" [ + `Token IF ; + `Current ; + `Token THEN ; + `Lower ; + `Token ELSE ; + `Current ; + ] + + let it : O.n_operator = make_name "E_ifthen" [ + `Token IF ; + `Current ; + `Token THEN ; + `Lower ; + ] + + let sequence = infix "E_sequence" `Left SEMICOLON + + let match_clause = make_name "e_match_clause" [ + make_name "" [`Named pattern_name ; `Token ARROW ; `Named no_match_name] + ] + let match_with = make_name "E_match" [ + `Token MATCH ; `Current ; `Token WITH ; + `List (Lead_ne VBAR, `Named match_clause.name) ; + ] + let lt = infix "E_lt" `Left LT + let le = infix "E_le" `Left LE + let gt = infix "E_gt" `Left GT + let eq = infix "E_eq" `Left EQUAL + + let cons = infix "E_cons" `Left DOUBLE_COLON + + let addition = infix "E_addition" `Left PLUS + let substraction = infix "E_substraction" `Left MINUS + + let multiplication = infix "E_multiplication" `Left TIMES + let division = infix "E_division" `Left DIV + + let arith_variable : O.n_operator = make_name "E_variable" [ `Named variable_name ] + let int : O.n_operator = make_name "E_int" [ `Named int_name ] + let tz : O.n_operator = make_name "E_tz" [ `Named tz_name ] + let unit : O.n_operator = make_name "E_unit" [ `Named unit_name ] + let string : O.n_operator = make_name "E_string" [ `Named string_name ] + let constructor : O.n_operator = make_name "E_constructor" [ `Named constructor_name ] + + let module_ident : O.n_operator = make_name "E_module_ident" [ + `List (Trail_force_ne DOT, `Named constructor_name) ; `Named variable_name ; + ] + let access : O.n_operator = infix "E_access" `Right DOT + let accessor : O.n_operator = make_name "E_accessor" [ + `Named variable_name ; `List (Lead_ne DOT, `Named variable_name) ; + ] + + let assignment : O.n_operator = infix "E_assign" `Left LEFT_ARROW + + let pair = infix "E_pair" `Left COMMA + + let name = make_name "E_name" [`Token TILDE ; `Current] + + let no_sequence_expression = O.name_hierarchy no_seq_name [ + [let_in ; fun_ ; record ; ite ; it ; match_with] ; + [pair] ; + [application] ; + [lt ; le ; gt ; eq] ; + [assignment] ; + [cons] ; [addition ; substraction] ; [multiplication ; division] ; [list] ; - [arith_variable] ; + [name] ; + [arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ; + [paren "E_no_seq_bottom" expression_name] ] [] + let no_match_expression = O.name_hierarchy no_match_name [ + [let_in ; fun_ ; record ; ite ; it ] ; + [pair] ; + [application] ; + [lt ; le ; gt ; eq] ; + [assignment] ; + [cons] ; + [addition ; substraction] ; + [multiplication ; division] ; + [list] ; + [name] ; + [arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ; + [paren "E_no_match_bottom" expression_name] + ] [] + + let expression = O.name_hierarchy expression_name [ + [sequence] ; + [let_in ; fun_ ; record ; ite ; it ; match_with] ; + [pair] ; + [application] ; + [lt ; le ; gt ; eq] ; + [assignment] ; + [cons] ; + [addition ; substraction] ; + [multiplication ; division] ; + [list] ; + [name] ; + [arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ; + [paren "E_paren" expression_name] + ] [] + + let singletons = List.map O.rule_singleton [record_element ; match_clause] +end + +module Type_expression = struct + + open Token + open O + + let list : O.n_operator = make_name "T_list" [ + `Token LIST ; `Token LSQUARE ; `List (Lead SEMICOLON, `Current) ; `Token RSQUARE ; + ] + + let let_in : O.n_operator = make_name "T_let_in" [ + `Token LET ; `Named variable_name ; + `Token EQUAL ; `Current ; + `Token IN ; `Current ; + ] + + let record_element : O.rule = make_name "t_record_element" [ + make_name "" [`Named variable_name ; `Token COLON ; `Named type_expression_name] + ] + + let record : O.n_operator = make_name "T_record" [ + `Token LBRACKET ; + `List (Trail SEMICOLON, `Named record_element.name) ; + `Token RBRACKET ; + ] + + let application = empty_infix "T_application" `Left + + let pair = infix "T_pair" `Left COMMA + + let arith_variable : O.n_operator = make_name "T_variable" [ `Named variable_name ] + + let arith = O.name_hierarchy type_expression_name [ + [let_in ; record ] ; + [pair] ; + [application] ; + [list] ; + [arith_variable] ; + [paren "T_paren" type_expression_name] + ] [] + + let singletons = [O.rule_singleton record_element] + end module Program = struct open Token + open O let statement_name = "statement" - let program : O.rule = make_name program_name [[ - `List (`Trail, SEMICOLON, statement_name) + let program : O.rule = make_name program_name [make_name "" [ + `List (Trail_option DOUBLE_SEMICOLON, statement_name) ]] - let statement : O.rule = make_name statement_name [ - [`Token CONST ; `Named variable_name ; `Token EQUAL ; `Named expression_name] + let param_name = "param" + + let param : O.rule = make_name param_name [ + make_name "restricted_pattern" [ `Named Pattern.restricted_pattern_name ] ; + make_name "implicit_named_param" [ `Token TILDE ; `Named variable_name ] ; ] - let singletons = List.map O.rule_singleton [program ; statement] + let statement : O.rule = make_name statement_name [ + make_name "variable_declaration" [`Token LET ; `Named variable_name ; `List (Naked, variable_name) ; `Token EQUAL ; `Named expression_name] ; + make_name "init_declaration" [`Token LET_INIT ; `Named variable_name ; `List (Naked, variable_name) ; `Token EQUAL ; `Named expression_name] ; + make_name "entry_declaration" [`Token LET_ENTRY ; `Named variable_name ; `List (Naked, param_name) ; `Token EQUAL ; `Named expression_name] ; + make_name "type_declaration" [`Token TYPE ; `Named variable_name ; `Token EQUAL ; `Named type_expression_name] ; + ] + + let singletons = List.map O.rule_singleton [program ; statement ; param] end -let language = O.language program_name (variable :: Program.singletons) [Expression.arith] +let language = O.language program_name ( + variable :: constructor :: int :: unit :: string :: tz :: + Program.singletons @ + Pattern.singletons @ + Expression.singletons @ + Type_expression.singletons + ) [ + Pattern.main ; + Pattern.restricted_pattern ; + Expression.no_sequence_expression ; + Expression.no_match_expression ; + Expression.expression ; + Type_expression.arith ; + ] let () = let argn = Array.length Sys.argv in diff --git a/src/ligo/multifix/lex/generator.ml b/src/ligo/multifix/lex/generator.ml index faec9cc64..eb52583fd 100644 --- a/src/ligo/multifix/lex/generator.ml +++ b/src/ligo/multifix/lex/generator.ml @@ -5,7 +5,13 @@ type pre_token = { let make name pattern = { name ; pattern } -let keyword = fun k -> make (String.uppercase_ascii k) k +let keyword = fun k -> + let regexp = Str.regexp "[^0-9a-zA-Z]" in + let constructor_name = + Str.global_replace regexp "_" + @@ String.uppercase_ascii k + in + make constructor_name k let symbol = fun sym name -> make name sym module Print_mly = struct @@ -17,8 +23,10 @@ module Print_mly = struct let tokens = fun ppf tokens -> fprintf ppf "%%token EOF\n" ; fprintf ppf "%%token INT\n" ; + fprintf ppf "%%token TZ\n" ; fprintf ppf "%%token STRING\n" ; fprintf ppf "%%token NAME\n" ; + fprintf ppf "%%token CONSTRUCTOR_NAME\n" ; fprintf ppf "\n%a\n\n" (PP_helpers.list_sep token (PP_helpers.const "\n")) tokens ; fprintf ppf "%%%%\n" end @@ -47,19 +55,40 @@ rule token = parse *) | ('\r'? '\n' '\r'?) { Lexing.new_line lexbuf; token lexbuf } +| '"' { string "" lexbuf } | [' ' '\t'] { token lexbuf } -| ['0'-'9']+ as i +| (['0'-'9']+ as n) '.' (['0'-'9']['0'-'9'] as d) "tz" { TZ ((int_of_string n) * 100 + (int_of_string d)) } +| (['0'-'9']+ as i) 'p'? { INT (int_of_string i) } -| '"' ( [^ '"' '\\'] | ( '\\' [^ '"'] ) ) as s '"' - { STRING s } |pre} let post = - {post|| (['a'-'z']['a'-'z''A'-'Z''0'-'9''_']+) as v + {post| +| (['a'-'z''_']['a'-'z''A'-'Z''0'-'9''_']*) as v { NAME v } +| (['A'-'Z']['a'-'z''A'-'Z''0'-'9''_']*) as v + { CONSTRUCTOR_NAME v } | eof { EOF } +| "(*" { comment 1 lexbuf } | _ { raise (Unexpected_character (Printf.sprintf "At offset %d: unexpected character.\n" (Lexing.lexeme_start lexbuf))) } + +and string s = parse + | "\\\"" { string (s ^ "\"") lexbuf } + | "\\\\" { string (s ^ "\\") lexbuf } + | '"' { STRING s } + | eof { raise (Unexpected_character "missing string terminator") } + | _ as c { string (s ^ (String.make 1 c)) lexbuf } + + +and comment n = parse + | "*)" { if n = 1 then token lexbuf else comment (n - 1) lexbuf } + | "(*" { comment (n + 1) lexbuf } + | '"' ( [^ '"' '\\'] | ( '\\' [^ '"'] ) ) '"' { comment n lexbuf } + | eof { raise (Unexpected_character "missing comment terminator") } + | ('\r'? '\n' '\r'?) { Lexing.new_line lexbuf; comment n lexbuf } + | _ { comment n lexbuf } + |post} let tokens = fun ppf tokens -> fprintf ppf "%s%a\n%s" pre (PP_helpers.list_sep token (PP_helpers.const "\n")) tokens post @@ -77,7 +106,9 @@ module Print_ml = struct let to_string : token -> string = function | STRING _ -> "STRING" | NAME _ -> "NAME s" + | CONSTRUCTOR_NAME _ -> "CONSTRUCTOR_NAME s" | INT _ -> "INT n" + | TZ _ -> "TZ n" | EOF -> "EOF" |pre} @@ -86,20 +117,46 @@ let to_string : token -> string = function end let tokens = [ + keyword "let%init" ; + keyword "let%entry" ; keyword "let" ; + keyword "type" ; keyword "in" ; + keyword "if" ; + keyword "then" ; + keyword "else" ; keyword "list" ; keyword "block" ; keyword "for" ; keyword "const" ; + keyword "fun" ; + keyword "match" ; + keyword "with" ; + symbol "()" "UNIT" ; symbol "+" "PLUS" ; + symbol "~" "TILDE" ; + symbol "->" "ARROW" ; + symbol "<-" "LEFT_ARROW" ; + symbol "<=" "LE" ; + symbol "<" "LT" ; + symbol ">" "GT" ; symbol "-" "MINUS" ; symbol "*" "TIMES" ; symbol "/" "DIV" ; symbol "=" "EQUAL" ; + symbol "|" "VBAR" ; symbol "[" "LSQUARE" ; symbol "]" "RSQUARE" ; + symbol "(" "LPAREN" ; + symbol ")" "RPAREN" ; + symbol "{" "LBRACKET" ; + symbol "}" "RBRACKET" ; + symbol ";;" "DOUBLE_SEMICOLON" ; symbol ";" "SEMICOLON" ; + symbol "::" "DOUBLE_COLON" ; + symbol ":" "COLON" ; + symbol "," "COMMA" ; + symbol "." "DOT" ; ] let () = diff --git a/src/ligo/multifix/pre_parser.mly b/src/ligo/multifix/pre_parser.mly index d110c8efd..d555c6b79 100644 --- a/src/ligo/multifix/pre_parser.mly +++ b/src/ligo/multifix/pre_parser.mly @@ -1,11 +1,19 @@ %{ - open Ast + %} %start entry_point %% +naked_list(X): + | { [] } + | x = X xs = naked_list(X) { x :: xs } + +naked_list_ne(X): + | x = X { [ x ] } + | x = X xs = naked_list_ne(X) { x :: xs } + trail_list(separator, X): | { [] } | trail_list_content(separator, X) { $1 } @@ -17,6 +25,29 @@ trail_list_content(separator, X): trail_list_last(separator, X): | x = X option(separator) { [ x ] } +trail_force_list(separator, X): + | { [] } + | x = X separator xs = trail_force_list(separator, X) { x :: xs } + +trail_force_list_ne(separator, X): + | x = X separator { [ x ] } + | x = X separator xs = trail_force_list_ne(separator, X) { x :: xs } + +trail_option_list(separator, X): + | { [] } + | trail_option_list_content(separator, X) { $1 } + +trail_option_list_content(separator, X): + | x = trail_option_list_last(separator, X) { x } + | x = X option(separator) xs = trail_option_list_content(separator, X) { x :: xs } + +trail_option_list_last(separator, X): + | x = X option(separator) { [ x ] } + +lead_list_ne(separator, X): + | separator x = X { [x] } + | separator x = X xs = lead_list_ne(separator, X) { x :: xs } + lead_list(separator, X): | { [] } | lead_list_content(separator, X) { $1 } diff --git a/src/ligo/multifix/user.ml b/src/ligo/multifix/user.ml index 6738970c1..8244bad25 100644 --- a/src/ligo/multifix/user.ml +++ b/src/ligo/multifix/user.ml @@ -31,8 +31,8 @@ let parse_file (source: string) : Ast.entry_point result = match e with | Parser.Error -> error "Parse" | Lexer.Error s -> error ("Lexer " ^ s) - | Lexer.Unexpected_character _ -> error "Unexpected char" - | _ -> simple_error "unrecognized parse_ error" + | Lexer.Unexpected_character s -> error ("Unexpected char" ^ s) + | _ -> error "unrecognized parse_ error" ) @@ (fun () -> let raw = Parser.entry_point Lexer.token lexbuf in raw diff --git a/src/ligo/operators/dune b/src/ligo/operators/dune new file mode 100644 index 000000000..ad20103e6 --- /dev/null +++ b/src/ligo/operators/dune @@ -0,0 +1,4 @@ +(library + (name operators) + (public_name ligo.operators) +)