integration

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 }

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

src/ligo/contracts/new-syntax.mligo

@@ -0,0 +1 @@
+let toto = at * bo in list [ toto ; tata ; titi ]

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
 

src/ligo/multifix/ast.ml

@@ -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
-
-

src/ligo/multifix/dune

@@ -1,8 +1,15 @@
 (library
   (name multifix)
   (public_name ligo.multifix)
-  (libraries lex)
+  (libraries
-  (modules ast parser location user)
+    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)

src/ligo/multifix/generator.ml

@@ -13,28 +13,60 @@ type token = Token.token
 
 module O = struct
 
-  type element =
+  type 'a list_element = [`Trail | `Lead | `Separator] * token * 'a
-    | Named of string (* Named rule, like type_var *)
+
-    | Token of token
+  type basic_rhs_element = [
-    | List of ([`Trail | `Lead | `Separator] * token * token * token)
+    | `Named of string
-    | Current
+    | `Token of token
-    | Lower (* Lower precedence *)
+  ]
+
+  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 hierarchy = {
-  type n_hierarchy = hierarchy name
+    levels : levels ;
-
+    auxiliary_rules : rule list ;
-  type singleton = {
-    type_name : string ;
-    type_expression : string ;
-    menhir_rule : string ;
-    menhir_code : string ;
   }
+  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 =
+  let manual_singleton name menhir_codes ast_code : singleton = Manual (make_name name {menhir_codes ; ast_code})
-    {type_name ; type_expression ; menhir_rule ; menhir_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
+    let levels : levels = List.Ne.mapi name_i nopss' in
-    make_name name levels
+    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")
+        | _, `Lower, `Lower -> raise (Failure "double assoc")
-        | `None, Lower, _ -> `Left
+        | `None, `Lower, _ -> `Left
-        | `None, _, Lower -> `Right
+        | `None, _, `Lower -> `Right
-        | `Left, _, Lower -> raise (Failure "different assocs")
+        | `Left, _, `Lower -> raise (Failure "different assocs")
-        | `Right, 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=@.  @[<v>%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")
+        | `Named s -> Some (s ^ " Location.wrap")
-        | List _ -> Some ("(" ^ level_name ^ " Location.wrap list)")
+        | `List _ -> Some ("(" ^ level_name ^ " Location.wrap list)")
-        | Token _ -> None
+        | `Token _ -> None
-        | Current | Lower -> Some (level_name ^ " Location.wrap") in
+        | `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@.  @[<v>{@;  @[<v>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:@.  @[<v>%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
+       | `Token t -> i := !i - 1 ; PP.string ppf @@ Token.to_string t
-       | List (mode, beg, sep, end_) ->
+       | `List (mode, sep, content) ->
-         fprintf ppf "%s %s = %s(%s, %s) %s"
+         fprintf ppf "%s = %s(%s, wrap(%s))"
-           (Token.to_string beg)
            letters.(!i)
            (match mode with | `Lead -> "lead_list" | `Trail -> "trail_list" | `Separator -> "separated_list")
            (Token.to_string sep)
-           cur_lvl_name
+           (match content with | `Lower -> prev_lvl_name | `Named s -> s | `Current -> cur_lvl_name)
-           (Token.to_string end_)
+       | `Named n ->
-       | Named n ->
+           fprintf ppf "%s = wrap(%s)" letters.(!i) n
-           fprintf ppf "%s = %s" letters.(!i) n
+       | `Current ->
-       | Current ->
+           fprintf ppf "%s = wrap(%s)" letters.(!i) cur_lvl_name
-           fprintf ppf "%s = %s" letters.(!i) cur_lvl_name
+       | `Lower ->
-       | Lower ->
+         fprintf ppf "%s = wrap(%s)" letters.(!i) prev_lvl_name
-         fprintf ppf "%s = %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
+          | `Token _ -> i := !i - 1 ; None
-          | List _ | Named _ | Current | Lower -> Some letters.(!i)
+          | `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@;  @[<v>{@;  @[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]
+  | `Left -> make_name name [`Current ; `Token t ; `Lower]
-  | `Right -> make_name name [Current ; Token t ; Lower]
+  | `Right -> make_name name [`Current ; `Token t ; `Lower]
 
-let list = make_name "List" [
+let expression_name = "expression"
-    O.Token Token.LIST ; List (`Lead, Token.LSQUARE, Token.SEMICOLON, Token.RSQUARE) ;
+let type_expression_name = "type_expression"
-]
+let program_name = "program"
+let variable_name = "variable"
 
-let let_in : O.n_operator = make_name "Let_in" [
+let variable = O.manual_singleton variable_name ["| NAME { $1 }"] "string"
-    O.Token Token.LET ; Named "variable" ;
-    O.Token Token.EQUAL ; Current ;
-    O.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
+module Expression = struct
-let division = infix "Division" `Left Token.DIV
 
-let arith_variable : O.n_operator = make_name "Arith_variable" [ O.Named "variable" ]
+  open Token
 
-let arith = O.name_hierarchy "arith" [
+  let list : O.n_operator = make_name "List" [
+      `Token LIST ; `Token LSQUARE ; `List (`Lead, 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 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] ;
-]
+    ] []
 
-let language = O.language "arith" [variable] [arith]
+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

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" ;

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 }

src/ligo/multifix/parser.mli

@@ -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)

src/ligo/multifix/parser.mly

@@ -1,99 +0,0 @@
-%{
-    open Ast
-%}
-
-%start <Ast.entry_point Location.wrap> 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 }

src/ligo/multifix/partial_parser.mly

@@ -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 }

src/ligo/multifix/pre_parser.mly

@@ -2,7 +2,7 @@
     open Ast
 %}
 
-%start <Ast.entry_point Location.wrap> entry_point
+%start <Ast.entry_point> 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 }

src/ligo/multifix/user.ml

@@ -1,10 +1,34 @@
-let () =
+open Trace
-  (match Array.length Sys.argv with
+
-  | 1 -> exit 1
+let parse_file (source: string) : Ast.entry_point result =
-  | _ -> ()) ;
+  let pp_input =
-  let path = Sys.argv.(1) in
+    let prefix = Filename.(source |> basename |> remove_extension)
-  let chan = open_in path in
+    and suffix = ".pp.ligo"
-  let lexbuf = Lexing.from_channel chan in
+    in prefix ^ suffix in
-  let _ast = Parser.entry_point Lex.Lexer.token lexbuf in
+
-  Format.printf "parse ok\n" ;
+  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

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 ;
+]

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 ;