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

start simplify liquidity

Browse Source
This commit is contained in:
Galfour 2019-04-12 13:30:11 +00:00
parent 71307ce626
commit badda06e7b
12 changed files with 130 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/lib_utils/function.ml Normal file
View File

@ -0,0 +1,2 @@
let compose = fun f g x -> f (g x)
let (>|) = compose

2
src/lib_utils/location.ml
View File

@ -29,3 +29,5 @@ type 'a wrap = {
}
let wrap ~loc wrap_content = { wrap_content ; location = loc }
let unwrap { wrap_content ; _ } = wrap_content
let map f x = { x with wrap_content = f x.wrap_content }

2
src/lib_utils/tezos_utils.ml
View File

@ -6,6 +6,8 @@ module Time = Tezos_base.TzPervasives.Time
module Memory_proto_alpha = X_memory_proto_alpha
module Micheline = X_tezos_micheline
module Function = Function
module Error_monad = X_error_monad
module Trace = Trace
module PP_helpers = PP

6
src/lib_utils/trace.ml
View File

@ -110,6 +110,12 @@ let bind_map_smap f smap = bind_smap (X_map.String.map f smap)
let bind_map_list f lst = bind_list (List.map f lst)
let bind_location (x:_ Location.wrap) =
x.wrap_content >>? fun wrap_content ->
ok { x with wrap_content }
let bind_map_location f x = bind_location (Location.map f x)
let bind_fold_list f init lst =
let aux x y =
x >>? fun x ->

1
src/ligo/ligo.ml
View File

@ -9,6 +9,7 @@ module Mini_c = Mini_c
module Typer = Typer
module Transpiler = Transpiler
module Parser_multifix = Multifix
module Simplify_multifix = Simplify_multifix
open Trace

1
src/ligo/multifix/.gitignore vendored Normal file
View File

@ -0,0 +1 @@
ast.ml

1
src/ligo/multifix/dune
View File

@ -38,6 +38,7 @@
(targets ast.ml)
(deps generator.exe)
(action (system "./generator.exe ast > ast.ml"))
(mode promote-until-clean)
)
;; Generating Generator

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

@ -70,11 +70,12 @@ module O = struct
type levels = level List.Ne.t
type hierarchy = {
prefix : string ;
levels : levels ;
auxiliary_rules : rule list ;
}
type n_hierarchy = hierarchy name
let make_hierarchy levels auxiliary_rules : hierarchy = { levels ; auxiliary_rules }
let make_hierarchy prefix levels auxiliary_rules : hierarchy = { levels ; auxiliary_rules ; prefix }
type language = {
entry_point : string ;
@ -89,11 +90,11 @@ module O = struct
let language entry_point singletons hierarchies = {entry_point ; singletons ; hierarchies}
let name_hierarchy name : n_operators list -> rule list -> n_hierarchy = fun nopss rules ->
let name_hierarchy name prefix : 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 : levels = List.Ne.mapi name_i nopss' in
make_name name @@ make_hierarchy levels rules
make_name name @@ make_hierarchy prefix levels rules
end
@ -139,6 +140,15 @@ module Check = struct
end
let make_constructor : _ -> (string * string) -> unit = fun ppf (gr, rhs) ->
let gr = String.capitalize_ascii gr in
match rhs with
| "" -> Format.fprintf ppf "%s" gr
| s -> Format.fprintf ppf "%s_%s" gr s
let make_operator : _ -> (string * string) -> unit = fun ppf (prefix, op) ->
Format.fprintf ppf "%s_%s" prefix op
module Print_AST = struct
open Format
open PP_helpers
@ -157,11 +167,11 @@ module Print_AST = struct
in
List.filter_map aux rhs.content in
let type_element = fun ppf te -> fprintf ppf "%s" te in
fprintf ppf "| `%s_%s of (%a)"
(String.capitalize_ascii gr.name) rhs.name
fprintf ppf "| %a of (%a)"
make_constructor (gr.name, rhs.name)
(list_sep type_element (const " * ")) type_elements
in
fprintf ppf "%s = [@. @[<v>%a@]]" gr.name
fprintf ppf "%s =@. @[<v>%a@]" gr.name
(list_sep aux new_line) gr.content
let singleton : _ -> O.singleton -> _ = fun ppf s ->
@ -173,10 +183,10 @@ module Print_AST = struct
match ss with
| [] -> ()
| hd :: tl ->
fprintf ppf "%a\n" (prepend "type " singleton) hd ;
fprintf ppf "%a" (list_sep (prepend "and " singleton) (const "\n")) tl
fprintf ppf "%a\n" (prepend "type " (singleton)) hd ;
fprintf ppf "%a" (list_sep (prepend "and " (singleton)) (const "\n")) tl
let n_operator level_name : _ -> O.n_operator -> _ = fun ppf nop ->
let n_operator prefix level_name : _ -> O.n_operator -> _ = fun ppf nop ->
let type_elements =
let aux : O.element -> string option = fun e ->
match e with
@ -188,17 +198,17 @@ module Print_AST = struct
| `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)"
(get_name nop)
fprintf ppf "| %a of (%a)"
make_operator (prefix, nop.name)
(list_sep type_element (const " * ")) type_elements
let n_hierarchy t : _ -> O.n_hierarchy -> _ = fun ppf nh ->
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 "%s %s = [@.@[%a@]]" t
fprintf ppf "%s %s = @.@[%a@]" t
name
(list_sep (n_operator name) new_line) nops
(list_sep (n_operator nh.content.prefix name) new_line) nops
let n_hierarchies (first:bool) : _ -> O.n_hierarchy list -> _ = fun ppf ss ->
match ss with
@ -260,7 +270,7 @@ module Print_Grammar = struct
i := !i + 1 ; s
in
let content = List.filter_map aux rhs.content in
fprintf ppf "`%s_%s (%a)" (String.capitalize_ascii gr.name) rhs.name (list_sep string (const " , ")) content
fprintf ppf "%a (%a)" make_constructor (gr.name, rhs.name) (list_sep string (const " , ")) content
in
let aux : _ -> O.rhs -> _ = fun ppf rhs ->
fprintf ppf "| %a { %a }"
@ -304,7 +314,7 @@ module Print_Grammar = struct
in
(list_sep element (const " ")) ppf (get_content nop)
let n_operator_code : _ -> O.n_operator -> _ = fun ppf nop ->
let n_operator_code prefix : _ -> O.n_operator -> _ = fun ppf nop ->
let (name, elements) = destruct nop in
let elements' =
let i = ref 0 in
@ -316,24 +326,24 @@ module Print_Grammar = struct
in i := !i + 1 ; r
in
List.filter_map aux elements in
fprintf ppf "`%s (%a)" name (list_sep string (const " , ")) elements'
fprintf ppf "%a (%a)" make_operator (prefix, name) (list_sep string (const " , ")) elements'
let n_operator prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop ->
let n_operator prefix prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop ->
let name = get_name nop in
fprintf ppf "%a@;| %a { %a }" comment name
(n_operator_rule prev_lvl_name cur_lvl_name) nop
n_operator_code nop
(n_operator_code prefix) nop
let level prev_lvl_name : _ -> O.level -> _ = fun ppf l ->
let level prefix prev_lvl_name : _ -> O.level -> _ = fun ppf l ->
let name = get_name l in
match prev_lvl_name with
| "" -> (
fprintf ppf "%s :@. @[<v>%a@]" name
(list_sep (n_operator prev_lvl_name name) new_line) (get_content l) ;
(list_sep (n_operator prefix prev_lvl_name name) new_line) (get_content l) ;
)
| _ -> (
fprintf ppf "%s :@. @[<v>%a@;| %s { $1 }@]" name
(list_sep (n_operator prev_lvl_name name) new_line) (get_content l)
(list_sep (n_operator prefix prev_lvl_name name) new_line) (get_content l)
prev_lvl_name
)
@ -341,10 +351,10 @@ module Print_Grammar = struct
let name = get_name nh in
fprintf ppf "%a@.%%inline %s : %s_0 { $1 }@.@;" comment ("Top-level for " ^ name) name name;
let (hd, tl) = List.Ne.rev (get_content nh).levels in
fprintf ppf "%a" (level "") hd ;
fprintf ppf "%a" (level nh.content.prefix "") hd ;
let aux prev_name lvl =
new_lines 2 ppf () ;
fprintf ppf "%a" (level prev_name) lvl ;
fprintf ppf "%a" (level nh.content.prefix prev_name) lvl ;
get_name lvl
in
let _last_name = List.fold_left aux (get_name hd) tl in
@ -399,9 +409,9 @@ module Pattern = struct
open Token
open O
let application = empty_infix "P_application" `Left
let application = empty_infix "application" `Left
let list : O.n_operator = make_name "P_list" [
let list : O.n_operator = make_name "list" [
`Token LIST ; `Token LSQUARE ; `List (Lead SEMICOLON, `Current) ; `Token RSQUARE ;
]
@ -409,37 +419,37 @@ module Pattern = struct
make_name "" [`Named variable_name ; `Token EQUAL ; `Named pattern_name]
]
let record : O.n_operator = make_name "P_record" [
let record : O.n_operator = make_name "record" [
`Token LBRACKET ;
`List (Trail SEMICOLON, `Named record_element.name) ;
`Token RBRACKET ;
]
let pair = infix "P_pair" `Left COMMA
let pair = infix "pair" `Left COMMA
let variable : O.n_operator = make_name "P_variable" [ `Named variable_name ]
let constructor : O.n_operator = make_name "P_constructor" [ `Named constructor_name ]
let variable : O.n_operator = make_name "variable" [ `Named variable_name ]
let constructor : O.n_operator = make_name "constructor" [ `Named constructor_name ]
let module_ident : O.n_operator = make_name "P_module_ident" [
let module_ident : O.n_operator = make_name "module_ident" [
`List (Trail_force_ne DOT, `Named constructor_name) ; `Named variable_name ;
]
let unit : O.n_operator = make_name "P_unit" [ `Named unit_name ]
let unit : O.n_operator = make_name "unit" [ `Named unit_name ]
let restricted_pattern_name = "resitrcted_pattern"
let restricted_pattern_name = "restricted_pattern"
let restricted_pattern = O.name_hierarchy restricted_pattern_name [
let restricted_pattern = O.name_hierarchy restricted_pattern_name "Pr" [
[variable ; unit] ;
[paren "P_restrict" pattern_name]
[paren "restrict" pattern_name]
] []
let main = O.name_hierarchy pattern_name [
let main = O.name_hierarchy pattern_name "P" [
[record] ;
[application] ;
[pair] ;
[list] ;
[variable ; constructor ; module_ident ; unit] ;
[paren "P_paren" pattern_name]
[paren "paren" pattern_name]
] []
let singletons = [O.rule_singleton record_element]
@ -450,18 +460,18 @@ module Expression = struct
open Token
open O
let application = empty_infix "E_application" `Right
let application = empty_infix "application" `Right
let list : O.n_operator = make_name "E_list" [
let list : O.n_operator = make_name "list" [
`Token LSQUARE ; `List (Trail SEMICOLON, `Current) ; `Token RSQUARE ;
]
let fun_ : O.n_operator = make_name "E_fun" [
let fun_ : O.n_operator = make_name "fun" [
`Token FUN ; `Named pattern_name ;
`Token ARROW ; `Current ;
]
let let_in : O.n_operator = make_name "E_let_in" [
let let_in : O.n_operator = make_name "let_in" [
`Token LET ; `Named pattern_name ;
`Token EQUAL ; `Current ;
`Token IN ; `Current ;
@ -475,13 +485,13 @@ module Expression = struct
make_name "record_implicit" [`Named variable_name ] ;
]
let record : O.n_operator = make_name "E_record" [
let record : O.n_operator = make_name "record" [
`Token LBRACKET ;
`List (Trail SEMICOLON, `Named record_element.name) ;
`Token RBRACKET ;
]
let ite : O.n_operator = make_name "E_ifthenelse" [
let ite : O.n_operator = make_name "ifthenelse" [
`Token IF ;
`Current ;
`Token THEN ;
@ -490,57 +500,57 @@ module Expression = struct
`Current ;
]
let it : O.n_operator = make_name "E_ifthen" [
let it : O.n_operator = make_name "ifthen" [
`Token IF ;
`Current ;
`Token THEN ;
`Lower ;
]
let sequence = infix "E_sequence" `Left SEMICOLON
let sequence = infix "sequence" `Left SEMICOLON
let match_clause = make_name "e_match_clause" [
make_name "" [`Named pattern_name ; `Token ARROW ; `Named no_match_name]
]
let match_with = make_name "E_match" [
let match_with = make_name "match" [
`Token MATCH ; `Current ; `Token WITH ;
`List (Lead_ne VBAR, `Named match_clause.name) ;
]
let lt = infix "E_lt" `Left LT
let le = infix "E_le" `Left LE
let gt = infix "E_gt" `Left GT
let eq = infix "E_eq" `Left EQUAL
let lt = infix "lt" `Left LT
let le = infix "le" `Left LE
let gt = infix "gt" `Left GT
let eq = infix "eq" `Left EQUAL
let cons = infix "E_cons" `Left DOUBLE_COLON
let cons = infix "cons" `Left DOUBLE_COLON
let addition = infix "E_addition" `Left PLUS
let substraction = infix "E_substraction" `Left MINUS
let addition = infix "addition" `Left PLUS
let substraction = infix "substraction" `Left MINUS
let multiplication = infix "E_multiplication" `Left TIMES
let division = infix "E_division" `Left DIV
let multiplication = infix "multiplication" `Left TIMES
let division = infix "division" `Left DIV
let arith_variable : O.n_operator = make_name "E_variable" [ `Named variable_name ]
let int : O.n_operator = make_name "E_int" [ `Named int_name ]
let tz : O.n_operator = make_name "E_tz" [ `Named tz_name ]
let unit : O.n_operator = make_name "E_unit" [ `Named unit_name ]
let string : O.n_operator = make_name "E_string" [ `Named string_name ]
let constructor : O.n_operator = make_name "E_constructor" [ `Named constructor_name ]
let arith_variable : O.n_operator = make_name "variable" [ `Named variable_name ]
let int : O.n_operator = make_name "int" [ `Named int_name ]
let tz : O.n_operator = make_name "tz" [ `Named tz_name ]
let unit : O.n_operator = make_name "unit" [ `Named unit_name ]
let string : O.n_operator = make_name "string" [ `Named string_name ]
let constructor : O.n_operator = make_name "constructor" [ `Named constructor_name ]
let module_ident : O.n_operator = make_name "E_module_ident" [
let module_ident : O.n_operator = make_name "module_ident" [
`List (Trail_force_ne DOT, `Named constructor_name) ; `Named variable_name ;
]
let access : O.n_operator = infix "E_access" `Right DOT
let accessor : O.n_operator = make_name "E_accessor" [
let access : O.n_operator = infix "access" `Right DOT
let accessor : O.n_operator = make_name "accessor" [
`Named variable_name ; `List (Lead_ne DOT, `Named variable_name) ;
]
let assignment : O.n_operator = infix "E_assign" `Left LEFT_ARROW
let assignment : O.n_operator = infix "assign" `Left LEFT_ARROW
let pair = infix "E_pair" `Left COMMA
let pair = infix "pair" `Left COMMA
let name = make_name "E_name" [`Token TILDE ; `Current]
let name = make_name "name" [`Token TILDE ; `Current]
let no_sequence_expression = O.name_hierarchy no_seq_name [
let no_sequence_expression = O.name_hierarchy no_seq_name "Es" [
[let_in ; fun_ ; record ; ite ; it ; match_with] ;
[pair] ;
[application] ;
@ -552,10 +562,10 @@ module Expression = struct
[list] ;
[name] ;
[arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ;
[paren "E_no_seq_bottom" expression_name]
[paren "no_seq_bottom" expression_name]
] []
let no_match_expression = O.name_hierarchy no_match_name [
let no_match_expression = O.name_hierarchy no_match_name "Em" [
[let_in ; fun_ ; record ; ite ; it ] ;
[pair] ;
[application] ;
@ -567,10 +577,10 @@ module Expression = struct
[list] ;
[name] ;
[arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ;
[paren "E_no_match_bottom" expression_name]
[paren "no_match_bottom" expression_name]
] []
let expression = O.name_hierarchy expression_name [
let expression = O.name_hierarchy expression_name "E" [
[sequence] ;
[let_in ; fun_ ; record ; ite ; it ; match_with] ;
[pair] ;
@ -583,7 +593,7 @@ module Expression = struct
[list] ;
[name] ;
[arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ;
[paren "E_paren" expression_name]
[paren "paren" expression_name]
] []
let singletons = List.map O.rule_singleton [record_element ; match_clause]
@ -594,11 +604,11 @@ module Type_expression = struct
open Token
open O
let list : O.n_operator = make_name "T_list" [
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 "T_let_in" [
let let_in : O.n_operator = make_name "let_in" [
`Token LET ; `Named variable_name ;
`Token EQUAL ; `Current ;
`Token IN ; `Current ;
@ -608,25 +618,25 @@ module Type_expression = struct
make_name "" [`Named variable_name ; `Token COLON ; `Named type_expression_name]
]
let record : O.n_operator = make_name "T_record" [
let record : O.n_operator = make_name "record" [
`Token LBRACKET ;
`List (Trail SEMICOLON, `Named record_element.name) ;
`Token RBRACKET ;
]
let application = empty_infix "T_application" `Left
let application = empty_infix "application" `Left
let pair = infix "T_pair" `Left COMMA
let pair = infix "pair" `Left COMMA
let arith_variable : O.n_operator = make_name "T_variable" [ `Named variable_name ]
let arith_variable : O.n_operator = make_name "variable" [ `Named variable_name ]
let arith = O.name_hierarchy type_expression_name [
let arith = O.name_hierarchy type_expression_name "T" [
[let_in ; record ] ;
[pair] ;
[application] ;
[list] ;
[arith_variable] ;
[paren "T_paren" type_expression_name]
[paren "paren" type_expression_name]
] []
let singletons = [O.rule_singleton record_element]

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

@ -1,5 +1,5 @@
%{
open Ast
%}
%start <Ast.entry_point> entry_point

2
src/ligo/simplify_mixfix.ml
View File

@ -1,2 +0,0 @@
(* open Trace
* open Multifix.User *)

18
src/ligo/simplify_multifix.ml Normal file
View File

@ -0,0 +1,18 @@
open Trace
open Function
module I = Multifix.Ast
module O = Ast_simplified
let statement : I.statement -> O.declaration result = fun s ->
match s with
(* | Statement_variable_declaration (s, [], expr) -> simple_fail (thunk "") *)
| Statement_variable_declaration _ -> simple_fail (thunk "")
| Statement_init_declaration _ -> simple_fail (thunk "")
| Statement_entry_declaration _ -> simple_fail (thunk "")
| Statement_type_declaration _ -> simple_fail (thunk "")
let program : I.program -> O.program result = fun (Program lst) ->
bind_map_list (apply Location.unwrap >| bind_map_location statement) lst
let main : I.entry_point -> O.program Location.wrap result =
bind_map_location program

6
src/ligo/test/multifix_tests.ml
View File

@ -6,6 +6,12 @@ let basic () : unit result =
let%bind _ = User.parse_file "./contracts/new-syntax.mligo" in
ok ()
let simplify () : unit result =
let%bind raw = User.parse_file "./contracts/new-syntax.mligo" in
let%bind _simpl = Ligo.Simplify_multifix.main raw in
ok ()
let main = "Parser Multifix", [
test "basic" basic ;
test "simplify" simplify ;
]