From fa4b570950276484a4045743dd36237f6feb14a9 Mon Sep 17 00:00:00 2001 From: Galfour Date: Thu, 14 Mar 2019 18:22:51 +0000 Subject: [PATCH] translations from typed-ligo to mini-c --- src/ligo/dune | 3 +- src/ligo/helpers/tree.ml | 86 +++++++++++ src/ligo/mini_c.ml | 260 +++++++++++++++++++++++++++------ src/ligo/parser/AST2.ml | 171 +++++++++++++++++----- src/ligo/parser/Typecheck2.ml | 42 +++--- src/ligo/parser/Typecheck2.mli | 42 +++--- src/ligo/parser/dune | 39 +++-- src/ligo/parser/ligo_parser.ml | 1 + 8 files changed, 498 insertions(+), 146 deletions(-) create mode 100644 src/ligo/helpers/tree.ml create mode 100644 src/ligo/parser/ligo_parser.ml diff --git a/src/ligo/dune b/src/ligo/dune index 7ec8e668f..3d9fc830b 100644 --- a/src/ligo/dune +++ b/src/ligo/dune @@ -12,9 +12,10 @@ tezos-micheline meta-michelson ligo-helpers + ligo-parser ) (preprocess (pps ppx_let) ) - (flags (:standard -w +1..62-4-44-40-42-9@39@33 )) + (flags (:standard -w +1..62-4-9-44-40-42@39@33 )) ) diff --git a/src/ligo/helpers/tree.ml b/src/ligo/helpers/tree.ml new file mode 100644 index 000000000..5c6a0595e --- /dev/null +++ b/src/ligo/helpers/tree.ml @@ -0,0 +1,86 @@ +[@@@warning "-9"] + +module Append = struct + type 'a t' = + | Leaf of 'a + | Node of { + a : 'a t' ; + b : 'a t' ; + size : int ; + full : bool ; + } + + type 'a t = + | Empty + | Full of 'a t' + + let node (a, b, size, full) = Node {a;b;size;full} + + let rec exists' f = function + | Leaf s' when f s' -> true + | Leaf _ -> false + | Node{a;b} -> exists' f a || exists' f b + let exists f = function + | Empty -> false + | Full x -> exists' f x + + let rec exists_path' f = function + | Leaf x -> if f x then Some [] else None + | Node {a;b} -> ( + match exists_path' f a with + | Some a -> Some (false :: a) + | None -> ( + match exists_path' f b with + | Some b -> Some (true :: b) + | None -> None + ) + ) + + let exists_path f = function + | Empty -> None + | Full x -> exists_path' f x + + let empty : 'a t = Empty + + let size' = function + | Leaf _ -> 1 + | Node {size} -> size + + let size = function + | Empty -> 0 + | Full x -> size' x + + let rec append' x = function + | Leaf e -> node (Leaf e, Leaf x, 1, true) + | Node({full=true;size}) as n -> node(n, Leaf x, size + 1, false) + | Node({a=Node a;b;full=false} as n) -> ( + match append' x b with + | Node{full=false} as b -> Node{n with b} + | Node({full=true} as b) -> Node{n with b = Node b ; full = b.size = a.size} + | Leaf _ -> assert false + ) + | Node{a=Leaf _;full=false} -> assert false + + let append x = function + | Empty -> Full (Leaf x) + | Full t -> Full (append' x t) + + let of_list lst = + let rec aux = function + | [] -> Empty + | hd :: tl -> append hd (aux tl) + in + aux @@ List.rev lst + + let rec fold' leaf node = function + | Leaf x -> leaf x + | Node {a;b} -> node (fold' leaf node a) (fold' leaf node b) + + let fold_ne leaf node = function + | Empty -> raise (Failure "Tree.Append.fold_ne") + | Full x -> fold' leaf node x + + let fold empty leaf node = function + | Empty -> empty + | Full x -> fold' leaf node x +end diff --git a/src/ligo/mini_c.ml b/src/ligo/mini_c.ml index 68c9079cf..3d075112e 100644 --- a/src/ligo/mini_c.ml +++ b/src/ligo/mini_c.ml @@ -8,6 +8,7 @@ open Script_ir_translator module Michelson = Tezos_utils.Micheline.Michelson module Stack = Meta_michelson.Wrap.Stack module Types = Meta_michelson.Contract.Types +module Append_tree = Tree.Append type type_name = string @@ -27,16 +28,9 @@ type type_value = [ and environment_element = string * type_value -and environment_small' = - | Leaf of environment_element - | Node of { - a : environment_small' ; - b : environment_small' ; - size : int ; - full : bool ; - } +and environment_small' = environment_element Append_tree.t' -and environment_small = Empty | Full of environment_small' +and environment_small = environment_element Append_tree.t and environment = environment_small list @@ -124,7 +118,7 @@ module PP = struct and environment_element ppf ((s, tv) : environment_element) = Format.fprintf ppf "%s : %a" s type_ tv - and environment_small' ppf = function + and environment_small' ppf = let open Append_tree in function | Leaf x -> environment_element ppf x | Node {a; b ; full ; size} -> fprintf ppf "@[N(f:%b,s:%d)[@;%a,@;%a@]@;]" @@ -135,14 +129,14 @@ module PP = struct | Empty -> fprintf ppf "[]" | Full x -> environment_small' ppf x - and environment_small_hlist' ppf = function + and environment_small_hlist' ppf = let open Append_tree in function | Leaf x -> environment_element ppf x | Node {a;b} -> fprintf ppf "%a, %a" environment_small_hlist' a environment_small_hlist' b - and environment_small_hlist ppf = function + and environment_small_hlist ppf = let open Append_tree in function | Empty -> fprintf ppf "" | Full x -> environment_small_hlist' ppf x @@ -267,7 +261,7 @@ module Translate_type = struct let%bind (Ex_ty ret) = type_ ret in ok @@ Ex_ty Types.(pair capture @@ lambda (pair capture arg) ret) - and environment_small' = function + and environment_small' = let open Append_tree in function | Leaf (_, x) -> type_ x | Node {a;b} -> let%bind (Ex_ty a) = environment_small' a in @@ -322,7 +316,7 @@ module Translate_type = struct let%bind michelson_type = type_ tyv in ok @@ annotate ("@" ^ name) michelson_type - and environment_small' = function + and environment_small' = let open Append_tree in function | Leaf x -> environment_element x | Node {a;b} -> let%bind a = environment_small' a in @@ -403,44 +397,19 @@ module Environment = struct type element = environment_element module Small = struct + open Append_tree + type t' = environment_small' type t = environment_small - let node (a, b, size, full) = Node {a;b;size;full} - - let rec has' s = function - | Leaf (s',_) when s = s' -> true - | Leaf _ -> false - | Node{a;b} -> has' s a || has' s b + let has' s = exists' (fun ((x, _):element) -> x = s) let has s = function | Empty -> false | Full x -> has' s x - let empty : t = Empty + let empty : t = empty - let size' = function - | Leaf _ -> 1 - | Node {size} -> size - - let size = function - | Empty -> 0 - | Full x -> size' x - - let rec append' x = function - | Leaf e -> node (Leaf e, Leaf x, 1, true) - | Node({full=true;size}) as n -> node(n, Leaf x, size + 1, false) - | Node({a=Node a;b;full=false} as n) -> ( - match append' x b with - | Node{full=false} as b -> Node{n with b} - | Node({full=true} as b) -> Node{n with b = Node b ; full = b.size = a.size} - | Leaf _ -> assert false - ) - | Node{a=Leaf _;full=false} -> assert false - - let append ((s, _) as x) = function - | Empty -> Full (Leaf x) - | Full t -> - if has' s t then Full (t) else Full (append' x t) + let append s (e:t) = if has (fst s) e then e else append s e let of_list lst = let rec aux = function @@ -640,7 +609,7 @@ module Environment = struct Tezos_utils.Micheline.Michelson.pp schema_michelson in let%bind _ = - Trace.trace_tzresult_lwt (error "error parsing big.get code" error_message) @@ + trace_tzresult_lwt (error "error parsing big.get code" error_message) @@ Tezos_utils.Memory_proto_alpha.parse_michelson code input_stack_ty output_stack_ty in @@ -1015,6 +984,207 @@ module Translate_ir = struct | _ -> simple_fail "this value can't be transpiled back yet" end +module Translate_AST = struct + + module AST = Ligo_parser.Typed.O + module SMap = Ligo_parser.Typed.SMap + + module Rename = struct + open! AST + + let rec rename_expr_case (src:string) (dst:string) : expr_case -> expr_case = function + | App {operator;arguments} -> App {operator = rename_operator src dst operator ; arguments = rename_exprs src dst arguments} + | Var n when n.name.name = src -> Var {n with name = {n.name with name = dst}} + | Var n -> Var n + | Constant c -> Constant c + | Record r -> Record (List.map (fun (key, expr) -> key, rename_expr src dst expr) r) + | Lambda {parameter} as l when parameter.name.name = src -> l + | Lambda ({instructions;declarations} as l) -> + Lambda {l with instructions = rename_instrs src dst instructions ; declarations = rename_declarations src dst declarations} + + and rename_expr (src:string) (dst:string) (e : expr) : expr = + { e with expr = rename_expr_case src dst e.expr } + + and rename_exprs src dst exprs = List.map (rename_expr src dst) exprs + + and rename_operator_case (src:string) (dst:string) : operator_case -> operator_case = function + | Function n when n.name = src -> Function {n with name = dst} + | x -> x + + and rename_operator src dst (o:operator) : operator = {o with operator = rename_operator_case src dst o.operator} + + and rename_var src dst (v:var_name) : var_name = + if v.name = src + then {v with name = dst} + else v + + and rename_instr (src:string) (dst:string) : instr -> instr = function + | Assignment {name;value;orig} when name.name = src -> Assignment {name = {name with name = dst};value;orig} + | Assignment {name;value;orig} -> Assignment {value = rename_expr src dst value;name;orig} + | While {condition;body;orig} -> While {condition = rename_expr src dst condition;body=rename_instrs src dst body;orig} + | ForCollection {list;var;body;orig} -> ForCollection {list = rename_expr src dst list;var = rename_var src dst var; + body = rename_instrs src dst body;orig} + | Match ({expr;cases} as a) -> Match {a with expr = rename_expr src dst expr ; cases = rename_match_cases src dst cases} + | ProcedureCall {expr;orig} -> ProcedureCall {expr = rename_expr src dst expr;orig} + | Fail {expr;orig} -> Fail {expr = rename_expr src dst expr;orig} + + and rename_instrs src dst : instr list -> instr list = List.map (rename_instr src dst) + + and rename_match_cases (src:string) (dst:string) (m:(_ * instr list) list) = + List.map (fun (x, y) -> x, rename_instrs src dst y) m + + and rename_declaration (src:string) (dst:string) ({var} as d: decl) : decl = + if var.name.name = src + then {d with var = {var with name = {var.name with name = dst}}} + else d + + and rename_declarations (src:string) (dst:string) (decls:decl list) = + List.map (rename_declaration src dst) decls + end + + let rec translate_type : AST.type_expr -> type_value result = fun {type_expr} -> + match type_expr with + | Unit -> ok (`Base Unit) + | Int -> ok (`Base Int) + | String -> ok (`Base String) + | Bool -> ok (`Base Bool) + | Sum lst -> + let node = Append_tree.of_list @@ List.map snd lst in + let aux a b : type_value result = + let%bind a = a in + let%bind b = b in + ok (`Or (a, b)) + in + Append_tree.fold_ne translate_type aux node + | Record r -> + let node = Append_tree.of_list @@ List.map snd r in + let aux a b : type_value result = + let%bind a = a in + let%bind b = b in + ok (`Pair (a, b)) + in + Append_tree.fold_ne translate_type aux node + | Ref t -> translate_type t + | Function {arg;ret} -> + let%bind arg = translate_type arg in + let%bind ret = translate_type ret in + ok (`Function(arg, ret)) + | TypeApp _ -> simple_fail "No type application" + + let translate_constant : AST.constant -> value result = function + | Unit -> ok `Unit + | String s -> ok (`String s) + | Int n -> ok (`Int (Z.to_int n)) + | False -> ok (`Bool false) + | True -> ok (`Bool true) + | _ -> simple_fail "" + + let rec translate_lambda : AST.lambda -> anon_function result = + fun {declarations;parameter;instructions;result} -> + let ({name;ty}:AST.typed_var) = parameter in + let%bind input_ty = translate_type ty in + let declarations : AST.decl list = Rename.rename_declarations name.name "input" declarations in + let instructions : AST.instr list = Rename.rename_instrs name.name "input" instructions in + let%bind output_statement = + let%bind (output_expr : expression) = translate_expr result in + ok (Assignment (Variable("output", output_expr))) + in + let%bind output_ty = translate_type result.ty in + let%bind (declaration_statements : statement list) = translate_declarations declarations in + let%bind (instruction_statements : statement list) = translate_instructions instructions in + let body = declaration_statements @ instruction_statements @ [output_statement] in + ok {input=input_ty;output=output_ty;body} + + and translate_expr' : AST.expr_case -> expression' result = function + | Var {name} -> ok (Var name.name) + | Constant cst -> + let%bind value = translate_constant cst in + ok (Literal value) + | Lambda _ -> simple_fail "Mini_c doesn't deal with lambda in expressions yet" + | _ -> simple_fail "" + + and translate_expr : AST.expr -> expression result = fun {expr;ty} -> + let%bind expr = translate_expr' expr in + let%bind ty = translate_type ty in + ok (expr, ty) + + and translate_declaration : AST.decl -> statement result = fun {var;value} -> + let%bind expr = translate_expr value in + ok (Assignment(Variable(var.name.name, expr))) + + and translate_declarations : AST.decl list -> statement list result = fun declarations -> + bind_list @@ List.map translate_declaration declarations + + and translate_match (expr:AST.expr) (cases: (AST.pattern * AST.instr list) list) : statement result = + match cases with + | [(AST.PTrue, instrs_true) ; (AST.PFalse, instrs_false) ] -> + let%bind cond = translate_expr expr in + let%bind b_true = translate_instructions instrs_true in + let%bind b_false = translate_instructions instrs_false in + ok (Cond (cond, b_true, b_false)) + | [(AST.PFalse, instrs_false) ; (AST.PTrue, instrs_true) ] -> + let%bind cond = translate_expr expr in + let%bind b_true = translate_instructions instrs_true in + let%bind b_false = translate_instructions instrs_false in + ok (Cond (cond, b_true, b_false)) + | _ -> simple_fail "unrecognized pattern" + + and translate_instruction : AST.instr -> statement result = function + | Assignment {name ; value} -> + let%bind expr = translate_expr value in + ok (Assignment (Variable(name.name, expr))) + | While {condition ; body} -> + let%bind block = translate_instructions body in + let%bind cond = translate_expr condition in + ok (While (cond, block)) + | ForCollection _ -> simple_fail "We don't deal with for collection yet" + | Match {expr;cases} -> translate_match expr cases + | Fail _ -> simple_fail "Fail have to be added in Mini_C" + | ProcedureCall _ -> simple_fail "Drop Unit have to be added in Mini_C" + + and translate_instructions : AST.instr list -> statement list result = fun instrs -> + bind_list @@ List.map translate_instruction instrs + + let translate_program : AST.ast -> block result = fun {declarations} -> + translate_declarations declarations + + let rec to_mini_c_value' : (AST.expr_case * AST.type_expr) -> value result = function + | Constant c, _ -> translate_constant c + | App {arguments;operator = {operator = Construcor c ; ty = {type_expr = Sum lst}}}, _ -> + let node = Append_tree.of_list @@ List.map fst lst in + let%bind lst = + trace_option (simple_error "Not constructor of variant type") @@ + Append_tree.exists_path (fun (x:AST.name_and_region) -> x.name = c.name) node in + let arg = List.hd arguments in + let%bind arg = to_mini_c_value arg in + let ors = List.fold_left (fun b a -> if a then `Right b else `Left b) arg (List.rev lst) in + ok ors + | App _, _ -> simple_fail "Applications aren't value" + | Record lst, _ -> + let node = Append_tree.of_list @@ List.map snd lst in + let aux a b = + let%bind a = a in + let%bind b = b in + ok (`Pair (a, b)) + in + Append_tree.fold_ne to_mini_c_value aux node + | Lambda _, _-> simple_fail "Lambda aren't value yet" + | Var _, _-> simple_fail "Var aren't value yet" + + and to_mini_c_value : AST.expr -> value result = fun {expr;ty} -> + to_mini_c_value' (expr, ty) + + let ghost expr ty : AST.expr = {expr;ty;orig=`TODO} + + let of_mini_c_value ({type_expr} as ty, v : AST.type_expr * value) : AST.expr result = match (type_expr, v) with + | String, `String s -> ok @@ ghost (Constant (String s)) ty + | Bool, `Bool b -> ok @@ ghost (Constant (if b then True else False)) ty + | Unit, `Unit -> ok @@ ghost (Constant (Unit)) ty + | Int, `Int n -> ok @@ ghost (Constant (Int (Z.of_int n))) ty + | Function _, _ -> simple_fail "Functions aren't retrieved from Mini_C yet" + | _ -> simple_fail "of_mini_c_value error" +end + module Run = struct open Tezos_utils.Micheline diff --git a/src/ligo/parser/AST2.ml b/src/ligo/parser/AST2.ml index 019c3df9f..c91612138 100644 --- a/src/ligo/parser/AST2.ml +++ b/src/ligo/parser/AST2.ml @@ -7,8 +7,14 @@ open Region module SMap = Map.Make(String) module O = struct - type type_name = string - type var_name = string + type asttodo = [`TODO] + + type name_and_region = {name: string; orig: Region.t} + type type_name = name_and_region + type var_name = name_and_region + type field_name = name_and_region + + type record_key = [`Field of field_name | `Component of int] type pattern = PVar of var_name @@ -23,43 +29,58 @@ module O = struct | PSome of pattern | PCons of pattern * pattern | PNull - | PTuple of pattern list + | PRecord of record_key precord - type type_expr = - Prod of type_expr list - | Sum of (type_name * type_expr) list - | Record of (type_name * type_expr) list - | TypeApp of type_name * (type_expr list) - | Function of { args: type_expr list; ret: type_expr } + and 'key precord = ('key * pattern) list + + type type_constructor = + Option + | List + | Set + | Map + + type type_expr_case = + Sum of (type_name * type_expr) list + | Record of record_key type_record + | TypeApp of type_constructor * (type_expr list) + | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr - | Unit + | String | Int + | Unit + | Bool + and 'key type_record = ('key * type_expr) list + + and type_expr = { type_expr: type_expr_case; name: type_name option; orig: Region.t } type typed_var = { name:var_name; ty:type_expr } - type type_decl = { name:string; ty:type_expr } + type type_decl = { name:type_name; ty:type_expr } type expr = App of { operator: operator; arguments: expr list } - | Var of var_name + | Var of var_name | Constant of constant | Lambda of lambda and decl = { name:var_name; ty:type_expr; value: expr } and lambda = { - parameters: type_expr SMap.t; + parameter: typed_var; declarations: decl list; instructions: instr list; result: expr; } and operator = - Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod + Function of var_name + | Construcor of var_name + | UpdateField of record_key + | GetField of record_key + | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod | Neg | Not | Tuple | Set | List | MapLookup - | Function of string and constant = Unit | Int of Z.t | String of string | Bytes of MBytes.t | False | True @@ -87,8 +108,12 @@ let (|>) v f = f v (* pipe f to v *) let (@@) f v = f v (* apply f on v *) let (@.) f g x = f (g x) (* compose *) let map f l = List.rev (List.rev_map f l) -(* TODO: check that List.to_seq, List.append and SMap.of_seq are not broken - (i.e. check that they are tail-recursive) *) +let mapi f l = + let f (i, l) elem = + (i + 1, (f i elem) :: l) + in snd (List.fold_left f (0,[]) l) +(* TODO: check that List.append is not broken + (i.e. check that it is tail-recursive) *) let append_map f l = map f l |> List.flatten let append l1 l2 = List.append l1 l2 let list_to_map l = List.fold_left (fun m (k,v) -> SMap.add k v m) SMap.empty l @@ -110,16 +135,37 @@ let s_sepseq : ('a,'sep) Utils.sepseq -> 'a list = | Some nsepseq -> s_nsepseq nsepseq let s_name {value=name; region} : O.var_name = + let () = ignore (region) in + {name;orig = region} + +let name_to_string {value=name; region} : string = let () = ignore (region) in name +let type_expr (orig : Region.t) (e : O.type_expr_case) : O.type_expr = + { type_expr = e; name = None; orig } + +let s_type_constructor {value=name;region} : O.type_constructor = + let () = ignore (region) in + match name with + "Option" -> Option + | "List" -> List + | "Map" -> Map + | "Set" -> Set + (* TODO: escape the name, prevent any \x1b and other weird characters from appearing in the output *) + | _ -> failwith ("Unknown type constructor: " ^ name) + let rec s_cartesian {value=sequence; region} : O.type_expr = let () = ignore (region) in - Prod (map s_type_expr (s_nsepseq sequence)) + s_nsepseq sequence + |>map s_type_expr + |> mapi (fun i p -> `Component i, p) + |> (fun x -> (Record x : O.type_expr_case)) + |> type_expr region and s_sum_type {value=sequence; region} : O.type_expr = let () = ignore (region) in - Sum (map s_variant (s_nsepseq sequence)) + type_expr region (Sum (map s_variant (s_nsepseq sequence))) and s_variant {value=(constr, kwd_of, cartesian); region} = let () = ignore (kwd_of,region) in @@ -127,15 +173,15 @@ and s_variant {value=(constr, kwd_of, cartesian); region} = and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_expr = let () = ignore (kwd_record,region,kwd_end) in - Record (map s_field_decl (s_nsepseq field_decls)) + type_expr region (Record (map s_field_decl (s_nsepseq field_decls))) and s_field_decl {value=(var, colon, type_expr); region} = let () = ignore (colon,region) in - (s_name var, s_type_expr type_expr) + (`Field (s_name var), s_type_expr type_expr) and s_type_app {value=(type_name,type_tuple); region} : O.type_expr = let () = ignore (region) in - TypeApp (s_name type_name, s_type_tuple type_tuple) + type_expr region (TypeApp (s_type_constructor type_name, s_type_tuple type_tuple)) and s_type_tuple ({value=(lpar, sequence, rpar); region} : (I.type_name, I.comma) Utils.nsepseq I.par) : O.type_expr list = let () = ignore (lpar,rpar,region) in @@ -148,9 +194,9 @@ and s_par_type {value=(lpar, type_expr, rpar); region} : O.type_expr = and s_type_alias name : O.type_expr = let () = ignore () in - TypeApp (s_name name, []) + type_expr name.region (TypeApp (s_type_constructor name, [])) -and s_type_expr : I.type_expr -> O.type_expr = function +and s_type_expr (orig : I.type_expr) : O.type_expr = match orig with Prod cartesian -> s_cartesian cartesian | Sum sum_type -> s_sum_type sum_type | Record record_type -> s_record_type record_type @@ -161,7 +207,8 @@ and s_type_expr : I.type_expr -> O.type_expr = function let s_type_decl I.{value={kwd_type;name;kwd_is;type_expr;terminator}; region} : O.type_decl = let () = ignore (kwd_type,kwd_is,terminator,region) in - O.{ name = s_name name; ty = s_type_expr type_expr } + let ty = s_type_expr type_expr in + O.{ name = s_name name; ty = { ty with name = Some (s_name name) } } let s_storage_decl I.{value={kwd_storage; name; colon; store_type; terminator}; region} : O.typed_var = let () = ignore (kwd_storage,colon,terminator,region) in @@ -183,6 +230,18 @@ let s_none {value=(l, (c_None, colon, type_expr), r); region} : O.expr = let () = ignore (l, c_None, colon, r, region) in Constant (CNone (s_type_expr type_expr)) +let parameters_to_tuple (parameters : (string * O.type_expr) list) : O.type_expr = + (* TODO: use records with named fields to have named arguments. *) + let parameter_tuple = O.Record (mapi (fun i (_name,ty) -> `Component i, ty) parameters) in + O.{ type_expr = parameter_tuple; name = None; orig = Region.ghost } +and parameters_to_decls singleparam (parameters : (string * O.type_expr) list) : O.decl list = + let f i (name,ty) = + O.{ name = {name; orig=Region.ghost}; + ty = ty; + value = App { operator = O.GetField (`Component i); + arguments = [Var singleparam] } } + in mapi f parameters + let rec bin l operator r = O.App { operator; arguments = [s_expr l; s_expr r] } and una operator v = O.App { operator; arguments = [s_expr v] } and s_expr : I.expr -> O.expr = @@ -205,7 +264,7 @@ and s_expr : I.expr -> O.expr = | Neg {value=(minus, expr); region} -> let () = ignore (region, minus) in una Neg expr | Not {value=(kwd_not, expr); region} -> let () = ignore (region, kwd_not) in una Not expr | Int {value=(lexeme, z); region} -> let () = ignore (region, lexeme) in Constant (Int z) - | Var {value=lexeme; region} -> let () = ignore (region) in Var lexeme + | Var lexeme -> Var (s_name lexeme) | String {value=s; region} -> let () = ignore (region) in Constant (String s) | Bytes {value=(lexeme, mbytes); region} -> let () = ignore (region, lexeme) in Constant (Bytes mbytes) | False c_False -> let () = ignore (c_False) in Constant (False) @@ -286,7 +345,10 @@ and s_raw {value=(lpar, (core_pattern, cons, pattern), rpar); region} = and s_ptuple {value=(lpar, sequence, rpar); region} = let () = ignore (lpar, rpar, region) in - PTuple (map s_core_pattern (s_nsepseq sequence)) + s_nsepseq sequence + |> map s_core_pattern + |> mapi (fun i p -> `Component i, p) + |> fun x -> O.PRecord x and s_psome {value=(c_Some,{value=(l,psome,r);region=region2});region} : O.pattern = let () = ignore (c_Some,l,r,region2,region) in @@ -298,11 +360,11 @@ and s_const_decl I.{value={kwd_const;name;colon;const_type;equal;init;terminator and s_param_const {value=(kwd_const,variable,colon,type_expr); region} : string * O.type_expr = let () = ignore (kwd_const,colon,region) in - s_name variable, s_type_expr type_expr + name_to_string variable, s_type_expr type_expr and s_param_var {value=(kwd_var,variable,colon,type_expr); region} : string * O.type_expr = let () = ignore (kwd_var,colon,region) in - s_name variable, s_type_expr type_expr + name_to_string variable, s_type_expr type_expr and s_param_decl : I.param_decl -> string * O.type_expr = function ParamConst p -> s_param_const p @@ -406,9 +468,13 @@ and s_constr_app {value=(constr, arguments); region} : O.expr = let () = ignore (region) in App { operator = Function (s_name constr); arguments = s_arguments arguments } -and s_arguments {value=(lpar, sequence, rpar); region} = +and s_arguments {value=(lpar, sequence, rpar); region} : O.expr list = + (* TODO: should return a tuple *) let () = ignore (lpar,rpar,region) in - map s_expr (s_nsepseq sequence); + match map s_expr (s_nsepseq sequence) with + [] -> [Constant Unit] + | [single_argument] -> [single_argument] + | args -> [App { operator = Tuple; arguments = args }] ; and s_fail ((kwd_fail, expr) : (I.kwd_fail * I.expr)) : O.instr = let () = ignore (kwd_fail) in @@ -431,14 +497,27 @@ and s_block I.{value={opening;instr;terminator;close}; _} : O.instr list = let () = ignore (opening,terminator,close) in s_instructions instr +and gensym = + let i = ref 0 in + fun ty -> + i := !i + 1; + (* TODO: Region.ghost *) + ({name = {name=(string_of_int !i) ^ "gensym"; orig = Region.ghost}; ty} : O.typed_var) + and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_decls;block;kwd_with;return;terminator}; region} : O.decl = let () = ignore (kwd_function,colon,kwd_is,kwd_with,terminator,region) in + let tuple_type = s_parameters param |> parameters_to_tuple in + let single_argument = gensym tuple_type in + let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in O.{ name = s_name name; - ty = Function { args = map snd (s_parameters param); ret = s_type_expr ret_type }; + ty = type_expr region (Function { arg = tuple_type; + ret = s_type_expr ret_type }); value = Lambda { - parameters = s_parameters param |> list_to_map; - declarations = map s_local_decl local_decls; + parameter = single_argument; + declarations = append + (s_parameters param |> parameters_to_decls single_argument_xxx) + (map s_local_decl local_decls); instructions = s_block block; result = s_expr return } @@ -446,12 +525,18 @@ and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_dec and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;terminator}; region} = let () = ignore (kwd_procedure,kwd_is,terminator,region) in + let tuple_type = s_parameters param |> parameters_to_tuple in + let single_argument = gensym tuple_type in + let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in O.{ name = s_name name; - ty = Function { args = map snd (s_parameters param); ret = Unit }; + ty = type_expr region (Function { arg = tuple_type; + ret = type_expr region Unit }); value = Lambda { - parameters = s_parameters param |> list_to_map; - declarations = map s_local_decl local_decls; + parameter = single_argument; + declarations = append + (s_parameters param |> parameters_to_decls single_argument_xxx) + (map s_local_decl local_decls); instructions = s_block block; result = O.Constant O.Unit } @@ -459,12 +544,18 @@ and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;term and s_entry_decl I.{value={kwd_entrypoint;name;param;kwd_is;local_decls;block;terminator}; region} = let () = ignore (kwd_entrypoint,kwd_is,terminator,region) in + let tuple_type = s_parameters param |> parameters_to_tuple in + let single_argument = gensym tuple_type in + let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in O.{ name = s_name name; - ty = Function { args = map snd (s_parameters param); ret = Unit }; + ty = type_expr region (Function { arg = tuple_type; + ret = type_expr region Unit }); value = Lambda { - parameters = s_parameters param |> list_to_map; - declarations = map s_local_decl local_decls; + parameter = single_argument; + declarations = append + (s_parameters param |> parameters_to_decls single_argument_xxx) + (map s_local_decl local_decls); instructions = s_block block; result = O.Constant O.Unit } diff --git a/src/ligo/parser/Typecheck2.ml b/src/ligo/parser/Typecheck2.ml index bb5970036..3edc1b66b 100644 --- a/src/ligo/parser/Typecheck2.ml +++ b/src/ligo/parser/Typecheck2.ml @@ -5,9 +5,10 @@ module SMap = Map.Make(String) module O = struct type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *) - type type_name = string - type var_name = { name: string; orig: asttodo } - type record_key = [`Field of string | `Component of int] + type name_and_region = {name: string; orig: Region.t} + type type_name = name_and_region + type var_name = name_and_region + type field_name = name_and_region type pattern = PVar of var_name @@ -22,28 +23,26 @@ module O = struct | PSome of pattern | PCons of pattern * pattern | PNull - | PRecord of pattern list + | PRecord of (field_name * pattern) list type type_constructor = - | Option + Option | List | Set | Map type type_expr_case = - | Sum of (type_name * type_expr_case) list - | Record of record_key type_record - | TypeApp of type_constructor * (type_expr_case list) - | Function of { args: type_expr_case list; ret: type_expr_case } - | Ref of type_expr_case - | TC of type_constructor + Sum of (type_name * type_expr) list + | Record of (field_name * type_expr) list + | TypeApp of type_constructor * (type_expr list) + | Function of { arg: type_expr; ret: type_expr } + | Ref of type_expr | String | Int | Unit | Bool - and 'key type_record = ('key * type_expr_case) list - type type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } + and type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } type typed_var = { name:var_name; ty:type_expr; orig: asttodo } @@ -53,24 +52,25 @@ module O = struct App of { operator: operator; arguments: expr list } | Var of typed_var | Constant of constant - | Record of record_key expr_record + | Record of (field_name * expr) list | Lambda of lambda - and 'key expr_record = ('key * expr list) - and expr = { expr: expr_case; ty:type_expr; orig: asttodo } and decl = { var: typed_var; value: expr; orig: asttodo } and lambda = { - parameters: typed_var SMap.t; + parameter: typed_var; declarations: decl list; instructions: instr list; result: expr; } and operator_case = - Function of string + Function of var_name + | Construcor of var_name + | UpdateField of field_name + | GetField of field_name | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod | Neg | Not | Set @@ -89,16 +89,14 @@ module O = struct and instr = Assignment of { name: var_name; value: expr; orig: asttodo } | While of { condition: expr; body: instr list; orig: asttodo } - | ForCollection of { list: expr; key: var_name; value: var_name option; body: instr list; orig: asttodo } - | If of { condition: expr; ifso: instr list; ifnot: instr list; orig: asttodo } + | ForCollection of { list: expr; var: var_name; body: instr list; orig: asttodo } | Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo } - | DropUnit of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *) + | ProcedureCall of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *) | Fail of { expr: expr; orig: asttodo } type ast = { types : type_decl list; storage_decl : typed_var; - operations_decl : typed_var; declarations : decl list; orig: AST.t } diff --git a/src/ligo/parser/Typecheck2.mli b/src/ligo/parser/Typecheck2.mli index e8fe362f0..a85ddba8b 100644 --- a/src/ligo/parser/Typecheck2.mli +++ b/src/ligo/parser/Typecheck2.mli @@ -5,9 +5,10 @@ module SMap : Map.S with type key = string module O : sig type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *) - type type_name = string - type var_name = { name: string; orig: asttodo } - type record_key = [`Field of string | `Component of int] + type name_and_region = {name: string; orig: Region.t} + type type_name = name_and_region + type var_name = name_and_region + type field_name = name_and_region type pattern = PVar of var_name @@ -22,28 +23,26 @@ module O : sig | PSome of pattern | PCons of pattern * pattern | PNull - | PRecord of pattern list + | PRecord of (field_name * pattern) list type type_constructor = - | Option + Option | List | Set | Map type type_expr_case = - | Sum of (type_name * type_expr_case) list - | Record of record_key type_record - | TypeApp of type_constructor * (type_expr_case list) - | Function of { args: type_expr_case list; ret: type_expr_case } - | Ref of type_expr_case - | TC of type_constructor + Sum of (type_name * type_expr) list + | Record of (field_name * type_expr) list + | TypeApp of type_constructor * (type_expr list) + | Function of { arg: type_expr; ret: type_expr } + | Ref of type_expr | String | Int | Unit | Bool - and 'key type_record = ('key * type_expr_case) list - type type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } + and type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } type typed_var = { name:var_name; ty:type_expr; orig: asttodo } @@ -53,24 +52,25 @@ module O : sig App of { operator: operator; arguments: expr list } | Var of typed_var | Constant of constant - | Record of record_key expr_record + | Record of (field_name * expr) list | Lambda of lambda - and 'key expr_record = ('key * expr list) - and expr = { expr: expr_case; ty:type_expr; orig: asttodo } and decl = { var: typed_var; value: expr; orig: asttodo } and lambda = { - parameters: typed_var SMap.t; + parameter: typed_var; declarations: decl list; instructions: instr list; result: expr; } and operator_case = - Function of string + Function of var_name + | Construcor of var_name + | UpdateField of field_name + | GetField of field_name | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod | Neg | Not | Set @@ -89,16 +89,14 @@ module O : sig and instr = Assignment of { name: var_name; value: expr; orig: asttodo } | While of { condition: expr; body: instr list; orig: asttodo } - | ForCollection of { list: expr; key: var_name; value: var_name option; body: instr list; orig: asttodo } - | If of { condition: expr; ifso: instr list; ifnot: instr list; orig: asttodo } + | ForCollection of { list: expr; var: var_name; body: instr list; orig: asttodo } | Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo } - | DropUnit of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *) + | ProcedureCall of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *) | Fail of { expr: expr; orig: asttodo } type ast = { types : type_decl list; storage_decl : typed_var; - operations_decl : typed_var; declarations : decl list; orig: AST.t } diff --git a/src/ligo/parser/dune b/src/ligo/parser/dune index d497a7c13..1f867bb32 100644 --- a/src/ligo/parser/dune +++ b/src/ligo/parser/dune @@ -6,24 +6,31 @@ (modules ParToken Parser) (flags -la 1 --explain --external-tokens LexToken)) -(executables - (names LexerMain ParserMain) - (public_names ligo-lexer ligo-parser) - (package ligo-parser) - (modules_without_implementation Error) - (libraries getopt hex str uutf zarith)) +(library + (name ligo_parser) + (public_name ligo-parser) + (modules_without_implementation Error) + (libraries getopt hex str uutf zarith) +) + +;; (executables +;; (names LexerMain ParserMain) +;; (public_names ligo-lexer ligo-parser) +;; (package ligo-parser) +;; (modules_without_implementation Error) +;; (libraries getopt hex str uutf zarith)) ;; Les deux directives (rule) qui suivent sont pour le dev local. ;; Il suffit de faire "dune build Parser.exe" pour avoir un Parser.exe dans le dossier. ;; Pour le purger, il faut faire "dune clean". -(rule - (targets Parser.exe) - (deps ParserMain.exe) - (action (copy ParserMain.exe Parser.exe)) - (mode promote-until-clean)) +;; (rule +;; (targets Parser.exe) +;; (deps ParserMain.exe) +;; (action (copy ParserMain.exe Parser.exe)) +;; (mode promote-until-clean)) -(rule - (targets Lexer.exe) - (deps LexerMain.exe) - (action (copy LexerMain.exe Lexer.exe)) - (mode promote-until-clean)) +;; (rule +;; (targets Lexer.exe) +;; (deps LexerMain.exe) +;; (action (copy LexerMain.exe Lexer.exe)) +;; (mode promote-until-clean)) diff --git a/src/ligo/parser/ligo_parser.ml b/src/ligo/parser/ligo_parser.ml new file mode 100644 index 000000000..72c356b95 --- /dev/null +++ b/src/ligo/parser/ligo_parser.ml @@ -0,0 +1 @@ +module Typed = Typecheck2