balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

integration

Browse Source
This commit is contained in:
Galfour 2019-04-06 11:18:55 +00:00
parent 7d6ce14a70
commit e9f90858a2
16 changed files with 272 additions and 305 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/lib_utils/location.ml
View File

@ -22,3 +22,10 @@ let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t =
let virtual_location s = Virtual s let virtual_location s = Virtual s
let dummy = virtual_location "dummy" let dummy = virtual_location "dummy"
type 'a wrap = {
wrap_content : 'a ;
location : t ;
}
let wrap ~loc wrap_content = { wrap_content ; location = loc }

1
src/lib_utils/tezos_utils.ml
View File

@ -9,6 +9,7 @@ module Micheline = X_tezos_micheline
module Error_monad = X_error_monad module Error_monad = X_error_monad
module Trace = Trace module Trace = Trace
module PP = PP module PP = PP
module Location = Location
module List = X_list module List = X_list
module Option = Tezos_base.TzPervasives.Option module Option = Tezos_base.TzPervasives.Option

1
src/ligo/contracts/new-syntax.mligo Normal file
View File

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

1
src/ligo/ligo.ml
View File

@ -8,6 +8,7 @@ module AST_Typed = Ast_typed
module Mini_c = Mini_c module Mini_c = Mini_c
module Typer = Typer module Typer = Typer
module Transpiler = Transpiler module Transpiler = Transpiler
module Parser_multifix = Multifix
open Trace open Trace

19
src/ligo/multifix/ast.ml
View File

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

17
src/ligo/multifix/dune
View File

@ -1,8 +1,15 @@
(library (library
(name multifix) (name multifix)
(public_name ligo.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 ;; Generating parser
@ -51,12 +58,6 @@
;; Tests ;; Tests
(alias
(name test-user)
(deps user.exe foo.test)
(action (system "./user.exe foo.test"))
)
(alias (alias
(name runtest) (name runtest)
(deps generator.exe) (deps generator.exe)

254
src/ligo/multifix/generator.ml
View File

@ -13,28 +13,60 @@ type token = Token.token
module O = struct 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 operator = element list
type n_operator = operator name type n_operator = operator name
type n_operators = n_operator list type n_operators = n_operator list
type level = n_operators name 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 = { type language = {
entry_point : string ; entry_point : string ;
@ -44,15 +76,15 @@ module O = struct
let get_op : n_operator -> operator = get_content 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 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 nopss' = List.Ne.of_list nopss in
let name_i = fun i x -> make_name (name ^ "_" ^ (string_of_int i)) x 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 end
@ -65,7 +97,7 @@ module Check = struct
match es with 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") raise (Failure "two non-token separated ops in a row")
| _ :: tl -> aux tl | _ :: tl -> aux tl
in in
@ -73,7 +105,7 @@ module Check = struct
aux es in aux es in
let op : n_operator -> unit = fun x -> elements @@ get_content x 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 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 List.iter hierarchy l.hierarchies
let associativity : language -> unit = fun l -> 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 aux : ([`Left | `Right | `None] as 'a) -> n_operator -> 'a = fun ass nop ->
let op = get_content nop in let op = get_content nop in
match ass, List.hd op, List.nth op (List.length op - 1) with 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 | m, _, _ -> m
in in
let _assert = List.fold_left aux `None (get_content l) in let _assert = List.fold_left aux `None (get_content l) in
() ()
in in
let hierarchy : n_hierarchy -> unit = fun h -> 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 List.iter hierarchy l.hierarchies
end end
@ -101,17 +133,41 @@ end
module Print_AST = struct module Print_AST = struct
open Format 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 -> 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 n_operator level_name : _ -> O.n_operator -> _ = fun ppf nop ->
let type_elements = let type_elements =
let aux : O.element -> string option = fun e -> let aux : O.element -> string option = fun e ->
match e with 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 List.filter_map aux (get_content nop) in
let type_element = fun ppf te -> fprintf ppf "%s" te in let type_element = fun ppf te -> fprintf ppf "%s" te in
fprintf ppf "| %s of (%a)" fprintf ppf "| %s of (%a)"
@ -119,7 +175,7 @@ module Print_AST = struct
PP.(list_sep type_element (const " * ")) type_elements PP.(list_sep type_element (const " * ")) type_elements
let n_hierarchy : _ -> O.n_hierarchy -> _ = fun ppf nh -> 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 nops = List.Ne.concat levels in
let name = get_name nh in let name = get_name nh in
fprintf ppf "type %s =@.@[%a@]" fprintf ppf "type %s =@.@[%a@]"
@ -130,38 +186,76 @@ module Print_AST = struct
fprintf ppf "%a@.@." PP.comment "Language" ; 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 "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@.%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 end
module Print_Grammar = struct module Print_Grammar = struct
open Format 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 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 n_operator_rule prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop ->
let i = ref 0 in let i = ref 0 in
let element : _ -> O.element -> _ = fun ppf element -> let element : _ -> O.element -> _ = fun ppf element ->
(match element with (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) letters.(!i)
(match mode with | `Lead -> "lead_list" | `Trail -> "trail_list" | `Separator -> "separated_list") (match mode with | `Lead -> "lead_list" | `Trail -> "trail_list" | `Separator -> "separated_list")
(Token.to_string sep) (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 i := !i + 1
in in
@ -174,8 +268,8 @@ module Print_Grammar = struct
let aux : O.element -> _ = fun e -> let aux : O.element -> _ = fun e ->
let r = let r =
match e with 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 i := !i + 1 ; r
in in
List.filter_map aux elements 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 n_operator prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop ->
let name = get_name nop in 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_rule prev_lvl_name cur_lvl_name) nop
n_operator_code nop n_operator_code nop
@ -203,7 +297,7 @@ module Print_Grammar = struct
let n_hierarchy : _ -> O.n_hierarchy -> _ = fun ppf nh -> let n_hierarchy : _ -> O.n_hierarchy -> _ = fun ppf nh ->
let name = get_name nh in let name = get_name nh in
fprintf ppf "%a@.%%inline %s : %s_0 { $1 }@.@;" PP.comment ("Top-level for " ^ name) name name; 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 ; fprintf ppf "%a" (level "") hd ;
let aux prev_name lvl = let aux prev_name lvl =
PP.new_lines 2 ppf () ; PP.new_lines 2 ppf () ;
@ -215,7 +309,7 @@ module Print_Grammar = struct
let language : _ -> O.language -> _ = fun ppf l -> let language : _ -> O.language -> _ = fun ppf l ->
fprintf ppf "%a@.@." PP.comment "Generated Language" ; 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.comment "Singletons" ;
fprintf ppf "@[%a@]@.@." (PP.list_sep singleton PP.new_line) l.singletons ; fprintf ppf "@[%a@]@.@." (PP.list_sep singleton PP.new_line) l.singletons ;
fprintf ppf "%a@.@." PP.comment "Hierarchies" ; fprintf ppf "%a@.@." PP.comment "Hierarchies" ;
@ -223,22 +317,32 @@ module Print_Grammar = struct
end end
let variable = O.singleton "variable" "string" "NAME" "$1"
let infix : string -> [`Left | `Right] -> token -> O.n_operator = fun name assoc t -> let infix : string -> [`Left | `Right] -> token -> O.n_operator = fun name assoc t ->
let open O in
match assoc with 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 variable = O.manual_singleton variable_name ["| NAME { $1 }"] "string"
module Expression = struct
open Token
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" [ let let_in : O.n_operator = make_name "Let_in" [
O.Token Token.LET ; Named "variable" ; `Token Token.LET ; `Named "variable" ;
O.Token Token.EQUAL ; Current ; `Token Token.EQUAL ; `Current ;
O.Token Token.IN ; Current ; `Token Token.IN ; `Current ;
] ]
let addition = infix "Addition" `Left Token.PLUS let addition = infix "Addition" `Left Token.PLUS
@ -247,7 +351,7 @@ let substraction = infix "Substraction" `Left Token.MINUS
let multiplication = infix "Multiplication" `Left Token.TIMES let multiplication = infix "Multiplication" `Left Token.TIMES
let division = infix "Division" `Left Token.DIV let division = infix "Division" `Left Token.DIV
let arith_variable : O.n_operator = make_name "Arith_variable" [ O.Named "variable" ] let arith_variable : O.n_operator = make_name "Arith_variable" [ `Named "variable" ]
let arith = O.name_hierarchy "arith" [ let arith = O.name_hierarchy "arith" [
[let_in] ; [let_in] ;
@ -255,9 +359,27 @@ let arith = O.name_hierarchy "arith" [
[multiplication ; division] ; [multiplication ; division] ;
[list] ; [list] ;
[arith_variable] ; [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]
] ]
let language = O.language "arith" [variable] [arith] end
let language = O.language "arith" [variable] [Expression.arith]
let () = let () =
let argn = Array.length Sys.argv in let argn = Array.length Sys.argv in

1
src/ligo/multifix/lex/generator.ml
View File

@ -91,6 +91,7 @@ let tokens = [
keyword "list" ; keyword "list" ;
keyword "block" ; keyword "block" ;
keyword "for" ; keyword "for" ;
keyword "const" ;
symbol "+" "PLUS" ; symbol "+" "PLUS" ;
symbol "-" "MINUS" ; symbol "-" "MINUS" ;
symbol "*" "TIMES" ; symbol "*" "TIMES" ;

6
src/ligo/multifix/location.ml
View File

@ -23,9 +23,3 @@ let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t =
let virtual_location s = Virtual s let virtual_location s = Virtual s
let dummy = virtual_location "dummy" let dummy = virtual_location "dummy"
type 'a wrap = {
wrap_content : 'a ;
location : t ;
}
let wrap ~loc wrap_content = { wrap_content ; location = loc }

12
src/ligo/multifix/parser.mli
View File

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

99
src/ligo/multifix/parser.mly
View File

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

70
src/ligo/multifix/partial_parser.mly
View File

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

5
src/ligo/multifix/pre_parser.mly
View File

@ -2,7 +2,7 @@
open Ast 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): lead_list_first (separator, X):
| option(separator) x = X { [ x ] } | option(separator) x = X { [ x ] }
%inline wrap(X):
| x = X { let loc = Location.make $startpos $endpos in Location.wrap ~loc x }

44
src/ligo/multifix/user.ml
View File

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

11
src/ligo/test/multifix_tests.ml Normal file
View File

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

1
src/ligo/test/test.ml
View File

@ -3,6 +3,7 @@
let () = let () =
(* Printexc.record_backtrace true ; *) (* Printexc.record_backtrace true ; *)
Alcotest.run "LIGO" [ Alcotest.run "LIGO" [
Multifix_tests.main ;
Integration_tests.main ; Integration_tests.main ;
Compiler_tests.main ; Compiler_tests.main ;
Transpiler_tests.main ; Transpiler_tests.main ;