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 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 Trace = Trace
module PP = PP
module Location = Location
module List = X_list
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 Typer = Typer
module Transpiler = Transpiler
module Parser_multifix = Multifix
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
(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)

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

@ -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=@. @[<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")
| 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@. @[<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
| 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@; @[<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]
| `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

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

@ -91,6 +91,7 @@ let tokens = [
keyword "list" ;
keyword "block" ;
keyword "for" ;
keyword "const" ;
symbol "+" "PLUS" ;
symbol "-" "MINUS" ;
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 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
%}
%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 }

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

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

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 () =
(* Printexc.record_backtrace true ; *)
Alcotest.run "LIGO" [
Multifix_tests.main ;
Integration_tests.main ;
Compiler_tests.main ;
Transpiler_tests.main ;