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

translations from typed-ligo to mini-c

Browse Source
This commit is contained in:
Galfour 2019-03-14 18:22:51 +00:00
parent 7cc6a681b1
commit fa4b570950
8 changed files with 498 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/ligo/dune
View File

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

86
src/ligo/helpers/tree.ml Normal file
View File

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

260
src/ligo/mini_c.ml
View File

@ -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 "@[<v 2>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

169
src/ligo/parser/AST2.ml
View File

@ -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,21 +29,33 @@ 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 }
@ -48,18 +66,21 @@ module O = struct
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
}

42
src/ligo/parser/Typecheck2.ml
View File

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

42
src/ligo/parser/Typecheck2.mli
View File

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

37
src/ligo/parser/dune
View File

@ -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)
(library
(name ligo_parser)
(public_name ligo-parser)
(modules_without_implementation Error)
(libraries getopt hex str uutf zarith))
(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))

1
src/ligo/parser/ligo_parser.ml Normal file
View File

@ -0,0 +1 @@
module Typed = Typecheck2