integration
This commit is contained in:
parent
7d6ce14a70
commit
e9f90858a2
@ -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 }
|
||||||
|
@ -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
1
src/ligo/contracts/new-syntax.mligo
Normal file
@ -0,0 +1 @@
|
|||||||
|
let toto = at * bo in list [ toto ; tata ; titi ]
|
@ -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
|
||||||
|
|
||||||
|
@ -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
|
|
||||||
|
|
||||||
|
|
@ -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)
|
||||||
|
@ -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,41 +317,69 @@ 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 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" [
|
||||||
[let_in] ;
|
`Token LIST ; `Token LSQUARE ; `List (`Lead, SEMICOLON, `Current) ; `Token RSQUARE ;
|
||||||
[addition ; substraction] ;
|
]
|
||||||
[multiplication ; division] ;
|
|
||||||
[list] ;
|
|
||||||
[arith_variable] ;
|
|
||||||
]
|
|
||||||
|
|
||||||
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 () =
|
||||||
let argn = Array.length Sys.argv in
|
let argn = Array.length Sys.argv in
|
||||||
|
@ -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" ;
|
||||||
|
@ -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 }
|
|
||||||
|
@ -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)
|
|
@ -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 }
|
|
@ -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 }
|
|
@ -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 }
|
||||||
|
@ -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
11
src/ligo/test/multifix_tests.ml
Normal 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 ;
|
||||||
|
]
|
@ -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 ;
|
||||||
|
Loading…
Reference in New Issue
Block a user