From e9f90858a2ec0c98d630d1d5cd850c8bb0218e15 Mon Sep 17 00:00:00 2001 From: Galfour Date: Sat, 6 Apr 2019 11:18:55 +0000 Subject: [PATCH] integration --- src/lib_utils/location.ml | 7 + src/lib_utils/tezos_utils.ml | 1 + src/ligo/contracts/new-syntax.mligo | 1 + src/ligo/ligo.ml | 1 + src/ligo/multifix/ast.ml | 19 -- src/ligo/multifix/dune | 17 +- src/ligo/multifix/generator.ml | 282 +++++++++++++++++++-------- src/ligo/multifix/lex/generator.ml | 1 + src/ligo/multifix/location.ml | 6 - src/ligo/multifix/parser.mli | 12 -- src/ligo/multifix/parser.mly | 99 ---------- src/ligo/multifix/partial_parser.mly | 70 ------- src/ligo/multifix/pre_parser.mly | 5 +- src/ligo/multifix/user.ml | 44 ++++- src/ligo/test/multifix_tests.ml | 11 ++ src/ligo/test/test.ml | 1 + 16 files changed, 272 insertions(+), 305 deletions(-) create mode 100644 src/ligo/contracts/new-syntax.mligo delete mode 100644 src/ligo/multifix/ast.ml delete mode 100644 src/ligo/multifix/parser.mli delete mode 100644 src/ligo/multifix/parser.mly delete mode 100644 src/ligo/multifix/partial_parser.mly create mode 100644 src/ligo/test/multifix_tests.ml diff --git a/src/lib_utils/location.ml b/src/lib_utils/location.ml index 776cd7f93..5fbea6e3b 100644 --- a/src/lib_utils/location.ml +++ b/src/lib_utils/location.ml @@ -22,3 +22,10 @@ let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t = let virtual_location s = Virtual s let dummy = virtual_location "dummy" + +type 'a wrap = { + wrap_content : 'a ; + location : t ; +} + +let wrap ~loc wrap_content = { wrap_content ; location = loc } diff --git a/src/lib_utils/tezos_utils.ml b/src/lib_utils/tezos_utils.ml index 317714915..079c7f9f3 100644 --- a/src/lib_utils/tezos_utils.ml +++ b/src/lib_utils/tezos_utils.ml @@ -9,6 +9,7 @@ module Micheline = X_tezos_micheline module Error_monad = X_error_monad module Trace = Trace module PP = PP +module Location = Location module List = X_list module Option = Tezos_base.TzPervasives.Option diff --git a/src/ligo/contracts/new-syntax.mligo b/src/ligo/contracts/new-syntax.mligo new file mode 100644 index 000000000..debde1b01 --- /dev/null +++ b/src/ligo/contracts/new-syntax.mligo @@ -0,0 +1 @@ +let toto = at * bo in list [ toto ; tata ; titi ] diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml index 17995dd49..273ceb74f 100644 --- a/src/ligo/ligo.ml +++ b/src/ligo/ligo.ml @@ -8,6 +8,7 @@ module AST_Typed = Ast_typed module Mini_c = Mini_c module Typer = Typer module Transpiler = Transpiler +module Parser_multifix = Multifix open Trace diff --git a/src/ligo/multifix/ast.ml b/src/ligo/multifix/ast.ml deleted file mode 100644 index c28731cba..000000000 --- a/src/ligo/multifix/ast.ml +++ /dev/null @@ -1,19 +0,0 @@ -(* AST *) -(* Language *) - - (* Singletons *) -type variable = string - - (* Hierarchies *) -type arith = -| Let_in of (variable Location.wrap * arith Location.wrap * arith Location.wrap) -| Addition of (arith Location.wrap * arith Location.wrap) -| Substraction of (arith Location.wrap * arith Location.wrap) -| Multiplication of (arith Location.wrap * arith Location.wrap) -| Division of (arith Location.wrap * arith Location.wrap) -| List of ((arith Location.wrap list)) -| Arith_variable of (variable Location.wrap) - (* Entry point *) -type entry_point = arith - - diff --git a/src/ligo/multifix/dune b/src/ligo/multifix/dune index d07ade9ae..198700359 100644 --- a/src/ligo/multifix/dune +++ b/src/ligo/multifix/dune @@ -1,8 +1,15 @@ (library (name multifix) (public_name ligo.multifix) - (libraries lex) - (modules ast parser location user) + (libraries + tezos-utils + lex + ) + (modules ast parser user) + (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Tezos_utils )) + (preprocess + (pps ppx_let) + ) ) ;; Generating parser @@ -51,12 +58,6 @@ ;; Tests -(alias - (name test-user) - (deps user.exe foo.test) - (action (system "./user.exe foo.test")) -) - (alias (name runtest) (deps generator.exe) diff --git a/src/ligo/multifix/generator.ml b/src/ligo/multifix/generator.ml index fcc68ad72..4b080beae 100644 --- a/src/ligo/multifix/generator.ml +++ b/src/ligo/multifix/generator.ml @@ -13,28 +13,60 @@ type token = Token.token module O = struct - type element = - | Named of string (* Named rule, like type_var *) - | Token of token - | List of ([`Trail | `Lead | `Separator] * token * token * token) - | Current - | Lower (* Lower precedence *) + type 'a list_element = [`Trail | `Lead | `Separator] * token * 'a + + type basic_rhs_element = [ + | `Named of string + | `Token of token + ] + + type rhs_element = [ + | basic_rhs_element + | `List of string list_element + ] + + type rhs = rhs_element list + type rule = rhs list name + + type manual_rule_content = { + menhir_codes : string list ; + ast_code : string ; + } + type manual_rule = manual_rule_content name + + type singleton = + | Manual of manual_rule + | Generated of rule + + type name_element = [ + | `Named of string + | `Current + | `Lower + ] + + type element = [ + | `Named of string + | `Token of token + | `List of name_element list_element + | `Current + | `Lower + ] + type operator = element list type n_operator = operator name type n_operators = n_operator list type level = n_operators name + type level_list = level list + type levels = level List.Ne.t - type hierarchy = level List.Ne.t - type n_hierarchy = hierarchy name - - type singleton = { - type_name : string ; - type_expression : string ; - menhir_rule : string ; - menhir_code : string ; + type hierarchy = { + levels : levels ; + auxiliary_rules : rule list ; } + type n_hierarchy = hierarchy name + let make_hierarchy levels auxiliary_rules : hierarchy = { levels ; auxiliary_rules } type language = { entry_point : string ; @@ -44,15 +76,15 @@ module O = struct let get_op : n_operator -> operator = get_content - let singleton type_name type_expression menhir_rule menhir_code = - {type_name ; type_expression ; menhir_rule ; menhir_code} + let manual_singleton name menhir_codes ast_code : singleton = Manual (make_name name {menhir_codes ; ast_code}) let language entry_point singletons hierarchies = {entry_point ; singletons ; hierarchies} - let name_hierarchy name : n_operators list -> n_hierarchy = fun nopss -> + + let name_hierarchy name : n_operators list -> rule list -> n_hierarchy = fun nopss rules -> let nopss' = List.Ne.of_list nopss in let name_i = fun i x -> make_name (name ^ "_" ^ (string_of_int i)) x in - let levels : hierarchy = List.Ne.mapi name_i nopss' in - make_name name levels + let levels : levels = List.Ne.mapi name_i nopss' in + make_name name @@ make_hierarchy levels rules end @@ -65,7 +97,7 @@ module Check = struct match es with | [] -> () | [ _ ] -> () - | (List _ | Named _ | Current | Lower) :: (List _ | Named _ | Current | Lower) :: _ -> + | (`List _ | `Named _ | `Current | `Lower) :: (`List _ | `Named _ | `Current | `Lower) :: _ -> raise (Failure "two non-token separated ops in a row") | _ :: tl -> aux tl in @@ -73,7 +105,7 @@ module Check = struct aux es in let op : n_operator -> unit = fun x -> elements @@ get_content x in let level : level -> unit = fun l -> List.iter op @@ get_content l in - let hierarchy : n_hierarchy -> unit = fun h -> List.Ne.iter level @@ get_content h in + let hierarchy : n_hierarchy -> unit = fun h -> List.Ne.iter level @@ h.content.levels in List.iter hierarchy l.hierarchies let associativity : language -> unit = fun l -> @@ -81,18 +113,18 @@ module Check = struct let aux : ([`Left | `Right | `None] as 'a) -> n_operator -> 'a = fun ass nop -> let op = get_content nop in match ass, List.hd op, List.nth op (List.length op - 1) with - | _, Lower, Lower -> raise (Failure "double assoc") - | `None, Lower, _ -> `Left - | `None, _, Lower -> `Right - | `Left, _, Lower -> raise (Failure "different assocs") - | `Right, Lower, _ -> raise (Failure "different assocs") + | _, `Lower, `Lower -> raise (Failure "double assoc") + | `None, `Lower, _ -> `Left + | `None, _, `Lower -> `Right + | `Left, _, `Lower -> raise (Failure "different assocs") + | `Right, `Lower, _ -> raise (Failure "different assocs") | m, _, _ -> m in let _assert = List.fold_left aux `None (get_content l) in () in let hierarchy : n_hierarchy -> unit = fun h -> - List.Ne.iter level (get_content h) in + List.Ne.iter level h.content.levels in List.iter hierarchy l.hierarchies end @@ -101,17 +133,41 @@ end module Print_AST = struct open Format + let manual_rule : _ -> O.manual_rule -> _ = fun ppf mr -> + fprintf ppf "type %s = %s" mr.name mr.content.ast_code + + let generated_rule : _ -> O.rule -> _ = fun ppf gr -> + let aux : _ -> O.rhs -> _ = fun ppf rhs -> + let type_elements = + 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)") + | `Token _ -> None + in + List.filter_map aux rhs in + let type_element = fun ppf te -> fprintf ppf "%s" te in + fprintf ppf "| %s of (%a)" + gr.name + PP.(list_sep type_element (const " * ")) type_elements + in + fprintf ppf "type %s=@. @[%a@]" gr.name + PP.(list_sep aux new_line) gr.content + let singleton : _ -> O.singleton -> _ = fun ppf s -> - fprintf ppf "type %s = %s" s.type_name s.type_expression + match s with + | Manual s -> manual_rule ppf s + | Generated s -> generated_rule ppf s + let n_operator level_name : _ -> O.n_operator -> _ = fun ppf nop -> let type_elements = let aux : O.element -> string option = fun e -> match e with - | Named s -> Some (s ^ " Location.wrap") - | List _ -> Some ("(" ^ level_name ^ " Location.wrap list)") - | Token _ -> None - | Current | Lower -> Some (level_name ^ " Location.wrap") in + | `Named s -> Some (s ^ " Location.wrap") + | `List _ -> Some ("(" ^ level_name ^ " 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)" @@ -119,7 +175,7 @@ module Print_AST = struct PP.(list_sep type_element (const " * ")) type_elements let n_hierarchy : _ -> O.n_hierarchy -> _ = fun ppf nh -> - let levels = List.Ne.map get_content (get_content nh) in + 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 "type %s =@.@[%a@]" @@ -130,38 +186,76 @@ module Print_AST = struct fprintf ppf "%a@.@." PP.comment "Language" ; fprintf ppf " %a@.%a@.@." PP.comment "Singletons" PP.(list_sep singleton new_line) l.singletons ; fprintf ppf " %a@.%a@." PP.comment "Hierarchies" PP.(list_sep n_hierarchy (new_lines 2)) l.hierarchies ; - fprintf ppf " %a@.type entry_point = %s@.@." PP.comment "Entry point" l.entry_point ; + fprintf ppf " %a@.type entry_point = %s Location.wrap@.@." PP.comment "Entry point" l.entry_point ; () end module Print_Grammar = struct open Format - let singleton : _ -> O.singleton -> _ = fun ppf s -> - fprintf ppf "%s : %s@. @[{@; @[let loc = Location.make $startpos $endpos in@;Location.wrap ~loc %s@]@;}@;@]" - s.type_name s.menhir_rule s.menhir_code - let letters = [| "a" ; "b" ; "c" ; "d" ; "e" ; "f" ; "g" ; "h" ; "i" ; "j" |] + + let manual_rule : _ -> O.manual_rule -> _ = fun ppf mr -> + let {name;content} = mr in + fprintf ppf "%s:@. @[%a@]" name (PP.list_sep PP.string PP.new_line) content.menhir_codes + + let generated_rule : _ -> O.rule -> _ = fun ppf gr -> + let aux_rule : _ -> O.rhs -> _ = fun ppf rhs -> + let i = ref 0 in + let aux : _ -> O.rhs_element -> _ = fun ppf e -> + (match e with + | `Named s -> fprintf ppf "%s = %s" letters.(!i) s + | `List (mode, sep, s) -> + fprintf ppf "%s = %s(%s, %s)" + letters.(!i) + (match mode with | `Lead -> "lead_list" | `Trail -> "trail_list" | `Separator -> "separated_list") + (Token.to_string sep) + s + | `Token t -> i := !i - 1 ; PP.string ppf @@ Token.to_string t) ; + i := !i + 1 + in + fprintf ppf "%a" PP.(list_sep aux (const " ")) rhs in + let aux_code : _ -> O.rhs -> _ = fun ppf rhs -> + let i = ref 0 in + let aux : O.rhs_element -> _ = fun e -> + let s = (match e with + | `Named _ | `List _ -> Some (letters.(!i)) + | `Token _ -> i := !i - 1 ; None) in + i := !i + 1 ; s + in + let content = List.filter_map aux rhs in + fprintf ppf "%a" PP.(list_sep string (const " , ")) content + in + let aux : _ -> O.rhs -> _ = fun ppf rhs -> + fprintf ppf "| %a { %a }" + aux_rule rhs + aux_code rhs in + fprintf ppf "%s:@.%a" gr.name PP.(list_sep aux (const "\n")) gr.content + + let singleton : _ -> O.singleton -> _ = fun ppf s -> + match s with + | Manual s -> manual_rule ppf s + | Generated s -> generated_rule ppf s + + let n_operator_rule prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop -> let i = ref 0 in let element : _ -> O.element -> _ = fun ppf element -> (match element with - | Token t -> i := !i - 1 ; PP.string ppf @@ Token.to_string t - | List (mode, beg, sep, end_) -> - fprintf ppf "%s %s = %s(%s, %s) %s" - (Token.to_string beg) + | `Token t -> i := !i - 1 ; PP.string ppf @@ Token.to_string t + | `List (mode, sep, content) -> + fprintf ppf "%s = %s(%s, wrap(%s))" letters.(!i) (match mode with | `Lead -> "lead_list" | `Trail -> "trail_list" | `Separator -> "separated_list") (Token.to_string sep) - cur_lvl_name - (Token.to_string end_) - | Named n -> - fprintf ppf "%s = %s" letters.(!i) n - | Current -> - fprintf ppf "%s = %s" letters.(!i) cur_lvl_name - | Lower -> - fprintf ppf "%s = %s" letters.(!i) prev_lvl_name + (match content with | `Lower -> prev_lvl_name | `Named s -> s | `Current -> cur_lvl_name) + | `Named n -> + fprintf ppf "%s = wrap(%s)" letters.(!i) n + | `Current -> + fprintf ppf "%s = wrap(%s)" letters.(!i) cur_lvl_name + | `Lower -> + fprintf ppf "%s = wrap(%s)" letters.(!i) prev_lvl_name ) ; i := !i + 1 in @@ -174,8 +268,8 @@ module Print_Grammar = struct let aux : O.element -> _ = fun e -> let r = match e with - | Token _ -> i := !i - 1 ; None - | List _ | Named _ | Current | Lower -> Some letters.(!i) + | `Token _ -> i := !i - 1 ; None + | `List _ | `Named _ | `Current | `Lower -> Some letters.(!i) in i := !i + 1 ; r in List.filter_map aux elements in @@ -183,7 +277,7 @@ module Print_Grammar = struct let n_operator prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop -> let name = get_name nop in - fprintf ppf "%a@;| %a@; @[{@; @[let loc = Location.make $startpos $endpos in@;Location.wrap ~loc %@%@ %a@]@;}@]" PP.comment name + fprintf ppf "%a@;| %a { %a }" PP.comment name (n_operator_rule prev_lvl_name cur_lvl_name) nop n_operator_code nop @@ -203,7 +297,7 @@ module Print_Grammar = struct let n_hierarchy : _ -> O.n_hierarchy -> _ = fun ppf nh -> let name = get_name nh in fprintf ppf "%a@.%%inline %s : %s_0 { $1 }@.@;" PP.comment ("Top-level for " ^ name) name name; - let (hd, tl) = List.Ne.rev @@ get_content nh in + let (hd, tl) = List.Ne.rev (get_content nh).levels in fprintf ppf "%a" (level "") hd ; let aux prev_name lvl = PP.new_lines 2 ppf () ; @@ -215,7 +309,7 @@ module Print_Grammar = struct let language : _ -> O.language -> _ = fun ppf l -> fprintf ppf "%a@.@." PP.comment "Generated Language" ; - fprintf ppf "entry_point : %s EOF { $1 }@.@." l.entry_point ; + fprintf ppf "entry_point : wrap(%s) EOF { $1 }@.@." l.entry_point ; fprintf ppf "%a@.@." PP.comment "Singletons" ; fprintf ppf "@[%a@]@.@." (PP.list_sep singleton PP.new_line) l.singletons ; fprintf ppf "%a@.@." PP.comment "Hierarchies" ; @@ -223,41 +317,69 @@ module Print_Grammar = struct end -let variable = O.singleton "variable" "string" "NAME" "$1" let infix : string -> [`Left | `Right] -> token -> O.n_operator = fun name assoc t -> - let open O in match assoc with - | `Left -> make_name name [Current ; Token t ; Lower] - | `Right -> make_name name [Current ; Token t ; Lower] + | `Left -> make_name name [`Current ; `Token t ; `Lower] + | `Right -> make_name name [`Current ; `Token t ; `Lower] -let list = make_name "List" [ - O.Token Token.LIST ; List (`Lead, Token.LSQUARE, Token.SEMICOLON, Token.RSQUARE) ; -] +let expression_name = "expression" +let type_expression_name = "type_expression" +let program_name = "program" +let variable_name = "variable" -let let_in : O.n_operator = make_name "Let_in" [ - O.Token Token.LET ; Named "variable" ; - O.Token Token.EQUAL ; Current ; - O.Token Token.IN ; Current ; -] +let variable = O.manual_singleton variable_name ["| NAME { $1 }"] "string" -let addition = infix "Addition" `Left Token.PLUS -let substraction = infix "Substraction" `Left Token.MINUS -let multiplication = infix "Multiplication" `Left Token.TIMES -let division = infix "Division" `Left Token.DIV +module Expression = struct -let arith_variable : O.n_operator = make_name "Arith_variable" [ O.Named "variable" ] + open Token -let arith = O.name_hierarchy "arith" [ - [let_in] ; - [addition ; substraction] ; - [multiplication ; division] ; - [list] ; - [arith_variable] ; -] + let list : O.n_operator = make_name "List" [ + `Token LIST ; `Token LSQUARE ; `List (`Lead, SEMICOLON, `Current) ; `Token RSQUARE ; + ] -let language = O.language "arith" [variable] [arith] + let let_in : O.n_operator = make_name "Let_in" [ + `Token Token.LET ; `Named "variable" ; + `Token Token.EQUAL ; `Current ; + `Token Token.IN ; `Current ; + ] + + let addition = infix "Addition" `Left Token.PLUS + let substraction = infix "Substraction" `Left Token.MINUS + + let multiplication = infix "Multiplication" `Left Token.TIMES + let division = infix "Division" `Left Token.DIV + + let arith_variable : O.n_operator = make_name "Arith_variable" [ `Named "variable" ] + + let arith = O.name_hierarchy "arith" [ + [let_in] ; + [addition ; substraction] ; + [multiplication ; division] ; + [list] ; + [arith_variable] ; + ] [] + +end + +module Program = struct + + open Token + + let statement_name = "statement" + + let program : O.rule = make_name program_name [[ + `List (`Trail, SEMICOLON, statement_name) + ]] + + let statement : O.rule = make_name statement_name [ + [`Token CONST ; `Named variable_name ; `Token EQUAL ; `Named expression_name] + ] + +end + +let language = O.language "arith" [variable] [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 927d13913..9e029de69 100644 --- a/src/ligo/multifix/lex/generator.ml +++ b/src/ligo/multifix/lex/generator.ml @@ -91,6 +91,7 @@ let tokens = [ keyword "list" ; keyword "block" ; keyword "for" ; + keyword "const" ; symbol "+" "PLUS" ; symbol "-" "MINUS" ; symbol "*" "TIMES" ; diff --git a/src/ligo/multifix/location.ml b/src/ligo/multifix/location.ml index 5fbea6e3b..cd160a125 100644 --- a/src/ligo/multifix/location.ml +++ b/src/ligo/multifix/location.ml @@ -23,9 +23,3 @@ let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t = let virtual_location s = Virtual s let dummy = virtual_location "dummy" -type 'a wrap = { - wrap_content : 'a ; - location : t ; -} - -let wrap ~loc wrap_content = { wrap_content ; location = loc } diff --git a/src/ligo/multifix/parser.mli b/src/ligo/multifix/parser.mli deleted file mode 100644 index 7c93c3f9b..000000000 --- a/src/ligo/multifix/parser.mli +++ /dev/null @@ -1,12 +0,0 @@ - -(* The type of tokens. *) - -type token = Lex.Token.token - -(* This exception is raised by the monolithic API functions. *) - -exception Error - -(* The monolithic API. *) - -val entry_point: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Ast.entry_point Location.wrap) diff --git a/src/ligo/multifix/parser.mly b/src/ligo/multifix/parser.mly deleted file mode 100644 index 577e959a8..000000000 --- a/src/ligo/multifix/parser.mly +++ /dev/null @@ -1,99 +0,0 @@ -%{ - open Ast -%} - -%start entry_point - -%% - -trail_list(separator, X): - | { [] } - | trail_list_content(separator, X) { $1 } - -trail_list_content(separator, X): - | x = trail_list_last(separator, X) { x } - | x = X separator xs = trail_list_content(separator, X) { x :: xs } - -trail_list_last(separator, X): - | x = X option(separator) { [ x ] } - -lead_list(separator, X): - | { [] } - | lead_list_content(separator, X) { $1 } - -lead_list_content(separator, X): - | x = lead_list_first(separator, X) { x } - | xs = lead_list_content(separator, X) separator x = X { xs @ [ x ] } - -lead_list_first (separator, X): - | option(separator) x = X { [ x ] } -(* Full Grammar *) -(* Generated Language *) - -entry_point : arith EOF { $1 } - -(* Singletons *) - -variable : NAME - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc $1 - } - - -(* Hierarchies *) - -(* Top-level for arith *) -%inline arith : arith_0 { $1 } - -arith_4 : - (* Arith_variable *) - | a = variable - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ Arith_variable (a) - } -arith_3 : - (* List *) - | LIST LSQUARE a = lead_list(SEMICOLON, arith_3) RSQUARE - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ List (a) - } - | arith_4 { $1 } -arith_2 : - (* Multiplication *) - | a = arith_2 TIMES b = arith_3 - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ Multiplication (a , b) - } - (* Division *) - | a = arith_2 DIV b = arith_3 - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ Division (a , b) - } - | arith_3 { $1 } -arith_1 : - (* Addition *) - | a = arith_1 PLUS b = arith_2 - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ Addition (a , b) - } - (* Substraction *) - | a = arith_1 MINUS b = arith_2 - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ Substraction (a , b) - } - | arith_2 { $1 } -arith_0 : - (* Let_in *) - | LET a = variable EQUAL b = arith_0 IN c = arith_0 - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ Let_in (a , b , c) - } - | arith_1 { $1 } diff --git a/src/ligo/multifix/partial_parser.mly b/src/ligo/multifix/partial_parser.mly deleted file mode 100644 index 507ae7163..000000000 --- a/src/ligo/multifix/partial_parser.mly +++ /dev/null @@ -1,70 +0,0 @@ -(* Full Grammar *) -(* Generated Language *) - -entry_point : arith EOF { $1 } - -(* Singletons *) - -variable : NAME - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc $1 - } - - -(* Hierarchies *) - -(* Top-level for arith *) -%inline arith : arith_0 { $1 } - -arith_4 : - (* Arith_variable *) - | a = variable - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ Arith_variable (a) - } -arith_3 : - (* List *) - | LIST LSQUARE a = lead_list(SEMICOLON, arith_3) RSQUARE - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ List (a) - } - | arith_4 { $1 } -arith_2 : - (* Multiplication *) - | a = arith_2 TIMES b = arith_3 - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ Multiplication (a , b) - } - (* Division *) - | a = arith_2 DIV b = arith_3 - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ Division (a , b) - } - | arith_3 { $1 } -arith_1 : - (* Addition *) - | a = arith_1 PLUS b = arith_2 - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ Addition (a , b) - } - (* Substraction *) - | a = arith_1 MINUS b = arith_2 - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ Substraction (a , b) - } - | arith_2 { $1 } -arith_0 : - (* Let_in *) - | LET a = variable EQUAL b = arith_0 IN c = arith_0 - { - let loc = Location.make $startpos $endpos in - Location.wrap ~loc @@ Let_in (a , b , c) - } - | arith_1 { $1 } diff --git a/src/ligo/multifix/pre_parser.mly b/src/ligo/multifix/pre_parser.mly index 4df86927b..d110c8efd 100644 --- a/src/ligo/multifix/pre_parser.mly +++ b/src/ligo/multifix/pre_parser.mly @@ -2,7 +2,7 @@ open Ast %} -%start entry_point +%start entry_point %% @@ -27,3 +27,6 @@ lead_list_content(separator, X): lead_list_first (separator, X): | option(separator) x = X { [ x ] } + +%inline wrap(X): + | x = X { let loc = Location.make $startpos $endpos in Location.wrap ~loc x } diff --git a/src/ligo/multifix/user.ml b/src/ligo/multifix/user.ml index 149f39215..0045683b6 100644 --- a/src/ligo/multifix/user.ml +++ b/src/ligo/multifix/user.ml @@ -1,10 +1,34 @@ -let () = - (match Array.length Sys.argv with - | 1 -> exit 1 - | _ -> ()) ; - let path = Sys.argv.(1) in - let chan = open_in path in - let lexbuf = Lexing.from_channel chan in - let _ast = Parser.entry_point Lex.Lexer.token lexbuf in - Format.printf "parse ok\n" ; - () +open Trace + +let parse_file (source: string) : Ast.entry_point result = + let pp_input = + let prefix = Filename.(source |> basename |> remove_extension) + and suffix = ".pp.ligo" + in prefix ^ suffix in + + let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s -o %s" + source pp_input in + let%bind () = sys_command cpp_cmd in + + let%bind channel = + generic_try (simple_error "error opening file") @@ + (fun () -> open_in pp_input) in + let lexbuf = Lexing.from_channel channel in + let module Lexer = Lex.Lexer in + specific_try (function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in + simple_error str + ) + | _ -> simple_error "unrecognized parse_ error" + ) @@ (fun () -> + let raw = Parser.entry_point Lexer.token lexbuf in + raw + ) >>? fun raw -> + ok raw diff --git a/src/ligo/test/multifix_tests.ml b/src/ligo/test/multifix_tests.ml new file mode 100644 index 000000000..cf4a8f025 --- /dev/null +++ b/src/ligo/test/multifix_tests.ml @@ -0,0 +1,11 @@ +open Trace +open Test_helpers +open Ligo.Parser_multifix + +let basic () : unit result = + let%bind _ = User.parse_file "./contracts/new-syntax.mligo" in + ok () + +let main = "Parser Multifix", [ + test "basic" basic ; +] diff --git a/src/ligo/test/test.ml b/src/ligo/test/test.ml index 33e8c8c9a..15e0f154e 100644 --- a/src/ligo/test/test.ml +++ b/src/ligo/test/test.ml @@ -3,6 +3,7 @@ let () = (* Printexc.record_backtrace true ; *) Alcotest.run "LIGO" [ + Multifix_tests.main ; Integration_tests.main ; Compiler_tests.main ; Transpiler_tests.main ;