Skip to content

Instantly share code, notes, and snippets.

@renatoalencar

renatoalencar/compile.ml

Created September 18, 2022 18:42
Show Gist options
  • Save renatoalencar/e9b5f73ff899997ba1f32a4b354b76de to your computer and use it in GitHub Desktop.
Save renatoalencar/e9b5f73ff899997ba1f32a4b354b76de to your computer and use it in GitHub Desktop.
Download ZIP
Michelson to Grain
Raw
compile.ml
module Result_let_syntax = struct
let (let*) = Result.bind
let (let+) a f = Result.map f a
end
module Parse = struct
open Tezos_micheline
module MPrim = Michelson_v1_primitives
let to_parsing_error error =
Result.map_error (fun x -> `Parsing_error x) error
let to_prim_parsing_error error =
Result.map_error (fun x -> `Prim_parsing_error x) error
let parse_expr expr =
let open Result_let_syntax in
let* tokenized =
expr
|> Micheline_parser.tokenize
|> Micheline_parser.no_parsing_error
|> to_parsing_error
in
let* parsed =
tokenized
|> Micheline_parser.parse_expression
|> Micheline_parser.no_parsing_error
|> to_parsing_error
in
let* x =
parsed
|> Micheline.strip_locations
|> MPrim.prims_of_strings
|> to_prim_parsing_error
in
Ok x
end
open Tezos_micheline.Micheline
open Michelson_v1_primitives
open Grain_parsing
open Ast_helper
open Parser_header
let dummy_loc = (Lexing.dummy_pos, Lexing.dummy_pos)
let mkstr = mkstr dummy_loc
let mkid name = mkid name Location.dummy_loc
let gensym_count = ref 0
let gensym name =
incr gensym_count;
Printf.sprintf "%s_%d" name !gensym_count
let rec compile_type typ =
match typ with
| Prim (_, T_int, _, _) -> Typ.var "BigInt"
| Prim (_, T_or, [ left; right ], _) -> Typ.constr (mkid [ mkstr "Union" ]) [ compile_type left; compile_type right ]
| _ -> assert false
let compile_toplevel_type ~name typ =
Dat.abstract (mkstr name) [] (Some (compile_type typ))
let rec compile_code stack code =
match stack, code with
| expr :: stack, Prim (_, I_UNPAIR, _, _) :: code ->
let fst = gensym "fst" in
let snd = gensym "snd" in
let unpair =
Exp.let_ Nonrecursive Immutable
[ Vb.mk (Pat.tuple [ Pat.var (mkstr fst); Pat.var (mkstr snd) ]) expr ]
in
let stack =
Exp.ident (mkid [ (mkstr fst) ]) :: Exp.ident (mkid [ (mkstr snd) ]) :: stack
in
let block, stack_size = compile_code stack code in
unpair :: block, stack_size
| a :: b :: stack, Prim (_, I_ADD, _, _) :: code ->
let stack =
Exp.apply (Exp.ident @@ mkid [ mkstr "BigInt"; mkstr "add" ]) [ a; b ] :: stack
in
compile_code stack code
| a :: b :: stack, Prim (_, I_SUB, _, _) :: code ->
let stack =
Exp.apply (Exp.ident @@ mkid [ mkstr "BigInt"; mkstr "sub" ]) [ a; b ] :: stack
in
compile_code stack code
| stack, Prim (_, I_NIL, _, _) :: code ->
let stack = Exp.list [] :: stack in
compile_code stack code
| fst :: snd :: stack, Prim (_, I_PAIR, _, _) :: code ->
let stack = Exp.tuple [ fst; snd ] :: stack in
compile_code stack code
| union :: stack, Prim (_, I_IF_LEFT, [ Seq (_, left_branch) ; Seq (_, right_branch) ], _) :: code ->
let l = gensym "l" in
let r = gensym "r" in
let left_branch, left_stack_size =
compile_code (Exp.ident (mkid [ mkstr l ]) :: stack) left_branch
in
let right_branch, right_stack_size =
compile_code (Exp.ident (mkid [ mkstr r ]) :: stack) right_branch
in
assert (left_stack_size = right_stack_size);
let match_ =
Exp.match_ union
[ Mb.mk (Pat.construct (mkid [ mkstr "L" ]) [ Pat.var (mkstr l) ]) (Exp.block left_branch) None
; Mb.mk (Pat.construct (mkid [ mkstr "R" ]) [ Pat.var (mkstr r) ]) (Exp.block right_branch) None ]
in
let binding_names =
let rec aux = function
| 0 -> []
| n -> gensym "bind" :: aux (n - 1)
in
aux left_stack_size
in
let unwrap_tuple =
Exp.let_ Nonrecursive Immutable
[ Vb.mk (Pat.tuple (List.map (fun name -> Pat.var (mkstr name)) binding_names)) match_ ]
in
let bindings =
List.map (fun name -> Exp.ident (mkid [ (mkstr name) ])) binding_names
in
let block, stack_size = compile_code bindings code in
unwrap_tuple :: block, stack_size
| fst :: snd :: stack, Prim (_, I_SWAP, _, _) :: code ->
compile_code (snd :: fst :: stack) code
| stack, [] -> [ Exp.tuple stack ], List.length stack
| stack, code ->
failwith (Printf.sprintf "Stack %d code %d" (List.length stack) (List.length code))
let compile_contract contract =
match root contract with
| Seq (_, [ Prim (_, K_parameter, [ parameter ], _)
; Prim (_, K_storage, [ storage ], _)
; Prim (_, K_code, [ Seq (_, code) ], _) ]) ->
let main_function =
let lambda =
let code, _ = compile_code [ Exp.ident @@ mkid [ (mkstr "arg") ] ] code in
Exp.lambda [Pat.var (mkstr "arg")] @@ Exp.block code
in
Top.let_ Nonexported Nonrecursive Immutable
[ Vb.mk (Pat.var (mkstr "main")) lambda ]
in
make_program
[ Top.import (Imp.mk [ PImportModule (mkid [ mkstr "BigInt" ]) ] (mkstr "bigint"))
; Top.data
[ Nonexported
, Dat.variant
(mkstr "Union")
[ Typ.var "left"
; Typ.var "right" ]
[ CDecl.tuple (mkstr "L") [ Typ.var "left" ]
; CDecl.tuple (mkstr "R") [ Typ.var "right" ] ] ]
; Top.data [ Nonexported, compile_toplevel_type ~name:"Parameter" parameter ]
; Top.data [ Nonexported, compile_toplevel_type ~name:"Storage" storage ]
; main_function ]
| _ -> assert false
let () =
let ast =
{| { parameter (or int int); storage int; code { UNPAIR; IF_LEFT { ADD } { SWAP; SUB } ; NIL operation; PAIR } } |}
|> Parse.parse_expr
|> Result.get_ok
|> compile_contract
in
ast
|> Grain_formatting.Format.format_ast ~eol:Grain_utils.Fs_access.LF ~original_source:[||]
|> print_endline;
(*
import BigInt from "bigint"
enum Union<left, right> {
L(left),
R(right),
}
type Parameter = Union<BigInt, BigInt>
type Storage = BigInt
let main = arg => {
let (fst_1, snd_2) = arg
let (bind_5) = match (fst_1) {
L(l_3) => {
(BigInt.add(l_3, snd_2),)
},
R(r_4) => {
(BigInt.sub(snd_2, r_4),)
},
}
(([], bind_5),)
}
*)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment