initial commit

.gitignore

@@ -0,0 +1,6 @@
+_build/*
+*/_build
+.merlin
+*/.merlin
+*.install
+*/*.install

README_INSTALL

@@ -0,0 +1,20 @@
+switch=titi
+cd src/ligo
+sudo apt -y install libev-dev libhidapi-dev
+opam init
+eval $(opam env)
+opam switch create $switch ocaml-base-compiler.4.06.1
+eval $(opam env --switch=$switch --set-switch)
+opam repository add new-tezos https://gitlab.com/gabriel.alfour/new-tezos-opam-repository.git
+
+# si une build a déjà été tentée, il vaut mieux git add tout ce qui est utile et git clean -dfx pour supprimer tout le reste (dune 1.7 crée des fichiers non compatibles avec dune 1.6)
+opam install -y ocplib-endian alcotest
+
+(cd ligo-parser && opam install -y .)
+eval $(opam env)
+(cd ligo-helpers && opam install -y .)
+eval $(opam env)
+(opam install -y .)
+eval $(opam env)
+opam install merlin ocp-indent ledit
+opam user-setup install

TODO.txt

@@ -0,0 +1,21 @@
+# Main
+
+## Back-end
+
+- Replace Mini_c environments with stacks
+  + Compiler_environment : bad pack make first element deepest
+  + Add types to pack and unpack
+- Think about Coq
+
+## Amendments
+
+- Bubble_n
+- Partial application
+- Type size limit (1.000 -> 10.000)
+
+# PPX
+
+## Deriving
+
+- Generate ADT helpers (this removes 90% of Combinators and a lot of maintenance when modifying ASTs)
+- Generate option helpers (this makes writing main much easier, much like one would in an untyped language)

ast_simplified/PP.ml

@@ -0,0 +1,119 @@
+open Types
+open PP_helpers
+open Format
+
+let list_sep_d x ppf lst = match lst with
+  | [] -> ()
+  | _ -> fprintf ppf "@;  @[<v>%a@]@;" (list_sep x (tag "@;")) lst
+
+let smap_sep_d x ppf m =
+  if Map.String.is_empty m
+  then ()
+  else fprintf ppf "@;  @[<v>%a@]@;" (smap_sep x (tag "@;")) m
+
+let rec type_expression ppf (te:type_expression) = match te with
+  | T_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d type_expression) lst
+  | T_sum m -> fprintf ppf "sum[%a]" (smap_sep_d type_expression) m
+  | T_record m -> fprintf ppf "record[%a]" (smap_sep_d type_expression) m
+  | T_function (p, r) -> fprintf ppf "%a -> %a" type_expression p type_expression r
+  | T_variable name -> fprintf ppf "%s" name
+  | T_constant (name, lst) -> fprintf ppf "%s(%a)" name (list_sep_d type_expression) lst
+
+let literal ppf (l:literal) = match l with
+  | Literal_unit -> fprintf ppf "Unit"
+  | Literal_bool b -> fprintf ppf "%b" b
+  | Literal_int n -> fprintf ppf "%d" n
+  | Literal_nat n -> fprintf ppf "+%d" n
+  | Literal_tez n -> fprintf ppf "%dtz" n
+  | Literal_string s -> fprintf ppf "%S" s
+  | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
+  | Literal_address s -> fprintf ppf "@%S" s
+  | Literal_operation _ -> fprintf ppf "Operation(...bytes)"
+
+let rec expression ppf (e:expression) = match e with
+  | E_literal l -> literal ppf l
+  | E_variable name -> fprintf ppf "%s" name
+  | E_application (f, arg) -> fprintf ppf "(%a)@(%a)" annotated_expression f annotated_expression arg
+  | E_constructor (name, ae) -> fprintf ppf "%s(%a)" name annotated_expression ae
+  | E_constant (name, lst) -> fprintf ppf "%s(%a)" name (list_sep_d annotated_expression) lst
+  | E_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d annotated_expression) lst
+  | E_accessor (ae, p) -> fprintf ppf "%a.%a" annotated_expression ae access_path p
+  | E_record m -> fprintf ppf "record[%a]" (smap_sep_d annotated_expression) m
+  | E_map m -> fprintf ppf "map[%a]" (list_sep_d assoc_annotated_expression) m
+  | E_list lst -> fprintf ppf "list[%a]" (list_sep_d annotated_expression) lst
+  | E_look_up (ds, ind) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression ind
+  | E_lambda {binder;input_type;output_type;result;body} ->
+      fprintf ppf "lambda (%s:%a) : %a {@;  @[<v>%a@]@;} return %a"
+        binder type_expression input_type type_expression output_type
+        block body annotated_expression result
+  | E_matching (ae, m) ->
+      fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m
+  | E_failwith ae ->
+      fprintf ppf "failwith %a" annotated_expression ae
+
+and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) ->
+  fprintf ppf "%a -> %a" annotated_expression a annotated_expression b
+
+and access ppf (a:access) =
+  match a with
+  | Access_tuple n -> fprintf ppf "%d" n
+  | Access_record s -> fprintf ppf "%s" s
+  | Access_map s -> fprintf ppf "(%a)" annotated_expression s
+
+and access_path ppf (p:access_path) =
+  fprintf ppf "%a" (list_sep access (const ".")) p
+
+and type_annotation ppf (ta:type_expression option) = match ta with
+  | None -> fprintf ppf ""
+  | Some t -> type_expression ppf t
+
+and annotated_expression ppf (ae:annotated_expression) = match ae.type_annotation with
+  | None -> fprintf ppf "%a" expression ae.expression
+  | Some t -> fprintf ppf "(%a) : %a" expression ae.expression type_expression t
+
+and value : _ -> value -> unit = fun x -> annotated_expression x
+
+and block ppf (b:block) = (list_sep instruction (tag "@;")) ppf b
+
+and single_record_patch ppf ((p, ae) : string * ae) =
+  fprintf ppf "%s <- %a" p annotated_expression ae
+
+and single_tuple_patch ppf ((p, ae) : int * ae) =
+  fprintf ppf "%d <- %a" p annotated_expression ae
+
+and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor_name * name) * a -> unit =
+  fun f ppf ((c,n),a) ->
+  fprintf ppf "| %s %s -> %a" c n f a
+
+and matching : type a . (formatter -> a -> unit) -> formatter -> a matching -> unit =
+  fun f ppf m -> match m with
+    | Match_tuple (lst, b) ->
+        fprintf ppf "let (%a) = %a" (list_sep_d string) lst f b
+    | Match_variant lst ->
+        fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
+    | Match_bool {match_true ; match_false} ->
+        fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
+    | Match_list {match_nil ; match_cons = (hd, tl, match_cons)} ->
+        fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" f match_nil hd tl f match_cons
+    | Match_option {match_none ; match_some = (some, match_some)} ->
+        fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none some f match_some
+
+and instruction ppf (i:instruction) = match i with
+  | I_skip -> fprintf ppf "skip"
+  | I_do ae -> fprintf ppf "do %a" annotated_expression ae
+  | I_record_patch (name, path, lst) -> fprintf ppf "%s.%a[%a]" name access_path path (list_sep_d single_record_patch) lst
+  | I_tuple_patch (name, path, lst) -> fprintf ppf "%s.%a[%a]" name access_path path (list_sep_d single_tuple_patch) lst
+  | I_loop (cond, b) -> fprintf ppf "while (%a) { %a }" annotated_expression cond block b
+  | I_assignment {name;annotated_expression = ae} ->
+      fprintf ppf "%s := %a" name annotated_expression ae
+  | I_matching (ae, m) ->
+      fprintf ppf "match %a with %a" annotated_expression ae (matching block) m
+
+let declaration ppf (d:declaration) = match d with
+  | Declaration_type {type_name ; type_expression = te} ->
+      fprintf ppf "type %s = %a" type_name type_expression te
+  | Declaration_constant {name ; annotated_expression = ae} ->
+      fprintf ppf "const %s = %a" name annotated_expression ae
+
+let program ppf (p:program) =
+  fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p)

ast_simplified/ast_simplified.ml

@@ -0,0 +1,8 @@
+include Types
+include Misc
+include Combinators
+
+module Types = Types
+module Misc = Misc
+module PP = PP
+module Combinators = Combinators

ast_simplified/combinators.ml

@@ -0,0 +1,186 @@
+open Types
+open Simple_utils.Trace
+module Option = Simple_utils.Option
+
+module SMap = Map.String
+
+let get_name : named_expression -> string = fun x -> x.name
+let get_type_name : named_type_expression -> string = fun x -> x.type_name
+let get_type_annotation (x:annotated_expression) = x.type_annotation
+let get_expression (x:annotated_expression) = x.expression
+
+let i_assignment : _ -> instruction = fun x -> I_assignment x
+let named_expression name annotated_expression = { name ; annotated_expression }
+let named_typed_expression name expression ty = { name ; annotated_expression = { expression ; type_annotation = Some ty } }
+let typed_expression expression ty = { expression ; type_annotation = Some ty }
+let untyped_expression expression = { expression ; type_annotation = None }
+
+let get_untyped_expression : annotated_expression -> expression result = fun ae ->
+  let%bind () =
+    trace_strong (simple_error "expression is typed") @@
+    Assert.assert_none ae.type_annotation in
+  ok ae.expression
+
+let t_bool      : type_expression = T_constant ("bool", [])
+let t_string    : type_expression = T_constant ("string", [])
+let t_bytes     : type_expression = T_constant ("bytes", [])
+let t_int       : type_expression = T_constant ("int", [])
+let t_operation : type_expression = T_constant ("operation", [])
+let t_nat       : type_expression = T_constant ("nat", [])
+let t_tez       : type_expression = T_constant ("tez", [])
+let t_unit      : type_expression = T_constant ("unit", [])
+let t_address      : type_expression = T_constant ("address", [])
+let t_option  o : type_expression = T_constant ("option", [o])
+let t_list  t : type_expression = T_constant ("list", [t])
+let t_variable n : type_expression = T_variable n
+let t_tuple lst : type_expression = T_tuple lst
+let t_pair (a , b) = t_tuple [a ; b]
+let t_record m  : type_expression = (T_record m)
+
+let t_record_ez lst =
+  let m = SMap.of_list lst in
+  t_record m
+
+let t_sum m : type_expression = T_sum m
+let ez_t_sum (lst:(string * type_expression) list) : type_expression =
+  let aux prev (k, v) = SMap.add k v prev in
+  let map = List.fold_left aux SMap.empty lst in
+  T_sum map
+
+let t_function param result : type_expression = T_function (param, result)
+let t_map key value = (T_constant ("map", [key ; value]))
+
+let make_e_a ?type_annotation expression = {expression ; type_annotation}
+let make_e_a_full expression type_annotation = make_e_a ~type_annotation expression
+
+let make_name (s : string) : name = s
+
+let e_var (s : string) : expression = E_variable s
+
+let e_unit () : expression = E_literal (Literal_unit)
+let e_int n : expression = E_literal (Literal_int n)
+let e_nat n : expression = E_literal (Literal_nat n)
+let e_bool   b : expression = E_literal (Literal_bool b)
+let e_string s : expression = E_literal (Literal_string s)
+let e_address s : expression = E_literal (Literal_address s)
+let e_tez s : expression = E_literal (Literal_tez s)
+let e_bytes  b : expression = E_literal (Literal_bytes (Bytes.of_string b))
+let e_record map : expression = E_record map
+let e_tuple lst : expression = E_tuple lst
+let e_some s : expression = E_constant ("SOME", [s])
+let e_none : expression = E_constant ("NONE", [])
+let e_map lst : expression = E_map lst
+let e_list lst : expression = E_list lst
+let e_pair a b : expression = E_tuple [a; b]
+let e_constructor s a : expression = E_constructor (s , a)
+let e_match a b : expression = E_matching (a , b)
+let e_match_bool a b c : expression = e_match a (Match_bool {match_true = b ; match_false = c})
+let e_accessor a b = E_accessor (a , b)
+let e_accessor_props a b = e_accessor a (List.map (fun x -> Access_record x) b)
+let e_variable v = E_variable v
+let e_failwith v = E_failwith v
+
+let e_a_unit : annotated_expression = make_e_a_full (e_unit ()) t_unit
+let e_a_string s : annotated_expression = make_e_a_full (e_string s) t_string
+let e_a_int n : annotated_expression = make_e_a_full (e_int n) t_int
+let e_a_nat n : annotated_expression = make_e_a_full (e_nat n) t_nat
+let e_a_bool b : annotated_expression = make_e_a_full (e_bool b) t_bool
+let e_a_list lst : annotated_expression = make_e_a (e_list lst)
+let e_a_constructor s a : annotated_expression = make_e_a (e_constructor s a)
+let e_a_address x = make_e_a_full (e_address x) t_address
+let e_a_tez x = make_e_a_full (e_tez x) t_tez
+
+let e_a_record r =
+  let type_annotation = Option.(
+      map ~f:t_record (bind_map_smap get_type_annotation r)
+    ) in
+  make_e_a ?type_annotation (e_record r)
+
+let ez_e_a_record lst =
+  let aux prev (k, v) = SMap.add k v prev in
+  let map = List.fold_left aux SMap.empty lst in
+  e_a_record map
+
+let e_a_tuple lst =
+  let type_annotation = Option.(
+      map ~f:t_tuple (bind_map_list get_type_annotation lst)
+    ) in
+  make_e_a ?type_annotation (e_tuple lst)
+
+let e_a_pair a b =
+  let type_annotation = Option.(
+      map ~f:t_pair
+      @@ bind_map_pair get_type_annotation (a , b)
+    ) in
+  make_e_a ?type_annotation (e_pair a b)
+
+let e_a_some opt =
+  let type_annotation = Option.(
+      map ~f:t_option (get_type_annotation opt)
+    ) in
+  make_e_a ?type_annotation (e_some opt)
+
+let e_a_typed_none t_opt =
+  let type_annotation = t_option t_opt in
+  make_e_a ~type_annotation e_none
+
+let e_a_typed_list lst t =
+  make_e_a ~type_annotation:(t_list t) (e_list lst)
+
+let e_a_map lst k v = make_e_a ~type_annotation:(t_map k v) (e_map lst)
+
+let e_lambda (binder : string)
+    (input_type : type_expression)
+    (output_type : type_expression)
+    (result : expression)
+    (body : block)
+  : expression =
+  E_lambda {
+    binder = (make_name binder) ;
+    input_type = input_type ;
+    output_type = output_type ;
+    result = (make_e_a result) ;
+    body ;
+  }
+
+let e_tuple (lst : ae list) : expression = E_tuple lst
+let ez_e_tuple (lst : expression list) : expression =
+  e_tuple (List.map make_e_a lst)
+
+let e_constructor (s : string) (e : ae) : expression = E_constructor (make_name s, e)
+
+let e_record (lst : (string * ae) list) : expression =
+  let aux prev (k, v) = SMap.add k v prev in
+  let map = List.fold_left aux SMap.empty lst in
+  E_record map
+
+let ez_e_record  (lst : (string * expression) list) : expression =
+  (* TODO: define a correct implementation of List.map
+   * (an implementation that does not fail with stack overflow) *)
+  e_record (List.map (fun (s,e) -> (s, make_e_a e)) lst)
+
+
+let get_a_accessor = fun t ->
+  match t.expression with
+  | E_accessor (a , b) -> ok (a , b)
+  | _ -> simple_fail "not an accessor"
+
+let assert_a_accessor = fun t ->
+  let%bind _ = get_a_accessor t in
+  ok ()
+
+let get_access_record : access -> string result = fun a ->
+  match a with
+  | Access_tuple _
+  | Access_map _ -> simple_fail "not an access record"
+  | Access_record s -> ok s
+
+let get_a_pair = fun t ->
+  match t.expression with
+  | E_tuple [a ; b] -> ok (a , b)
+  | _ -> simple_fail "not a pair"
+
+let get_a_list = fun t ->
+  match t.expression with
+  | E_list lst -> ok lst
+  | _ -> simple_fail "not a pair"

ast_simplified/dune

@@ -0,0 +1,12 @@
+(library
+  (name ast_simplified)
+  (public_name ligo.ast_simplified)
+  (libraries
+    simple-utils
+    tezos-utils
+  )
+  (preprocess
+    (pps simple-utils.ppx_let_generalized)
+  )
+  (flags (:standard -open Simple_utils ))
+)

ast_simplified/misc.ml

@@ -0,0 +1,258 @@
+open Trace
+open Types
+
+let assert_literal_eq (a, b : literal * literal) : unit result =
+  match (a, b) with
+  | Literal_bool a, Literal_bool b when a = b -> ok ()
+  | Literal_bool _, Literal_bool _ -> simple_fail "different bools"
+  | Literal_bool _, _ -> simple_fail "bool vs non-bool"
+  | Literal_int a, Literal_int b when a = b -> ok ()
+  | Literal_int _, Literal_int _ -> simple_fail "different ints"
+  | Literal_int _, _ -> simple_fail "int vs non-int"
+  | Literal_nat a, Literal_nat b when a = b -> ok ()
+  | Literal_nat _, Literal_nat _ -> simple_fail "different nats"
+  | Literal_nat _, _ -> simple_fail "nat vs non-nat"
+  | Literal_tez a, Literal_tez b when a = b -> ok ()
+  | Literal_tez _, Literal_tez _ -> simple_fail "different tezs"
+  | Literal_tez _, _ -> simple_fail "tez vs non-tez"
+  | Literal_string a, Literal_string b when a = b -> ok ()
+  | Literal_string _, Literal_string _ -> simple_fail "different strings"
+  | Literal_string _, _ -> simple_fail "string vs non-string"
+  | Literal_bytes a, Literal_bytes b when a = b -> ok ()
+  | Literal_bytes _, Literal_bytes _ -> simple_fail "different bytess"
+  | Literal_bytes _, _ -> simple_fail "bytes vs non-bytes"
+  | Literal_unit, Literal_unit -> ok ()
+  | Literal_unit, _ -> simple_fail "unit vs non-unit"
+  | Literal_address a, Literal_address b when a = b -> ok ()
+  | Literal_address _, Literal_address _ -> simple_fail "different addresss"
+  | Literal_address _, _ -> simple_fail "address vs non-address"
+  | Literal_operation _, Literal_operation _ -> simple_fail "can't compare operations"
+  | Literal_operation _, _ -> simple_fail "operation vs non-operation"
+
+
+let rec assert_value_eq (a, b: (value*value)) : unit result =
+  let error_content () =
+    Format.asprintf "\n@[<v>- %a@;- %a]" PP.value a PP.value b
+  in
+  trace (fun () -> error (thunk "not equal") error_content ()) @@
+  match (a.expression, b.expression) with
+  | E_literal a, E_literal b ->
+      assert_literal_eq (a, b)
+  | E_constant (ca, lsta), E_constant (cb, lstb) when ca = cb -> (
+      let%bind lst =
+        generic_try (simple_error "constants with different number of elements")
+          (fun () -> List.combine lsta lstb) in
+      let%bind _all = bind_list @@ List.map assert_value_eq lst in
+      ok ()
+    )
+  | E_constant _, E_constant _ ->
+      simple_fail "different constants"
+  | E_constant _, _ ->
+      let error_content () =
+        Format.asprintf "%a vs %a"
+          PP.annotated_expression a
+          PP.annotated_expression b
+      in
+      fail @@ (fun () -> error (thunk "comparing constant with other stuff") error_content ())
+
+  | E_constructor (ca, a), E_constructor (cb, b) when ca = cb -> (
+      let%bind _eq = assert_value_eq (a, b) in
+      ok ()
+    )
+  | E_constructor _, E_constructor _ ->
+      simple_fail "different constructors"
+  | E_constructor _, _ ->
+      simple_fail "comparing constructor with other stuff"
+
+  | E_tuple lsta, E_tuple lstb -> (
+      let%bind lst =
+        generic_try (simple_error "tuples with different number of elements")
+          (fun () -> List.combine lsta lstb) in
+      let%bind _all = bind_list @@ List.map assert_value_eq lst in
+      ok ()
+    )
+  | E_tuple _, _ ->
+      simple_fail "comparing tuple with other stuff"
+
+  | E_record sma, E_record smb -> (
+      let aux _ a b =
+        match a, b with
+        | Some a, Some b -> Some (assert_value_eq (a, b))
+        | _ -> Some (simple_fail "different record keys")
+      in
+      let%bind _all = bind_smap @@ Map.String.merge aux sma smb in
+      ok ()
+    )
+  | E_record _, _ ->
+      simple_fail "comparing record with other stuff"
+
+  | E_map lsta, E_map lstb -> (
+      let%bind lst = generic_try (simple_error "maps of different lengths")
+          (fun () ->
+             let lsta' = List.sort compare lsta in
+             let lstb' = List.sort compare lstb in
+             List.combine lsta' lstb') in
+      let aux = fun ((ka, va), (kb, vb)) ->
+        let%bind _ = assert_value_eq (ka, kb) in
+        let%bind _ = assert_value_eq (va, vb) in
+        ok () in
+      let%bind _all = bind_map_list aux lst in
+      ok ()
+    )
+  | E_map _, _ ->
+      simple_fail "comparing map with other stuff"
+
+  | E_list lsta, E_list lstb -> (
+      let%bind lst =
+        generic_try (simple_error "list of different lengths")
+          (fun () -> List.combine lsta lstb) in
+      let%bind _all = bind_map_list assert_value_eq lst in
+      ok ()
+    )
+  | E_list _, _ ->
+      simple_fail "comparing list with other stuff"
+
+  | _, _ -> simple_fail "comparing not a value"
+
+
+(* module Rename = struct
+ *   open Trace
+ *
+ *   module Type = struct
+ *     (\* Type renaming, not needed. Yet. *\)
+ *   end
+ * 
+ *   module Value = struct
+ *     type renaming = string * (string * access_path) (\* src -> dst *\)
+ *     type renamings = renaming list
+ *     let filter (r:renamings) (s:string) : renamings =
+ *       List.filter (fun (x, _) -> not (x = s)) r
+ *     let filters (r:renamings) (ss:string list) : renamings =
+ *       List.filter (fun (x, _) -> not (List.mem x ss)) r
+ * 
+ *     let rec rename_instruction (r:renamings) (i:instruction) : instruction result =
+ *       match i with
+ *       | I_assignment ({name;annotated_expression = e} as a) -> (
+ *           match List.assoc_opt name r with
+ *           | None ->
+ *               let%bind annotated_expression = rename_annotated_expression (filter r name) e in
+ *               ok (I_assignment {a with annotated_expression})
+ *           | Some (name', lst) -> (
+ *               let%bind annotated_expression = rename_annotated_expression r e in
+ *               match lst with
+ *               | [] -> ok (I_assignment {name = name' ; annotated_expression})
+ *               | lst ->
+ *                   let (hds, tl) =
+ *                     let open List in
+ *                     let r = rev lst in
+ *                     rev @@ tl r, hd r
+ *                   in
+ *                   let%bind tl' = match tl with
+ *                     | Access_record n -> ok n
+ *                     | Access_tuple _ -> simple_fail "no support for renaming into tuples yet" in
+ *                   ok (I_record_patch (name', hds, [tl', annotated_expression]))
+ *             )
+ *         )
+ *       | I_skip -> ok I_skip
+ *       | I_fail e ->
+ *           let%bind e' = rename_annotated_expression r e in
+ *           ok (I_fail e')
+ *       | I_loop (cond, body) ->
+ *           let%bind cond' = rename_annotated_expression r cond in
+ *           let%bind body' = rename_block r body in
+ *           ok (I_loop (cond', body'))
+ *       | I_matching (ae, m) ->
+ *           let%bind ae' = rename_annotated_expression r ae in
+ *           let%bind m' = rename_matching rename_block r m in
+ *           ok (I_matching (ae', m'))
+ *       | I_record_patch (v, path, lst) ->
+ *           let aux (x, y) =
+ *             let%bind y' = rename_annotated_expression (filter r v) y in
+ *             ok (x, y') in
+ *           let%bind lst' = bind_map_list aux lst in
+ *           match List.assoc_opt v r with
+ *           | None -> (
+ *               ok (I_record_patch (v, path, lst'))
+ *             )
+ *           | Some (v', path') -> (
+ *               ok (I_record_patch (v', path' @ path, lst'))
+ *             )
+ *     and rename_block (r:renamings) (bl:block) : block result =
+ *       bind_map_list (rename_instruction r) bl
+ * 
+ *     and rename_matching : type a . (renamings -> a -> a result) -> renamings -> a matching -> a matching result =
+ *       fun f r m ->
+ *       match m with
+ *       | Match_bool { match_true = mt ; match_false = mf } ->
+ *           let%bind match_true = f r mt in
+ *           let%bind match_false = f r mf in
+ *           ok (Match_bool {match_true ; match_false})
+ *       | Match_option { match_none = mn ; match_some = (some, ms) } ->
+ *           let%bind match_none = f r mn in
+ *           let%bind ms' = f (filter r some) ms in
+ *           ok (Match_option {match_none ; match_some = (some, ms')})
+ *       | Match_list { match_nil = mn ; match_cons = (hd, tl, mc) } ->
+ *           let%bind match_nil = f r mn in
+ *           let%bind mc' = f (filters r [hd;tl]) mc in
+ *           ok (Match_list {match_nil ; match_cons = (hd, tl, mc')})
+ *       | Match_tuple (lst, body) ->
+ *           let%bind body' = f (filters r lst) body in
+ *           ok (Match_tuple (lst, body'))
+ * 
+ *     and rename_matching_instruction = fun x -> rename_matching rename_block x
+ * 
+ *     and rename_matching_expr = fun x -> rename_matching rename_expression x
+ * 
+ *     and rename_annotated_expression (r:renamings) (ae:annotated_expression) : annotated_expression result =
+ *       let%bind expression = rename_expression r ae.expression in
+ *       ok {ae with expression}
+ * 
+ *     and rename_expression : renamings -> expression -> expression result = fun r e ->
+ *       match e with
+ *       | E_literal _ as l -> ok l
+ *       | E_constant (name, lst) ->
+ *           let%bind lst' = bind_map_list (rename_annotated_expression r) lst in
+ *           ok (E_constant (name, lst'))
+ *       | E_constructor (name, ae) ->
+ *           let%bind ae' = rename_annotated_expression r ae in
+ *           ok (E_constructor (name, ae'))
+ *       | E_variable v -> (
+ *           match List.assoc_opt v r with
+ *           | None -> ok (E_variable v)
+ *           | Some (name, path) -> ok (E_accessor (ae (E_variable (name)), path))
+ *         )
+ *       | E_lambda ({binder;body;result} as l) ->
+ *           let r' = filter r binder in
+ *           let%bind body = rename_block r' body in
+ *           let%bind result = rename_annotated_expression r' result in
+ *           ok (E_lambda {l with body ; result})
+ *       | E_application (f, arg) ->
+ *           let%bind f' = rename_annotated_expression r f in
+ *           let%bind arg' = rename_annotated_expression r arg in
+ *           ok (E_application (f', arg'))
+ *       | E_tuple lst ->
+ *           let%bind lst' = bind_map_list (rename_annotated_expression r) lst in
+ *           ok (E_tuple lst')
+ *       | E_accessor (ae, p) ->
+ *           let%bind ae' = rename_annotated_expression r ae in
+ *           ok (E_accessor (ae', p))
+ *       | E_record sm ->
+ *           let%bind sm' = bind_smap
+ *             @@ SMap.map (rename_annotated_expression r) sm in
+ *           ok (E_record sm')
+ *       | E_map m ->
+ *           let%bind m' = bind_map_list
+ *             (fun (x, y) -> bind_map_pair (rename_annotated_expression r) (x, y)) m in
+ *           ok (E_map m')
+ *       | E_list lst ->
+ *           let%bind lst' = bind_map_list (rename_annotated_expression r) lst in
+ *           ok (E_list lst')
+ *       | E_look_up m ->
+ *           let%bind m' = bind_map_pair (rename_annotated_expression r) m in
+ *           ok (E_look_up m')
+ *       | E_matching (ae, m) ->
+ *           let%bind ae' = rename_annotated_expression r ae in
+ *           let%bind m' = rename_matching rename_annotated_expression r m in
+ *           ok (E_matching (ae', m'))
+ *   end
+ * end *)

ast_simplified/types.ml

@@ -0,0 +1,126 @@
+module Map = Simple_utils.Map
+module Location = Simple_utils.Location
+
+type name = string
+type type_name = string
+type constructor_name = string
+
+type 'a name_map = 'a Map.String.t
+type 'a type_name_map = 'a Map.String.t
+
+type program = declaration Location.wrap list
+
+and declaration =
+  | Declaration_type of named_type_expression
+  | Declaration_constant of named_expression
+  (* | Macro_declaration of macro_declaration *)
+
+and value = annotated_expression
+
+and annotated_expression = {
+  expression: expression ;
+  type_annotation: te option ;
+}
+
+and named_expression = {
+  name: name ;
+  annotated_expression: ae ;
+}
+
+and named_type_expression = {
+  type_name: type_name ;
+  type_expression: type_expression ;
+}
+
+and te = type_expression
+and ae = annotated_expression
+and te_map = type_expression type_name_map
+and ae_map = annotated_expression name_map
+
+and type_expression =
+  | T_tuple of te list
+  | T_sum of te_map
+  | T_record of te_map
+  | T_function of te * te
+  | T_variable of type_name
+  | T_constant of type_name * te list
+
+and lambda = {
+  binder: name ;
+  input_type: type_expression ;
+  output_type: type_expression ;
+  result: ae ;
+  body: block ;
+}
+
+and expression =
+  (* Base *)
+  | E_literal of literal
+  | E_constant of (name * ae list) (* For language constants, like (Cons hd tl) or (plus i j) *)
+  | E_variable of name
+  | E_lambda of lambda
+  | E_application of (ae * ae)
+  (* E_Tuple *)
+  | E_tuple of ae list
+  (* Sum *)
+  | E_constructor of (name * ae) (* For user defined constructors *)
+  (* E_record *)
+  | E_record of ae_map
+  | E_accessor of (ae * access_path)
+  (* Data Structures *)
+  | E_map of (ae * ae) list
+  | E_list of ae list
+  | E_look_up of (ae * ae)
+  (* Matching *)
+  | E_matching of (ae * matching_expr)
+  | E_failwith of ae
+
+and access =
+  | Access_tuple of int
+  | Access_record of string
+  | Access_map of ae
+
+and access_path = access list
+
+and literal =
+  | Literal_unit
+  | Literal_bool of bool
+  | Literal_int of int
+  | Literal_nat of int
+  | Literal_tez of int
+  | Literal_string of string
+  | Literal_bytes of bytes
+  | Literal_address of string
+  | Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation
+
+and block = instruction list
+and b = block
+
+and instruction =
+  | I_assignment of named_expression
+  | I_matching of ae * matching_instr
+  | I_loop of ae * b
+  | I_skip
+  | I_do of ae
+  | I_record_patch of (name * access_path * (string * ae) list)
+  | I_tuple_patch of (name * access_path * (int * ae) list)
+
+and 'a matching =
+  | Match_bool of {
+      match_true : 'a ;
+      match_false : 'a ;
+    }
+  | Match_list of {
+      match_nil : 'a ;
+      match_cons : name * name * 'a ;
+    }
+  | Match_option of {
+      match_none : 'a ;
+      match_some : name * 'a ;
+    }
+  | Match_tuple of name list * 'a
+  | Match_variant of ((constructor_name * name) * 'a) list
+
+and matching_instr = b matching
+
+and matching_expr = annotated_expression matching

ast_typed/PP.ml

@@ -0,0 +1,115 @@
+open Types
+open Format
+open PP_helpers
+
+let list_sep_d x = list_sep x (const " , ")
+let smap_sep_d x = smap_sep x (const " , ")
+
+
+let rec type_value' ppf (tv':type_value') : unit =
+  match tv' with
+  | T_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d type_value) lst
+  | T_sum m -> fprintf ppf "sum[%a]" (smap_sep_d type_value) m
+  | T_record m -> fprintf ppf "record[%a]" (smap_sep_d type_value) m
+  | T_function (a, b) -> fprintf ppf "%a -> %a" type_value a type_value b
+  | T_constant (c, []) -> fprintf ppf "%s" c
+  | T_constant (c, n) -> fprintf ppf "%s(%a)" c (list_sep_d type_value) n
+
+and type_value ppf (tv:type_value) : unit =
+  type_value' ppf tv.type_value'
+
+let rec annotated_expression ppf (ae:annotated_expression) : unit =
+  match ae.type_annotation.simplified with
+  | Some _ -> fprintf ppf "@[<v>%a:%a@]" expression ae.expression type_value ae.type_annotation
+  | _ -> fprintf ppf "@[<v>%a@]" expression ae.expression
+
+and lambda ppf l =
+  let {binder;input_type;output_type;result;body} = l in
+  fprintf ppf "lambda (%s:%a) : %a {@;  @[<v>%a@]@;} return %a"
+    binder type_value input_type type_value output_type
+    block body annotated_expression result
+
+and expression ppf (e:expression) : unit =
+  match e with
+  | E_literal l -> literal ppf l
+  | E_constant (c, lst) -> fprintf ppf "%s(%a)" c (list_sep_d annotated_expression) lst
+  | E_constructor (c, lst) -> fprintf ppf "%s(%a)" c annotated_expression lst
+  | E_variable a -> fprintf ppf "%s" a
+  | E_application (f, arg) -> fprintf ppf "(%a) (%a)" annotated_expression f annotated_expression arg
+  | E_lambda l -> fprintf ppf "%a" lambda l
+  | E_tuple_accessor (ae, i) -> fprintf ppf "%a.%d" annotated_expression ae i
+  | E_record_accessor (ae, s) -> fprintf ppf "%a.%s" annotated_expression ae s
+  | E_tuple lst -> fprintf ppf "tuple[@;  @[<v>%a@]@;]" (list_sep annotated_expression (tag ",@;")) lst
+  | E_record m -> fprintf ppf "record[%a]" (smap_sep_d annotated_expression) m
+  | E_map m -> fprintf ppf "map[@;  @[<v>%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m
+  | E_list m -> fprintf ppf "list[@;  @[<v>%a@]@;]" (list_sep annotated_expression (tag ",@;")) m
+  | E_look_up (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i
+  | E_matching (ae, m) ->
+      fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m
+  | E_failwith ae -> fprintf ppf "failwith %a" annotated_expression ae
+
+and value ppf v = annotated_expression ppf v
+
+and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) ->
+  fprintf ppf "%a -> %a" annotated_expression a annotated_expression b
+
+and literal ppf (l:literal) : unit =
+  match l with
+  | Literal_unit -> fprintf ppf "unit"
+  | Literal_bool b -> fprintf ppf "%b" b
+  | Literal_int n -> fprintf ppf "%d" n
+  | Literal_nat n -> fprintf ppf "+%d" n
+  | Literal_tez n -> fprintf ppf "%dtz" n
+  | Literal_string s -> fprintf ppf "%s" s
+  | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
+  | Literal_address s -> fprintf ppf "@%s" s
+  | Literal_operation _ -> fprintf ppf "Operation(...bytes)"
+
+and block ppf (b:block) = (list_sep instruction (tag "@;")) ppf b
+
+and single_record_patch ppf ((s, ae) : string * ae) =
+  fprintf ppf "%s <- %a" s annotated_expression ae
+
+and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor_name * name) * a -> unit =
+  fun f ppf ((c,n),a) ->
+  fprintf ppf "| %s %s -> %a" c n f a
+
+and matching : type a . (formatter -> a -> unit) -> _ -> a matching -> unit = fun f ppf m -> match m with
+  | Match_tuple (lst, b) ->
+      fprintf ppf "let (%a) = %a" (list_sep_d (fun ppf -> fprintf ppf "%s")) lst f b
+  | Match_variant (lst , _) ->
+      fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
+  | Match_bool {match_true ; match_false} ->
+      fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
+  | Match_list {match_nil ; match_cons = (hd, tl, match_cons)} ->
+      fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" f match_nil hd tl f match_cons
+  | Match_option {match_none ; match_some = (some, match_some)} ->
+      fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none (fst some) f match_some
+
+and pre_access ppf (a:access) = match a with
+  | Access_record n -> fprintf ppf ".%s" n
+  | Access_tuple i -> fprintf ppf ".%d" i
+  | Access_map n -> fprintf ppf ".%a" annotated_expression n
+
+and instruction ppf (i:instruction) = match i with
+  | I_skip -> fprintf ppf "skip"
+  | I_do ae -> fprintf ppf "do %a" annotated_expression ae
+  | I_loop (cond, b) -> fprintf ppf "while (%a) {@;  @[<v>%a@]@;}" annotated_expression cond block b
+  | I_declaration {name;annotated_expression = ae} ->
+      fprintf ppf "let %s = %a" name annotated_expression ae
+  | I_assignment {name;annotated_expression = ae} ->
+      fprintf ppf "%s := %a" name annotated_expression ae
+  | I_matching (ae, m) ->
+      fprintf ppf "match %a with %a" annotated_expression ae (matching block) m
+  | I_patch (s, p, e) ->
+      fprintf ppf "%s%a := %a"
+        s.type_name (fun ppf -> List.iter (pre_access ppf)) p
+        annotated_expression e
+
+let declaration ppf (d:declaration) =
+  match d with
+  | Declaration_constant ({name ; annotated_expression = ae} , _) ->
+      fprintf ppf "const %s = %a" name annotated_expression ae
+
+let program ppf (p:program) =
+  fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p)

ast_typed/ast_typed.ml

@@ -0,0 +1,12 @@
+module Types = Types
+module Environment = Environment
+module PP = PP
+module Combinators = struct
+  include Combinators
+  include Combinators_environment
+end
+module Misc = Misc
+
+include Types
+include Misc
+include Combinators

ast_typed/combinators.ml

@@ -0,0 +1,213 @@
+open Trace
+open Types
+
+let make_t type_value' simplified = { type_value' ; simplified }
+let make_a_e expression type_annotation environment = { expression ; type_annotation ; dummy_field = () ; environment }
+let make_n_e name a_e = { name ; annotated_expression = a_e }
+
+let t_bool ?s () : type_value = make_t (T_constant ("bool", [])) s
+let t_string ?s () : type_value = make_t (T_constant ("string", [])) s
+let t_bytes ?s () : type_value = make_t (T_constant ("bytes", [])) s
+let t_int ?s () : type_value = make_t (T_constant ("int", [])) s
+let t_address ?s () : type_value = make_t (T_constant ("address", [])) s
+let t_operation ?s () : type_value = make_t (T_constant ("operation", [])) s
+let t_nat ?s () : type_value = make_t (T_constant ("nat", [])) s
+let t_tez ?s () : type_value = make_t (T_constant ("tez", [])) s
+let t_unit ?s () : type_value = make_t (T_constant ("unit", [])) s
+let t_option o ?s () : type_value = make_t (T_constant ("option", [o])) s
+let t_tuple lst ?s () : type_value = make_t (T_tuple lst) s
+let t_list t ?s () : type_value = make_t (T_constant ("list", [t])) s
+let t_contract t ?s () : type_value = make_t (T_constant ("contract", [t])) s
+let t_pair a b ?s () = t_tuple [a ; b] ?s ()
+
+
+let t_record m ?s () : type_value = make_t (T_record m) s
+let make_t_ez_record (lst:(string * type_value) list) : type_value =
+  let aux prev (k, v) = SMap.add k v prev in
+  let map = List.fold_left aux SMap.empty lst in
+  make_t (T_record map) None
+let ez_t_record lst ?s () : type_value =
+  let m = SMap.of_list lst in
+  t_record m ?s ()
+
+let t_map key value ?s () = make_t (T_constant ("map", [key ; value])) s
+
+let t_sum m ?s () : type_value = make_t (T_sum m) s
+let make_t_ez_sum (lst:(string * type_value) list) : type_value =
+  let aux prev (k, v) = SMap.add k v prev in
+  let map = List.fold_left aux SMap.empty lst in
+  make_t (T_sum map) None
+
+let t_function param result ?s () : type_value = make_t (T_function (param, result)) s
+let t_shallow_closure param result ?s () : type_value = make_t (T_function (param, result)) s
+
+let get_type_annotation (x:annotated_expression) = x.type_annotation
+let get_type' (x:type_value) = x.type_value'
+let get_environment (x:annotated_expression) = x.environment
+let get_expression (x:annotated_expression) = x.expression
+
+let get_t_bool (t:type_value) : unit result = match t.type_value' with
+  | T_constant ("bool", []) -> ok ()
+  | _ -> simple_fail "not a bool"
+
+let get_t_unit (t:type_value) : unit result = match t.type_value' with
+  | T_constant ("unit", []) -> ok ()
+  | _ -> simple_fail "not a unit"
+
+let get_t_tez (t:type_value) : unit result = match t.type_value' with
+  | T_constant ("tez", []) -> ok ()
+  | _ -> simple_fail "not a tez"
+
+let get_t_contract (t:type_value) : type_value result = match t.type_value' with
+  | T_constant ("contract", [x]) -> ok x
+  | _ -> simple_fail "not a contract"
+
+let get_t_option (t:type_value) : type_value result = match t.type_value' with
+  | T_constant ("option", [o]) -> ok o
+  | _ -> simple_fail "not a option"
+
+let get_t_list (t:type_value) : type_value result = match t.type_value' with
+  | T_constant ("list", [o]) -> ok o
+  | _ -> simple_fail "not a list"
+
+let get_t_tuple (t:type_value) : type_value list result = match t.type_value' with
+  | T_tuple lst -> ok lst
+  | _ -> simple_fail "not a tuple"
+
+let get_t_pair (t:type_value) : (type_value * type_value) result = match t.type_value' with
+  | T_tuple lst ->
+      let%bind () =
+        trace_strong (simple_error "not a pair") @@
+        Assert.assert_list_size lst 2 in
+      ok List.(nth lst 0 , nth lst 1)
+  | _ -> simple_fail "not a tuple"
+
+let get_t_function (t:type_value) : (type_value * type_value) result = match t.type_value' with
+  | T_function ar -> ok ar
+  | _ -> simple_fail "not a tuple"
+
+let get_t_sum (t:type_value) : type_value SMap.t result = match t.type_value' with
+  | T_sum m -> ok m
+  | _ -> simple_fail "not a sum"
+
+let get_t_record (t:type_value) : type_value SMap.t result = match t.type_value' with
+  | T_record m -> ok m
+  | _ -> simple_fail "not a record type"
+
+let get_t_map (t:type_value) : (type_value * type_value) result =
+  match t.type_value' with
+  | T_constant ("map", [k;v]) -> ok (k, v)
+  | _ -> simple_fail "get: not a map"
+
+let get_t_map_key : type_value -> type_value result = fun t ->
+  let%bind (key , _) = get_t_map t in
+  ok key
+
+let get_t_map_value : type_value -> type_value result = fun t ->
+  let%bind (_ , value) = get_t_map t in
+  ok value
+
+let assert_t_tez :type_value -> unit result = get_t_tez
+
+let assert_t_map (t:type_value) : unit result =
+  match t.type_value' with
+  | T_constant ("map", [_ ; _]) -> ok ()
+  | _ -> simple_fail "not a map"
+
+let assert_t_list (t:type_value) : unit result =
+  match t.type_value' with
+  | T_constant ("list", [_]) -> ok ()
+  | _ -> simple_fail "assert: not a list"
+
+let assert_t_operation (t:type_value) : unit result =
+  match t.type_value' with
+  | T_constant ("operation" , []) -> ok ()
+  | _ -> simple_fail "assert: not an operation"
+
+let assert_t_list_operation (t : type_value) : unit result =
+  let%bind t' = get_t_list t in
+  assert_t_operation t'
+
+let assert_t_int : type_value -> unit result = fun t -> match t.type_value' with
+  | T_constant ("int", []) -> ok ()
+  | _ -> simple_fail "not an int"
+
+let assert_t_nat : type_value -> unit result = fun t -> match t.type_value' with
+  | T_constant ("nat", []) -> ok ()
+  | _ -> simple_fail "not an nat"
+
+let assert_t_bool : type_value -> unit result = fun v -> get_t_bool v
+let assert_t_unit : type_value -> unit result = fun v -> get_t_unit v
+
+let e_record map : expression = E_record map
+let ez_e_record (lst : (string * ae) list) : expression =
+  let aux prev (k, v) = SMap.add k v prev in
+  let map = List.fold_left aux SMap.empty lst in
+  e_record map
+let e_some s : expression = E_constant ("SOME", [s])
+let e_none : expression = E_constant ("NONE", [])
+
+let e_map lst : expression = E_map lst
+
+let e_unit : expression = E_literal (Literal_unit)
+let e_int n : expression = E_literal (Literal_int n)
+let e_nat n : expression = E_literal (Literal_nat n)
+let e_tez n : expression = E_literal (Literal_tez n)
+let e_bool b : expression = E_literal (Literal_bool b)
+let e_string s : expression = E_literal (Literal_string s)
+let e_address s : expression = E_literal (Literal_address s)
+let e_operation s : expression = E_literal (Literal_operation s)
+let e_lambda l : expression = E_lambda l
+let e_pair a b : expression = E_tuple [a; b]
+let e_application a b : expression = E_application (a , b)
+let e_variable v : expression = E_variable v
+let e_list lst : expression = E_list lst
+
+let e_a_unit = make_a_e e_unit (t_unit ())
+let e_a_int n = make_a_e (e_int n) (t_int ())
+let e_a_nat n = make_a_e (e_nat n) (t_nat ())
+let e_a_tez n = make_a_e (e_tez n) (t_tez ())
+let e_a_bool b = make_a_e (e_bool b) (t_bool ())
+let e_a_string s = make_a_e (e_string s) (t_string ())
+let e_a_address s = make_a_e (e_address s) (t_address ())
+let e_a_pair a b = make_a_e (e_pair a b) (t_pair a.type_annotation b.type_annotation ())
+let e_a_some s = make_a_e (e_some s) (t_option s.type_annotation ())
+let e_a_lambda l = make_a_e (e_lambda l) (t_function l.input_type l.output_type ())
+let e_a_none t = make_a_e e_none (t_option t ())
+let e_a_tuple lst = make_a_e (E_tuple lst) (t_tuple (List.map get_type_annotation lst) ())
+let e_a_record r = make_a_e (e_record r) (t_record (SMap.map get_type_annotation r) ())
+let e_a_application a b = make_a_e (e_application a b) (get_type_annotation b)
+let e_a_variable v ty = make_a_e (e_variable v) ty
+let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_annotation) r) ())
+let e_a_map lst k v = make_a_e (e_map lst) (t_map k v ())
+let e_a_list lst t = make_a_e (e_list lst) (t_list t ())
+
+let get_a_int (t:annotated_expression) =
+  match t.expression with
+  | E_literal (Literal_int n) -> ok n
+  | _ -> simple_fail "not an int"
+
+let get_a_unit (t:annotated_expression) =
+  match t.expression with
+  | E_literal (Literal_unit) -> ok ()
+  | _ -> simple_fail "not a unit"
+
+let get_a_bool (t:annotated_expression) =
+  match t.expression with
+  | E_literal (Literal_bool b) -> ok b
+  | _ -> simple_fail "not a bool"
+
+
+let get_a_record_accessor = fun t ->
+  match t.expression with
+  | E_record_accessor (a , b) -> ok (a , b)
+  | _ -> simple_fail "not an accessor"
+
+let get_declaration_by_name : program -> string -> declaration result = fun p name ->
+  let aux : declaration -> bool = fun declaration ->
+    match declaration with
+    | Declaration_constant (d , _) -> d.name = name
+  in
+  trace_option (simple_error "no declaration with given name") @@
+  List.find_opt aux @@ List.map Location.unwrap p
+

ast_typed/combinators_environment.ml

@@ -0,0 +1,28 @@
+open Types
+open Combinators
+
+let make_a_e_empty expression type_annotation = make_a_e expression type_annotation Environment.full_empty
+
+let e_a_empty_unit = e_a_unit Environment.full_empty
+let e_a_empty_int n = e_a_int n Environment.full_empty
+let e_a_empty_nat n = e_a_nat n Environment.full_empty
+let e_a_empty_tez n = e_a_tez n Environment.full_empty
+let e_a_empty_bool b = e_a_bool b Environment.full_empty
+let e_a_empty_string s = e_a_string s Environment.full_empty
+let e_a_empty_address s = e_a_address s Environment.full_empty
+let e_a_empty_pair a b = e_a_pair a b Environment.full_empty
+let e_a_empty_some s = e_a_some s Environment.full_empty
+let e_a_empty_none t = e_a_none t Environment.full_empty
+let e_a_empty_tuple lst = e_a_tuple lst Environment.full_empty
+let e_a_empty_record r = e_a_record r Environment.full_empty
+let e_a_empty_map lst k v = e_a_map lst k v Environment.full_empty
+let e_a_empty_list lst t = e_a_list lst t Environment.full_empty
+let ez_e_a_empty_record r = ez_e_a_record r Environment.full_empty
+let e_a_empty_lambda l = e_a_lambda l Environment.full_empty
+
+open Environment
+
+let env_sum_type ?(env = full_empty)
+    ?(name = "a_sum_type")
+    (lst : (string * type_value) list) =
+  add_type name (make_t_ez_sum lst) env

ast_typed/dune

@@ -0,0 +1,13 @@
+(library
+  (name ast_typed)
+  (public_name ligo.ast_typed)
+  (libraries
+    simple-utils
+    tezos-utils
+    ast_simplified ; Is that a good idea?
+  )
+  (preprocess
+    (pps simple-utils.ppx_let_generalized)
+  )
+  (flags (:standard -open Simple_utils))
+)

ast_typed/environment.ml

@@ -0,0 +1,79 @@
+open Types
+open Combinators
+
+type element = environment_element
+let make_element : type_value -> full_environment -> environment_element_definition -> element =
+  fun type_value source_environment definition -> {type_value ; source_environment ; definition}
+
+let make_element_binder = fun t s -> make_element t s ED_binder
+let make_element_declaration = fun t s d -> make_element t s (ED_declaration d)
+
+module Small = struct
+  type t = small_environment
+
+  let empty : t = ([] , [])
+
+  let get_environment : t -> environment = fst
+  let get_type_environment : t -> type_environment = snd
+  let map_environment : _ -> t -> t = fun f (a , b) -> (f a , b)
+  let map_type_environment : _ -> t -> t = fun f (a , b) -> (a , f b)
+
+  let add : string -> element -> t -> t = fun k v -> map_environment (fun x -> (k , v) :: x)
+  let add_type : string -> type_value -> t -> t = fun k v -> map_type_environment (fun x -> (k , v) :: x)
+  let get_opt : string -> t -> element option = fun k x -> List.assoc_opt k (get_environment x)
+  let get_type_opt : string -> t -> type_value option = fun k x -> List.assoc_opt k (get_type_environment x)
+end
+
+type t = full_environment
+let empty : environment = Small.(get_environment empty)
+let full_empty : t = List.Ne.singleton Small.empty
+let add : string -> element -> t -> t = fun k v -> List.Ne.hd_map (Small.add k v)
+let add_ez_binder : string -> type_value -> t -> t = fun k v e ->
+  List.Ne.hd_map (Small.add k (make_element_binder v e)) e
+let add_ez_declaration : string -> type_value -> expression -> t -> t = fun k v expr e ->
+  List.Ne.hd_map (Small.add k (make_element_declaration v e expr)) e
+let add_ez_ae : string -> annotated_expression -> t -> t = fun k ae e ->
+  add_ez_declaration k (get_type_annotation ae) (get_expression ae) e
+let add_type : string -> type_value -> t -> t = fun k v -> List.Ne.hd_map (Small.add_type k v)
+let get_opt : string -> t -> element option = fun k x -> List.Ne.find_map (Small.get_opt k) x
+let get_type_opt : string -> t -> type_value option = fun k x -> List.Ne.find_map (Small.get_type_opt k) x
+
+let get_constructor : string -> t -> (type_value * type_value) option = fun k x -> (* Left is the constructor, right is the sum type *)
+  let aux = fun x ->
+    let aux = fun (_type_name , x) ->
+      match x.type_value' with
+      | T_sum m when Map.String.mem k m -> Some (Map.String.find k m , x)
+      | _ -> None
+    in
+    List.find_map aux (Small.get_type_environment x) in
+  List.Ne.find_map aux x
+
+
+module PP = struct
+  open Format
+  open PP_helpers
+
+  let list_sep_scope x = list_sep x (const " | ")
+
+  let environment_element = fun ppf (k , (ele : environment_element)) ->
+    fprintf ppf "%s -> %a" k PP.type_value ele.type_value
+
+  let type_environment_element = fun ppf (k , tv) ->
+    fprintf ppf "%s -> %a" k PP.type_value tv
+
+  let environment : _ -> environment -> unit = fun ppf lst ->
+    fprintf ppf "E[%a]" (list_sep environment_element (const " , ")) lst
+
+  let type_environment = fun ppf lst ->
+    fprintf ppf "T[%a]" (list_sep type_environment_element (const " , ")) lst
+
+  let small_environment : _ -> small_environment -> unit = fun ppf e ->
+    fprintf ppf "- %a\t%a"
+      environment (Small.get_environment e)
+      type_environment (Small.get_type_environment e)
+
+  let full_environment : _ -> full_environment -> unit = fun ppf e ->
+    fprintf ppf "@[%a]"
+      (ne_list_sep small_environment (tag "@;")) e
+end
+

ast_typed/misc.ml

@@ -0,0 +1,417 @@
+open Trace
+open Types
+
+module Errors = struct
+  let different_kinds a b () =
+    let title = (thunk "different kinds") in
+    let full () = Format.asprintf "(%a) VS (%a)" PP.type_value a PP.type_value b in
+    error title full ()
+
+  let different_constants a b () =
+    let title = (thunk "different constants") in
+    let full () = Format.asprintf "%s VS %s" a b in
+    error title full ()
+
+  let different_size_type name a b () =
+    let title () = name ^ " have different sizes" in
+    let full () = Format.asprintf "%a VS %a" PP.type_value a PP.type_value b in
+    error title full ()
+
+  let different_size_constants = different_size_type "constants"
+
+  let different_size_tuples = different_size_type "tuples"
+
+  let different_size_sums = different_size_type "sums"
+
+  let different_size_records = different_size_type "records"
+
+end
+
+module Free_variables = struct
+
+  type bindings = string list
+  let mem : string -> bindings -> bool = List.mem
+  let singleton : string -> bindings = fun s -> [ s ]
+  let union : bindings -> bindings -> bindings = (@)
+  let unions : bindings list -> bindings = List.concat
+  let empty : bindings = []
+  let of_list : string list -> bindings = fun x -> x
+
+  let rec expression : bindings -> expression -> bindings = fun b e ->
+    let self = annotated_expression b in
+    match e with
+    | E_lambda l -> lambda b l
+    | E_literal _ -> empty
+    | E_constant (_ , lst) -> unions @@ List.map self lst
+    | E_variable name -> (
+        match mem name b with
+        | true -> empty
+        | false -> singleton name
+      )
+    | E_application (a, b) -> unions @@ List.map self [ a ; b ]
+    | E_tuple lst -> unions @@ List.map self lst
+    | E_constructor (_ , a) -> self a
+    | E_record m -> unions @@ List.map self @@ Map.String.to_list m
+    | E_record_accessor (a, _) -> self a
+    | E_tuple_accessor (a, _) -> self a
+    | E_list lst -> unions @@ List.map self lst
+    | E_map m -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m
+    | E_look_up (a , b) -> unions @@ List.map self [ a ; b ]
+    | E_matching (a , cs) -> union (self a) (matching_expression b cs)
+    | E_failwith a -> self a
+
+  and lambda : bindings -> lambda -> bindings = fun b l ->
+    let b' = union (singleton l.binder) b in
+    let (b'', frees) = block' b' l.body in
+    union (annotated_expression b'' l.result) frees
+
+  and annotated_expression : bindings -> annotated_expression -> bindings = fun b ae ->
+    expression b ae.expression
+
+  and instruction' : bindings -> instruction -> bindings * bindings = fun b i ->
+    match i with
+    | I_declaration n -> union (singleton n.name) b , (annotated_expression b n.annotated_expression)
+    | I_assignment n -> b , (annotated_expression b n.annotated_expression)
+    | I_skip -> b , empty
+    | I_do e -> b , annotated_expression b e
+    | I_loop (a , bl) -> b , union (annotated_expression b a) (block b bl)
+    | I_patch (_ , _ , a) -> b , annotated_expression b a
+    | I_matching (a , cs) -> b , union (annotated_expression b a) (matching_block b cs)
+
+  and block' : bindings -> block -> (bindings * bindings) = fun b bl ->
+    let aux = fun (binds, frees) cur ->
+      let (binds', frees') = instruction' binds cur in
+      (binds', union frees frees') in
+    List.fold_left aux (b , []) bl
+
+  and block : bindings -> block -> bindings = fun b bl ->
+    let (_ , frees) = block' b bl in
+    frees
+
+  and matching_variant_case : type a . (bindings -> a -> bindings) -> bindings -> ((constructor_name * name) * a) -> bindings  = fun f b ((_,n),c) ->
+    f (union (singleton n) b) c
+
+  and matching : type a . (bindings -> a -> bindings) -> bindings -> a matching -> bindings = fun f b m ->
+    match m with
+    | Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa)
+    | Match_list { match_nil = n ; match_cons = (hd, tl, c) } -> union (f b n) (f (union (of_list [hd ; tl]) b) c)
+    | Match_option { match_none = n ; match_some = ((opt, _), s) } -> union (f b n) (f (union (singleton opt) b) s)
+    | Match_tuple (lst , a) -> f (union (of_list lst) b) a
+    | Match_variant (lst , _) -> unions @@ List.map (matching_variant_case f b) lst
+
+  and matching_expression = fun x -> matching annotated_expression x
+
+  and matching_block = fun x -> matching block x
+
+end
+
+(* module Dependencies = struct
+ * 
+ *   type bindings = string list
+ *   let mem : string -> bindings -> bool = List.mem
+ *   let singleton : string -> bindings = fun s -> [ s ]
+ *   let union : bindings -> bindings -> bindings = (@)
+ *   let unions : bindings list -> bindings = List.concat
+ *   let empty : bindings = []
+ *   let of_list : string list -> bindings = fun x -> x
+ * 
+ *   let rec expression : bindings -> full_environment -> expression -> bindings = fun b _env e ->
+ *     let self = annotated_expression b in
+ *     match e with
+ *     | E_lambda l ->
+ *         let b' = union (singleton l.binder) b in
+ *         let (b'', frees) = block' b' l.body in
+ *         union (annotated_expression b'' l.result) frees
+ *     | E_literal _ -> empty
+ *     | E_constant (_ , lst) -> unions @@ List.map self lst
+ *     | E_variable name -> (
+ *         match mem name b with
+ *         | true -> empty
+ *         | false -> singleton name
+ *       )
+ *     | E_application (a, b) -> unions @@ List.map self [ a ; b ]
+ *     | E_tuple lst -> unions @@ List.map self lst
+ *     | E_constructor (_ , a) -> self a
+ *     | E_record m -> unions @@ List.map self @@ Map.String.to_list m
+ *     | E_record_accessor (a, _) -> self a
+ *     | E_tuple_accessor (a, _) -> self a
+ *     | E_list lst -> unions @@ List.map self lst
+ *     | E_map m -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m
+ *     | E_look_up (a , b) -> unions @@ List.map self [ a ; b ]
+ *     | E_matching (a , cs) -> union (self a) (matching_expression b cs)
+ *     | E_failwith a -> self a
+ * 
+ *   and annotated_expression : bindings -> annotated_expression -> bindings = fun b ae ->
+ *     let open Combinators in
+ *     expression b (get_environment ae) (get_expression ae)
+ * 
+ *   and instruction' : bindings -> instruction -> bindings * bindings = fun b i ->
+ *     match i with
+ *     | I_declaration n -> union (singleton n.name) b , (annotated_expression b n.annotated_expression)
+ *     | I_assignment n -> b , (annotated_expression b n.annotated_expression)
+ *     | I_skip -> b , empty
+ *     | I_do e -> b , annotated_expression b e
+ *     | I_loop (a , bl) -> b , union (annotated_expression b a) (block b bl)
+ *     | I_patch (_ , _ , a) -> b , annotated_expression b a
+ *     | I_matching (a , cs) -> b , union (annotated_expression b a) (matching_block b cs)
+ * 
+ *   and block' : bindings -> block -> (bindings * bindings) = fun b bl ->
+ *     let aux = fun (binds, frees) cur ->
+ *       let (binds', frees') = instruction' binds cur in
+ *       (binds', union frees frees') in
+ *     List.fold_left aux (b , []) bl
+ * 
+ *   and block : bindings -> block -> bindings = fun b bl ->
+ *     let (_ , frees) = block' b bl in
+ *     frees
+ * 
+ *   and matching_variant_case : type a . (bindings -> a -> bindings) -> bindings -> ((constructor_name * name) * a) -> bindings  = fun f b ((_,n),c) ->
+ *     f (union (singleton n) b) c
+ * 
+ *   and matching : type a . (bindings -> a -> bindings) -> bindings -> a matching -> bindings = fun f b m ->
+ *     match m with
+ *     | Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa)
+ *     | Match_list { match_nil = n ; match_cons = (hd, tl, c) } -> union (f b n) (f (union (of_list [hd ; tl]) b) c)
+ *     | Match_option { match_none = n ; match_some = ((opt, _), s) } -> union (f b n) (f (union (singleton opt) b) s)
+ *     | Match_tuple (lst , a) -> f (union (of_list lst) b) a
+ *     | Match_variant (lst , _) -> unions @@ List.map (matching_variant_case f b) lst
+ * 
+ *   and matching_expression = fun x -> matching annotated_expression x
+ * 
+ *   and matching_block = fun x -> matching block x
+ * 
+ * end *)
+
+
+open Errors
+
+let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = match (a.type_value', b.type_value') with
+  | T_tuple ta, T_tuple tb -> (
+      let%bind _ =
+        trace_strong (fun () -> (different_size_tuples a b ()))
+        @@ Assert.assert_true List.(length ta = length tb) in
+      bind_list_iter assert_type_value_eq (List.combine ta tb)
+    )
+  | T_tuple _, _ -> fail @@ different_kinds a b
+  | T_constant (ca, lsta), T_constant (cb, lstb) -> (
+      let%bind _ =
+        trace_strong (different_size_constants a b)
+        @@ Assert.assert_true List.(length lsta = length lstb) in
+      let%bind _ =
+        trace_strong (different_constants ca cb)
+        @@ Assert.assert_true (ca = cb) in
+      trace (simple_error "constant sub-expression")
+      @@ bind_list_iter assert_type_value_eq (List.combine lsta lstb)
+    )
+  | T_constant _, _ -> fail @@ different_kinds a b
+  | T_sum sa, T_sum sb -> (
+      let sa' = SMap.to_kv_list sa in
+      let sb' = SMap.to_kv_list sb in
+      let aux ((ka, va), (kb, vb)) =
+        let%bind _ =
+          Assert.assert_true ~msg:"different keys in sum types"
+          @@ (ka = kb) in
+        assert_type_value_eq (va, vb)
+      in
+      let%bind _ =
+        trace_strong (different_size_sums a b)
+        @@ Assert.assert_list_same_size sa' sb' in
+      trace (simple_error "sum type") @@
+      bind_list_iter aux (List.combine sa' sb')
+
+    )
+  | T_sum _, _ -> fail @@ different_kinds a b
+  | T_record ra, T_record rb -> (
+      let ra' = SMap.to_kv_list ra in
+      let rb' = SMap.to_kv_list rb in
+      let aux ((ka, va), (kb, vb)) =
+        let%bind _ =
+          let error =
+            let title () = "different props in record" in
+            let content () = Format.asprintf "%s vs %s" ka kb in
+            error title content in
+          trace_strong error @@
+          Assert.assert_true (ka = kb) in
+        assert_type_value_eq (va, vb)
+      in
+      let%bind _ =
+        trace_strong (different_size_records a b)
+        @@ Assert.assert_list_same_size ra' rb' in
+      trace (simple_error "record type")
+      @@ bind_list_iter aux (List.combine ra' rb')
+
+    )
+  | T_record _, _ -> fail @@ different_kinds a b
+  | T_function (param, result), T_function (param', result') ->
+      let%bind _ = assert_type_value_eq (param, param') in
+      let%bind _ = assert_type_value_eq (result, result') in
+      ok ()
+  | T_function _, _ -> fail @@ different_kinds a b
+
+(* No information about what made it fail *)
+let type_value_eq ab = Trace.to_bool @@ assert_type_value_eq ab
+
+let assert_literal_eq (a, b : literal * literal) : unit result =
+  match (a, b) with
+  | Literal_bool a, Literal_bool b when a = b -> ok ()
+  | Literal_bool _, Literal_bool _ -> simple_fail "different bools"
+  | Literal_bool _, _ -> simple_fail "bool vs non-bool"
+  | Literal_int a, Literal_int b when a = b -> ok ()
+  | Literal_int _, Literal_int _ -> simple_fail "different ints"
+  | Literal_int _, _ -> simple_fail "int vs non-int"
+  | Literal_nat a, Literal_nat b when a = b -> ok ()
+  | Literal_nat _, Literal_nat _ -> simple_fail "different nats"
+  | Literal_nat _, _ -> simple_fail "nat vs non-nat"
+  | Literal_tez a, Literal_tez b when a = b -> ok ()
+  | Literal_tez _, Literal_tez _ -> simple_fail "different tezs"
+  | Literal_tez _, _ -> simple_fail "tez vs non-tez"
+  | Literal_string a, Literal_string b when a = b -> ok ()
+  | Literal_string _, Literal_string _ -> simple_fail "different strings"
+  | Literal_string _, _ -> simple_fail "string vs non-string"
+  | Literal_bytes a, Literal_bytes b when a = b -> ok ()
+  | Literal_bytes _, Literal_bytes _ -> simple_fail "different bytess"
+  | Literal_bytes _, _ -> simple_fail "bytes vs non-bytes"
+  | Literal_unit, Literal_unit -> ok ()
+  | Literal_unit, _ -> simple_fail "unit vs non-unit"
+  | Literal_address a, Literal_address b when a = b -> ok ()
+  | Literal_address _, Literal_address _ -> simple_fail "different addresss"
+  | Literal_address _, _ -> simple_fail "address vs non-address"
+  | Literal_operation _, Literal_operation _ -> simple_fail "can't compare operations"
+  | Literal_operation _, _ -> simple_fail "operation vs non-operation"
+
+
+let rec assert_value_eq (a, b: (value*value)) : unit result =
+  let error_content () =
+    Format.asprintf "\n%a vs %a" PP.value a PP.value b
+  in
+  trace (fun () -> error (thunk "not equal") error_content ()) @@
+  match (a.expression, b.expression) with
+  | E_literal a, E_literal b ->
+      assert_literal_eq (a, b)
+  | E_constant (ca, lsta), E_constant (cb, lstb) when ca = cb -> (
+      let%bind lst =
+        generic_try (simple_error "constants with different number of elements")
+          (fun () -> List.combine lsta lstb) in
+      let%bind _all = bind_list @@ List.map assert_value_eq lst in
+      ok ()
+    )
+  | E_constant _, E_constant _ ->
+      simple_fail "different constants"
+  | E_constant _, _ ->
+      let error_content () =
+        Format.asprintf "%a vs %a"
+          PP.annotated_expression a
+          PP.annotated_expression b
+      in
+      fail @@ (fun () -> error (thunk "comparing constant with other stuff") error_content ())
+
+  | E_constructor (ca, a), E_constructor (cb, b) when ca = cb -> (
+      let%bind _eq = assert_value_eq (a, b) in
+      ok ()
+    )
+  | E_constructor _, E_constructor _ ->
+      simple_fail "different constructors"
+  | E_constructor _, _ ->
+      simple_fail "comparing constructor with other stuff"
+
+  | E_tuple lsta, E_tuple lstb -> (
+      let%bind lst =
+        generic_try (simple_error "tuples with different number of elements")
+          (fun () -> List.combine lsta lstb) in
+      let%bind _all = bind_list @@ List.map assert_value_eq lst in
+      ok ()
+    )
+  | E_tuple _, _ ->
+      simple_fail "comparing tuple with other stuff"
+
+  | E_record sma, E_record smb -> (
+      let aux _ a b =
+        match a, b with
+        | Some a, Some b -> Some (assert_value_eq (a, b))
+        | _ -> Some (simple_fail "different record keys")
+      in
+      let%bind _all = bind_smap @@ SMap.merge aux sma smb in
+      ok ()
+    )
+  | E_record _, _ ->
+      simple_fail "comparing record with other stuff"
+
+  | E_map lsta, E_map lstb -> (
+      let%bind lst = generic_try (simple_error "maps of different lengths")
+          (fun () ->
+             let lsta' = List.sort compare lsta in
+             let lstb' = List.sort compare lstb in
+             List.combine lsta' lstb') in
+      let aux = fun ((ka, va), (kb, vb)) ->
+        let%bind _ = assert_value_eq (ka, kb) in
+        let%bind _ = assert_value_eq (va, vb) in
+        ok () in
+      let%bind _all = bind_map_list aux lst in
+      ok ()
+    )
+  | E_map _, _ ->
+      simple_fail "comparing map with other stuff"
+
+  | E_list lsta, E_list lstb -> (
+      let%bind lst =
+        generic_try (simple_error "list of different lengths")
+          (fun () -> List.combine lsta lstb) in
+      let%bind _all = bind_map_list assert_value_eq lst in
+      ok ()
+    )
+  | E_list _, _ ->
+      simple_fail "comparing list with other stuff"
+
+  | _, _ -> simple_fail "comparing not a value"
+
+let merge_annotation (a:type_value option) (b:type_value option) : type_value result =
+  match a, b with
+  | None, None -> simple_fail "no annotation"
+  | Some a, None -> ok a
+  | None, Some b -> ok b
+  | Some a, Some b ->
+      let%bind _ = assert_type_value_eq (a, b) in
+      match a.simplified, b.simplified with
+      | _, None -> ok a
+      | _, Some _ -> ok b
+
+open Combinators
+
+let program_to_main : program -> string -> lambda result = fun p s ->
+  let%bind (main , input_type , output_type) =
+    let pred = fun d ->
+      match d with
+      | Declaration_constant (d , _) when d.name = s -> Some d.annotated_expression
+      | Declaration_constant _ -> None
+    in
+    let%bind main =
+      trace_option (simple_error "no main with given name") @@
+      List.find_map (Function.compose pred Location.unwrap) p in
+    let%bind (input_ty , output_ty) =
+      match (get_type' @@ get_type_annotation main) with
+      | T_function (i , o) -> ok (i , o)
+      | _ -> simple_fail "program main isn't a function" in
+    ok (main , input_ty , output_ty)
+  in
+  let body =
+    let aux : declaration -> instruction = fun d ->
+      match d with
+      | Declaration_constant (d , _) -> I_declaration d in
+    List.map (Function.compose aux Location.unwrap) p in
+  let env =
+    let aux = fun _ d ->
+      match d with
+      | Declaration_constant (_ , env) -> env in
+    List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in
+  let binder = "@contract_input" in
+  let result =
+    let input_expr = e_a_variable binder input_type env in
+    let main_expr = e_a_variable s (get_type_annotation main) env in
+    e_a_application main_expr input_expr env in
+  ok {
+    binder ;
+    input_type ;
+    output_type ;
+    body ;
+    result ;
+  }

ast_typed/types.ml

@@ -0,0 +1,169 @@
+[@@@warning "-30"]
+
+module S = Ast_simplified
+
+module SMap = Map.String
+
+type name = string
+type type_name = string
+type constructor_name = string
+
+type 'a name_map = 'a SMap.t
+type 'a type_name_map = 'a SMap.t
+
+type program = declaration Location.wrap list
+
+and declaration =
+  | Declaration_constant of (named_expression * full_environment)
+  (* | Macro_declaration of macro_declaration *)
+
+and environment_element_definition =
+  | ED_binder
+  | ED_declaration of expression
+
+and environment_element = {
+  type_value : type_value ;
+  source_environment : full_environment ;
+  definition : environment_element_definition ;
+}
+and environment = (string * environment_element) list
+and type_environment = (string * type_value) list
+and small_environment = (environment * type_environment)
+and full_environment = small_environment List.Ne.t
+
+and annotated_expression = {
+  expression: expression ;
+  type_annotation: tv ;
+  environment: full_environment ;
+  dummy_field: unit ;
+}
+
+and named_expression = {
+  name: name ;
+  annotated_expression: ae ;
+}
+
+and tv = type_value
+and ae = annotated_expression
+and tv_map = type_value type_name_map
+and ae_map = annotated_expression name_map
+
+and type_value' =
+  | T_tuple of tv list
+  | T_sum of tv_map
+  | T_record of tv_map
+  | T_constant of type_name * tv list
+  | T_function of (tv * tv)
+
+and type_value = {
+  type_value' : type_value' ;
+  simplified : S.type_expression option ;
+}
+
+and named_type_value = {
+  type_name: name ;
+  type_value : type_value ;
+}
+
+and lambda = {
+  binder: name ;
+  input_type: tv ;
+  output_type: tv ;
+  result: ae ;
+  body: block ;
+}
+
+and expression =
+  (* Base *)
+  | E_literal of literal
+  | E_constant of (name * ae list) (* For language constants, like (Cons hd tl) or (plus i j) *)
+  | E_variable of name
+  | E_application of (ae * ae)
+  | E_lambda of lambda
+  (* Tuple *)
+  | E_tuple of ae list
+  | E_tuple_accessor of (ae * int) (* Access n'th tuple's element *)
+  (* Sum *)
+  | E_constructor of (name * ae) (* For user defined constructors *)
+  (* Record *)
+  | E_record of ae_map
+  | E_record_accessor of (ae * string)
+  (* Data Structures *)
+  | E_map of (ae * ae) list
+  | E_list of ae list
+  | E_look_up of (ae * ae)
+  (* Advanced *)
+  | E_matching of (ae * matching_expr)
+  | E_failwith of ae
+
+and value = annotated_expression (* todo (for refactoring) *)
+
+and literal =
+  | Literal_unit
+  | Literal_bool of bool
+  | Literal_int of int
+  | Literal_nat of int
+  | Literal_tez of int
+  | Literal_string of string
+  | Literal_bytes of bytes
+  | Literal_address of string
+  | Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation
+
+and block = instruction list
+and b = block
+
+and instruction =
+  | I_declaration of named_expression
+  | I_assignment of named_expression
+  | I_matching of ae * matching_instr
+  | I_loop of ae * b
+  | I_do of ae
+  | I_skip
+  | I_patch of named_type_value * access_path * ae
+
+and access =
+  | Access_tuple of int
+  | Access_record of string
+  | Access_map of ae
+
+and access_path = access list
+
+and 'a matching =
+  | Match_bool of {
+      match_true : 'a ;
+      match_false : 'a ;
+    }
+  | Match_list of {
+      match_nil : 'a ;
+      match_cons : name * name * 'a ;
+    }
+  | Match_option of {
+      match_none : 'a ;
+      match_some : (name * type_value) * 'a ;
+    }
+  | Match_tuple of (name list * 'a)
+  | Match_variant of (((constructor_name * name) * 'a) list * type_value)
+
+and matching_instr = b matching
+
+and matching_expr = ae matching
+
+open Trace
+
+let get_entry (p:program) (entry : string) : annotated_expression result =
+  let aux (d:declaration) =
+    match d with
+    | Declaration_constant ({name ; annotated_expression} , _) when entry = name -> Some annotated_expression
+    | Declaration_constant _ -> None
+  in
+  let%bind result =
+    trace_option (simple_error "no entry point with given name") @@
+    List.find_map aux (List.map Location.unwrap p) in
+  ok result
+
+let get_functional_entry (p:program) (entry : string) : (lambda * type_value) result =
+  let%bind entry = get_entry p entry in
+  match entry.expression with
+  | E_lambda l -> ok (l, entry.type_annotation)
+  | _ -> simple_fail "given entry point is not functional"
+

bin/cli.ml

@@ -0,0 +1,107 @@
+open Cmdliner
+open Trace
+
+let toplevel x =
+  match x with
+  | Trace.Ok ((), annotations) -> ignore annotations; ()
+  | Errors ss ->
+      Format.printf "Errors: %a\n%!" errors_pp @@ List.map (fun f -> f()) ss
+
+let main =
+  let term = Term.(const print_endline $ const "Ligo needs a command. Do ligo --help") in
+  (term , Term.info "ligo")
+
+let compile_file =
+  let f source entry_point =
+    toplevel @@
+    let%bind contract =
+      trace (simple_error "compile michelson") @@
+      Ligo.Contract.compile_contract_file source entry_point in
+    Format.printf "Contract:\n%s\n" contract ;
+    ok ()
+  in
+  let term =
+    let source =
+      let open Arg in
+      let info =
+        let docv = "SOURCE_FILE" in
+        let doc = "$(docv) is the path to the .ligo file of the contract." in
+        info ~docv ~doc [] in
+      required @@ pos 0 (some string) None info in
+    let entry_point =
+      let open Arg in
+      let info =
+        let docv = "ENTRY_POINT" in
+        let doc = "$(docv) is entry-point that will be compiled." in
+        info ~docv ~doc [] in
+      value @@ pos 1 string "main" info in
+    Term.(const f $ source $ entry_point) in
+  let docs = "Compile contracts." in
+  (term , Term.info ~docs "compile-contract")
+
+let compile_parameter =
+  let f source entry_point expression =
+    toplevel @@
+    let%bind value =
+      trace (simple_error "compile-input") @@
+      Ligo.Contract.compile_contract_parameter source entry_point expression in
+    Format.printf "Input:\n%s\n" value;
+    ok ()
+  in
+  let term =
+    let source =
+      let open Arg in
+      let docv = "SOURCE_FILE" in
+      let doc = "$(docv) is the path to the .ligo file of the contract." in
+      let info = info ~docv ~doc [] in
+      required @@ pos 0 (some string) None info in
+    let entry_point =
+      let open Arg in
+      let docv = "ENTRY_POINT" in
+      let doc = "$(docv) is the entry-point of the contract." in
+      let info = info ~docv ~doc [] in
+      required @@ pos 1 (some string) None info in
+    let expression =
+      let open Arg in
+      let docv = "EXPRESSION" in
+      let doc = "$(docv) is the expression that will be compiled." in
+      let info = info ~docv ~doc [] in
+      required @@ pos 2 (some string) None info in
+    Term.(const f $ source $ entry_point $ expression) in
+  let docs = "Compile contracts parameters." in
+  (term , Term.info ~docs "compile-parameter")
+
+let compile_storage =
+  let f source entry_point expression =
+    toplevel @@
+    let%bind value =
+      trace (simple_error "compile-storage") @@
+      Ligo.Contract.compile_contract_storage source entry_point expression in
+    Format.printf "Storage:\n%s\n" value;
+    ok ()
+  in
+  let term =
+    let source =
+      let open Arg in
+      let docv = "SOURCE_FILE" in
+      let doc = "$(docv) is the path to the .ligo file of the contract." in
+      let info = info ~docv ~doc [] in
+      required @@ pos 0 (some string) None info in
+    let entry_point =
+      let open Arg in
+      let docv = "ENTRY_POINT" in
+      let doc = "$(docv) is the entry-point of the contract." in
+      let info = info ~docv ~doc [] in
+      required @@ pos 1 (some string) None info in
+    let expression =
+      let open Arg in
+      let docv = "EXPRESSION" in
+      let doc = "$(docv) is the expression that will be compiled." in
+      let info = info ~docv ~doc [] in
+      required @@ pos 2 (some string) None info in
+    Term.(const f $ source $ entry_point $ expression) in
+  let docs = "Compile contracts storage." in
+  (term , Term.info ~docs "compile-storage")
+
+
+let () = Term.exit @@ Term.eval_choice main [compile_file ; compile_parameter ; compile_storage]

bin/dune

@@ -0,0 +1,14 @@
+(executable
+  (name cli)
+  (public_name ligo)
+  (libraries
+    simple-utils
+    cmdliner
+    ligo
+  )
+  (package ligo)
+  (preprocess
+    (pps simple-utils.ppx_let_generalized)
+  )
+  (flags (:standard -open Simple_utils))
+)

compiler/compiler.ml

@@ -0,0 +1,6 @@
+module Uncompiler = Uncompiler
+module Program = Compiler_program
+module Type = Compiler_type
+module Environment = Compiler_environment
+
+include Program

compiler/compiler_environment.ml

@@ -0,0 +1,277 @@
+open Trace
+open Mini_c
+open Environment
+open Micheline.Michelson
+open Memory_proto_alpha.Script_ir_translator
+
+module Stack = Meta_michelson.Stack
+
+let get : environment -> string -> michelson result = fun e s ->
+  let%bind (type_value , position) =
+    let error =
+      let title () = "Environment.get" in
+      let content () = Format.asprintf "%s in %a"
+          s PP.environment e in
+      error title content in
+    generic_try error @@
+    (fun () -> Environment.get_i s e) in
+  let rec aux = fun n ->
+    match n with
+    | 0 -> i_dup
+    | n -> seq [
+        dip @@ aux (n - 1) ;
+        i_swap ;
+      ]
+  in
+  let code = aux position in
+
+  let%bind () =
+    let error () = ok @@ simple_error "error producing Env.get" in
+    let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
+    let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
+    let output_stack_ty = Stack.(ty @: input_stack_ty) in
+    let%bind _ =
+      Trace.trace_tzresult_lwt_r error @@
+      Memory_proto_alpha.parse_michelson code
+        input_stack_ty output_stack_ty in
+    ok ()
+  in
+
+  ok code
+
+let set : environment -> string -> michelson result = fun e s ->
+  let%bind (type_value , position) =
+    generic_try (simple_error "Environment.get") @@
+    (fun () -> Environment.get_i s e) in
+  let rec aux = fun n ->
+    match n with
+    | 0 -> dip i_drop
+    | n -> seq [
+        i_swap ;
+        dip (aux (n - 1)) ;
+      ]
+  in
+  let code = aux position in
+
+  let%bind () =
+    let error () = ok @@ simple_error "error producing Env.set" in
+    let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in
+    let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
+    let input_stack_ty = Stack.(ty @: env_stack_ty) in
+    let output_stack_ty = env_stack_ty in
+    let%bind _ =
+      Trace.trace_tzresult_lwt_r error @@
+      Memory_proto_alpha.parse_michelson code
+        input_stack_ty output_stack_ty in
+    ok ()
+  in
+
+  ok code
+
+let add : environment -> (string * type_value) -> michelson result = fun e (_s , type_value) ->
+  let code = seq [] in
+
+  let%bind () =
+    let error () = ok @@ simple_error "error producing Env.get" in
+    let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in
+    let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
+    let input_stack_ty = Stack.(ty @: env_stack_ty) in
+    let output_stack_ty = Stack.(ty @: env_stack_ty) in
+    let%bind _ =
+      Trace.trace_tzresult_lwt_r error @@
+      Memory_proto_alpha.parse_michelson code
+        input_stack_ty output_stack_ty in
+    ok ()
+  in
+
+  ok code
+
+let select : environment -> string list -> michelson result = fun e lst ->
+  let module L = Logger.Stateful() in
+  let e_lst =
+    let e_lst = Environment.to_list e in
+    let aux selector (s , _) =
+      L.log @@ Format.asprintf "Selector : %a\n" PP_helpers.(list_sep string (const " , ")) selector ;
+      match List.mem s selector with
+      | true -> List.remove_element s selector , true
+      | false -> selector , false in
+    let e_lst' = List.fold_map_right aux lst e_lst in
+    let e_lst'' = List.combine e_lst e_lst' in
+    e_lst'' in
+  let code =
+    let aux = fun code (_ , b) ->
+      match b with
+      | false -> seq [dip code ; i_drop]
+      | true -> dip code
+    in
+    List.fold_right' aux (seq []) e_lst in
+
+  let%bind () =
+    let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
+    let e' =
+      Environment.of_list
+      @@ List.map fst
+      @@ List.filter snd
+      @@ e_lst
+    in
+    let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e' in
+    let error () =
+      let title () = "error producing Env.select" in
+      let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n"
+          PP.environment e
+          PP.environment e'
+          PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst
+          Micheline.Michelson.pp code
+          (L.get ())
+      in
+      ok @@ (error title content) in
+    let%bind _ =
+      Trace.trace_tzresult_lwt_r error @@
+      Memory_proto_alpha.parse_michelson code
+        input_stack_ty output_stack_ty in
+    ok ()
+  in
+
+  ok code
+
+let clear : environment -> michelson result = fun e -> select e []
+
+let select_env : environment -> environment -> michelson result = fun e e' ->
+  let lst = Environment.get_names e' in
+  select e lst
+
+let pack : environment -> michelson result = fun e ->
+  let%bind () =
+    trace_strong (simple_error "pack empty env") @@
+    Assert.assert_true (List.length e <> 0) in
+  let code = seq @@ List.map (Function.constant i_pair) @@ List.tl e in
+
+  let%bind () =
+    let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
+    let repr = Environment.closure_representation e in
+    let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ repr in
+    let output_stack_ty = Stack.(output_ty @: nil) in
+    let error () =
+      let title () = "error producing Env.pack" in
+      let content () = Format.asprintf ""
+      in
+      ok @@ (error title content) in
+    let%bind _ =
+      Trace.trace_tzresult_lwt_r error @@
+      Memory_proto_alpha.parse_michelson code
+        input_stack_ty output_stack_ty in
+    ok ()
+  in
+
+  ok code
+
+let unpack : environment -> michelson result = fun e ->
+  let%bind () =
+    trace_strong (simple_error "unpack empty env") @@
+    Assert.assert_true (List.length e <> 0) in
+
+  let l = List.length e - 1 in
+  let rec aux n =
+    match n with
+    | 0 -> seq []
+    | n -> seq [
+        i_unpair ;
+        dip (aux (n - 1)) ;
+      ] in
+  let code = aux l in
+
+  let%bind () =
+    let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e in
+    let repr = Environment.closure_representation e in
+    let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ repr in
+    let input_stack_ty = Stack.(input_ty @: nil) in
+    let error () =
+      let title () = "error producing Env.unpack" in
+      let content () = Format.asprintf "\nEnvironment:%a\nType Representation:%a\nCode:%a\n"
+          PP.environment e
+          PP.type_ repr
+          Micheline.Michelson.pp code
+      in
+      ok @@ (error title content) in
+    let%bind _ =
+      Trace.trace_tzresult_lwt_r error @@
+      Memory_proto_alpha.parse_michelson code
+        input_stack_ty output_stack_ty in
+    ok ()
+  in
+
+  ok code
+
+
+let pack_select : environment -> string list -> michelson result = fun e lst ->
+  let module L = Logger.Stateful() in
+  let e_lst =
+    let e_lst = Environment.to_list e in
+    let aux selector (s , _) =
+      L.log @@ Format.asprintf "Selector : %a\n" PP_helpers.(list_sep string (const " , ")) selector ;
+      match List.mem s selector with
+      | true -> List.remove_element s selector , true
+      | false -> selector , false in
+    let e_lst' = List.fold_map_right aux lst e_lst in
+    let e_lst'' = List.combine e_lst e_lst' in
+    e_lst'' in
+  let (_ , code) =
+    let aux = fun (first , code) (_ , b) ->
+      match b with
+      | false -> (first , seq [dip code ; i_swap])
+      | true -> (false ,
+                 match first with
+                 | true -> i_dup
+                 | false -> seq [dip code ; i_dup ; dip i_pair ; i_swap]
+                )
+    in
+    List.fold_right' aux (true , seq []) e_lst in
+
+  let%bind () =
+    let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
+    let e' =
+      Environment.of_list
+      @@ List.map fst
+      @@ List.filter snd
+      @@ e_lst
+    in
+    let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in
+    let output_stack_ty = Stack.(output_ty @: input_stack_ty) in
+    let error () =
+      let title () = "error producing Env.pack_select" in
+      let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n"
+          PP.environment e
+          PP.environment e'
+          PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst
+          Micheline.Michelson.pp code
+          (L.get ())
+      in
+      ok @@ (error title content) in
+    let%bind _ =
+      Trace.trace_tzresult_lwt_r error @@
+      Memory_proto_alpha.parse_michelson code
+        input_stack_ty output_stack_ty in
+    ok ()
+  in
+
+  ok code
+
+let add_packed_anon : environment -> type_value -> michelson result = fun e type_value ->
+  let code = seq [i_pair] in
+
+  let%bind () =
+    let error () = ok @@ simple_error "error producing add packed" in
+    let%bind (Ex_ty input_ty) = Compiler_type.Ty.environment_representation e in
+    let e' = Environment.add ("_add_packed_anon" , type_value) e in
+    let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in
+    let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
+    let input_stack_ty = Stack.(ty @: input_ty @: nil) in
+    let output_stack_ty = Stack.(output_ty @: nil) in
+    let%bind _ =
+      Trace.trace_tzresult_lwt_r error @@
+      Memory_proto_alpha.parse_michelson code
+        input_stack_ty output_stack_ty in
+    ok ()
+  in
+
+  ok code

compiler/compiler_program.ml

@@ -0,0 +1,540 @@
+open Trace
+open Mini_c
+
+module Michelson = Micheline.Michelson
+open Michelson
+module Stack = Meta_michelson.Stack
+module Contract_types = Meta_michelson.Types
+
+open Memory_proto_alpha.Script_ir_translator
+
+open Operators.Compiler
+
+let get_predicate : string -> type_value -> expression list -> predicate result = fun s ty lst ->
+  match Map.String.find_opt s Operators.Compiler.predicates with
+  | Some x -> ok x
+  | None -> (
+      match s with
+      | "MAP_REMOVE" ->
+          let%bind v = match lst with
+            | [ _ ; expr ] ->
+                let%bind (_, v) = Mini_c.Combinators.(get_t_map (Expression.get_type expr)) in
+                ok v
+            | _ -> simple_fail "mini_c . MAP_REMOVE" in
+          let%bind v_ty = Compiler_type.type_ v in
+          ok @@ simple_binary @@ seq [dip (i_none v_ty) ; prim I_UPDATE ]
+      | "LEFT" ->
+          let%bind r = match lst with
+            | [ _ ] -> get_t_right ty
+            | _ -> simple_fail "mini_c . LEFT" in
+          let%bind r_ty = Compiler_type.type_ r in
+          ok @@ simple_unary @@ prim ~children:[r_ty] I_LEFT
+      | "RIGHT" ->
+          let%bind l = match lst with
+            | [ _ ] -> get_t_left ty
+            | _ -> simple_fail "mini_c . RIGHT" in
+          let%bind l_ty = Compiler_type.type_ l in
+          ok @@ simple_unary @@ prim ~children:[l_ty] I_RIGHT
+      | "CONTRACT" ->
+          let%bind r = match lst with
+            | [ _ ] -> get_t_contract ty
+            | _ -> simple_fail "mini_c . CONTRACT" in
+          let%bind r_ty = Compiler_type.type_ r in
+          ok @@ simple_unary @@ seq [
+            prim ~children:[r_ty] I_CONTRACT ;
+            i_assert_some_msg (i_push_string "bad address for get_contract") ;
+          ]
+      | x -> simple_fail ("predicate \"" ^ x ^ "\" doesn't exist")
+    )
+
+let rec translate_value (v:value) : michelson result = match v with
+  | D_bool b -> ok @@ prim (if b then D_True else D_False)
+  | D_int n -> ok @@ int (Z.of_int n)
+  | D_nat n -> ok @@ int (Z.of_int n)
+  | D_tez n -> ok @@ int (Z.of_int n)
+  | D_string s -> ok @@ string s
+  | D_bytes s -> ok @@ bytes (Tezos_stdlib.MBytes.of_bytes s)
+  | D_unit -> ok @@ prim D_Unit
+  | D_pair (a, b) -> (
+      let%bind a = translate_value a in
+      let%bind b = translate_value b in
+      ok @@ prim ~children:[a;b] D_Pair
+    )
+  | D_left a -> translate_value a >>? fun a -> ok @@ prim ~children:[a] D_Left
+  | D_right b -> translate_value b >>? fun b -> ok @@ prim ~children:[b] D_Right
+  | D_function anon -> translate_function anon
+  | D_none -> ok @@ prim D_None
+  | D_some s ->
+      let%bind s' = translate_value s in
+      ok @@ prim ~children:[s'] D_Some
+  | D_map lst ->
+      let%bind lst' = bind_map_list (bind_map_pair translate_value) lst in
+      let aux (a, b) = prim ~children:[a;b] D_Elt in
+      ok @@ seq @@ List.map aux lst'
+  | D_list lst ->
+      let%bind lst' = bind_map_list translate_value lst in
+      ok @@ seq lst'
+  | D_operation _ ->
+      simple_fail "can't compile an operation"
+
+and translate_function (content:anon_function) : michelson result =
+  let%bind body = translate_quote_body content in
+  ok @@ seq [ body ]
+
+and translate_expression ?(first=false) (expr:expression) (env:environment) : (michelson * environment) result =
+  let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in
+  let error_message () = Format.asprintf  "%a" PP.expression expr in
+
+  let return ?env' code =
+    let env' =
+      let default = env in
+      Environment.add ("_tmp_expression" , ty) @@ Option.unopt ~default env' in
+    let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment env in
+    let%bind output_type = Compiler_type.type_ ty in
+    let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment env' in
+    let error_message () =
+      let%bind schema_michelsons = Compiler_type.environment env in
+      ok @@ Format.asprintf
+        "expression : %a\ncode : %a\nschema type : %a\noutput type : %a"
+        PP.expression expr
+        Michelson.pp code
+        PP_helpers.(list_sep Michelson.pp (const ".")) schema_michelsons
+        Michelson.pp output_type
+    in
+    let%bind _ =
+      Trace.trace_tzresult_lwt_r
+        (fun () ->
+           let%bind error_message = error_message () in
+           ok @@ (fun () -> error (thunk "error parsing expression code")
+                                  (fun () -> error_message)
+                                  ())) @@
+      Tezos_utils.Memory_proto_alpha.parse_michelson code
+        input_stack_ty output_stack_ty
+    in
+    ok (code , env')
+  in
+
+  trace (error (thunk "compiling expression") error_message) @@
+  match expr' with
+  | E_capture_environment c ->
+      let%bind code = Compiler_environment.pack_select env c in
+      return @@ code
+  | E_literal v ->
+      let%bind v = translate_value v in
+      let%bind t = Compiler_type.type_ ty in
+      return @@ i_push t v
+  | E_application(f, arg) -> (
+      match Combinators.Expression.get_type f with
+      | T_function _ -> (
+          trace (simple_error "Compiling quote application") @@
+          let%bind (f , env') = translate_expression ~first f env in
+          let%bind (arg , _) = translate_expression arg env' in
+          return @@ seq [
+            i_comment "quote application" ;
+            i_comment "get f" ;
+            f ;
+            i_comment "get arg" ;
+            arg ;
+            prim I_EXEC ;
+          ]
+        )
+      | T_deep_closure (small_env, input_ty , _) -> (
+          trace (simple_error "Compiling deep closure application") @@
+          let%bind (arg' , env') = translate_expression arg env in
+          let%bind (f' , env'') = translate_expression f env' in
+          let%bind f_ty = Compiler_type.type_ f.type_value in
+          let%bind append_closure = Compiler_environment.add_packed_anon small_env input_ty in
+          let error =
+            let error_title () = "michelson type-checking closure application" in
+            let error_content () =
+              Format.asprintf "\nEnv. %a\nEnv'. %a\nEnv''. %a\nclosure. %a ; %a ; %a\narg. %a\n"
+                PP.environment env
+                PP.environment env'
+                PP.environment env''
+                PP.expression_with_type f Michelson.pp f_ty Michelson.pp f'
+                PP.expression_with_type arg
+            in
+            error error_title error_content
+          in
+          trace error @@
+          return @@ seq [
+            i_comment "closure application" ;
+            i_comment "arg" ;
+            arg' ;
+            i_comment "f'" ;
+            f' ; i_unpair ;
+            i_comment "append" ;
+            dip @@ seq [i_swap ; append_closure] ;
+            i_comment "exec" ;
+            i_swap ; i_exec ;
+          ]
+        )
+      | _ -> simple_fail "E_applicationing something not appliable"
+    )
+  | E_variable x ->
+      let%bind code = Compiler_environment.get env x in
+      return code
+  | E_constant(str, lst) ->
+      let module L = Logger.Stateful() in
+      let%bind lst' =
+        let aux env expr =
+          let%bind (code , env') = translate_expression expr env in
+          L.log @@ Format.asprintf "\n%a -> %a in %a\n"
+            PP.expression expr
+            Michelson.pp code
+            PP.environment env ;
+          ok (env' , code)
+        in
+        bind_fold_map_right_list aux env lst in
+      let%bind predicate = get_predicate str ty lst in
+      let pre_code = seq @@ List.rev lst' in
+      let%bind code = match (predicate, List.length lst) with
+        | Constant c, 0 -> ok @@ seq [
+            pre_code ;
+            c ;
+          ]
+        | Unary f, 1 -> ok @@ seq [
+            pre_code ;
+            f ;
+          ]
+        | Binary f, 2 -> ok @@ seq [
+            pre_code ;
+            f ;
+          ]
+        | Ternary f, 3 -> ok @@ seq [
+            pre_code ;
+            f ;
+          ]
+        | _ -> simple_fail "bad arity"
+      in
+      let error =
+        let title () = "error compiling constant" in
+        let content () = L.get () in
+        error title content in
+      trace error @@
+      return code
+  | E_empty_map sd ->
+      let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in
+      return @@ i_empty_map src dst
+  | E_empty_list t ->
+      let%bind t' = Compiler_type.type_ t in
+      return @@ i_nil t'
+  | E_make_none o ->
+      let%bind o' = Compiler_type.type_ o in
+      return @@ i_none o'
+  | E_Cond (c, a, b) -> (
+      let%bind (c' , env') = translate_expression c env in
+      let%bind (a' , _) = translate_expression a env' in
+      let%bind (b' , _) = translate_expression b env' in
+      let%bind code = ok (seq [
+          c' ;
+          i_if a' b' ;
+        ]) in
+      return code
+    )
+  | E_if_none (c, n, (_ , s)) -> (
+      let%bind (c' , _env') = translate_expression c env in
+      let%bind (n' , _) = translate_expression n n.environment in
+      let%bind (s' , _) = translate_expression s s.environment in
+      let%bind restrict_s = Compiler_environment.select_env s.environment env in
+      let%bind code = ok (seq [
+          c' ;
+          i_if_none n' (seq [
+              s' ;
+              restrict_s ;
+            ])
+          ;
+        ]) in
+      return code
+    )
+  | E_if_left (c, (_ , l), (_ , r)) -> (
+      let%bind (c' , _env') = translate_expression c env in
+      let%bind (l' , _) = translate_expression l l.environment in
+      let%bind (r' , _) = translate_expression r r.environment in
+      let%bind restrict_l = Compiler_environment.select_env l.environment env in
+      let%bind restrict_r = Compiler_environment.select_env r.environment env in
+      let%bind code = ok (seq [
+          c' ;
+          i_if_left (seq [
+              l' ;
+              i_comment "restrict left" ;
+              dip restrict_l ;
+            ]) (seq [
+              r' ;
+              i_comment "restrict right" ;
+              dip restrict_r ;
+            ])
+          ;
+        ]) in
+      return code
+    )
+  | E_let_in (v, expr , body) -> (
+      let%bind (expr' , _) = translate_expression expr env in
+      let env' = Environment.add v env in
+      let%bind (body' , _) = translate_expression body env' in
+      let%bind restrict = Compiler_environment.select_env env' env in
+      let%bind code = ok (seq [
+          expr' ;
+          body' ;
+          i_comment "restrict let" ;
+          dip restrict ;
+        ]) in
+      return code
+    )
+
+and translate_statement ((s', w_env) as s:statement) : michelson result =
+  let error_message () = Format.asprintf "%a" PP.statement s in
+  let return code =
+    let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment w_env.pre_environment in
+    let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment w_env.post_environment in
+    let error_message () =
+      let%bind pre_env_michelson = Compiler_type.environment w_env.pre_environment in
+      let%bind post_env_michelson = Compiler_type.environment w_env.post_environment in
+      ok @@ Format.asprintf
+        "statement : %a\ncode : %a\npre type : %a\npost type : %a\n"
+        PP.statement s
+        Michelson.pp code
+        PP_helpers.(list_sep Michelson.pp (const " ; ")) pre_env_michelson
+        PP_helpers.(list_sep Michelson.pp (const " ; ")) post_env_michelson
+    in
+    let%bind _ =
+      Trace.trace_tzresult_lwt_r (fun () -> let%bind error_message = error_message () in
+                                   ok (fun () -> error (thunk "error parsing statement code")
+                                                 (fun () -> error_message)
+                                                 ())) @@
+      Tezos_utils.Memory_proto_alpha.parse_michelson_fail code
+        input_stack_ty output_stack_ty
+    in
+    ok code
+  in
+
+  trace (fun () -> error (thunk "compiling statement") error_message ()) @@ match s' with
+  | S_environment_add _ ->
+      simple_fail "add not ready yet"
+  | S_environment_select sub_env ->
+      let%bind code = Compiler_environment.select_env w_env.pre_environment sub_env in
+      return code
+  | S_environment_load (expr , env) ->
+      let%bind (expr' , _) = translate_expression expr w_env.pre_environment in
+      let%bind clear = Compiler_environment.select w_env.pre_environment [] in
+      let%bind unpack = Compiler_environment.unpack env in
+      return @@ seq [
+        expr' ;
+        dip clear ;
+        unpack ;
+      ]
+  | S_declaration (s, expr) ->
+      let tv = Combinators.Expression.get_type expr in
+      let%bind (expr , _) = translate_expression expr w_env.pre_environment in
+      let%bind add = Compiler_environment.add w_env.pre_environment (s, tv) in
+      return @@ seq [
+        i_comment "declaration" ;
+        seq [
+          i_comment "expr" ;
+          expr ;
+        ] ;
+        seq [
+          i_comment "env <- env . expr" ;
+          add ;
+        ];
+      ]
+  | S_assignment (s, expr) ->
+      let%bind (expr , _) = translate_expression expr w_env.pre_environment in
+      let%bind set = Compiler_environment.set w_env.pre_environment s in
+      return @@ seq [
+        i_comment "assignment" ;
+        seq [
+          i_comment "expr" ;
+          expr ;
+        ] ;
+        seq [
+          i_comment "env <- env . expr" ;
+          set ;
+        ];
+      ]
+  | S_cond (expr, a, b) ->
+      let%bind (expr , _) = translate_expression expr w_env.pre_environment in
+      let%bind a' = translate_regular_block a in
+      let%bind b' = translate_regular_block b in
+      return @@ seq [
+        expr ;
+        prim ~children:[seq [a'];seq [b']] I_IF ;
+      ]
+  | S_do expr -> (
+      match Combinators.Expression.get_content expr with
+      | E_constant ("FAILWITH" , [ fw ] ) -> (
+          let%bind (fw' , _) = translate_expression fw w_env.pre_environment in
+          return @@ seq [
+            fw' ;
+            i_failwith ;
+          ]
+        )
+      | _ -> (
+          let%bind (expr' , _) = translate_expression expr w_env.pre_environment in
+          return @@ seq [
+            expr' ;
+            i_drop ;
+          ]
+        )
+    )
+  | S_if_none (expr, none, ((name, tv), some)) ->
+      let%bind (expr , _) = translate_expression expr w_env.pre_environment in
+      let%bind none' = translate_regular_block none in
+      let%bind some' = translate_regular_block some in
+      let%bind add =
+        let env' = w_env.pre_environment in
+        Compiler_environment.add env' (name, tv) in
+      let%bind restrict_s = Compiler_environment.select_env (snd some).post_environment w_env.pre_environment in
+      return @@ seq [
+        expr ;
+        prim ~children:[
+          seq [none'] ;
+          seq [add ; some' ; restrict_s] ;
+        ] I_IF_NONE
+      ]
+  | S_while (expr, block) ->
+      let%bind (expr , _) = translate_expression expr w_env.pre_environment in
+      let%bind block' = translate_regular_block block in
+      let%bind restrict_block =
+        let env_while = (snd block).pre_environment in
+        Compiler_environment.select_env (snd block).post_environment env_while in
+      return @@ seq [
+        expr ;
+        prim ~children:[seq [
+            block' ;
+            restrict_block ;
+            expr]] I_LOOP ;
+      ]
+  | S_patch (name, lrs, expr) ->
+      let%bind (expr' , env') = translate_expression expr w_env.pre_environment in
+      let%bind get_code = Compiler_environment.get env' name in
+      let modify_code =
+        let aux acc step = match step with
+          | `Left -> seq [dip i_unpair ; acc ; i_pair]
+          | `Right -> seq [dip i_unpiar ; acc ; i_piar]
+        in
+        let init = dip i_drop in
+        List.fold_right' aux init lrs
+      in
+      let%bind set_code = Compiler_environment.set w_env.pre_environment name in
+      let error =
+        let title () = "michelson type-checking patch" in
+        let content () =
+          let aux ppf = function
+            | `Left -> Format.fprintf ppf "left"
+            | `Right -> Format.fprintf ppf "right" in
+          Format.asprintf "Sub path: %a\n"
+            PP_helpers.(list_sep aux (const " , ")) lrs
+        in
+        error title content in
+      trace error @@
+      return @@ seq [
+        expr' ;
+        get_code ;
+        i_swap ; modify_code ;
+        set_code ;
+      ]
+
+and translate_regular_block ((b, env):block) : michelson result =
+  let aux prev statement =
+    let%bind (lst : michelson list) = prev in
+    let%bind instruction = translate_statement statement in
+    ok (instruction :: lst)
+  in
+  let%bind codes =
+    let error_message () =
+      let%bind schema_michelsons = Compiler_type.environment env.pre_environment in
+      ok @@ Format.asprintf "\nblock : %a\nschema : %a\n"
+        PP.block (b, env)
+        PP_helpers.(list_sep Michelson.pp (const " ; ")) schema_michelsons
+    in
+    trace_r (fun () ->
+        let%bind error_message = error_message () in
+        ok (fun () -> error (thunk "compiling regular block")
+                      (fun () -> error_message)
+                      ())) @@
+    List.fold_left aux (ok []) b in
+  let code = seq (List.rev codes) in
+  ok code
+
+and translate_quote_body ({body;result} as f:anon_function) : michelson result =
+  let%bind body' = translate_regular_block body in
+  let%bind (expr , _) = translate_expression result (snd body).post_environment in
+  let%bind restrict = Compiler_environment.clear (snd body).post_environment in
+  let code = seq [
+      i_comment "function body" ;
+      body' ;
+      i_comment "function result" ;
+      expr ;
+      dip restrict ;
+    ] in
+
+  let%bind _assert_type =
+    let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ f.input in
+    let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ f.output in
+    let input_stack_ty = Stack.(input_ty @: nil) in
+    let output_stack_ty = Stack.(output_ty @: nil) in
+    let error_message () =
+      Format.asprintf
+        "\ncode : %a\ninput : %a\noutput : %a\nenv : %a\n"
+        Tezos_utils.Micheline.Michelson.pp code
+        PP.type_ f.input
+        PP.type_ f.output
+        PP.environment (snd body).post_environment
+    in
+    let%bind _ =
+      Trace.trace_tzresult_lwt (
+        error (thunk "error parsing quote code") error_message
+      ) @@
+      Tezos_utils.Memory_proto_alpha.parse_michelson code
+        input_stack_ty output_stack_ty
+    in
+    ok ()
+  in
+
+  ok code
+
+type compiled_program = {
+  input : ex_ty ;
+  output : ex_ty ;
+  body : michelson ;
+}
+
+let get_main : program -> string -> anon_function result = fun p entry ->
+  let is_main (((name , expr), _):toplevel_statement) =
+    match Combinators.Expression.(get_content expr , get_type expr)with
+    | (E_literal (D_function content) , T_function _)
+      when name = entry ->
+        Some content
+    | _ ->  None
+  in
+  let%bind main =
+    trace_option (simple_error "no functional entry") @@
+    List.find_map is_main p
+  in
+  ok main
+
+let translate_program (p:program) (entry:string) : compiled_program result =
+  let%bind main = get_main p entry in
+  let {input;output} : anon_function = main in
+  let%bind body = translate_quote_body main in
+  let%bind input = Compiler_type.Ty.type_ input in
+  let%bind output = Compiler_type.Ty.type_ output in
+  ok ({input;output;body}:compiled_program)
+
+let translate_entry (p:anon_function) : compiled_program result =
+  let {input;output} : anon_function = p in
+  let%bind body =
+    trace (simple_error "compile entry body") @@
+    translate_quote_body p in
+  let%bind input = Compiler_type.Ty.type_ input in
+  let%bind output = Compiler_type.Ty.type_ output in
+  ok ({input;output;body}:compiled_program)
+
+let translate_contract : anon_function -> michelson result = fun f ->
+  let%bind compiled_program = translate_entry f in
+  let%bind (param_ty , storage_ty) = Combinators.get_t_pair f.input in
+  let%bind param_michelson = Compiler_type.type_ param_ty in
+  let%bind storage_michelson = Compiler_type.type_ storage_ty in
+  let contract = Michelson.contract param_michelson storage_michelson compiled_program.body in
+  ok contract

compiler/compiler_type.ml

@@ -0,0 +1,173 @@
+open Trace
+open Mini_c.Types
+
+open Tezos_utils.Memory_proto_alpha
+open Script_ir_translator
+
+module O = Tezos_utils.Micheline.Michelson
+module Contract_types = Meta_michelson.Types
+
+module Ty = struct
+
+  let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) ()
+
+  let comparable_type_base : type_base -> ex_comparable_ty result = fun tb ->
+    let open Contract_types in
+    let return x = ok @@ Ex_comparable_ty x in
+    match tb with
+    | Base_unit -> fail (not_comparable "unit")
+    | Base_bool -> fail (not_comparable "bool")
+    | Base_nat -> return nat_k
+    | Base_tez -> return tez_k
+    | Base_int -> return int_k
+    | Base_string -> return string_k
+    | Base_address -> return address_k
+    | Base_bytes -> return bytes_k
+    | Base_operation -> fail (not_comparable "operation")
+
+  let comparable_type : type_value -> ex_comparable_ty result = fun tv ->
+    match tv with
+    | T_base b -> comparable_type_base b
+    | T_deep_closure _ -> fail (not_comparable "deep closure")
+    | T_function _ -> fail (not_comparable "function")
+    | T_or _ -> fail (not_comparable "or")
+    | T_pair _ -> fail (not_comparable "pair")
+    | T_map _ -> fail (not_comparable "map")
+    | T_list _ -> fail (not_comparable "list")
+    | T_option _ -> fail (not_comparable "option")
+    | T_contract _ -> fail (not_comparable "contract")
+
+  let base_type : type_base -> ex_ty result = fun b ->
+    let open Contract_types in
+    let return x = ok @@ Ex_ty x in
+    match b with
+    | Base_unit -> return unit
+    | Base_bool -> return bool
+    | Base_int -> return int
+    | Base_nat -> return nat
+    | Base_tez -> return tez
+    | Base_string -> return string
+    | Base_address -> return address
+    | Base_bytes -> return bytes
+    | Base_operation -> return operation
+
+  let rec type_ : type_value -> ex_ty result =
+    function
+    | T_base b -> base_type b
+    | T_pair (t, t') -> (
+        type_ t >>? fun (Ex_ty t) ->
+        type_ t' >>? fun (Ex_ty t') ->
+        ok @@ Ex_ty (Contract_types.pair t t')
+      )
+    | T_or (t, t') -> (
+        type_ t >>? fun (Ex_ty t) ->
+        type_ t' >>? fun (Ex_ty t') ->
+        ok @@ Ex_ty (Contract_types.union t t')
+      )
+    | T_function (arg, ret) ->
+        let%bind (Ex_ty arg) = type_ arg in
+        let%bind (Ex_ty ret) = type_ ret in
+        ok @@ Ex_ty (Contract_types.lambda arg ret)
+    | T_deep_closure (c, arg, ret) ->
+        let%bind (Ex_ty capture) = environment_representation c in
+        let%bind (Ex_ty arg) = type_ arg in
+        let%bind (Ex_ty ret) = type_ ret in
+        ok @@ Ex_ty Contract_types.(pair (lambda (pair arg capture) ret) capture)
+    | T_map (k, v) ->
+        let%bind (Ex_comparable_ty k') = comparable_type k in
+        let%bind (Ex_ty v') = type_ v in
+        ok @@ Ex_ty Contract_types.(map k' v')
+    | T_list t ->
+        let%bind (Ex_ty t') = type_ t in
+        ok @@ Ex_ty Contract_types.(list t')
+    | T_option t ->
+        let%bind (Ex_ty t') = type_ t in
+        ok @@ Ex_ty Contract_types.(option t')
+    | T_contract t ->
+        let%bind (Ex_ty t') = type_ t in
+        ok @@ Ex_ty Contract_types.(contract t')
+
+  and environment_representation = function
+    | [] -> ok @@ Ex_ty Contract_types.unit
+    | [a] -> type_ @@ snd a
+    | a::b ->
+        let%bind (Ex_ty a) = type_ @@ snd a in
+        let%bind (Ex_ty b) = environment_representation b in
+        ok @@ Ex_ty (Contract_types.pair a b)
+
+  and environment : environment -> Meta_michelson.Stack.ex_stack_ty result = fun env ->
+    let open Meta_michelson in
+    let%bind lst =
+      bind_map_list type_
+      @@ List.map snd env in
+    let aux (Stack.Ex_stack_ty st) (Ex_ty cur) =
+      Stack.Ex_stack_ty (Stack.stack cur st)
+    in
+    ok @@ List.fold_right' aux (Ex_stack_ty Stack.nil) lst
+
+end
+
+
+let base_type : type_base -> O.michelson result =
+  function
+  | Base_unit -> ok @@ O.prim T_unit
+  | Base_bool -> ok @@ O.prim T_bool
+  | Base_int -> ok @@ O.prim T_int
+  | Base_nat -> ok @@ O.prim T_nat
+  | Base_tez -> ok @@ O.prim T_mutez
+  | Base_string -> ok @@ O.prim T_string
+  | Base_address -> ok @@ O.prim T_address
+  | Base_bytes -> ok @@ O.prim T_bytes
+  | Base_operation -> ok @@ O.prim T_operation
+
+let rec type_ : type_value -> O.michelson result =
+  function
+  | T_base b -> base_type b
+  | T_pair (t, t') -> (
+      type_ t >>? fun t ->
+      type_ t' >>? fun t' ->
+      ok @@ O.prim ~children:[t;t'] O.T_pair
+    )
+  | T_or (t, t') -> (
+      type_ t >>? fun t ->
+      type_ t' >>? fun t' ->
+      ok @@ O.prim ~children:[t;t'] O.T_or
+    )
+  | T_map kv ->
+      let%bind (k', v') = bind_map_pair type_ kv in
+      ok @@ O.prim ~children:[k';v'] O.T_map
+  | T_list t ->
+      let%bind t' = type_ t in
+      ok @@ O.prim ~children:[t'] O.T_list
+  | T_option o ->
+      let%bind o' = type_ o in
+      ok @@ O.prim ~children:[o'] O.T_option
+  | T_contract o ->
+      let%bind o' = type_ o in
+      ok @@ O.prim ~children:[o'] O.T_contract
+  | T_function (arg, ret) ->
+      let%bind arg = type_ arg in
+      let%bind ret = type_ ret in
+      ok @@ O.prim ~children:[arg;ret] T_lambda
+  | T_deep_closure (c, arg, ret) ->
+      let%bind capture = environment_closure c in
+      let%bind arg = type_ arg in
+      let%bind ret = type_ ret in
+      ok @@ O.t_pair (O.t_lambda (O.t_pair arg capture) ret) capture
+
+and environment_element (name, tyv) =
+  let%bind michelson_type = type_ tyv in
+  ok @@ O.annotate ("@" ^ name) michelson_type
+
+and environment = fun env ->
+  bind_map_list type_
+  @@ List.map snd env
+
+and environment_closure =
+  function
+  | [] -> simple_fail "Type of empty env"
+  | [a] -> type_ @@ snd a
+  | a :: b ->
+      let%bind a = type_ @@ snd a in
+      let%bind b = environment_closure b in
+      ok @@ O.t_pair a b

compiler/dune

@@ -0,0 +1,15 @@
+(library
+  (name compiler)
+  (public_name ligo.compiler)
+  (libraries
+    simple-utils
+    tezos-utils
+    meta_michelson
+    mini_c
+    operators
+  )
+  (preprocess
+    (pps simple-utils.ppx_let_generalized)
+  )
+  (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils ))
+)

compiler/uncompiler.ml

@@ -0,0 +1,91 @@
+open Trace
+open Mini_c.Types
+open Memory_proto_alpha
+open Script_typed_ir
+open Script_ir_translator
+
+let rec translate_value (Ex_typed_value (ty, value)) : value result =
+  match (ty, value) with
+  | Pair_t ((a_ty, _, _), (b_ty, _, _), _), (a, b) -> (
+      let%bind a = translate_value @@ Ex_typed_value(a_ty, a) in
+      let%bind b = translate_value @@ Ex_typed_value(b_ty, b) in
+      ok @@ D_pair(a, b)
+    )
+  | Union_t ((a_ty, _), _, _), L a -> (
+      let%bind a = translate_value @@ Ex_typed_value(a_ty, a) in
+      ok @@ D_left a
+    )
+  | Union_t (_, (b_ty, _), _), R b -> (
+      let%bind b = translate_value @@ Ex_typed_value(b_ty, b) in
+      ok @@ D_right b
+    )
+  | (Int_t _), n ->
+      let%bind n =
+        trace_option (simple_error "too big to fit an int") @@
+        Alpha_context.Script_int.to_int n in
+      ok @@ D_int n
+  | (Nat_t _), n ->
+      let%bind n =
+        trace_option (simple_error "too big to fit an int") @@
+        Alpha_context.Script_int.to_int n in
+      ok @@ D_nat n
+  | (Mutez_t _), n ->
+      let%bind n =
+        generic_try (simple_error "too big to fit an int") @@
+        (fun () -> Int64.to_int @@ Alpha_context.Tez.to_mutez n) in
+      ok @@ D_nat n
+  | (Bool_t _), b ->
+      ok @@ D_bool b
+  | (String_t _), s ->
+      ok @@ D_string s
+  | (Address_t _), s ->
+      ok @@ D_string (Alpha_context.Contract.to_b58check s)
+  | (Unit_t _), () ->
+      ok @@ D_unit
+  | (Option_t _), None ->
+      ok @@ D_none
+  | (Option_t ((o_ty, _), _, _)), Some s ->
+      let%bind s' = translate_value @@ Ex_typed_value (o_ty, s) in
+      ok @@ D_some s'
+  | (Map_t (k_cty, v_ty, _)), m ->
+      let k_ty = Script_ir_translator.ty_of_comparable_ty k_cty in
+      let lst =
+        let aux k v acc = (k, v) :: acc in
+        let lst = Script_ir_translator.map_fold aux m [] in
+        List.rev lst in
+      let%bind lst' =
+        let aux (k, v) =
+          let%bind k' = translate_value (Ex_typed_value (k_ty, k)) in
+          let%bind v' = translate_value (Ex_typed_value (v_ty, v)) in
+          ok (k', v')
+        in
+        bind_map_list aux lst
+      in
+      ok @@ D_map lst'
+  | (List_t (ty, _)), lst ->
+      let lst' =
+        let aux acc cur = cur :: acc in
+        let lst = List.fold_left aux lst [] in
+        List.rev lst in
+      let%bind lst'' =
+        let aux = fun t -> translate_value (Ex_typed_value (ty, t)) in
+        bind_map_list aux lst'
+      in
+      ok @@ D_list lst''
+  | (Operation_t _) , op ->
+      ok @@ D_operation op
+  | ty, v ->
+      let%bind error =
+        let%bind m_data =
+          trace_tzresult_lwt (simple_error "unparsing unrecognized data") @@
+          Tezos_utils.Memory_proto_alpha.unparse_michelson_data ty v in
+        let%bind m_ty =
+          trace_tzresult_lwt (simple_error "unparsing unrecognized data") @@
+          Tezos_utils.Memory_proto_alpha.unparse_michelson_ty ty in
+        let error_content () =
+          Format.asprintf "%a : %a"
+            Michelson.pp m_data
+            Michelson.pp m_ty in
+        ok @@ (fun () -> error (thunk "this value can't be transpiled back yet") error_content ())
+      in
+      fail error

contracts/annotation.ligo

@@ -0,0 +1,5 @@
+const lst : list(int) = list [] ;
+
+const address : address = "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" ;
+
+const address_2 : address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address) ;

contracts/arithmetic.ligo

@@ -0,0 +1,17 @@
+function mod_op (const n : int) : nat is
+  begin skip end with n mod 42
+
+function plus_op (const n : int) : int is
+  begin skip end with n + 42
+
+function minus_op (const n : int) : int is
+  begin skip end with n - 42
+
+function times_op (const n : int) : int is
+  begin skip end with n * 42
+
+function div_op (const n : int) : int is
+  begin skip end with n / 2
+
+function int_op (const n : nat) : int is
+  block { skip } with int(n)

contracts/basic.mligo

@@ -0,0 +1,3 @@
+type toto = int
+
+let foo : toto = 42 + 127

contracts/boolean_operators.ligo

@@ -0,0 +1,11 @@
+function or_true (const b : bool) : bool is
+  begin skip end with b or True
+
+function or_false (const b : bool) : bool is
+  begin skip end with b or False
+
+function and_true (const b : bool) : bool is
+  begin skip end with b and True
+
+function and_false (const b : bool) : bool is
+  begin skip end with b and False

contracts/closure.ligo

@@ -0,0 +1,11 @@
+function foo (const i : int) : int is
+  function bar (const j : int) : int is
+    block { skip } with i + j ;
+  block { skip } with bar (i)
+
+function toto (const i : int) : int is
+  function tata (const j : int) : int is
+    block { skip } with i + j ;
+  function titi (const j : int) : int is
+    block { skip } with i + j ;
+  block { skip } with tata(i) + titi(i)

contracts/coase.ligo

@@ -0,0 +1,98 @@
+// Copyright Coase, Inc 2019
+
+type card_pattern_id is nat
+type card_pattern is record [
+  coefficient : tez ;
+  quantity : nat ;
+]
+
+type card_patterns is map(card_pattern_id , card_pattern)
+
+type card_id is nat
+type card is record [
+  card_owner : address ;
+  card_pattern : card_pattern_id ;
+]
+type cards is map(card_id , card)
+
+type storage_type is record [
+  cards : cards ;
+  card_patterns : card_patterns ;
+  next_id : nat ;
+]
+
+type action_buy_single is record [
+  card_to_buy : card_pattern_id ;
+]
+type action_sell_single is record [
+  card_to_sell : card_id ;
+]
+type action_transfer_single is record [
+  card_to_transfer : card_id ;
+  destination : address ;
+]
+
+type action is
+| Buy_single of action_buy_single
+| Sell_single of action_sell_single
+| Transfer_single of action_transfer_single
+
+function transfer_single(const action : action_transfer_single ; const s : storage_type) : (list(operation) * storage_type) is
+  begin
+    const cards : cards = s.cards ;
+    const card : card = get_force(action.card_to_transfer , cards) ;
+    if (card.card_owner =/= source) then fail "This card doesn't belong to you" else skip ;
+    card.card_owner := action.destination ;
+    cards[action.card_to_transfer] := card ;
+    s.cards := cards ;
+    const operations : list(operation) = nil ;
+  end with (operations , s) ;
+
+function sell_single(const action : action_sell_single ; const s : storage_type) : (list(operation) * storage_type) is
+  begin
+    const card : card = get_force(action.card_to_sell , s.cards) ;
+    if (card.card_owner =/= source) then fail "This card doesn't belong to you" else skip ;
+    const card_pattern : card_pattern = get_force(card.card_pattern , s.card_patterns) ;
+    card_pattern.quantity := abs(card_pattern.quantity - 1n);
+    const card_patterns : card_patterns = s.card_patterns ;
+    card_patterns[card.card_pattern] := card_pattern ;
+    s.card_patterns := card_patterns ;
+    const cards : cards = s.cards ;
+    remove action.card_to_sell from map cards ;
+    s.cards := cards ;
+    const price : tez = card_pattern.coefficient * card_pattern.quantity ;
+    const receiver : contract(unit) = get_contract(source) ;
+    const op : operation = transaction(unit , price , receiver) ;
+    const operations : list(operation) = list op end ;
+  end with (operations , s)
+
+function buy_single(const action : action_buy_single ; const s : storage_type) : (list(operation) * storage_type) is
+  begin
+    // Check funds
+    const card_pattern : card_pattern = get_force(action.card_to_buy , s.card_patterns) ;
+    const price : tez = card_pattern.coefficient * (card_pattern.quantity + 1n) ;
+    if (price > amount) then fail "Not enough money" else skip ;
+    // Administrative procedure
+    const operations : list(operation) = nil ;
+    // Increase quantity
+    card_pattern.quantity := card_pattern.quantity + 1n ;
+    const card_patterns : card_patterns = s.card_patterns ;
+    card_patterns[action.card_to_buy] := card_pattern ;
+    s.card_patterns := card_patterns ;
+    // Add card
+    const cards : cards = s.cards ;
+    cards[s.next_id] := record
+      card_owner = source ;
+      card_pattern = action.card_to_buy ;
+    end ;
+    s.cards := cards ;
+    s.next_id := s.next_id + 1n ;
+  end with (operations , s)
+
+function main(const action : action ; const s : storage_type) : (list(operation) * storage_type) is
+  block {skip} with
+  case action of
+  | Buy_single bs -> buy_single (bs , s)
+  | Sell_single as -> sell_single (as , s)
+  | Transfer_single at -> transfer_single (at , s)
+  end

contracts/condition.ligo

@@ -0,0 +1,8 @@
+function main (const i : int) : int is
+  var result : int := 23 ;
+  begin
+    if i = 2 then
+      result := 42
+    else
+      result := 0
+  end with result

contracts/counter.ligo

@@ -0,0 +1,6 @@
+type some_type is int
+
+function main (const p : int ; const s : some_type) : (list(operation) * int) is
+  block { skip } // skip is a do nothing instruction, needed for empty blocks
+  with ((nil : list(operation)), p + s)
+

contracts/counter.mligo

@@ -0,0 +1,4 @@
+type storage = int
+
+let%entry main (p:int) storage =
+  (list [] : operation list , p + storage)

contracts/declarations.ligo

@@ -0,0 +1,6 @@
+const foo : int = 42
+
+function main (const i : int) : int is
+  begin
+    skip
+  end with i + foo

contracts/dispatch-counter.ligo

@@ -0,0 +1,16 @@
+type action is
+| Increment of int
+| Decrement of int
+
+function increment(const i : int ; const n : int) : int is
+  block { skip } with (i + n)
+
+function decrement(const i : int ; const n : int) : int is
+  block { skip } with (i - n)
+
+function main (const p : action ; const s : int) : (list(operation) * int) is
+  block {skip} with ((nil : list(operation)),
+    case p of
+    | Increment n -> increment(s , n)
+    | Decrement n -> decrement(s , n)
+    end)

contracts/function-complex.ligo

@@ -0,0 +1,7 @@
+function main (const i : int) : int is
+  var j : int := 0 ;
+  var k : int := 1 ;
+  begin
+    j := k + i ;
+    k := i + j ;
+  end with (k + j)

contracts/function-shared.ligo

@@ -0,0 +1,8 @@
+function inc ( const i : int ) : int is
+ block { skip } with i + 1
+
+function double_inc ( const i : int ) : int is
+ block { skip } with inc(i + 1)
+
+function foo ( const i : int ) : int is
+ block { skip } with inc(i) + double_inc(i)

contracts/function.ligo

@@ -0,0 +1,4 @@
+function main (const i : int) : int is
+  begin
+    skip
+  end with i

contracts/heap-instance.ligo

@@ -0,0 +1,6 @@
+type heap_element is int * string
+
+function heap_element_lt(const x : heap_element ; const y : heap_element) : bool is
+  block { skip } with x.0 < y.0
+
+#include "heap.ligo"

contracts/heap.ligo

@@ -0,0 +1,90 @@
+type heap is map(nat, heap_element) ;
+
+function is_empty (const h : heap) : bool is
+  block {skip} with size(h) = 0n
+
+function get_top (const h : heap) : heap_element is
+  block {skip} with get_force(1n, h)
+
+function pop_switch (const h : heap) : heap is
+  block {
+   const result : heap_element = get_top (h) ;
+   const s : nat = size(h) ;
+   const last : heap_element = get_force(s, h) ;
+   remove 1n from map h ;
+   h[1n] := last ;
+  } with h
+
+function pop_ (const h : heap) : nat is
+  begin
+   const result : heap_element = get_top (h) ;
+   const s : nat = size(h) ;
+   var current : heap_element := get_force(s, h) ;
+   const i : nat = 1n ;
+   const left : nat = 2n * i ;
+   const right : nat = left + 1n ;
+   remove 1n from map h ;
+   h[1n] := current ;
+   var largest : nat := i ;
+   if (left <= s and heap_element_lt(get_force(s , h) , get_force(left , h))) then
+     largest := left
+   else if (right <= s and heap_element_lt(get_force(s , h) , get_force(right , h))) then
+     largest := right
+   else skip
+  end with largest
+
+function insert (const h : heap ; const e : heap_element) : heap is
+  begin
+    var i : nat := size(h) + 1n ;
+    h[i] := e ;
+    var largest : nat := i ;
+    var parent : nat := 0n ;
+    while (largest =/= i) block {
+      parent := i / 2n ;
+      largest := i ;
+      if (parent >= 1n) then block {
+        if (heap_element_lt(get_force(parent , h) , get_force(i , h))) then block {
+          largest := parent ;
+          const tmp : heap_element = get_force(i , h) ;
+          h[i] := get_force(parent , h) ;
+          h[parent] := tmp ;
+        } else skip
+      } else skip
+    }
+  end with h
+
+function pop (const h : heap) : (heap * heap_element * nat) is
+  begin
+   const result : heap_element = get_top (h) ;
+   var s : nat := size(h) ;
+   const last : heap_element = get_force(s, h) ;
+   remove s from map h ;
+   h[1n] := last ;
+   s := size(h) ;
+   var i : nat := 0n ;
+   var largest : nat := 1n ;
+   var left : nat := 0n ;
+   var right : nat := 0n ;
+   var c : nat := 0n ;
+   while (largest =/= i) block {
+     c := c + 1n ;
+     i := largest ;
+     left := 2n * i ;
+     right := left + 1n ;
+     if (left <= s) then begin
+       if (heap_element_lt(get_force(left , h) , get_force(i , h))) then begin
+        largest := left ;
+        const tmp : heap_element = get_force(i , h) ;
+        h[i] := get_force(left , h) ;
+        h[left] := tmp ;
+       end else skip ;
+     end else if (right <= s) then begin
+       if (heap_element_lt(get_force(right , h) , get_force(i , h))) then begin
+         largest := right ;
+         const tmp : heap_element = get_force(i , h) ;
+         h[i] := get_force(right , h) ;
+         h[left] := tmp ;
+       end else skip ;
+     end else skip ;
+  }
+  end with (h , result , c)

contracts/high-order.ligo

@@ -0,0 +1,6 @@
+function foobar (const i : int) : int is
+  function foo (const i : int) : int is
+    block { skip } with i ;
+  function bar (const f : int -> int) : int is
+    block { skip } with f ( i ) ;
+  block { skip } with bar (foo) ;

contracts/included.ligo

@@ -0,0 +1 @@
+const foo : int = 144

contracts/includer.ligo

@@ -0,0 +1,3 @@
+#include "included.ligo"
+
+const bar : int = foo

contracts/list.ligo

@@ -0,0 +1,19 @@
+type foobar is list(int)
+
+const fb : foobar = list
+  23 ;
+  42 ;
+end
+
+function size_ (const m : foobar) : nat is
+  block {skip} with (size(m))
+
+// function hdf (const m : foobar) : int is begin skip end with hd(m)
+
+const bl : foobar = list
+  144 ;
+  51 ;
+  42 ;
+  120 ;
+  421 ;
+end

contracts/loop.ligo

@@ -0,0 +1,19 @@
+function counter (var n : nat) : nat is block {
+  var i : nat := 0n ;
+  while (i < n) block {
+    i := i + 1n ;
+  }
+} with i
+
+function sum (var n : nat) : nat is block {
+  var i : nat := 0n ;
+  var r : nat := 0n ;
+  while (i < n) block {
+    i := i + 1n ;
+    r := r + i ;
+  }
+} with r
+
+function dummy (const n : nat) : nat is block {
+  while (False) block { skip }
+} with n

contracts/map.ligo

@@ -0,0 +1,33 @@
+type foobar is map(int, int)
+
+const fb : foobar = map
+  23 -> 0 ;
+  42 -> 0 ;
+end
+
+function set_ (var n : int ; var m : foobar) : foobar is block {
+  m[23] := n ;
+} with m
+
+
+function rm (var m : foobar) : foobar is block {
+  remove 42 from map m
+} with m
+
+function size_ (const m : foobar) : nat is
+  block {skip} with (size(m))
+
+function gf (const m : foobar) : int is begin skip end with get_force(23, m)
+
+function get (const m : foobar) : option(int) is
+  begin
+    skip
+  end with m[42]
+
+const bm : foobar = map
+  144 -> 23 ;
+  51 -> 23 ;
+  42 -> 23 ;
+  120 -> 23 ;
+  421 -> 23 ;
+end

contracts/match.ligo

@@ -0,0 +1,31 @@
+function match_bool (const i : int) : int is
+  var result : int := 23 ;
+  begin
+  case i = 2 of
+  | True -> result := 42
+  | False -> result := 0
+  end
+  end with result
+
+function match_option (const o : option(int)) : int is
+  var result : int := 23 ;
+  begin
+  case o of
+  | None -> skip
+  | Some(s) -> result := s
+  end
+  end with result
+
+function match_expr_bool (const i : int) : int is
+  begin skip end with
+  case i = 2 of
+  | True -> 42
+  | False -> 0
+  end
+
+function match_expr_option (const o : option(int)) : int is
+  begin skip end with
+  case o of
+  | None -> 42
+  | Some(s) -> s
+  end

contracts/multiple-parameters.ligo

@@ -0,0 +1,8 @@
+function ab(const a : int; const b : int) : int is
+  begin skip end with (a + b)
+
+function abcd(const a : int; const b : int; const c : int; const d : int) : int is
+  begin skip end with (a + b + c + d + 2)
+
+function abcde(const a : int; const b : int; const c : int; const d : int; const e : int) : int is
+  begin skip end with (c + e + 3)

contracts/new-syntax.mligo

@@ -0,0 +1,21 @@
+(** Type of storage for this contract *)
+type storage = {
+  challenge : string ;
+}
+
+(** Initial storage *)
+let%init storage = {
+  challenge = "" ;
+}
+
+type param = {
+  new_challenge : string ;
+  attempt : bytes ;
+}
+
+let%entry attempt (p:param) storage =
+  if Crypto.hash (Bytes.pack p.attempt) <> Bytes.pack storage.challenge then failwith "Failed challenge" ;
+  let contract : unit contract = Operation.get_contract sender in
+  let transfer : operation = Operation.transaction (unit , contract , 10.00tz) in
+  let storage : storage = storage.challenge <- p.new_challenge in
+  ((list [] : operation list), storage)

contracts/option.ligo

@@ -0,0 +1,4 @@
+type foobar is option(int)
+
+const s : foobar = Some(42)
+const n : foobar = None

contracts/quote-declaration.ligo

@@ -0,0 +1,8 @@
+function foo (const input : int) : int is begin
+   skip
+end with (input + 42)
+
+function main (const i : int) : int is
+  begin
+    skip
+  end with i + foo (i)

contracts/quote-declarations.ligo

@@ -0,0 +1,13 @@
+function foo (const input : int) : int is begin
+   skip
+end with (input + 23)
+
+function bar (const input : int) : int is begin
+   skip
+end with (input + 51)
+
+
+function main (const i : int) : int is
+  begin
+    skip
+  end with foo (i) + bar (i)

contracts/record.ligo

@@ -0,0 +1,56 @@
+type foobar is record
+     foo : int ;
+     bar : int ;
+end
+
+const fb : foobar = record
+  foo = 0 ;
+  bar = 0 ;
+end
+
+type abc is record
+  a : int ;
+  b : int ;
+  c : int ;
+end
+
+const abc : abc = record
+  a = 42 ;
+  b = 142 ;
+  c = 242 ;
+end
+
+const a : int = abc.a ;
+const b : int = abc.b ;
+const c : int = abc.c ;
+
+function projection (const r : foobar) : int is
+  begin
+    skip
+  end with r.foo + r.bar
+
+function modify (const r : foobar) : foobar is
+  block {
+    r.foo := 256 ;
+  } with r
+
+function modify_abc (const r : abc) : abc is
+  block {
+    r.b := 2048 ;
+  } with r
+
+type big_record is record
+     a : int ;
+     b : int ;
+     c : int ;
+     d : int ;
+     e : int ;
+end
+
+const br : big_record = record
+  a = 23 ;
+  b = 23 ;
+  c = 23 ;
+  d = 23 ;
+  e = 23 ;
+end

contracts/shadow.ligo

@@ -0,0 +1,4 @@
+function foo (const i : int) : int is
+  function bar (const i : int) : int is
+    block { skip } with i ;
+  block { skip } with bar (0)

contracts/string.ligo

@@ -0,0 +1 @@
+const s : string = "toto"

contracts/super-counter.ligo

@@ -0,0 +1,10 @@
+type action is
+| Increment of int
+| Decrement of int
+
+function main (const p : action ; const s : int) : (list(operation) * int) is
+  block {skip} with ((nil : list(operation)),
+    case p of
+    | Increment n -> s + n
+    | Decrement n -> s - n
+    end)

contracts/toto.ligo

@@ -0,0 +1,6 @@
+type toto is record
+  a : nat ;
+  b : nat
+end
+
+const foo : int = 3

contracts/tuple.ligo

@@ -0,0 +1,22 @@
+type abc is (int * int * int)
+
+function projection_abc (const tpl : abc) : int is
+  block { skip } with tpl.1
+
+function modify_abc (const tpl : abc) : abc is
+  block {
+    tpl.1 := 2048 ;
+  } with tpl
+
+type foobar is (int * int)
+
+const fb : foobar = (0, 0)
+
+function projection (const tpl : foobar) : int is
+  begin
+    skip
+  end with tpl.0 + tpl.1
+
+type big_tuple is (int * int * int * int * int)
+
+const br : big_tuple = (23, 23, 23, 23, 23)

contracts/unit.ligo

@@ -0,0 +1 @@
+const u : unit = unit

contracts/variant-matching.ligo

@@ -0,0 +1,11 @@
+type foobar is
+| Foo of int
+| Bar of bool
+| Kee of nat
+
+function fb(const p : foobar) : int is
+  block { skip } with (case p of
+  | Foo (n) -> n
+  | Bar (t) -> 42
+  | Kee (n) -> 23
+  end)

contracts/variant.ligo

@@ -0,0 +1,10 @@
+type foobar is
+| Foo of int
+| Bar of bool
+| Kee of nat
+
+const foo : foobar = Foo (42)
+
+const bar : foobar = Bar (True)
+
+const kee : foobar = Kee (23n)

dune

@@ -0,0 +1,25 @@
+(library
+  (name ligo)
+  (public_name ligo)
+  (libraries
+    simple-utils
+    tezos-utils
+    tezos-micheline
+    meta_michelson
+    main
+  )
+  (preprocess
+    (pps simple-utils.ppx_let_generalized)
+  )
+)
+
+(alias
+( name ligo-test)
+  (action (run test/test.exe))
+  (deps (glob_files contracts/*))
+)
+
+(alias
+  (name runtest)
+  (deps (alias ligo-test))
+)

dune-project

@@ -0,0 +1,2 @@
+(lang dune 1.6)
+(using menhir 2.0)

ligo.ml

@@ -0,0 +1 @@
+include Main

ligo.opam

@@ -0,0 +1,28 @@
+name: "ligo"
+opam-version: "2.0"
+version: "1.0"
+maintainer: "gabriel.alfour@gmail.com"
+authors: [ "Galfour" ]
+homepage: "https://gitlab.com/gabriel.alfour/tezos"
+bug-reports: "https://gitlab.com/gabriel.alfour/tezos/issues"
+synopsis: "A higher-level language which compiles to Michelson"
+dev-repo: "git+https://gitlab.com/gabriel.alfour/tezos.git"
+license: "MIT"
+depends: [
+  "ocamlfind" { build }
+  "dune" { build & >= "1.0.1" }
+  "menhir"
+  "ppx_let"
+  "ppx_deriving"
+  "tezos-utils"
+  "yojson"
+  "alcotest" { with-test }
+]
+build: [
+  [ "dune" "build" "-p" name "-j" jobs ]
+  # needed in the repository, but must not be present in the local ligo.opam [ "mv" "src/ligo/ligo.install" "." ]
+]
+
+url {
+  src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz"
+}

main/contract.ml

@@ -0,0 +1,178 @@
+open Trace
+
+include struct
+  open Ast_simplified
+  open Combinators
+
+  let assert_entry_point_defined : program -> string -> unit result =
+    fun program entry_point ->
+      let aux : declaration -> bool = fun declaration ->
+        match declaration with
+        | Declaration_type _ -> false
+        | Declaration_constant ne -> get_name ne = entry_point
+      in
+      trace_strong (simple_error "no entry-point with given name") @@
+      Assert.assert_true @@ List.exists aux @@ List.map Location.unwrap program
+end
+
+include struct
+  open Ast_typed
+  open Combinators
+
+  let get_entry_point_type : type_value -> (type_value * type_value) result = fun t ->
+    let%bind (arg , result) =
+      trace_strong (simple_error "entry-point doesn't have a function type") @@
+      get_t_function t in
+    let%bind (arg' , storage_param) =
+      trace_strong (simple_error "entry-point doesn't have 2 parameters") @@
+      get_t_pair arg in
+    let%bind (ops , storage_result) =
+      trace_strong (simple_error "entry-point doesn't have 2 results") @@
+      get_t_pair result in
+    let%bind () =
+      trace_strong (simple_error "entry-point doesn't have a list of operation as first result") @@
+      assert_t_list_operation ops in
+    let%bind () =
+      trace_strong (simple_error "entry-point doesn't identitcal type (storage) for second parameter and second result") @@
+      assert_type_value_eq (storage_param , storage_result) in
+    ok (arg' , storage_param)
+
+  let get_entry_point : program -> string -> (type_value * type_value) result = fun p e ->
+    let%bind declaration = get_declaration_by_name p e in
+    match declaration with
+    | Declaration_constant (d , _) -> get_entry_point_type d.annotated_expression.type_annotation
+
+  let assert_valid_entry_point = fun p e ->
+    let%bind _ = get_entry_point p e in
+    ok ()
+end
+
+let transpile_value
+    (e:Ast_typed.annotated_expression) : Mini_c.value result =
+  let%bind f =
+    let open Transpiler in
+    let (f , _) = functionalize e in
+    let%bind main = translate_main f in
+    ok main
+  in
+
+  let input = Mini_c.Combinators.d_unit in
+  let%bind r = Run_mini_c.run_entry f input in
+  ok r
+
+let compile_contract_file : string -> string -> string result = fun source entry_point ->
+  let%bind raw =
+    trace (simple_error "parsing") @@
+    Parser.parse_file source in
+  let%bind simplified =
+    trace (simple_error "simplifying") @@
+    Simplify.Pascaligo.simpl_program raw in
+  let%bind () =
+    assert_entry_point_defined simplified entry_point in
+  let%bind typed =
+    trace (simple_error "typing") @@
+    Typer.type_program simplified in
+  let%bind mini_c =
+    trace (simple_error "transpiling") @@
+    Transpiler.translate_entry typed entry_point in
+  let%bind michelson =
+    trace (simple_error "compiling") @@
+    Compiler.translate_contract mini_c in
+  let str =
+    Format.asprintf "%a" Micheline.Michelson.pp_stripped michelson in
+  ok str
+
+let compile_contract_parameter : string -> string -> string -> string result = fun source entry_point expression ->
+  let%bind (program , parameter_tv) =
+    let%bind raw =
+      trace (simple_error "parsing file") @@
+      Parser.parse_file source in
+    let%bind simplified =
+      trace (simple_error "simplifying file") @@
+      Simplify.Pascaligo.simpl_program raw in
+    let%bind () =
+      assert_entry_point_defined simplified entry_point in
+    let%bind typed =
+      trace (simple_error "typing file") @@
+      Typer.type_program simplified in
+    let%bind (param_ty , _) =
+      get_entry_point typed entry_point in
+    ok (typed , param_ty)
+  in
+  let%bind expr =
+    let%bind raw =
+      trace (simple_error "parsing expression") @@
+      Parser.parse_expression expression in
+    let%bind simplified =
+      trace (simple_error "simplifying expression") @@
+      Simplify.Pascaligo.simpl_expression raw in
+    let%bind typed =
+      let env =
+        let last_declaration = Location.unwrap List.(hd @@ rev program) in
+        match last_declaration with
+        | Declaration_constant (_ , env) -> env
+      in
+      trace (simple_error "typing expression") @@
+      Typer.type_annotated_expression env simplified in
+    let%bind () =
+      trace (simple_error "expression type doesn't match type parameter") @@
+      Ast_typed.assert_type_value_eq (parameter_tv , typed.type_annotation) in
+    let%bind mini_c =
+      trace (simple_error "transpiling expression") @@
+      transpile_value typed in
+    let%bind michelson =
+      trace (simple_error "compiling expression") @@
+      Compiler.translate_value mini_c in
+    let str =
+      Format.asprintf "%a" Micheline.Michelson.pp_stripped michelson in
+    ok str
+  in
+  ok expr
+
+
+let compile_contract_storage : string -> string -> string -> string result = fun source entry_point expression ->
+  let%bind (program , storage_tv) =
+    let%bind raw =
+      trace (simple_error "parsing file") @@
+      Parser.parse_file source in
+    let%bind simplified =
+      trace (simple_error "simplifying file") @@
+      Simplify.Pascaligo.simpl_program raw in
+    let%bind () =
+      assert_entry_point_defined simplified entry_point in
+    let%bind typed =
+      trace (simple_error "typing file") @@
+      Typer.type_program simplified in
+    let%bind (_ , storage_ty) =
+      get_entry_point typed entry_point in
+    ok (typed , storage_ty)
+  in
+  let%bind expr =
+    let%bind raw =
+      trace (simple_error "parsing expression") @@
+      Parser.parse_expression expression in
+    let%bind simplified =
+      trace (simple_error "simplifying expression") @@
+      Simplify.Pascaligo.simpl_expression raw in
+    let%bind typed =
+      let env =
+        let last_declaration = Location.unwrap List.(hd @@ rev program) in
+        match last_declaration with
+        | Declaration_constant (_ , env) -> env
+      in
+      trace (simple_error "typing expression") @@
+      Typer.type_annotated_expression env simplified in
+    let%bind () =
+      trace (simple_error "expression type doesn't match type storage") @@
+      Ast_typed.assert_type_value_eq (storage_tv , typed.type_annotation) in
+    let%bind mini_c =
+      trace (simple_error "transpiling expression") @@
+      transpile_value typed in
+    let%bind michelson =
+      trace (simple_error "compiling expression") @@
+      Compiler.translate_value mini_c in
+    let str =
+      Format.asprintf "%a" Micheline.Michelson.pp_stripped michelson in
+    ok str
+  in
+  ok expr

main/dune

@@ -0,0 +1,21 @@
+(library
+  (name main)
+  (public_name ligo.main)
+  (libraries
+    simple-utils
+    tezos-utils
+    parser
+    simplify
+    ast_simplified
+    typer
+    ast_typed
+    transpiler
+    mini_c
+    operators
+    compiler
+  )
+  (preprocess
+    (pps simple-utils.ppx_let_generalized)
+  )
+  (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils ))
+)

main/main.ml

@@ -0,0 +1,197 @@
+module Run_mini_c = Run_mini_c
+
+open Trace
+module Parser = Parser
+module AST_Raw = Parser.Pascaligo.AST
+module AST_Simplified = Ast_simplified
+module AST_Typed = Ast_typed
+module Mini_c = Mini_c
+module Typer = Typer
+module Transpiler = Transpiler
+(* module Parser_multifix = Multifix
+ * module Simplify_multifix = Simplify_multifix *)
+
+
+let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.Pascaligo.simpl_program p
+let simplify_expr (e:AST_Raw.expr) : Ast_simplified.annotated_expression result = Simplify.Pascaligo.simpl_expression e
+let unparse_simplified_expr (e:AST_Simplified.annotated_expression) : string result =
+  ok @@ Format.asprintf "%a" AST_Simplified.PP.annotated_expression e
+
+let type_ (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p
+let type_expression ?(env:Typer.Environment.t = Typer.Environment.full_empty)
+    (e:AST_Simplified.annotated_expression) : AST_Typed.annotated_expression result =
+  Typer.type_annotated_expression env e
+let untype_expression (e:AST_Typed.annotated_expression) : AST_Simplified.annotated_expression result = Typer.untype_annotated_expression e
+
+let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p
+let transpile_entry (p:AST_Typed.program) (name:string) : Mini_c.anon_function result = Transpiler.translate_entry p name
+let transpile_expression ?(env:Mini_c.Environment.t = Mini_c.Environment.empty)
+    (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression env e
+let transpile_value
+    (e:AST_Typed.annotated_expression) : Mini_c.value result =
+  let%bind f =
+    let open Transpiler in
+    let (f , _) = functionalize e in
+    let%bind main = translate_main f in
+    ok main
+  in
+
+  let input = Mini_c.Combinators.d_unit in
+  let%bind r = Run_mini_c.run_entry f input in
+  ok r
+
+let untranspile_value (v : Mini_c.value) (e:AST_Typed.type_value) : AST_Typed.annotated_expression result =
+  Transpiler.untranspile v e
+
+let compile : Mini_c.program -> string -> Compiler.Program.compiled_program result = Compiler.Program.translate_program
+
+let type_file ?(debug_simplify = false) ?(debug_typed = false)
+    (path:string) : AST_Typed.program result =
+  let%bind raw = Parser.parse_file path in
+  let%bind simpl =
+    trace (simple_error "simplifying") @@
+    simplify raw in
+  (if debug_simplify then
+     Format.(printf "Simplified : %a\n%!" AST_Simplified.PP.program simpl)
+  ) ;
+  let%bind typed =
+    trace (simple_error "typing") @@
+    type_ simpl in
+  (if debug_typed then (
+      Format.(printf "Typed : %a\n%!" AST_Typed.PP.program typed)
+    )) ;
+  ok typed
+
+
+let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.annotated_expression result =
+  let%bind result =
+    let%bind mini_c_main =
+      transpile_entry program entry in
+    Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in
+  let%bind typed_result =
+    let%bind typed_main = Ast_typed.get_entry program entry in
+    untranspile_value result typed_main.type_annotation in
+  ok typed_result
+
+let easy_evaluate_typed_simplified (entry:string) (program:AST_Typed.program) : Ast_simplified.annotated_expression result =
+  let%bind result =
+    let%bind mini_c_main =
+      transpile_entry program entry in
+    Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in
+  let%bind typed_result =
+    let%bind typed_main = Ast_typed.get_entry program entry in
+    untranspile_value result typed_main.type_annotation in
+  let%bind annotated_result = untype_expression typed_result in
+  ok annotated_result
+
+let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed")
+
+let easy_run_typed
+    ?(debug_mini_c = false) ?options (entry:string)
+    (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result =
+  let%bind () =
+    let open Ast_typed in
+    let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in
+    let%bind (arg_ty , _) =
+      trace_strong (simple_error "entry-point doesn't have a function type") @@
+      get_t_function @@ get_type_annotation d.annotated_expression in
+    Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input))
+  in
+
+  let%bind mini_c_main =
+    trace (simple_error "transpile mini_c entry") @@
+    transpile_entry program entry in
+  (if debug_mini_c then
+     Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main)
+  ) ;
+
+  let%bind mini_c_value = transpile_value input in
+
+  let%bind mini_c_result =
+    let error =
+      let title () = "run Mini_c" in
+      let content () =
+        Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main
+      in
+      error title content in
+    trace error @@
+    Run_mini_c.run_entry ?options mini_c_main mini_c_value in
+  let%bind typed_result =
+    let%bind main_result_type =
+      let%bind typed_main = Ast_typed.get_functional_entry program entry in
+      match (snd typed_main).type_value' with
+      | T_function (_, result) -> ok result
+      | _ -> simple_fail "main doesn't have fun type" in
+    untranspile_value mini_c_result main_result_type in
+  ok typed_result
+
+let easy_run_typed_simplified
+    ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string)
+    (program:AST_Typed.program) (input:Ast_simplified.annotated_expression) : Ast_simplified.annotated_expression result =
+  let%bind mini_c_main =
+    trace (simple_error "transpile mini_c entry") @@
+    transpile_entry program entry in
+  (if debug_mini_c then
+     Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main)
+  ) ;
+
+  let%bind typed_value =
+    let env =
+      let last_declaration = Location.unwrap List.(hd @@ rev program) in
+      match last_declaration with
+      | Declaration_constant (_ , env) -> env
+    in
+    type_expression ~env input in
+  let%bind mini_c_value = transpile_value typed_value in
+
+  let%bind mini_c_result =
+    let error =
+      let title () = "run Mini_c" in
+      let content () =
+        Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main
+      in
+      error title content in
+    trace error @@
+    Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in
+  let%bind typed_result =
+    let%bind main_result_type =
+      let%bind typed_main = Ast_typed.get_functional_entry program entry in
+      match (snd typed_main).type_value' with
+      | T_function (_, result) -> ok result
+      | _ -> simple_fail "main doesn't have fun type" in
+    untranspile_value mini_c_result main_result_type in
+  let%bind annotated_result = untype_expression typed_result in
+  ok annotated_result
+
+let easy_run_main_typed
+    ?(debug_mini_c = false)
+    (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result =
+  easy_run_typed ~debug_mini_c "main" program input
+
+let easy_run_main (path:string) (input:string) : AST_Typed.annotated_expression result =
+  let%bind typed = type_file path in
+
+  let%bind raw_expr = Parser.parse_expression input in
+  let%bind simpl_expr = simplify_expr raw_expr in
+  let%bind typed_expr = type_expression simpl_expr in
+  easy_run_main_typed typed typed_expr
+
+let compile_file (source: string) (entry_point:string) : Micheline.Michelson.t result =
+  let%bind raw =
+    trace (simple_error "parsing") @@
+    Parser.parse_file source in
+  let%bind simplified =
+    trace (simple_error "simplifying") @@
+    simplify raw in
+  let%bind typed =
+    trace (simple_error "typing") @@
+    type_ simplified in
+  let%bind mini_c =
+    trace (simple_error "transpiling") @@
+    transpile typed in
+  let%bind {body = michelson} =
+    trace (simple_error "compiling") @@
+    compile mini_c entry_point in
+  ok michelson
+
+module Contract = Contract

main/run_mini_c.ml

@@ -0,0 +1,60 @@
+open Trace
+open Mini_c
+open! Compiler.Program
+open Memory_proto_alpha.Script_ir_translator
+
+let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result =
+  let Compiler.Program.{input;output;body} : compiled_program = program in
+  let (Ex_ty input_ty) = input in
+  let (Ex_ty output_ty) = output in
+  let%bind input =
+    Trace.trace_tzresult_lwt (simple_error "error parsing input") @@
+    Tezos_utils.Memory_proto_alpha.parse_michelson_data input_michelson input_ty in
+  let body = Michelson.strip_annots body in
+  let%bind descr =
+    Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
+    Tezos_utils.Memory_proto_alpha.parse_michelson body
+      (Stack.(input_ty @: nil)) (Stack.(output_ty @: nil)) in
+  let open! Memory_proto_alpha.Script_interpreter in
+  let%bind (Item(output, Empty)) =
+    Trace.trace_tzresult_lwt (simple_error "error of execution") @@
+    Tezos_utils.Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in
+  ok (Ex_typed_value (output_ty, output))
+
+let run_node (program:program) (input:Michelson.t) : Michelson.t result =
+  let%bind compiled = translate_program program "main" in
+  let%bind (Ex_typed_value (output_ty, output)) = run_aux compiled input in
+  let%bind output =
+    Trace.trace_tzresult_lwt (simple_error "error unparsing output") @@
+    Tezos_utils.Memory_proto_alpha.unparse_michelson_data output_ty output in
+  ok output
+
+let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:value) : value result =
+  let%bind compiled =
+    let error =
+      let title () = "compile entry" in
+      let content () =
+        Format.asprintf "%a" PP.function_ entry
+      in
+      error title content in
+    trace error @@
+    translate_entry entry in
+  if debug_michelson then Format.printf "Program: %a\n" Michelson.pp compiled.body ;
+  let%bind input_michelson = translate_value input in
+  let%bind ex_ty_value = run_aux ?options compiled input_michelson in
+  let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in
+  ok result
+
+let run (program:program) (input:value) : value result =
+  let%bind input_michelson = translate_value input in
+  let%bind compiled = translate_program program "main" in
+  let%bind ex_ty_value = run_aux compiled input_michelson in
+  let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in
+  ok result
+
+let expression_to_value (e:expression) : value result =
+  match (Combinators.Expression.get_content e) with
+  | E_literal v -> ok v
+  | _ -> fail
+      @@ error (thunk "not a value")
+      @@ (fun () -> Format.asprintf "%a" PP.expression e)

meta_michelson/alpha_wrap.ml

@@ -0,0 +1,30 @@
+open Tezos_utils.Error_monad
+
+let dummy_environment = force_lwt ~msg:"getting dummy env" @@ Misc.init_environment ()
+
+let tc = dummy_environment.tezos_context
+
+module Proto_alpha = Tezos_utils.Memory_proto_alpha
+open Proto_alpha
+open Alpha_context
+open Alpha_environment
+
+let pack ty v = fst @@ force_lwt_alpha ~msg:"packing" @@ Script_ir_translator.pack_data tc ty v
+let unpack_opt (type a) : a Script_typed_ir.ty -> MBytes.t -> a option = fun ty bytes ->
+  force_lwt ~msg:"unpacking : parse" (
+    if Compare.Int.(MBytes.length bytes >= 1) &&
+       Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then
+      let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in
+      match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
+      | None -> return None
+      | Some expr ->
+        Script_ir_translator.parse_data tc ty (Micheline.root expr) >>=?? fun x -> return (Some (fst x))
+    else
+      return None
+  )
+
+let unpack ty a = match unpack_opt ty a with
+  | None -> raise @@ Failure "unpacking : of_bytes"
+  | Some x -> x
+
+let blake2b b = Alpha_environment.Raw_hashes.blake2b b

meta_michelson/contract.ml

@@ -0,0 +1,316 @@
+open Misc
+
+open Tezos_utils.Error_monad
+open Memory_proto_alpha
+open Alpha_context
+
+open Script_ir_translator
+open Script_typed_ir
+
+module Option = Simple_utils.Option
+module Cast = Tezos_utils.Cast
+
+type ('param, 'storage) toplevel = {
+  param_type : 'param ty ;
+  storage_type : 'storage ty ;
+  code : ('param * 'storage, packed_internal_operation list * 'storage) lambda
+}
+
+type ex_toplevel =
+    Ex_toplevel : ('a, 'b) toplevel -> ex_toplevel
+
+let get_toplevel ?environment toplevel_path claimed_storage_type claimed_parameter_type =
+  let toplevel_str = Streams.read_file toplevel_path in
+  contextualize ?environment ~msg:"toplevel" @@ fun {tezos_context = context ; _ } ->
+  let toplevel_expr = Cast.tl_of_string toplevel_str in
+  let (param_ty_node, storage_ty_node, code_field) =
+    force_ok_alpha ~msg:"parsing toplevel" @@
+    parse_toplevel toplevel_expr in
+  let (Ex_ty param_type, _) =
+    force_ok_alpha ~msg:"parse arg ty" @@
+    Script_ir_translator.parse_ty context ~allow_big_map:false ~allow_operation:false param_ty_node in
+  let (Ex_ty storage_type, _) =
+    force_ok_alpha ~msg:"parse storage ty" @@
+    parse_storage_ty context storage_ty_node in
+  let _ = force_ok_alpha ~msg:"storage eq" @@ Script_ir_translator.ty_eq context storage_type claimed_storage_type in
+  let _ = force_ok_alpha ~msg:"param eq" @@ Script_ir_translator.ty_eq context param_type claimed_parameter_type in
+  let param_type_full = Pair_t ((claimed_parameter_type, None, None),
+                                (claimed_storage_type, None, None), None) in
+  let ret_type_full =
+    Pair_t ((List_t (Operation_t None, None), None, None),
+            (claimed_storage_type, None, None), None) in
+  parse_returning (Toplevel { storage_type = claimed_storage_type ; param_type = claimed_parameter_type })
+    context (param_type_full, None) ret_type_full code_field >>=?? fun (code, _) ->
+  Error_monad.return {
+    param_type = claimed_parameter_type;
+    storage_type = claimed_storage_type;
+    code ;
+  }
+
+let make_toplevel code storage_type param_type =
+  { param_type ; storage_type ; code }
+
+module type ENVIRONMENT = sig
+  val identities : identity list
+  val tezos_context : t
+end
+
+type ex_typed_stack = Ex_typed_stack : ('a stack_ty * 'a Script_interpreter.stack) -> ex_typed_stack
+
+open Error_monad
+
+module Step (Env: ENVIRONMENT) = struct
+  open Env
+
+  type config = {
+    source : Contract.t option ;
+    payer : Contract.t option ;
+    self : Contract.t option ;
+    visitor : (Script_interpreter.ex_descr_stack -> unit) option ;
+    timestamp : Script_timestamp.t option ;
+    debug_visitor : (ex_typed_stack -> unit) option ;
+    amount : Tez.t option ;
+  }
+
+  let no_config = {
+    source = None ;
+    payer = None ;
+    self = None ;
+    visitor = None ;
+    debug_visitor = None ;
+    timestamp = None ;
+    amount = None ;
+  }
+
+  let of_param base param = match param with
+    | None -> base
+    | Some _ as x -> x
+
+  let make_config ?base_config ?source ?payer ?self ?visitor ?debug_visitor ?timestamp ?amount () =
+    let base_config = Option.unopt ~default:no_config base_config in {
+      source = Option.first_some source base_config.source ;
+      payer = Option.first_some payer base_config.payer ;
+      self = Option.first_some self base_config.self ;
+      visitor = Option.first_some visitor base_config.visitor ;
+      debug_visitor = Option.first_some debug_visitor base_config.debug_visitor ;
+      timestamp = Option.first_some timestamp base_config.timestamp ;
+      amount = Option.first_some amount base_config.amount ;
+    }
+
+  open Error_monad
+
+  let debug_visitor ?f () =
+    let open Script_interpreter in
+    let aux (Ex_descr_stack (descr, stack)) =
+      (match (descr.instr, descr.bef) with
+       | Nop, Item_t (String_t _, stack_ty, _) -> (
+           let (Item (s, stack)) = stack in
+           if s = "_debug"
+           then (
+             match f with
+             | None -> Format.printf "debug: %s\n%!" @@ Cast.stack_to_string stack_ty stack
+             | Some f -> f (Ex_typed_stack(stack_ty, stack))
+           ) else ()
+         )
+       | _ -> ()) ;
+      () in
+    aux
+
+  let step_lwt ?(config=no_config) (stack:'a Script_interpreter.stack) (code:('a, 'b) descr) =
+    let source = Option.unopt
+        ~default:(List.nth identities 0).implicit_contract config.source in
+    let payer = Option.unopt
+        ~default:(List.nth identities 1).implicit_contract config.payer in
+    let self = Option.unopt
+        ~default:(List.nth identities 2).implicit_contract config.self in
+    let amount = Option.unopt ~default:(Tez.one) config.amount in
+    let visitor =
+      let default = debug_visitor ?f:config.debug_visitor () in
+      Option.unopt ~default config.visitor in
+    let tezos_context = match config.timestamp with
+      | None -> tezos_context
+      | Some s -> Alpha_context.Script_timestamp.set_now tezos_context s in
+    Script_interpreter.step tezos_context ~source ~payer ~self ~visitor amount code stack >>=?? fun (stack, _) ->
+    return stack
+
+  let step_1_2 ?config (a:'a) (descr:('a * end_of_stack, 'b * ('c * end_of_stack)) descr) =
+    let open Script_interpreter in
+    step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Item(c, Empty))) ->
+    return (b, c)
+
+  let step_3_1 ?config (a:'a) (b:'b) (c:'c)
+      (descr:('a * ('b * ('c * end_of_stack)), 'd * end_of_stack) descr) =
+    let open Script_interpreter in
+    step_lwt ?config (Item(a, Item(b, Item(c, Empty)))) descr >>=? fun (Item(d, Empty)) ->
+    return d
+
+  let step_2_1 ?config (a:'a) (b:'b) (descr:('a * ('b * end_of_stack), 'c * end_of_stack) descr) =
+    let open Script_interpreter in
+    step_lwt ?config (Item(a, Item(b, Empty))) descr >>=? fun (Item(c, Empty)) ->
+    return c
+
+  let step_1_1 ?config (a:'a) (descr:('a * end_of_stack, 'b * end_of_stack) descr) =
+    let open Script_interpreter in
+    step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Empty)) ->
+    return b
+
+  let step_value ?config (a:'a) (descr:('a * end_of_stack, 'a * end_of_stack) descr) =
+    step_1_1 ?config a descr
+
+  let step ?config stack code =
+    force_lwt ~msg:"running a step" @@ step_lwt ?config stack code
+
+end
+
+let run_lwt_full ?source ?payer ?self toplevel storage param {identities ; tezos_context = context} =
+  let { code ; _ } : (_, _) toplevel = toplevel in
+
+  let source = Option.unopt
+      ~default:(List.nth identities 0).implicit_contract source in
+  let payer = Option.unopt
+      ~default:(List.nth identities 1).implicit_contract payer in
+  let self = Option.unopt
+      ~default:(List.nth identities 2).implicit_contract self in
+  let amount = Tez.one in
+
+  Script_interpreter.interp context ~source ~payer ~self amount code (param, storage)
+  >>=?? fun ((ops, storage), new_ctxt) ->
+  let gas = Alpha_context.Gas.consumed ~since:context ~until:new_ctxt in
+  return (storage, ops, gas)
+
+let run_lwt ?source ?payer ?self toplevel storage param env =
+  run_lwt_full ?source ?payer ?self toplevel storage param env >>=? fun (storage, _ops, _gas) ->
+  return storage
+
+let run ?environment toplevel storage param =
+  contextualize ?environment ~msg:"run toplevel" @@ run_lwt toplevel storage param
+
+let run_node ?environment toplevel storage_node param_node =
+  contextualize ?environment ~msg:"run toplevel" @@ fun {tezos_context = context ; _} ->
+  let {param_type ; storage_type ; _ } = toplevel in
+  parse_data context param_type param_node >>=?? fun (param, _) ->
+  parse_data context storage_type storage_node >>=?? fun (storage, _) ->
+  let storage = run toplevel storage param in
+  unparse_data context Readable storage_type storage >>=?? fun (storage_node, _) ->
+  return storage_node
+
+let run_str toplevel storage_str param_str =
+  let param_node = Cast.node_of_string param_str in
+  let storage_node = Cast.node_of_string storage_str in
+  run_node toplevel storage_node param_node
+
+type input = {
+  toplevel_path : string ;
+  storage : string ;
+  parameter : string
+}
+
+let parse_json json_str : input =
+  let json = force_ok_str ~msg:"main_contract: invalid json" @@ Tezos_utils.Data_encoding.Json.from_string json_str in
+  let json = match json with
+    | `O json ->  json
+    | _ -> raise @@ Failure "main_contract: not recorD"
+  in
+  let open Json in
+  let toplevel_path = force_string ~msg:"main_contract, top_level" @@ List.assoc "top_level" json in
+  let parameter = force_string ~msg:"main_contract, param" @@ List.assoc "param" json in
+  let storage = force_string ~msg:"main_contract, storage" @@ List.assoc "storage" json in
+  { toplevel_path ; storage ; parameter }
+
+let generate_json (storage_node:Script.node) : string =
+  let storage_expr = Tezos_micheline.Micheline.strip_locations storage_node in
+  let json = Data_encoding.Json.construct Script.expr_encoding storage_expr in
+  Format.fprintf Format.str_formatter "%a" Data_encoding.Json.pp json ;
+  Format.flush_str_formatter ()
+
+module Types = struct
+  open Script_typed_ir
+
+  let union a b = Union_t ((a, None), (b, None), None)
+  let assert_union = function
+    | Union_t ((a, _), (b, _), _) -> (a, b)
+    | _ -> assert false
+
+  let pair a b = Pair_t ((a, None, None), (b, None, None), None)
+  let assert_pair = function
+    | Pair_t ((a, _, _), ((b, _, _)), _) -> (a, b)
+    | _ -> assert false
+  let assert_pair_ex ?(msg="assert pair") (Ex_ty ty) = match ty with
+    | Pair_t ((a, _, _), ((b, _, _)), _) -> (Ex_ty a, Ex_ty b)
+    | _ -> raise (Failure msg)
+
+  let unit = Unit_t None
+
+  let bytes = Bytes_t None
+  let bytes_k = Bytes_key None
+
+  let nat = Nat_t None
+  let tez = Mutez_t None
+  let int = Int_t None
+  let nat_k = Nat_key None
+  let tez_k = Mutez_key None
+  let int_k = Int_key None
+
+  let big_map k v = Big_map_t (k, v, None)
+
+  let signature = Signature_t None
+  let operation = Operation_t None
+
+  let bool = Bool_t None
+
+  let mutez = Mutez_t None
+
+  let string = String_t None
+  let string_k = String_key None
+  let address_k = Address_key None
+
+  let key = Key_t None
+
+  let list a = List_t (a, None)
+  let assert_list = function
+    | List_t (a, _) -> a
+    | _ -> assert false
+
+  let option a = Option_t ((a, None), None, None)
+  let contract a = Contract_t (a, None)
+  let assert_option = function
+    | Option_t ((a, _), _, _) -> a
+    | _ -> assert false
+
+  let address = Address_t None
+
+  let lambda a b = Lambda_t (a, b, None)
+  let assert_lambda = function
+    | Lambda_t (a, b, _) -> (a, b)
+    | _ -> assert false
+  type ex_lambda = Ex_lambda : (_, _) lambda ty -> ex_lambda
+  let is_lambda : type a . a ty -> ex_lambda option = function
+    | Lambda_t (_, _, _) as x -> Some (Ex_lambda x)
+    | _ -> None
+
+  let timestamp = Timestamp_t None
+  let timestamp_k = Timestamp_key None
+
+  let map a b = Map_t (a, b, None)
+
+  let assert_type (_:'a ty) (_:'a) = ()
+end
+
+module Values = struct
+  let empty_map t = empty_map t
+
+  let empty_big_map key_type comparable_key_ty value_type : ('a, 'b) big_map = {
+    key_type ; value_type ; diff = empty_map comparable_key_ty ;
+  }
+
+  let int n = Script_int.of_int n
+
+  let nat n = Script_int.abs @@ Script_int.of_int n
+  let nat_to_int n = Option.unopt_exn @@ Script_int.to_int n
+
+  let tez n = Option.unopt_exn @@ Tez.of_mutez @@ Int64.of_int n
+
+  let left a = L a
+
+  let right b = R b
+end

meta_michelson/dune

@@ -0,0 +1,10 @@
+(library
+ (name meta_michelson)
+ (public_name ligo.meta_michelson)
+ (libraries
+   simple-utils
+   tezos-utils
+   michelson-parser
+   tezos-micheline
+ )
+)

meta_michelson/json.ml

@@ -0,0 +1,7 @@
+let force_record ~msg json = match json with
+  | `O json -> json
+  | _ -> raise @@ Failure ("not json record : " ^ msg)
+
+let force_string ~msg json = match json with
+  | `String str -> str
+  | _ -> raise @@ Failure ("not json str : " ^ msg)

meta_michelson/meta_michelson.ml

@@ -0,0 +1,12 @@
+module Run = struct
+  open Contract
+  let run_lwt_full = run_lwt_full
+  let run_lwt = run_lwt
+  let run_str = run_str
+  let run_node = run_node
+  let run = run
+end
+module Stack = Michelson_wrap.Stack
+module Values = Contract.Values
+module Types = Contract.Types
+

meta_michelson/michelson_wrap.ml

@@ -0,0 +1,514 @@
+open Tezos_utils.Memory_proto_alpha
+module AC = Alpha_context
+
+module Types = Contract.Types
+module Option = Simple_utils.Option
+module MBytes = Alpha_environment.MBytes
+
+module Stack = struct
+  open Script_typed_ir
+
+  let descr bef aft instr =
+    {
+      loc = 0 ;
+      bef ; aft ; instr
+    }
+
+  type nonrec 'a ty = 'a ty
+  type 'a t = 'a stack_ty
+  type nonrec ('a, 'b) descr = ('a, 'b) descr
+  type ('a, 'b) code = ('a t) -> ('a, 'b) descr
+
+  type ex_stack_ty = Ex_stack_ty : 'a t -> ex_stack_ty
+  type ex_descr = Ex_descr : ('a, 'b) descr -> ex_descr
+  type ex_code = Ex_code : ('a, 'b) code -> ex_code
+
+  let stack ?annot a b = Item_t (a, b, annot)
+  let unstack (item: (('a * 'rest) stack_ty)) : ('a ty * 'rest stack_ty) =
+    let Item_t (hd, tl, _) = item in
+    (hd, tl)
+
+  let nil = Empty_t
+  let head x = fst @@ unstack x
+  let tail x = snd @@ unstack x
+
+  let seq a b bef =
+    let a_descr = a bef in
+    let b_descr = b a_descr.aft in
+    let aft = b_descr.aft in
+    descr bef aft @@ Seq (a_descr, b_descr)
+
+  let (@>) (stack : 'b t) (code : ('a, 'b) code) = code stack
+  let (@|) = seq
+  let (@:) = stack
+
+  let (!:) : ('a, 'b) descr -> ('a, 'b) code = fun d _ -> d
+
+  let (<.) (stack:'a t) (code: ('a, 'b) code): ('a, 'b) descr = code stack
+
+  let (<::) : ('a, 'b) descr -> ('b, 'c) descr -> ('a, 'c) descr = fun ab bc ->
+    descr ab.bef bc.aft @@ Seq(ab, bc)
+
+  let (<:) (ab_descr:('a, 'b) descr) (code:('b, 'c) code) : ('a, 'c) descr =
+    let bc_descr = code ab_descr.aft in
+    ab_descr <:: bc_descr
+
+end
+
+open Stack
+
+type nat = AC.Script_int.n AC.Script_int.num
+type int_num = AC.Script_int.z AC.Script_int.num
+type bytes = MBytes.t
+type address = AC.Contract.t Script_typed_ir.ty
+type mutez = AC.Tez.t Script_typed_ir.ty
+
+
+module Stack_ops = struct
+  open Script_typed_ir
+  let dup : ('a * 'rest, 'a * ('a * 'rest)) code = fun bef ->
+    let Item_t (ty, rest, _) = bef in
+    descr bef (Item_t (ty, Item_t (ty, rest, None), None)) Dup
+
+  let drop : ('a * 'rest, 'rest) code = fun bef ->
+    let aft = snd @@ unstack bef in
+    descr bef aft Drop
+
+  let swap (bef : (('a * ('b * 'c)) stack_ty)) =
+    let Item_t (a, Item_t (b, rest, _), _) = bef in
+    descr bef (Item_t (b, (Item_t (a, rest, None)), None)) Swap
+
+  let dip code (bef : ('ty * 'rest) stack_ty) =
+    let Item_t (ty, rest, _) = bef in
+    let applied = code rest in
+    let aft = Item_t (ty, applied.aft, None) in
+    descr bef aft (Dip (code rest))
+
+  let noop : ('r, 'r) code = fun bef ->
+    descr bef bef Nop
+
+  let exec : (_, _) code = fun bef ->
+    let lambda = head @@ tail bef in
+    let (_, ret) = Types.assert_lambda lambda in
+    let aft = ret @: (tail @@ tail bef) in
+    descr bef aft Exec
+
+  let fail aft : ('a * 'r, 'b) code = fun bef ->
+    let head = fst @@ unstack bef in
+    descr bef aft (Failwith head)
+
+  let push_string str (bef : 'rest stack_ty) : (_, (string * 'rest)) descr =
+    let aft = Item_t (Types.string, bef, None) in
+    descr bef aft (Const (str))
+
+  let push_none (a:'a ty) : ('rest, 'a option * 'rest) code = fun r ->
+    let aft = stack (Types.option a) r in
+    descr r aft (Const None)
+
+  let push_unit : ('rest, unit * 'rest) code = fun r ->
+    let aft = stack Types.unit r in
+    descr r aft (Const ())
+
+  let push_nat n (bef : 'rest stack_ty) : (_, (nat * 'rest)) descr =
+    let aft = Item_t (Types.nat, bef, None) in
+    descr bef aft (Const (Contract.Values.nat n))
+
+  let push_int n (bef : 'rest stack_ty) : (_, (int_num * 'rest)) descr =
+    let aft = Types.int @: bef in
+    descr bef aft (Const (Contract.Values.int n))
+
+  let push_tez n (bef : 'rest stack_ty) : (_, (AC.Tez.tez * 'rest)) descr =
+    let aft = Types.mutez @: bef in
+    descr bef aft (Const (Contract.Values.tez n))
+
+  let push_bool b : ('s, bool * 's) code = fun bef ->
+    let aft = stack Types.bool bef in
+    descr bef aft (Const b)
+
+  let push_generic ty v : ('s, _ * 's) code = fun bef ->
+    let aft = stack ty bef in
+    descr bef aft (Const v)
+
+  let failstring str aft =
+    push_string str @| fail aft
+
+end
+
+module Stack_shortcuts = struct
+  open Stack_ops
+
+  let diip c x = dip (dip c) x
+  let diiip c x = dip (diip c) x
+  let diiiip c x = dip (diiip c) x
+
+  let bubble_1 = swap
+  let bubble_down_1 = swap
+
+  let bubble_2 : ('a * ('b * ('c * 'r)), 'c * ('a * ('b * 'r))) code = fun bef ->
+    bef <. dip swap <: swap
+  let bubble_down_2 : ('a * ('b * ('c * 'r)), ('b * ('c * ('a * 'r)))) code = fun bef ->
+    bef <. swap <: dip swap
+
+  let bubble_3 : ('a * ('b * ('c * ('d * 'r))), 'd * ('a * ('b * ('c * 'r)))) code = fun bef ->
+    bef <. diip swap <: dip swap <: swap
+
+  let keep_1 : type r s . ('a * r, s) code -> ('a * r, 'a * s) code = fun code bef ->
+    bef <. dup <: dip code
+
+  let save_1_1 : type r . ('a * r, 'b * r) code -> ('a * r, 'b * ('a * r)) code = fun code s ->
+    s <. keep_1 code <: swap
+
+  let keep_2 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), ('a * ('b * s))) code = fun code bef ->
+    (dup @| dip (swap @| dup @| dip (swap @| code))) bef
+
+  let keep_2_1 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), 'b * s) code = fun code bef ->
+    (dip dup @| swap @| dip code) bef
+
+  let relativize_1_1 : ('a * unit, 'b * unit) descr -> ('a * 'r, 'b * 'r) code = fun d s ->
+    let aft = head d.aft @: tail s in
+    descr s aft d.instr
+
+end
+
+module Pair_ops = struct
+  let car (bef : (('a * 'b) * 'rest) Stack.t) =
+    let (pair, rest) = unstack bef in
+    let (a, _) = Contract.Types.assert_pair pair in
+    descr bef (stack a rest) Car
+
+  let cdr (bef : (('a * 'b) * 'rest) Stack.t) =
+    let (pair, rest) = unstack bef in
+    let (_, b) = Contract.Types.assert_pair pair in
+    descr bef (stack b rest) Cdr
+
+  let pair (bef : ('a * ('b * 'rest)) Stack.t) =
+    let (a, rest) = unstack bef in
+    let (b, rest) = unstack rest in
+    let aft = (Types.pair a b) @: rest in
+    descr bef aft Cons_pair
+
+  open Stack_ops
+  let carcdr s = s <. car <: Stack_ops.dip cdr
+
+  let cdrcar s = s <. cdr <: dip car
+
+  let cdrcdr s = s <. cdr <: dip cdr
+
+  let carcar s = s <. car <: dip car
+
+  let cdar s = s <. cdr <: car
+
+  let unpair s = s <. dup <: car <: dip cdr
+end
+
+module Option_ops = struct
+  open Script_typed_ir
+
+  let cons bef =
+    let (hd, tl) = unstack bef in
+    descr bef (stack (Contract.Types.option hd) tl) Cons_some
+
+  let cond ?target none_branch some_branch : ('a option * 'r, 'b) code = fun bef ->
+    let (a_opt, base) = unstack bef in
+    let a = Types.assert_option a_opt in
+    let target = Option.unopt ~default:(none_branch base).aft target in
+    descr bef target (If_none (none_branch base, some_branch (stack a base)))
+
+  let force_some ?msg : ('a option * 'r, 'a * 'r) code = fun s ->
+    let (a_opt, base) = unstack s in
+    let a = Types.assert_option a_opt in
+    let target = a @: base in
+    cond ~target
+      (Stack_ops.failstring ("force_some : " ^ Option.unopt ~default:"" msg) target)
+      Stack_ops.noop s
+end
+
+module Union_ops = struct
+  open Script_typed_ir
+
+  let left (b:'b ty) : ('a * 'r, ('a, 'b) union * 'r) code = fun bef ->
+    let (a, base) = unstack bef in
+    let aft = Types.union a b @: base in
+    descr bef aft Left
+
+  let right (a:'a ty) : ('b * 'r, ('a, 'b) union * 'r) code = fun bef ->
+    let (b, base) = unstack bef in
+    let aft = Types.union a b @: base in
+    descr bef aft Right
+
+
+  let loop ?after (code: ('a * 'r, ('a, 'b) union * 'r) code): (('a, 'b) union * 'r, 'b * 'r) code = fun bef ->
+    let (union, base) = unstack bef in
+    let (a, b) = Types.assert_union union in
+    let code_stack = a @: base in
+    let aft = Option.unopt ~default:(b @: base) after in
+    descr bef aft (Loop_left (code code_stack))
+
+end
+
+module Arithmetic = struct
+  let neq : (int_num * 'r, bool *'r) code = fun bef ->
+    let aft = stack Types.bool @@ snd @@ unstack bef in
+    descr bef aft Neq
+
+  let neg : (int_num * 'r, int_num *'r) code = fun bef ->
+    let aft = stack Types.int @@ snd @@ unstack bef in
+    descr bef aft Neg_int
+
+  let abs : (int_num * 'r, nat *'r) code = fun bef ->
+    let aft = stack Types.nat @@ snd @@ unstack bef in
+    descr bef aft Abs_int
+
+  let int : (nat * 'r, int_num*'r) code = fun bef ->
+    let aft = stack Types.int @@ snd @@ unstack bef in
+    descr bef aft Int_nat
+
+  let nat_opt : (int_num * 'r, nat option * 'r) code = fun bef ->
+    let aft = stack Types.(option nat) @@ tail bef in
+    descr bef aft Is_nat
+
+  let nat_neq = fun s -> (int @| neq) s
+
+  let add_natnat (bef : (nat * (nat * 'rest)) Stack.t) =
+    let (nat, rest) = unstack bef in
+    let rest = tail rest in
+    let aft = stack nat rest in
+    descr bef aft Add_natnat
+
+  let add_intint (bef : (int_num * (int_num * 'rest)) Stack.t) =
+    let (nat, rest) = unstack bef in
+    let rest = tail rest in
+    let aft = stack nat rest in
+    descr bef aft Add_intint
+
+  let add_teztez : (AC.Tez.tez * (AC.Tez.tez * 'rest), _) code = fun bef ->
+    let aft = tail bef in
+    descr bef aft Add_tez
+
+  let mul_natnat (bef : (nat * (nat * 'rest)) Stack.t) =
+    let nat = head bef in
+    let rest = tail @@ tail bef in
+    let aft = stack nat rest in
+    descr bef aft Mul_natnat
+
+  let mul_intint (bef : (int_num * (int_num * 'rest)) Stack.t) =
+    let nat = head bef in
+    let rest = tail @@ tail bef in
+    let aft = stack nat rest in
+    descr bef aft Mul_intint
+
+  let sub_intint : (int_num * (int_num * 'r), int_num * 'r) code = fun bef ->
+    let aft = tail bef in
+    descr bef aft Sub_int
+
+  let sub_natnat : (nat * (nat * 'r), int_num * 'r) code =
+    fun bef -> bef <. int <: Stack_ops.dip int <: sub_intint
+
+  let ediv : (nat * (nat * 'r), (nat * nat) option * 'r) code = fun s ->
+    let (n, base) = unstack @@ snd @@ unstack s in
+    let aft = Types.option (Types.pair n n) @: base in
+    descr s aft Ediv_natnat
+
+  let ediv_tez = fun s ->
+    let aft = Types.(option @@ pair (head s) (head s)) @: tail @@ tail s in
+    descr s aft Ediv_teznat
+
+  open Option_ops
+  let force_ediv x = x <. ediv <: force_some
+  let force_ediv_tez x = (ediv_tez @| force_some) x
+
+  open Pair_ops
+  let div x = x <. force_ediv <: car
+
+  open Stack_ops
+  let div_n n s = s <. push_nat n <: swap <: div
+  let add_n n s = s <. push_nat n <: swap <: add_natnat
+  let add_teztez_n n s = s <. push_tez n <: swap <: add_teztez
+  let sub_n n s = s <. push_nat n <: swap <: sub_natnat
+
+  let force_nat s = s <. nat_opt <: force_some ~msg:"force nat"
+end
+
+module Boolean = struct
+  let bool_and (type r) : (bool * (bool * r), bool * r) code = fun bef ->
+    let aft = Types.bool @: tail @@ tail bef in
+    descr bef aft And
+
+  let bool_or (type r) : (bool * (bool * r), bool * r) code = fun bef ->
+    let aft = Types.bool @: tail @@ tail bef in
+    descr bef aft Or
+
+  open Script_typed_ir
+  let cond ?target true_branch false_branch : (bool * 'r, 's) code = fun bef ->
+    let base = tail bef in
+    let aft = Option.unopt ~default:((true_branch base).aft) target in
+    descr bef aft (If (true_branch base, false_branch base))
+
+  let loop (code : ('s, bool * 's) code) : ((bool * 's), 's) code = fun bef ->
+    let aft = tail bef in
+    descr bef aft @@ Loop (code aft)
+
+end
+
+module Comparison_ops = struct
+  let cmp c_ty : _ code = fun bef ->
+    let aft = stack Contract.Types.int @@ tail @@ tail @@ bef in
+    descr bef aft (Compare c_ty)
+
+  let cmp_bytes = fun x -> cmp (Bytes_key None) x
+
+  let eq : (int_num * 'r, bool *'r) code = fun bef ->
+    let aft = stack Contract.Types.bool @@ snd @@ unstack bef in
+    descr bef aft Eq
+
+  open Arithmetic
+  let eq_n n s = s <. sub_n n <: eq
+
+  let ge : (int_num * 'r, bool * 'r) code = fun bef ->
+    let base = tail bef in
+    let aft = stack Types.bool base in
+    descr bef aft Ge
+
+  let gt : (int_num * 'r, bool * 'r) code = fun bef ->
+    let base = tail bef in
+    let aft = stack Types.bool base in
+    descr bef aft Gt
+
+  let lt : (int_num * 'r, bool * 'r) code = fun bef ->
+    let base = tail bef in
+    let aft = stack Types.bool base in
+    descr bef aft Lt
+
+  let gt_nat s = s <. int <: gt
+
+  open Stack_ops
+  let assert_positive_nat s = s <. dup <: gt_nat <: Boolean.cond noop (failstring "positive" s)
+
+  let cmp_ge_nat : (nat * (nat * 'r), bool * 'r) code = fun bef ->
+    bef <. sub_natnat <: ge
+
+  let cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), bool * 'r) code = fun bef ->
+    bef <. cmp Types.timestamp_k <: ge
+
+  let assert_cmp_ge_nat : (nat * (nat * 'r), 'r) code = fun bef ->
+    bef <. cmp_ge_nat <: Boolean.cond noop (failstring "assert cmp ge nat" (tail @@ tail bef))
+
+  let assert_cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), 'r) code = fun bef ->
+    bef <. cmp_ge_timestamp <: Boolean.cond noop (failstring "assert cmp ge timestamp" (tail @@ tail bef))
+end
+
+
+module Bytes = struct
+
+  open Script_typed_ir
+
+  let pack (ty:'a ty) : ('a * 'r, bytes * 'r) code = fun bef ->
+    let aft = stack Types.bytes @@ tail bef in
+    descr bef aft (Pack ty)
+
+  let unpack_opt : type a . a ty -> (bytes * 'r, a option * 'r) code = fun ty bef ->
+    let aft = stack (Types.option ty) (tail bef) in
+    descr bef aft (Unpack ty)
+
+  let unpack ty s = s <. unpack_opt ty <: Option_ops.force_some
+
+  let concat : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) code = fun bef ->
+    let aft = tail bef in
+    descr bef aft Concat_bytes_pair
+
+  let sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef ->
+    descr bef bef Sha256
+
+  let blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef ->
+    descr bef bef Blake2b
+end
+
+
+module Map = struct
+  open Script_typed_ir
+
+  type ('a, 'b) t = ('a, 'b) map
+
+  let empty c_ty = Script_ir_translator.empty_map c_ty
+  let set (type a b) m (k:a) (v:b) = Script_ir_translator.map_update k (Some v) m
+
+  module Ops = struct
+    let update (bef : (('a * ('b option * (('a, 'b) map * ('rest)))) Stack.t)) : (_, ('a, 'b) map * 'rest) descr =
+      let Item_t (_, Item_t (_, Item_t (map, rest, _), _), _) = bef in
+      let aft = Item_t (map, rest, None) in
+      descr bef aft Map_update
+
+    let get : ?a:('a ty) -> 'b ty -> ('a * (('a, 'b) map * 'r), 'b option * 'r) code = fun ?a b bef ->
+      let _ = a in
+      let base = snd @@ unstack @@ snd @@ unstack bef in
+      let aft = stack (Types.option b) base in
+      descr bef aft Map_get
+
+    let big_get : 'a ty -> 'b ty -> ('a * (('a, 'b) big_map * 'r), 'b option * 'r) code = fun _a b bef ->
+      let base = snd @@ unstack @@ snd @@ unstack bef in
+      let aft = stack (Types.option b) base in
+      descr bef aft Big_map_get
+
+    let big_update : ('a * ('b option * (('a, 'b) big_map * 'r)), ('a, 'b) big_map * 'r) code = fun bef ->
+      let base = tail @@ tail bef in
+      descr bef base Big_map_update
+  end
+end
+
+module List_ops = struct
+  let nil ele bef =
+    let aft = stack (Types.list ele) bef in
+    descr bef aft Nil
+
+  let cons bef =
+    let aft = tail bef in
+    descr bef aft Cons_list
+
+  let cond ~target cons_branch nil_branch bef =
+    let (lst, aft) = unstack bef in
+    let a = Types.assert_list lst in
+    let cons_descr = cons_branch (a @: Types.list a @: aft) in
+    let nil_descr = nil_branch aft in
+    descr bef target (If_cons (cons_descr, nil_descr))
+
+  let list_iter : type a r . (a * r, r) code -> (a list * r, r) code = fun code bef ->
+    let (a_lst, aft) = unstack bef in
+    let a = Types.assert_list a_lst in
+    descr bef aft (List_iter (code (a @: aft)))
+
+end
+
+module Tez = struct
+
+  let amount : ('r, AC.Tez.t * 'r) code = fun bef ->
+    let aft = Types.mutez @: bef in
+    descr bef aft Amount
+
+  open Bytes
+
+  let tez_nat s = s <. pack Types.mutez <: unpack Types.nat
+  let amount_nat s = s <. amount <: pack Types.mutez <: unpack Types.nat
+end
+
+module Misc = struct
+
+  open Stack_ops
+  open Stack_shortcuts
+  open Comparison_ops
+  let min_nat : (nat * (nat * 'r), nat * 'r) code = fun s ->
+    s <.
+    keep_2 cmp_ge_nat <: bubble_2 <:
+    Boolean.cond drop (dip drop)
+
+  let debug ~msg () s = s <. push_string msg <: push_string "_debug" <: noop <: drop <: drop
+
+  let debug_msg msg = debug ~msg ()
+
+  let now : ('r, AC.Script_timestamp.t * 'r) code = fun bef ->
+    let aft = stack Types.timestamp bef in
+    descr bef aft Now
+
+end
+
+
+

meta_michelson/misc.ml

@@ -0,0 +1,302 @@
+module Signature = Tezos_base.TzPervasives.Signature
+open Tezos_utils.Memory_proto_alpha
+module Data_encoding = Alpha_environment.Data_encoding
+module MBytes = Alpha_environment.MBytes
+module Error_monad = Tezos_utils.Error_monad
+open Error_monad
+
+module Context_init = struct
+
+  type account = {
+      pkh : Signature.Public_key_hash.t ;
+      pk :  Signature.Public_key.t ;
+      sk :  Signature.Secret_key.t ;
+    }
+
+  let generate_accounts n : (account * Tez_repr.t) list =
+    let amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in
+    List.map (fun _ ->
+        let (pkh, pk, sk) = Signature.generate_key () in
+        let account = { pkh ; pk ; sk } in
+        account, amount)
+      (Simple_utils.List.range n)
+
+  let make_shell
+        ~level ~predecessor ~timestamp ~fitness ~operations_hash =
+    Tezos_base.Block_header.{
+        level ;
+        predecessor ;
+        timestamp ;
+        fitness ;
+        operations_hash ;
+        (* We don't care of the following values, only the shell validates them. *)
+        proto_level = 0 ;
+        validation_passes = 0 ;
+        context = Alpha_environment.Context_hash.zero ;
+    }
+
+  let default_proof_of_work_nonce =
+    MBytes.create Alpha_context.Constants.proof_of_work_nonce_size
+
+  let protocol_param_key = [ "protocol_parameters" ]
+
+  let check_constants_consistency constants =
+    let open Constants_repr in
+    let open Error_monad in
+    let { blocks_per_cycle ; blocks_per_commitment ;
+          blocks_per_roll_snapshot ; _ } = constants in
+    Error_monad.unless (blocks_per_commitment <= blocks_per_cycle)
+      (fun () -> failwith "Inconsistent constants : blocks per commitment must be \
+                           less than blocks per cycle") >>=? fun () ->
+    Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot)
+      (fun () -> failwith "Inconsistent constants : blocks per cycle \
+                           must be superior than blocks per roll snapshot") >>=?
+      return
+
+
+  let initial_context
+        constants
+        header
+        commitments
+        initial_accounts
+        security_deposit_ramp_up_cycles
+        no_reward_cycles
+    =
+    let open Tezos_base.TzPervasives.Error_monad in
+    let bootstrap_accounts =
+      List.map (fun ({ pk ; pkh ; _ }, amount) ->
+          let open! Parameters_repr in
+          { public_key_hash = pkh ; public_key = Some pk ; amount }
+        ) initial_accounts
+    in
+    let json =
+      Data_encoding.Json.construct
+        Parameters_repr.encoding
+        Parameters_repr.{
+          bootstrap_accounts ;
+          bootstrap_contracts = [] ;
+          commitments ;
+          constants ;
+          security_deposit_ramp_up_cycles ;
+          no_reward_cycles ;
+      }
+    in
+    let proto_params =
+      Data_encoding.Binary.to_bytes_exn Data_encoding.json json
+    in
+    Tezos_protocol_environment_memory.Context.(
+      set empty ["version"] (MBytes.of_string "genesis")
+    ) >>= fun ctxt ->
+    Tezos_protocol_environment_memory.Context.(
+      set ctxt protocol_param_key proto_params
+    ) >>= fun ctxt ->
+    Main.init ctxt header
+    >|= Alpha_environment.wrap_error >>=? fun { context; _ } ->
+    return context
+
+  let genesis
+        ?(preserved_cycles = Constants_repr.default.preserved_cycles)
+        ?(blocks_per_cycle = Constants_repr.default.blocks_per_cycle)
+        ?(blocks_per_commitment = Constants_repr.default.blocks_per_commitment)
+        ?(blocks_per_roll_snapshot = Constants_repr.default.blocks_per_roll_snapshot)
+        ?(blocks_per_voting_period = Constants_repr.default.blocks_per_voting_period)
+        ?(time_between_blocks = Constants_repr.default.time_between_blocks)
+        ?(endorsers_per_block = Constants_repr.default.endorsers_per_block)
+        ?(hard_gas_limit_per_operation = Constants_repr.default.hard_gas_limit_per_operation)
+        ?(hard_gas_limit_per_block = Constants_repr.default.hard_gas_limit_per_block)
+        ?(proof_of_work_threshold = Int64.(neg one))
+        ?(tokens_per_roll = Constants_repr.default.tokens_per_roll)
+        ?(michelson_maximum_type_size = Constants_repr.default.michelson_maximum_type_size)
+        ?(seed_nonce_revelation_tip = Constants_repr.default.seed_nonce_revelation_tip)
+        ?(origination_size = Constants_repr.default.origination_size)
+        ?(block_security_deposit = Constants_repr.default.block_security_deposit)
+        ?(endorsement_security_deposit = Constants_repr.default.endorsement_security_deposit)
+        ?(block_reward = Constants_repr.default.block_reward)
+        ?(endorsement_reward = Constants_repr.default.endorsement_reward)
+        ?(cost_per_byte = Constants_repr.default.cost_per_byte)
+        ?(hard_storage_limit_per_operation = Constants_repr.default.hard_storage_limit_per_operation)
+        ?(commitments = [])
+        ?(security_deposit_ramp_up_cycles = None)
+        ?(no_reward_cycles = None)
+        (initial_accounts : (account * Tez_repr.t) list)
+    =
+    if initial_accounts = [] then
+      Pervasives.failwith "Must have one account with a roll to bake";
+
+    (* Check there is at least one roll *)
+    let open Tezos_base.TzPervasives.Error_monad in
+    begin try
+        let (>>?=) x y = match x with
+          | Ok(a) -> y a
+          | Error(b) -> fail @@ List.hd b in
+        fold_left_s (fun acc (_, amount) ->
+            Alpha_environment.wrap_error @@
+              Tez_repr.(+?) acc amount >>?= fun acc ->
+                                            if acc >= tokens_per_roll then
+                                              raise Exit
+                                            else return acc
+          ) Tez_repr.zero initial_accounts >>=? fun _ ->
+      failwith "Insufficient tokens in initial accounts to create one roll"
+    with Exit -> return ()
+    end >>=? fun () ->
+
+    let constants : Constants_repr.parametric = {
+        preserved_cycles ;
+        blocks_per_cycle ;
+        blocks_per_commitment ;
+        blocks_per_roll_snapshot ;
+        blocks_per_voting_period ;
+        time_between_blocks ;
+        endorsers_per_block ;
+        hard_gas_limit_per_operation ;
+        hard_gas_limit_per_block ;
+        proof_of_work_threshold ;
+        tokens_per_roll ;
+        michelson_maximum_type_size ;
+        seed_nonce_revelation_tip ;
+        origination_size ;
+        block_security_deposit ;
+        endorsement_security_deposit ;
+        block_reward ;
+        endorsement_reward ;
+        cost_per_byte ;
+        hard_storage_limit_per_operation ;
+      } in
+    check_constants_consistency constants >>=? fun () ->
+
+    let hash =
+      Alpha_environment.Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
+    in
+    let shell = make_shell
+                  ~level:0l
+                  ~predecessor:hash
+                  ~timestamp:Tezos_utils.Time.epoch
+                  ~fitness: (Fitness_repr.from_int64 0L)
+                  ~operations_hash: Alpha_environment.Operation_list_list_hash.zero in
+    initial_context
+      constants
+      shell
+      commitments
+      initial_accounts
+      security_deposit_ramp_up_cycles
+      no_reward_cycles
+    >>=? fun context ->
+    return (context, shell, hash)
+
+  let init
+        ?(slow=false)
+        ?preserved_cycles
+        ?endorsers_per_block
+        ?commitments
+        n =
+    let open Error_monad in
+    let accounts = generate_accounts n in
+    let contracts = List.map (fun (a, _) ->
+                        Alpha_context.Contract.implicit_contract (a.pkh)) accounts in
+    begin
+      if slow then
+        genesis
+          ?preserved_cycles
+          ?endorsers_per_block
+          ?commitments
+          accounts
+      else
+        genesis
+          ?preserved_cycles
+          ~blocks_per_cycle:32l
+          ~blocks_per_commitment:4l
+          ~blocks_per_roll_snapshot:8l
+          ~blocks_per_voting_period:(Int32.mul 32l 8l)
+          ?endorsers_per_block
+          ?commitments
+          accounts
+    end >>=? fun ctxt ->
+    return (ctxt, accounts, contracts)
+
+  let contents
+        ?(proof_of_work_nonce = default_proof_of_work_nonce)
+        ?(priority = 0) ?seed_nonce_hash () =
+    Alpha_context.Block_header.({
+      priority ;
+      proof_of_work_nonce ;
+      seed_nonce_hash ;
+    })
+
+
+  let begin_construction ?(priority=0) ~timestamp ~(header:Alpha_context.Block_header.shell_header) ~hash ctxt =
+    let contents = contents ~priority () in
+    let protocol_data =
+      let open! Alpha_context.Block_header in {
+        contents ;
+        signature = Signature.zero ;
+      } in
+    let header = {
+        Alpha_context.Block_header.shell = {
+          predecessor = hash ;
+          proto_level = header.proto_level ;
+          validation_passes = header.validation_passes ;
+          fitness = header.fitness ;
+          timestamp ;
+          level = header.level ;
+          context = Alpha_environment.Context_hash.zero ;
+          operations_hash = Alpha_environment.Operation_list_list_hash.zero ;
+        } ;
+        protocol_data = {
+            contents ;
+            signature = Signature.zero ;
+          } ;
+      } in
+    Main.begin_construction
+      ~chain_id: Alpha_environment.Chain_id.zero
+      ~predecessor_context: ctxt
+      ~predecessor_timestamp: header.shell.timestamp
+      ~predecessor_fitness: header.shell.fitness
+      ~predecessor_level: header.shell.level
+      ~predecessor:hash
+      ~timestamp
+      ~protocol_data
+      () >>= fun x -> Lwt.return @@ Alpha_environment.wrap_error x >>=? fun state ->
+    return state.ctxt
+
+  let main n =
+    init n >>=? fun ((ctxt, header, hash), accounts, contracts) ->
+    let timestamp = Tezos_base.Time.now () in
+    begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt ->
+    return (ctxt, accounts, contracts)
+
+end
+
+type identity = {
+  public_key_hash : Signature.public_key_hash;
+  public_key : Signature.public_key;
+  secret_key : Signature.secret_key;
+  implicit_contract : Alpha_context.Contract.t;
+}
+
+type environment = {
+  tezos_context : Alpha_context.t ;
+  identities : identity list ;
+}
+
+let init_environment () =
+  Context_init.main 10 >>=? fun (tezos_context, accounts, contracts) ->
+  let accounts = List.map fst accounts in
+  let tezos_context = Alpha_context.Gas.set_limit tezos_context @@ Z.of_int 350000 in
+  let identities =
+    List.map (fun ((a:Context_init.account), c) -> {
+          public_key = a.pk ;
+          public_key_hash = a.pkh ;
+          secret_key = a.sk ;
+          implicit_contract = c ;
+        }) @@
+    List.combine accounts contracts in
+  return {tezos_context ; identities}
+
+let contextualize ~msg ?environment f =
+  let lwt =
+    let environment = match environment with
+      | None -> init_environment ()
+      | Some x -> return x in
+    environment >>=? f
+  in
+  force_ok ~msg @@ Lwt_main.run lwt

meta_michelson/streams.ml

@@ -0,0 +1,18 @@
+let read_file f =
+  let ic = open_in f in
+  let n = in_channel_length ic in
+  let s = Bytes.create n in
+  really_input ic s 0 n;
+  close_in ic;
+  Bytes.to_string s
+
+let read_lines filename = 
+  let lines = ref [] in
+  let chan = open_in filename in
+  try
+    while true; do
+      lines := input_line chan :: !lines
+    done; !lines
+  with End_of_file ->
+    close_in chan;
+    List.rev !lines

mini_c/PP.ml

@@ -0,0 +1,120 @@
+open Simple_utils.PP_helpers
+open Types
+open Format
+
+let list_sep_d x = list_sep x (const " , ")
+
+let space_sep ppf () = fprintf ppf " "
+
+let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R"
+
+let type_base ppf : type_base -> _ = function
+  | Base_unit -> fprintf ppf "unit"
+  | Base_bool -> fprintf ppf "bool"
+  | Base_int -> fprintf ppf "int"
+  | Base_nat -> fprintf ppf "nat"
+  | Base_tez -> fprintf ppf "tez"
+  | Base_string -> fprintf ppf "string"
+  | Base_address -> fprintf ppf "address"
+  | Base_bytes -> fprintf ppf "bytes"
+  | Base_operation -> fprintf ppf "operation"
+
+let rec type_ ppf : type_value -> _ = function
+  | T_or(a, b) -> fprintf ppf "(%a) | (%a)" type_ a type_ b
+  | T_pair(a, b) -> fprintf ppf "(%a) & (%a)" type_ a type_ b
+  | T_base b -> type_base ppf b
+  | T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_ a type_ b
+  | T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_ k type_ v
+  | T_list(t) -> fprintf ppf "list(%a)" type_ t
+  | T_option(o) -> fprintf ppf "option(%a)" type_ o
+  | T_contract(t) -> fprintf ppf "contract(%a)" type_ t
+  | T_deep_closure(c, arg, ret) ->
+      fprintf ppf "[%a](%a)->(%a)"
+        environment c
+        type_ arg type_ ret
+
+and environment_element ppf ((s, tv) : environment_element) =
+  Format.fprintf ppf "%s : %a" s type_ tv
+
+and environment ppf (x:environment) =
+  fprintf ppf "Env[%a]" (list_sep_d environment_element) x
+
+let rec value ppf : value -> unit = function
+  | D_bool b -> fprintf ppf "%b" b
+  | D_operation _ -> fprintf ppf "operation[...bytes]"
+  | D_int n -> fprintf ppf "%d" n
+  | D_nat n -> fprintf ppf "+%d" n
+  | D_tez n -> fprintf ppf "%dtz" n
+  | D_unit -> fprintf ppf " "
+  | D_string s -> fprintf ppf "\"%s\"" s
+  | D_bytes _ -> fprintf ppf "[bytes]"
+  | D_pair (a, b) -> fprintf ppf "(%a), (%a)" value a value b
+  | D_left a -> fprintf ppf "L(%a)" value a
+  | D_right b -> fprintf ppf "R(%a)" value b
+  | D_function x -> function_ ppf x
+  | D_none -> fprintf ppf "None"
+  | D_some s -> fprintf ppf "Some (%a)" value s
+  | D_map m -> fprintf ppf "Map[%a]" (list_sep_d value_assoc) m
+  | D_list lst -> fprintf ppf "List[%a]" (list_sep_d value) lst
+
+and value_assoc ppf : (value * value) -> unit = fun (a, b) ->
+  fprintf ppf "%a -> %a" value a value b
+
+and expression' ppf (e:expression') = match e with
+  | E_capture_environment s -> fprintf ppf "capture(%a)" (list_sep string (const " ; ")) s
+  | E_variable v -> fprintf ppf "%s" v
+  | E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b
+  | E_constant(p, lst) -> fprintf ppf "%s %a" p (pp_print_list ~pp_sep:space_sep expression) lst
+  | E_literal v -> fprintf ppf "%a" value v
+  | E_empty_map _ -> fprintf ppf "map[]"
+  | E_empty_list _ -> fprintf ppf "list[]"
+  | E_make_none _ -> fprintf ppf "none"
+  | E_Cond (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b
+  | E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %s -> %a" expression c expression n name expression s
+  | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) ->
+      fprintf ppf "%a ?? %s -> %a : %s -> %a" expression c name_l expression l name_r expression r
+  | E_let_in ((name , _) , expr , body) ->
+      fprintf ppf "let %s = %a in %a" name expression expr expression body
+
+and expression : _ -> expression -> _ = fun ppf e ->
+  expression' ppf e.content
+
+and expression_with_type : _ -> expression -> _  = fun ppf e ->
+  fprintf ppf "%a : %a"
+    expression' e.content
+    type_ e.type_value
+
+and function_ ppf ({binder ; input ; output ; body ; result}:anon_function) =
+  fprintf ppf "fun (%s:%a) : %a %a return %a"
+    binder
+    type_ input
+    type_ output
+    block body
+    expression result
+
+and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e
+
+and declaration ppf ((n, e):assignment) = fprintf ppf "let %s = %a;" n expression e
+
+and statement ppf ((s, _) : statement) = match s with
+  | S_environment_load _ -> fprintf ppf "load env"
+  | S_environment_select _ -> fprintf ppf "select env"
+  | S_environment_add (name, tv) -> fprintf ppf "add %s %a" name type_ tv
+  | S_declaration ass -> declaration ppf ass
+  | S_assignment ass -> assignment ppf ass
+  | S_do e -> fprintf ppf "do %a" expression e
+  | S_cond (expr, i, e) -> fprintf ppf "if (%a) %a %a" expression expr block i block e
+  | S_patch (r, path, e) ->
+      fprintf ppf "%s.%a := %a" r (list_sep lr (const ".")) path expression e
+  | S_if_none (expr, none, ((name, _), some)) -> fprintf ppf "if_none (%a) %a %s->%a" expression expr block none name block some
+  | S_while (e, b) -> fprintf ppf "while (%a) %a" expression e block b
+
+and block ppf ((b, _):block) =
+  match b with
+  | [] -> fprintf ppf "{}"
+  | b -> fprintf ppf "{@;  @[<v>%a@]@;}" (pp_print_list ~pp_sep:(tag "@;") statement) b
+
+let tl_statement ppf (ass, _) = assignment ppf ass
+
+let program ppf (p:program) =
+  fprintf ppf "Program:\n---\n%a" (pp_print_list ~pp_sep:pp_print_newline tl_statement) p

mini_c/combinators.ml

@@ -0,0 +1,161 @@
+open Trace
+open Types
+
+module Expression = struct
+  type t' = expression'
+  type t = expression
+
+  let get_content : t -> t' = fun e -> e.content
+  let get_type : t -> type_value = fun e -> e.type_value
+  let get_environment : t -> environment = fun e -> e.environment
+  let is_toplevel : t -> bool = fun e -> e.is_toplevel
+
+  let make = fun ?(itl = false) e' t env -> {
+    content = e' ;
+    type_value = t ;
+    environment = env ;
+    is_toplevel = itl ;
+  }
+
+  let make_tpl = fun ?(itl = false) (e' , t , env) -> {
+    content = e' ;
+    type_value = t ;
+    environment = env ;
+    is_toplevel = itl ;
+  }
+
+  let pair : t -> t -> t' = fun a b -> E_constant ("PAIR" , [ a ; b ])
+
+end
+
+let get_bool (v:value) = match v with
+  | D_bool b -> ok b
+  | _ -> simple_fail "not a bool"
+
+let get_int (v:value) = match v with
+  | D_int n -> ok n
+  | _ -> simple_fail "not an int"
+
+let get_nat (v:value) = match v with
+  | D_nat n -> ok n
+  | _ -> simple_fail "not a nat"
+
+let get_string (v:value) = match v with
+  | D_string s -> ok s
+  | _ -> simple_fail "not a string"
+
+let get_bytes (v:value) = match v with
+  | D_bytes b -> ok b
+  | _ -> simple_fail "not a bytes"
+
+let get_unit (v:value) = match v with
+  | D_unit -> ok ()
+  | _ -> simple_fail "not a unit"
+
+let get_option (v:value) = match v with
+  | D_none -> ok None
+  | D_some s -> ok (Some s)
+  | _ -> simple_fail "not an option"
+
+let get_map (v:value) = match v with
+  | D_map lst -> ok lst
+  | _ -> simple_fail "not a map"
+
+let get_list (v:value) = match v with
+  | D_list lst -> ok lst
+  | _ -> simple_fail "not a list"
+
+let get_t_option (v:type_value) = match v with
+  | T_option t -> ok t
+  | _ -> simple_fail "not an option"
+
+let get_pair (v:value) = match v with
+  | D_pair (a, b) -> ok (a, b)
+  | _ -> simple_fail "not a pair"
+
+let get_t_pair (t:type_value) = match t with
+  | T_pair (a, b) -> ok (a, b)
+  | _ -> simple_fail "not a type pair"
+
+let get_t_map (t:type_value) = match t with
+  | T_map kv -> ok kv
+  | _ -> simple_fail "not a type map"
+
+let get_t_list (t:type_value) = match t with
+  | T_list t -> ok t
+  | _ -> simple_fail "not a type list"
+
+let get_left (v:value) = match v with
+  | D_left b -> ok b
+  | _ -> simple_fail "not a left"
+
+let get_right (v:value) = match v with
+  | D_right b -> ok b
+  | _ -> simple_fail "not a right"
+
+let get_or (v:value) = match v with
+  | D_left b -> ok (false, b)
+  | D_right b -> ok (true, b)
+  | _ -> simple_fail "not a left/right"
+
+let wrong_type name t =
+  let title () = "not a " ^ name in
+  let content () = Format.asprintf "%a" PP.type_ t in
+  error title content
+
+let get_t_left t = match t with
+  | T_or (a , _) -> ok a
+  | _ -> fail @@ wrong_type "union" t
+
+let get_t_right t = match t with
+  | T_or (_ , b) -> ok b
+  | _ -> fail @@ wrong_type "union" t
+
+let get_t_contract t = match t with
+  | T_contract x -> ok x
+  | _ -> fail @@ wrong_type "contract" t
+
+let get_t_operation t = match t with
+  | T_base Base_operation -> ok ()
+  | _ -> fail @@ wrong_type "operation" t
+
+let get_operation (v:value) = match v with
+  | D_operation x -> ok x
+  | _ -> simple_fail "not an operation"
+
+
+let get_last_statement ((b', _):block) : statement result =
+  let aux lst = match lst with
+    | [] -> simple_fail "get_last: empty list"
+    | lst -> ok List.(nth lst (length lst - 1)) in
+  aux b'
+
+let t_int : type_value = T_base Base_int
+let t_nat : type_value = T_base Base_nat
+
+let t_function x y : type_value = T_function ( x , y )
+let t_deep_closure x y z : type_value = T_deep_closure ( x , y , z )
+let t_pair x y : type_value = T_pair ( x , y )
+let t_union x y : type_value = T_or ( x , y )
+
+let quote binder input output body result : anon_function =
+  {
+    binder ; input ; output ;
+    body ; result ;
+  }
+
+let basic_quote i o b : anon_function result =
+  let%bind (_, e) = get_last_statement b in
+  let r : expression = Expression.make_tpl (E_variable "output", o, e.post_environment) in
+  ok @@ quote "input" i o b r
+
+let basic_int_quote b : anon_function result =
+  basic_quote t_int t_int b
+
+let e_int expr env : expression = Expression.make_tpl (expr, t_int, env)
+let e_var_int name env : expression = e_int (E_variable name) env
+
+let d_unit : value = D_unit
+
+let environment_wrap pre_environment post_environment = { pre_environment ; post_environment }
+let id_environment_wrap e = environment_wrap e e

mini_c/combinators_smart.ml

@@ -0,0 +1,52 @@
+open Trace
+open Types
+open Combinators
+
+let basic_int_quote_env : environment =
+  let e = Environment.empty in
+  Environment.add ("input", t_int) e
+
+let statement s' env : statement =
+  match s' with
+  | S_environment_load (_ , env') -> s', environment_wrap env env'
+  | S_environment_select env' -> s', environment_wrap env env'
+  | S_environment_add (name, tv) -> s' , environment_wrap env (Environment.add (name , tv) env)
+  | S_cond _ -> s' , id_environment_wrap env
+  | S_do _ -> s' , id_environment_wrap env
+  | S_if_none _ -> s' , id_environment_wrap env
+  | S_while _ -> s' , id_environment_wrap env
+  | S_patch _ -> s' , id_environment_wrap env
+  | S_declaration (name , e) -> s', environment_wrap env (Environment.add (name , (Expression.get_type e)) env)
+  | S_assignment (name , e) -> s', environment_wrap env (Environment.add (name , (Expression.get_type e)) env)
+
+let block (statements:statement list) : block result =
+  match statements with
+  | [] -> simple_fail "no statements in block"
+  | lst ->
+      let first = List.hd lst in
+      let last = List.(nth lst (length lst - 1)) in
+      ok (lst, environment_wrap (snd first).pre_environment (snd last).post_environment)
+
+let append_statement' : block -> statement' -> block = fun b s' ->
+  let b_wrap = snd b in
+  let s = statement s' b_wrap.post_environment in
+  let s_wrap = snd s in
+  let b_wrap' = { b_wrap with post_environment = s_wrap.post_environment } in
+  let b_content = fst b in
+  (b_content @ [s], b_wrap')
+
+let prepend_statement : statement -> block -> block = fun s b ->
+  let s_wrap = snd s in
+  let b_wrap = snd b in
+  let b_wrap' = { b_wrap with pre_environment = s_wrap.pre_environment } in
+  let b_content = fst b in
+  (s :: b_content, b_wrap')
+
+let statements (lst:(environment -> statement) list) e : statement list =
+  let rec aux lst e = match lst with
+    | [] -> []
+    | hd :: tl ->
+        let s = hd e in
+        s :: aux tl (snd s).post_environment
+  in
+  aux lst e

mini_c/dune

@@ -0,0 +1,13 @@
+(library
+  (name mini_c)
+  (public_name ligo.mini_c)
+  (libraries
+    simple-utils
+    tezos-utils
+    meta_michelson
+  )
+  (preprocess
+    (pps simple-utils.ppx_let_generalized)
+  )
+  (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
+)

mini_c/environment.ml

@@ -0,0 +1,61 @@
+(* open Trace *)
+open Types
+
+(* module type ENVIRONMENT = sig
+ *   type element = environment_element
+ *   type t = environment
+ *
+ *   val empty : t
+ *   val add : element -> t -> t
+ *   val concat : t list -> t
+ *   val get_opt : string -> t -> type_value option
+ *   val get_i : string -> t -> (type_value * int)
+ *   val of_list : element list -> t
+ *   val closure_representation : t -> type_value
+ * end *)
+
+module Environment (* : ENVIRONMENT *) = struct
+  type element = environment_element
+  type t = environment
+
+  let empty : t = []
+  let add : element -> t -> t  = List.cons
+  let concat : t list -> t  = List.concat
+  let get_opt : string -> t -> type_value option  = List.assoc_opt
+  let has : string -> t -> bool = fun s t ->
+    match get_opt s t with
+    | None -> false
+    | Some _ -> true
+  let get_i : string -> t -> (type_value * int) = List.assoc_i
+  let of_list : element list -> t = fun x -> x
+  let to_list : t -> element list = fun x -> x
+  let get_names : t -> string list = List.map fst
+  let remove : int -> t -> t = List.remove
+
+  let select : string list -> t -> t = fun lst env ->
+    let e_lst =
+      let e_lst = to_list env in
+      let aux selector (s , _) =
+        match List.mem s selector with
+        | true -> List.remove_element s selector , true
+        | false -> selector , false in
+      let e_lst' = List.fold_map_right aux lst e_lst in
+      let e_lst'' = List.combine e_lst e_lst' in
+      e_lst'' in
+    of_list
+    @@ List.map fst
+    @@ List.filter snd
+    @@ e_lst
+
+
+  let fold : _ -> 'a -> t -> 'a = List.fold_left
+  let filter : _ -> t -> t = List.filter
+
+  let closure_representation : t -> type_value = fun t ->
+    match t with
+    | [] -> T_base Base_unit
+    | [ a ] -> snd a
+    | hd :: tl -> List.fold_left (fun acc cur -> T_pair (acc , snd cur)) (snd hd) tl
+end
+
+include Environment

mini_c/mini_c.ml

@@ -0,0 +1,10 @@
+module Types = Types
+include Types
+
+module PP = PP
+module Combinators = struct
+  include Combinators
+  include Combinators_smart
+end
+include Combinators
+module Environment = Environment

mini_c/types.ml

@@ -0,0 +1,109 @@
+type type_name = string
+
+type type_base =
+  | Base_unit
+  | Base_bool
+  | Base_int | Base_nat | Base_tez
+  | Base_string | Base_bytes | Base_address
+  | Base_operation
+
+type type_value =
+  | T_pair of (type_value * type_value)
+  | T_or of type_value * type_value
+  | T_function of type_value * type_value
+  | T_deep_closure of environment * type_value * type_value
+  | T_base of type_base
+  | T_map of (type_value * type_value)
+  | T_list of type_value
+  | T_contract of type_value
+  | T_option of type_value
+
+and environment_element = string * type_value
+
+and environment = environment_element list
+
+type environment_wrap = {
+  pre_environment : environment ;
+  post_environment : environment ;
+}
+
+type var_name = string
+type fun_name = string
+
+type value =
+  | D_unit
+  | D_bool of bool
+  | D_nat of int
+  | D_tez of int
+  | D_int of int
+  | D_string of string
+  | D_bytes of bytes
+  | D_pair of value * value
+  | D_left of value
+  | D_right of value
+  | D_some of value
+  | D_none
+  | D_map of (value * value) list
+  | D_list of value list
+  (* | `Macro of anon_macro ... The future. *)
+  | D_function of anon_function
+  | D_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation
+
+and selector = var_name list
+
+and expression' =
+  | E_literal of value
+  | E_capture_environment of selector
+  | E_constant of string * expression list
+  | E_application of expression * expression
+  | E_variable of var_name
+  | E_empty_map of (type_value * type_value)
+  | E_empty_list of type_value
+  | E_make_none of type_value
+  | E_Cond of expression * expression * expression
+  | E_if_none of expression * expression * ((var_name * type_value) * expression)
+  | E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression)
+  | E_let_in of ((var_name * type_value) * expression * expression)
+
+and expression = {
+  content : expression' ;
+  type_value : type_value ;
+  environment : environment ;  (* Environment in which the expressions are evaluated *)
+  is_toplevel : bool ;
+}
+
+and assignment = var_name * expression
+
+and statement' =
+  | S_environment_select of environment
+  | S_environment_load of (expression * environment)
+  | S_environment_add of (var_name * type_value)
+  | S_declaration of assignment (* First assignment *)
+  | S_assignment of assignment
+  | S_do of expression
+  | S_cond of expression * block * block
+  | S_patch of string * [`Left | `Right] list * expression
+  | S_if_none of expression * block * ((var_name * type_value) * block)
+  | S_while of expression * block
+
+and statement = statement' * environment_wrap
+
+and toplevel_statement = assignment * environment_wrap
+
+and anon_function = {
+  binder : string ;
+  input : type_value ;
+  output : type_value ;
+  body : block ;
+  result : expression ;
+}
+
+and capture =
+  | No_capture (* For functions that don't capture their environments. Quotes. *)
+  | Deep_capture of environment (* Retrieves only the values it needs. Multiple SETs on init. Lighter GETs and SETs at use. *)
+
+and block' = statement list
+
+and block = block' * environment_wrap
+
+and program = toplevel_statement list

operators/dune

@@ -0,0 +1,14 @@
+(library
+  (name operators)
+  (public_name ligo.operators)
+  (libraries
+    simple-utils
+    tezos-utils
+    ast_typed
+    mini_c
+  )
+  (preprocess
+    (pps simple-utils.ppx_let_generalized)
+  )
+  (flags (:standard -open Simple_utils ))
+)

operators/operators.ml

@@ -0,0 +1,407 @@
+open Trace
+
+module Simplify = struct
+
+  let type_constants = [
+    ("unit" , 0) ;
+    ("string" , 0) ;
+    ("bytes" , 0) ;
+    ("nat" , 0) ;
+    ("int" , 0) ;
+    ("tez" , 0) ;
+    ("bool" , 0) ;
+    ("operation" , 0) ;
+    ("address" , 0) ;
+    ("contract" , 1) ;
+    ("list" , 1) ;
+    ("option" , 1) ;
+    ("set" , 1) ;
+    ("map" , 2) ;
+    ("big_map" , 2) ;
+  ]
+
+  let constants = [
+    ("get_force" , 2) ;
+    ("transaction" , 3) ;
+    ("get_contract" , 1) ;
+    ("size" , 1) ;
+    ("int" , 1) ;
+    ("abs" , 1) ;
+    ("amount" , 0) ;
+    ("unit" , 0) ;
+    ("source" , 0) ;
+  ]
+
+  module Camligo = struct
+    let constants = [
+      ("Bytes.pack" , 1) ;
+      ("Crypto.hash" , 1) ;
+      ("Operation.transaction" , 3) ;
+      ("Operation.get_contract" , 1) ;
+      ("sender" , 0) ;
+      ("unit" , 0) ;
+      ("source" , 0) ;
+    ]
+  end
+
+end
+
+module Typer = struct
+  module Errors = struct
+    let wrong_param_number = fun name ->
+      let title () = "wrong number of params" in
+      let full () = name in
+      error title full
+  end
+
+  open Ast_typed
+
+  type typer_predicate = type_value list -> bool
+  type type_result = string * type_value
+  type typer' = type_value list -> type_value option -> type_result result
+  type typer = string * int * (typer_predicate * typer') list
+
+  let predicate_0 : typer_predicate = fun lst ->
+    match lst with
+    | [] -> true
+    | _ -> false
+
+  let predicate_1 : (type_value -> bool) -> typer_predicate = fun f lst ->
+    match lst with
+    | [ a ] -> f a
+    | _ -> false
+
+  let predicate_2 : (type_value -> type_value -> bool) -> typer_predicate = fun f lst ->
+    match lst with
+    | [ a ; b ] -> f a b
+    | _ -> false
+
+  let predicate_3 : (type_value -> type_value -> type_value -> bool) -> typer_predicate = fun f lst ->
+    match lst with
+    | [ a ; b ; c ] -> f a b c
+    | _ -> false
+
+  let true_1 = predicate_1 (fun _ -> true)
+  let true_2 = predicate_2 (fun _ _ -> true)
+  let true_3 = predicate_3 (fun _ _ _ -> true)
+
+  let eq_1 : type_value -> typer_predicate = fun v ->
+    let aux = fun a -> type_value_eq (a, v) in
+    predicate_1 aux
+
+  let eq_2 : type_value -> typer_predicate = fun v ->
+    let aux = fun a b -> type_value_eq (a, v) && type_value_eq (b, v) in
+    predicate_2 aux
+
+  let typer'_0 : (type_value option -> type_result result) -> typer' = fun f lst tv ->
+    match lst with
+    | [] -> f tv
+    | _ -> simple_fail "!!!"
+
+  let typer'_1 : (type_value -> type_result result) -> typer' = fun f lst _ ->
+    match lst with
+    | [ a ] -> f a
+    | _ -> simple_fail "!!!"
+
+  let typer'_1_opt : (type_value -> type_value option -> type_result result) -> typer' = fun f lst tv_opt ->
+    match lst with
+    | [ a ] -> f a tv_opt
+    | _ -> simple_fail "!!!"
+
+  let typer'_2 : (type_value -> type_value -> type_result result) -> typer' = fun f lst _ ->
+    match lst with
+    | [ a ; b ] -> f a b
+    | _ -> simple_fail "!!!"
+
+  let typer'_3 : (type_value -> type_value -> type_value -> type_result result) -> typer' = fun f lst _ ->
+    match lst with
+    | [ a ; b ; c ] -> f a b c
+    | _ -> simple_fail "!!!"
+
+  let typer_constant cst : typer' = fun _ _ -> ok cst
+
+  let constant_2 : string -> type_value -> typer' = fun s tv ->
+    let aux = fun _ _ -> ok (s, tv) in
+    typer'_2 aux
+
+  let make_2 : string -> _ list -> typer = fun name pfs ->
+    (name , 2 , List.map (Tuple.map_h_2 predicate_2 typer'_2) pfs)
+
+  let same_2 : string -> (string * type_value) list -> typer = fun s lst ->
+    let aux (s, tv) = eq_2 tv, constant_2 s tv in
+    (s , 2 , List.map aux lst)
+
+  let very_same_2 : string -> type_value -> typer = fun s tv -> same_2 s [s , tv]
+
+  open Combinators
+
+  let comparator : string -> typer = fun s -> s , 2 , [
+      (eq_2 (t_int ()), constant_2 s (t_bool ())) ;
+      (eq_2 (t_nat ()), constant_2 s (t_bool ())) ;
+      (eq_2 (t_tez ()), constant_2 s (t_bool ())) ;
+      (eq_2 (t_bytes ()), constant_2 s (t_bool ())) ;
+      (eq_2 (t_string ()), constant_2 s (t_bool ())) ;
+      (eq_2 (t_address ()), constant_2 s (t_bool ())) ;
+    ]
+
+  let boolean_operator_2 : string -> typer = fun s -> very_same_2 s (t_bool ())
+
+  let none = "NONE" , 0 , [
+      predicate_0 , typer'_0 (fun tv_opt -> match tv_opt with
+          | None -> simple_fail "untyped NONE"
+          | Some t -> ok ("NONE", t))
+    ]
+
+  let sub = "SUB" , 2 , [
+      eq_2 (t_int ()) , constant_2 "SUB_INT" (t_int ()) ;
+      eq_2 (t_nat ()) , constant_2 "SUB_NAT" (t_int ()) ;
+    ]
+
+  let some = "SOME" , 1 , [
+      true_1 , typer'_1 (fun s -> ok ("SOME", t_option s ())) ;
+    ]
+
+  let map_remove : typer = "MAP_REMOVE" , 2 , [
+      (true_2 , typer'_2 (fun k m ->
+          let%bind (src, _) = get_t_map m in
+          let%bind () = assert_type_value_eq (src, k) in
+          ok ("MAP_REMOVE", m)
+        ))
+    ]
+
+  let map_update : typer = "MAP_UPDATE" , 3 , [
+      (true_3 , typer'_3 (fun k v m ->
+           let%bind (src, dst) = get_t_map m in
+           let%bind () = assert_type_value_eq (src, k) in
+           let%bind () = assert_type_value_eq (dst, v) in
+           ok ("MAP_UPDATE", m)))
+    ]
+
+  let size : typer = "size" , 1 , [
+      (true_1, typer'_1 (fun t ->
+           let%bind () = bind_or (assert_t_map t, assert_t_list t) in
+           ok ("SIZE", t_nat ())))
+    ]
+
+  let get_force : typer = "get_force" , 2 , [
+      (true_2, typer'_2 (fun i_ty m_ty ->
+           let%bind (src, dst) = get_t_map m_ty in
+           let%bind _ = assert_type_value_eq (src, i_ty) in
+           ok ("GET_FORCE", dst)))
+    ]
+
+  let int : typer = "int" , 1 , [
+      (eq_1 (t_nat ()), typer_constant ("INT" , t_int ()))
+    ]
+
+  let bytes_pack : typer = "Bytes.pack" , 1 , [
+      (true_1 , typer'_1 (fun _ -> ok ("PACK" , t_bytes ())))
+    ]
+
+  let bytes_unpack = "Bytes.unpack" , 1 , [
+      eq_1 (t_bytes ()) , typer'_1_opt (fun _ tv_opt -> match tv_opt with
+          | None -> simple_fail "untyped UNPACK"
+          | Some t -> ok ("UNPACK", t))
+    ]
+
+  let crypto_hash = "Crypto.hash" , 1 , [
+      eq_1 (t_bytes ()) , typer_constant ("HASH" , t_bytes ()) ;
+    ]
+
+  let sender = "sender" , 0 , [
+      predicate_0 , typer_constant ("SENDER", t_address ())
+    ]
+
+  let source = "source" , 0 , [
+      predicate_0 , typer_constant ("SOURCE", t_address ())
+    ]
+
+  let unit = "unit" , 0 , [
+      predicate_0 , typer_constant ("UNIT", t_unit ())
+    ]
+
+  let amount = "amount" , 0 , [
+      predicate_0 , typer_constant ("AMOUNT", t_tez ())
+    ]
+
+  let transaction = "Operation.transaction" , 3 , [
+      true_3 , typer'_3 (
+        fun param amount contract ->
+          let%bind () =
+            assert_t_tez amount in
+          let%bind contract_param =
+            get_t_contract contract in
+          let%bind () =
+            assert_type_value_eq (param , contract_param) in
+          ok ("TRANSFER_TOKENS" , t_operation ())
+      )
+    ]
+  let transaction' = "transaction" , 3 , [
+      true_3 , typer'_3 (
+        fun param amount contract ->
+          let%bind () =
+            assert_t_tez amount in
+          let%bind contract_param =
+            get_t_contract contract in
+          let%bind () =
+            assert_type_value_eq (param , contract_param) in
+          ok ("TRANSFER_TOKENS" , t_operation ())
+      )
+    ]
+
+  let get_contract = "Operation.get_contract" , 1 , [
+      eq_1 (t_address ()) , typer'_1_opt (
+        fun _ tv_opt ->
+          let%bind tv =
+            trace_option (simple_error "get_contract needs a type annotation") tv_opt in
+          let%bind tv' =
+            trace_strong (simple_error "get_contract has a not-contract annotation") @@
+            get_t_contract tv in
+          ok ("CONTRACT" , t_contract tv' ())
+      )
+    ]
+  let get_contract' = "get_contract" , 1 , [
+      eq_1 (t_address ()) , typer'_1_opt (
+        fun _ tv_opt ->
+          let%bind tv =
+            trace_option (simple_error "get_contract needs a type annotation") tv_opt in
+          let%bind tv' =
+            trace_strong (simple_error "get_contract has a not-contract annotation") @@
+            get_t_contract tv in
+          ok ("CONTRACT" , t_contract tv' ())
+      )
+    ]
+
+  let num_2 : typer_predicate =
+    let aux = fun a b ->
+      (type_value_eq (a , t_int ()) || type_value_eq (a , t_nat ())) &&
+      (type_value_eq (b , t_int ()) || type_value_eq (b , t_nat ())) in
+    predicate_2 aux
+
+  let mod_ = "MOD" , 2 , [
+      num_2 , constant_2 "MOD" (t_nat ()) ;
+    ]
+
+  let abs = "abs" , 1 , [
+      eq_1 (t_int ()) , typer_constant ("ABS" , (t_nat ())) ;
+    ]
+
+  let times = "TIMES" , 2 , [
+      (eq_2 (t_nat ()) , constant_2 "TIMES_NAT" (t_nat ())) ;
+      (num_2 , constant_2 "TIMES_INT" (t_int ())) ;
+      (
+        let aux a b =
+          (type_value_eq (a , t_nat ()) && type_value_eq (b , t_tez ())) ||
+          (type_value_eq (b , t_nat ()) && type_value_eq (a , t_tez ())) in
+       predicate_2 aux , constant_2 "TIMES_TEZ" (t_tez ())
+     ) ;
+    ]
+
+  let constant_typers =
+    let typer_to_kv : typer -> (string * _) = fun (a, b, c) -> (a, (b, c)) in
+    Map.String.of_list
+    @@ List.map typer_to_kv [
+      same_2 "ADD" [
+        ("ADD_INT" , t_int ()) ;
+        ("ADD_NAT" , t_nat ()) ;
+        ("CONCAT" , t_string ()) ;
+      ] ;
+      times ;
+      same_2 "DIV" [
+        ("DIV_INT" , t_int ()) ;
+        ("DIV_NAT" , t_nat ()) ;
+      ] ;
+      mod_ ;
+      sub ;
+      none ;
+      some ;
+      comparator "EQ" ;
+      comparator "NEQ" ;
+      comparator "LT" ;
+      comparator "GT" ;
+      comparator "LE" ;
+      comparator "GE" ;
+      boolean_operator_2 "OR" ;
+      boolean_operator_2 "AND" ;
+      map_remove ;
+      map_update ;
+      int ;
+      size ;
+      get_force ;
+      bytes_pack ;
+      bytes_unpack ;
+      crypto_hash ;
+      sender ;
+      source ;
+      unit ;
+      amount ;
+      transaction ;
+      transaction' ;
+      get_contract ;
+      get_contract' ;
+      abs ;
+    ]
+
+end
+
+module Compiler = struct
+
+  module Michelson = Tezos_utils.Micheline.Michelson
+  open Michelson
+
+  type predicate =
+    | Constant of michelson
+    | Unary of michelson
+    | Binary of michelson
+    | Ternary of michelson
+
+  let simple_constant c = Constant c
+
+  let simple_unary c = Unary c
+
+  let simple_binary c = Binary c
+
+  let simple_ternary c = Ternary c
+
+  let predicates = Map.String.of_list [
+    ("ADD_INT" , simple_binary @@ prim I_ADD) ;
+    ("ADD_NAT" , simple_binary @@ prim I_ADD) ;
+    ("SUB_INT" , simple_binary @@ prim I_SUB) ;
+    ("SUB_NAT" , simple_binary @@ prim I_SUB) ;
+    ("TIMES_INT" , simple_binary @@ prim I_MUL) ;
+    ("TIMES_NAT" , simple_binary @@ prim I_MUL) ;
+    ("TIMES_TEZ" , simple_binary @@ prim I_MUL) ;
+    ("DIV_INT" , simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "DIV by 0") ; i_car]) ;
+    ("DIV_NAT" , simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "DIV by 0") ; i_car]) ;
+    ("MOD" , simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "MOD by 0") ; i_cdr]) ;
+    ("NEG" , simple_unary @@ prim I_NEG) ;
+    ("OR" , simple_binary @@ prim I_OR) ;
+    ("AND" , simple_binary @@ prim I_AND) ;
+    ("PAIR" , simple_binary @@ prim I_PAIR) ;
+    ("CAR" , simple_unary @@ prim I_CAR) ;
+    ("CDR" , simple_unary @@ prim I_CDR) ;
+    ("EQ" , simple_binary @@ seq [prim I_COMPARE ; prim I_EQ]) ;
+    ("NEQ" , simple_binary @@ seq [prim I_COMPARE ; prim I_NEQ]) ;
+    ("LT" , simple_binary @@ seq [prim I_COMPARE ; prim I_LT]) ;
+    ("LE" , simple_binary @@ seq [prim I_COMPARE ; prim I_LE]) ;
+    ("GT" , simple_binary @@ seq [prim I_COMPARE ; prim I_GT]) ;
+    ("GE" , simple_binary @@ seq [prim I_COMPARE ; prim I_GE]) ;
+    ("UPDATE" , simple_ternary @@ prim I_UPDATE) ;
+    ("SOME" , simple_unary @@ prim I_SOME) ;
+    ("GET_FORCE" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "GET_FORCE")]) ;
+    ("GET" , simple_binary @@ prim I_GET) ;
+    ("SIZE" , simple_unary @@ prim I_SIZE) ;
+    ("FAILWITH" , simple_unary @@ prim I_FAILWITH) ;
+    ("ASSERT" , simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])) ;
+    ("INT" , simple_unary @@ prim I_INT) ;
+    ("ABS" , simple_unary @@ prim I_ABS) ;
+    ("CONS" , simple_binary @@ prim I_CONS) ;
+    ("UNIT" , simple_constant @@ prim I_UNIT) ;
+    ("AMOUNT" , simple_constant @@ prim I_AMOUNT) ;
+    ("TRANSFER_TOKENS" , simple_ternary @@ prim I_TRANSFER_TOKENS) ;
+    ("SOURCE" , simple_constant @@ prim I_SOURCE) ;
+    ("SENDER" , simple_constant @@ prim I_SENDER) ;
+    ( "MAP_UPDATE" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE ]) ;
+  ]
+
+end

parser/camligo/.gitignore

@@ -0,0 +1,2 @@
+ast_generated.ml
+parser_generated.mly

parser/camligo/ast.ml

@@ -0,0 +1 @@
+include Ast_generated

parser/camligo/dune

@@ -0,0 +1,60 @@
+(library
+  (name parser_camligo)
+  (public_name ligo.parser.camligo)
+  (libraries
+    simple-utils
+    tezos-utils
+    lex
+  )
+  (modules ast ast_generated parser user)
+  (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils -open Tezos_utils ))
+  (preprocess
+    (pps
+      simple-utils.ppx_let_generalized
+      ppx_deriving.std
+    )
+  )
+)
+
+;; Generating parser
+
+(rule
+  (targets parser.ml parser.mli)
+  (deps parser_generated.mly ast.ml)
+  (action (system "menhir --explain --external-tokens Lex.Token lex/token.mly parser_generated.mly --base parser"))
+)
+
+(rule
+ (targets parser_generated.mly)
+ (deps partial_parser.mly pre_parser.mly)
+ (action (system "cat pre_parser.mly partial_parser.mly > parser_generated.mly"))
+ (mode promote-until-clean)
+)
+
+(rule
+ (targets partial_parser.mly)
+ (deps generator.exe)
+ (action (system "./generator.exe parser > partial_parser.mly"))
+)
+
+;; Generating AST
+
+(rule
+ (targets ast_generated.ml)
+ (deps generator.exe)
+ (action (system "./generator.exe ast > ast_generated.ml"))
+ (mode promote-until-clean)
+)
+
+;; Generating Generator
+
+(executable
+  (name generator)
+  (libraries
+    ocamlgraph
+    simple-utils
+    tezos-utils
+    lex
+  )
+  (modules generator)
+)

parser/camligo/generator.ml

@@ -0,0 +1,739 @@
+open Simple_utils
+
+type 'a name = {
+  content : 'a ;
+  name : string ;
+}
+
+let make_name name content = { name ; content }
+let destruct {name ; content} = (name, content)
+let get_name x = x.name
+let get_content x = x.content
+
+module Token = Lex.Token
+type token = Token.token
+
+module O = struct
+
+  type list_mode =
+    | Trail of token
+    | Trail_option of token
+    | Trail_force of token
+    | Trail_force_ne of token
+    | Lead of token
+    | Lead_ne of token
+    | Separated of token
+    | Separated_ne of token
+    | Separated_nene of token
+    | Naked
+    | Naked_ne
+
+  type 'a list_element = list_mode * 'a
+
+  type rhs_element = [
+    | `Named of string
+    | `Token of token
+    | `List of string list_element
+    | `Option of string
+  ]
+
+  type rhs = rhs_element list name
+  type rule = rhs list name
+
+  type manual_rule_content = {
+    menhir_codes : string list ;
+    ast_code : string ;
+  }
+  type manual_rule = manual_rule_content name
+
+  type singleton =
+    | Manual of manual_rule
+    | Generated of rule
+
+  type name_element = [
+    | `Named of string
+    | `Current
+    | `Lower
+  ]
+
+  type element = [
+    | `Named of string
+    | `Token of token
+    | `List of name_element list_element
+    | `Current
+    | `Lower
+  ]
+
+  type operator = element list
+  type n_operator = operator name
+
+  type n_operators = n_operator list
+  type level = n_operators name
+  type level_list = level list
+  type levels = level List.Ne.t
+
+  type hierarchy = {
+    prefix : string ;
+    levels : levels ;
+    auxiliary_rules : rule list ;
+  }
+  type n_hierarchy = hierarchy name
+  let make_hierarchy prefix levels auxiliary_rules : hierarchy = { levels ; auxiliary_rules ; prefix }
+
+  type language = {
+    entry_point : string ;
+    singletons : singleton list ;
+    hierarchies : n_hierarchy list ;
+  }
+
+  let get_op : n_operator -> operator = get_content
+
+  let manual_singleton name menhir_codes ast_code : singleton = Manual (make_name name {menhir_codes ; ast_code})
+  let rule_singleton rule : singleton = Generated rule
+  let language entry_point singletons hierarchies = {entry_point ; singletons ; hierarchies}
+
+  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 : int -> n_operators -> level = fun i x ->
+      let first = get_name (List.hd x) in
+      let name' = Format.asprintf "%s_%d_%s" name i first in
+      make_name name' x in
+    let levels : levels = List.Ne.mapi name_i nopss' in
+    make_name name @@ make_hierarchy prefix levels rules
+
+end
+
+module Check = struct
+  open O
+
+  let well_formed : language -> unit = fun l ->
+    let elements : element list -> unit = fun es ->
+      let rec aux = fun es ->
+        match es with
+        | [] -> ()
+        | [ _ ] -> ()
+        | (`List _ | `Named _ | `Current | `Lower) :: (`List _ | `Named _ | `Current | `Lower) :: _ ->
+          raise (Failure "two non-token separated ops in a row")
+        | _ :: tl -> aux tl
+      in
+      (if (List.length es < 2) then raise (Failure "operator is too short")) ;
+      aux es in
+    let op : n_operator -> unit = fun x -> elements @@ get_content x in
+    let level : level -> unit = fun l -> List.iter op @@ get_content l in
+    let hierarchy : n_hierarchy -> unit = fun h -> List.Ne.iter level @@ h.content.levels in
+    List.iter hierarchy l.hierarchies
+
+  let associativity : language -> unit = fun l ->
+    let level : level -> unit = fun l ->
+      let aux : ([`Left | `Right | `None] as 'a) -> n_operator -> 'a = fun ass nop ->
+        let op = get_content nop in
+        match ass, List.hd op, List.nth op (List.length op - 1) with
+        | _, `Lower, `Lower -> raise (Failure "double assoc")
+        | `None, `Lower, _ -> `Left
+        | `None, _, `Lower -> `Right
+        | `Left, _, `Lower -> raise (Failure "different assocs")
+        | `Right, `Lower, _ -> raise (Failure "different assocs")
+        | m, _, _ -> m
+      in
+      let _assert = List.fold_left aux `None (get_content l) in
+      ()
+    in
+    let hierarchy : n_hierarchy -> unit = fun h ->
+      List.Ne.iter level h.content.levels in
+    List.iter hierarchy l.hierarchies
+
+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
+
+  let manual_rule : _ -> O.manual_rule -> _ = fun ppf mr ->
+    fprintf ppf "%s = %s" mr.name mr.content.ast_code
+
+  let generated_rule : _ -> O.rule -> _ = fun ppf gr ->
+    let aux : _ -> O.rhs -> _ = fun ppf rhs ->
+      let type_elements =
+        let aux : O.rhs_element -> string option = fun e ->
+          match e with
+          | `Named s -> Some (s ^ " Location.wrap")
+          | `List ( _, s) -> Some ("(" ^ s ^ " Location.wrap list)")
+          | `Option s -> Some ("(" ^ s ^ " Location.wrap option)")
+          | `Token _ -> None
+        in
+        List.filter_map aux rhs.content in
+      let type_element = fun ppf te -> fprintf ppf "%s" te in
+      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
+      (list_sep aux new_line) gr.content
+
+  let singleton : _ -> O.singleton -> _ = fun ppf s ->
+    match s with
+    | Manual s -> manual_rule ppf s
+    | Generated s -> generated_rule ppf s
+
+  let singletons : _ -> O.singleton list -> _ = fun ppf ss ->
+    match ss with
+    | [] -> ()
+    | hd :: tl ->
+        fprintf ppf "%a\n" (prepend "type " (singleton)) hd ;
+        fprintf ppf "%a" (list_sep (prepend "and " (singleton)) (const "\n")) tl
+
+  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
+        | `Named s -> Some (s ^ " Location.wrap")
+        | `List ( _, s) -> Some ("(" ^ (match s with
+           | `Lower | `Current -> level_name |`Named s -> s
+          ) ^ " Location.wrap list)")
+        | `Token _ -> None
+        | `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 "| %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@] [@@@@deriving show]" t
+      name
+      (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
+    | [] -> ()
+    | hd :: tl ->
+        fprintf ppf "%a\n" (n_hierarchy (if first then "type" else "and")) hd ;
+        fprintf ppf "%a" (list_sep (n_hierarchy "and") (const "\n")) tl
+
+  let language : _ -> O.language -> _ = fun ppf l ->
+    fprintf ppf "%a@.@." comment "Language" ;
+    let first = List.length l.singletons = 0 in
+    fprintf ppf "  %a@.%a@.@." comment "Singletons" singletons l.singletons ;
+    fprintf ppf "  %a@.%a@." comment "Hierarchies" (n_hierarchies first) l.hierarchies ;
+    fprintf ppf "  %a@.type entry_point = %s Location.wrap@.@." comment "Entry point" l.entry_point ;
+    ()
+end
+
+module Print_Grammar = struct
+  open Format
+  open PP_helpers
+
+  let letters = [| "a" ; "b" ; "c" ; "d" ; "e" ; "f" ; "g" ; "h" ; "i" ; "j" |]
+
+
+  let manual_rule : _ -> O.manual_rule -> _ = fun ppf mr ->
+    let {name;content} = mr in
+    fprintf ppf "%s:@.  @[<v>%a@]" name (list_sep string new_line) content.menhir_codes
+
+  let generated_rule : _ -> O.rule -> _ = fun ppf gr ->
+    let aux_rule : _ -> O.rhs -> _ = fun ppf rhs ->
+      let i = ref 0 in
+      let aux : _ -> O.rhs_element -> _ = fun ppf e ->
+          (match e with
+          | `Named s -> fprintf ppf "%s = wrap(%s)" letters.(!i) s
+          | `Option s -> fprintf ppf "%s = option(wrap(%s))" letters.(!i) s
+          | `List (mode, s) ->
+              fprintf ppf "%s = %swrap(%s))"
+                letters.(!i)
+                (match mode with
+                 | Naked -> "naked_list("
+                 | Naked_ne -> "naked_list_ne("
+                 | Lead s -> "lead_list(" ^ (Token.to_string s) ^ ","
+                 | Lead_ne s -> "lead_list_ne(" ^ (Token.to_string s) ^ ","
+                 | Trail s -> "trail_list(" ^ (Token.to_string s) ^ ","
+                 | Trail_option s -> "trail_option_list(" ^ (Token.to_string s) ^ ","
+                 | Trail_force s -> "trail_force_list(" ^ (Token.to_string s) ^ ","
+                 | Trail_force_ne s -> "trail_force_list_ne(" ^ (Token.to_string s) ^ ","
+                 | Separated s -> "separated_list(" ^ (Token.to_string s) ^ ","
+                 | Separated_ne s -> "separated_list_ne(" ^ (Token.to_string s) ^ ","
+                 | Separated_nene s -> "separated_list_nene(" ^ (Token.to_string s) ^ ","
+                )
+                s
+          | `Token t -> i := !i - 1 ; string ppf @@ Token.to_string t) ;
+          i := !i + 1
+        in
+        fprintf ppf "%a" (list_sep aux (const " ")) rhs.content in
+    let aux_code : _ -> O.rhs -> _ = fun ppf rhs ->
+      let i = ref 0 in
+      let aux : O.rhs_element -> _ = fun e ->
+          let s = (match e with
+          | `Named _ | `List _ | `Option _ -> Some (letters.(!i))
+          | `Token _ -> i := !i - 1 ; None) in
+          i := !i + 1 ; s
+      in
+      let content = List.filter_map aux rhs.content in
+      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 }"
+        aux_rule rhs
+        aux_code rhs in
+    fprintf ppf "%s:@.%a" gr.name (list_sep aux (const "\n")) gr.content
+
+  let singleton : _ -> O.singleton -> _ = fun ppf s ->
+    match s with
+    | Manual s -> manual_rule ppf s
+    | Generated s -> generated_rule ppf s
+
+
+  let n_operator_rule prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop ->
+    let i = ref 0 in
+    let element : _ -> O.element -> _ = fun ppf element ->
+      (match element with
+       | `Token t -> i := !i - 1 ; string ppf @@ Token.to_string t
+       | `List (mode, content) ->
+         fprintf ppf "%s = %swrap(%s))"
+           letters.(!i)
+           (match mode with
+            | Naked -> "naked_list("
+            | Naked_ne -> "naked_list_ne("
+            | Lead s -> "lead_list(" ^ (Token.to_string s) ^ ","
+            | Lead_ne s -> "lead_list_ne(" ^ (Token.to_string s) ^ ","
+            | Trail s -> "trail_list(" ^ (Token.to_string s) ^ ","
+            | Trail_option s -> "trail_option_list(" ^ (Token.to_string s) ^ ","
+            | Trail_force s -> "trail_force_list(" ^ (Token.to_string s) ^ ","
+            | Trail_force_ne s -> "trail_force_list_ne(" ^ (Token.to_string s) ^ ","
+            | Separated s -> "separated_list(" ^ (Token.to_string s) ^ ","
+            | Separated_ne s -> "separated_list_ne(" ^ (Token.to_string s) ^ ","
+            | Separated_nene s -> "separated_list_nene(" ^ (Token.to_string s) ^ ","
+           )
+           (match content with | `Lower -> prev_lvl_name | `Named s -> s | `Current -> cur_lvl_name)
+       | `Named n ->
+           fprintf ppf "%s = wrap(%s)" letters.(!i) n
+       | `Current ->
+           fprintf ppf "%s = wrap(%s)" letters.(!i) cur_lvl_name
+       | `Lower ->
+         fprintf ppf "%s = wrap(%s)" letters.(!i) prev_lvl_name
+      ) ;
+      i := !i + 1
+    in
+    (list_sep element (const " ")) ppf (get_content 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
+      let aux : O.element -> _ = fun e ->
+        let r =
+          match e with
+          | `Token _ -> i := !i - 1 ; None
+          | `List _ | `Named _ | `Current | `Lower -> Some letters.(!i)
+        in i := !i + 1 ; r
+      in
+      List.filter_map aux elements in
+    fprintf ppf "%a (%a)" make_operator (prefix, name) (list_sep string (const " , ")) elements'
+
+  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 prefix) nop
+
+  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 prefix prev_lvl_name name) new_line) (get_content l) ;
+      )
+    | _ -> (
+        fprintf ppf "%s :@.  @[<v>%a@;| %s { $1 }@]" name
+          (list_sep (n_operator prefix prev_lvl_name name) new_line) (get_content l)
+          prev_lvl_name
+      )
+
+  let n_hierarchy : _ -> O.n_hierarchy -> _ = fun ppf nh ->
+    let name = get_name nh in
+    let top_level = get_name @@ List.Ne.hd nh.content.levels in
+    fprintf ppf "%a@.%%inline %s : %s { $1 }@.@;" comment ("Top-level for " ^ name) name top_level;
+    let (hd, tl) = List.Ne.rev (get_content nh).levels in
+    fprintf ppf "%a" (level nh.content.prefix "") hd ;
+    let aux prev_name lvl =
+      new_lines 2 ppf () ;
+      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
+    ()
+
+  let language : _ -> O.language -> _ = fun ppf l ->
+    fprintf ppf "%a@.@." comment "Generated Language" ;
+    fprintf ppf "entry_point : wrap(%s) EOF { $1 }@.@." l.entry_point ;
+    fprintf ppf "%a@.@." comment "Singletons" ;
+    fprintf ppf "@[%a@]@.@." (list_sep singleton new_line) l.singletons ;
+    fprintf ppf "%a@.@." comment "Hierarchies" ;
+    fprintf ppf "@[%a@]" (list_sep n_hierarchy new_line) l.hierarchies ;
+
+end
+
+
+let infix : string -> [`Left | `Right] -> token -> O.n_operator = fun name assoc t ->
+  match assoc with
+  | `Left -> make_name name [`Current ; `Token t ; `Lower]
+  | `Right -> make_name name [`Lower ; `Token t ; `Current]
+
+(* Ocaml is bad *)
+let empty_infix : string -> [`Left | `Right] -> O.n_operator = fun name assoc ->
+  match assoc with
+  | `Left -> make_name name [`Current ; `Lower]
+  | `Right -> make_name name [`Lower ; `Current]
+
+
+let paren : string -> string -> O.n_operator = fun constructor_name name ->
+  make_name constructor_name [`Token Token.LPAREN ; `Named name ; `Token Token.RPAREN]
+
+let expression_name = "expression"
+let type_expression_name = "type_expression"
+let restricted_type_expression_name = "restricted_type_expression"
+let program_name = "program"
+let variable_name = "variable"
+let pattern_name = "pattern"
+let constructor_name = "constructor"
+let int_name = "int_"
+let tz_name = "tz_"
+let unit_name = "unit_"
+let string_name = "string_"
+
+let variable = O.manual_singleton variable_name ["| NAME { $1 }"] "string"
+let int = O.manual_singleton int_name ["| INT { $1 }"] "int"
+let tz = O.manual_singleton tz_name ["| TZ { $1 }"] "int"
+let unit = O.manual_singleton unit_name ["| UNIT { () }"] "unit"
+let string = O.manual_singleton string_name ["| STRING { $1 }"] "string"
+let constructor = O.manual_singleton constructor_name ["| CONSTRUCTOR_NAME { $1 }"] "string"
+
+module Pattern = struct
+
+  open Token
+  open O
+
+  let application = empty_infix "application" `Left
+
+  let data_structure : O.n_operator = make_name "data_structure" [
+      `Named variable_name ; `Token LSQUARE ; `List (Lead SEMICOLON, `Current) ; `Token RSQUARE ;
+    ]
+
+  let record_element : O.rule = make_name "p_record_element" [
+      make_name "" [`Named variable_name ; `Token EQUAL ; `Named pattern_name]
+    ]
+
+  let record : O.n_operator = make_name "record" [
+      `Token LBRACKET ;
+      `List (Trail SEMICOLON, `Named record_element.name) ;
+      `Token RBRACKET ;
+    ]
+
+  let pair = infix "pair" `Left COMMA
+  let type_annotation = make_name "type_annotation" [
+      `Current ; `Token COLON ; `Named restricted_type_expression_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 "module_ident" [
+      `List (Trail_force_ne DOT, `Named constructor_name) ; `Named variable_name ;
+    ]
+
+  let unit : O.n_operator = make_name "unit" [ `Named unit_name ]
+
+  let restricted_pattern_name = "restricted_pattern"
+
+  let restricted_pattern = O.name_hierarchy restricted_pattern_name "Pr" [
+      [variable ; unit] ;
+      [paren "restrict" pattern_name]
+    ] []
+
+  let main = O.name_hierarchy pattern_name "P" [
+      [record] ;
+      [type_annotation] ;
+      [pair] ;
+      [data_structure] ;
+      [application] ;
+      [variable ; constructor ; module_ident ; unit] ;
+      [paren "paren" pattern_name]
+    ] []
+
+  let singletons = [O.rule_singleton record_element]
+end
+
+module Expression = struct
+
+  open Token
+  open O
+
+  let application = empty_infix "application" `Right
+
+  let type_annotation = make_name "type_annotation" [
+      `Current ; `Token COLON ; `Named restricted_type_expression_name
+    ]
+
+  let data_structure : O.n_operator = make_name "data_structure" [
+      `Named variable_name ; `Token LSQUARE ; `List (Trail SEMICOLON, `Current) ; `Token RSQUARE ;
+    ]
+
+  let fun_ : O.n_operator = make_name "fun" [
+      `Token FUN ; `Named pattern_name ;
+      `Token ARROW ; `Current ;
+    ]
+
+  let let_in : O.n_operator = make_name "let_in" [
+      `Token LET ; `Named pattern_name ;
+      `Token EQUAL ; `Current ;
+      `Token IN ; `Current ;
+    ]
+
+  let no_seq_name = "expression_no_seq"
+  let no_match_name = "expression_no_match"
+
+  let record_element : O.rule = make_name "e_record_element" [
+      make_name "record_explicit" [`Named variable_name ; `Token EQUAL ; `Named no_seq_name] ;
+      make_name "record_implicit" [`Named variable_name ] ;
+    ]
+
+  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 "ifthenelse" [
+      `Token IF ;
+      `Current ;
+      `Token THEN ;
+      `Lower ;
+      `Token ELSE ;
+      `Current ;
+    ]
+
+  let it : O.n_operator = make_name "ifthen" [
+      `Token IF ;
+      `Current ;
+      `Token THEN ;
+      `Lower ;
+    ]
+
+  (* let sequence = infix "sequence" `Left SEMICOLON *)
+  let sequence = make_name "sequence" [
+      `List (Separated_nene SEMICOLON , `Lower)
+    ]
+
+  let match_clause = make_name "e_match_clause" [
+      make_name "" [`Named pattern_name ; `Token ARROW ; `Named no_match_name]
+    ]
+  let match_with = make_name "match" [
+      `Token MATCH ; `Current ; `Token WITH ;
+      `List (Lead_ne VBAR, `Named match_clause.name) ;
+    ]
+  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 neq = infix "neq" `Left UNEQUAL
+
+  let cons = infix "cons" `Left DOUBLE_COLON
+
+  let addition = infix "addition" `Left PLUS
+  let substraction = infix "substraction" `Left MINUS
+
+  let multiplication = infix "multiplication" `Left TIMES
+  let division = infix "division" `Left DIV
+
+  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 "module_ident" [
+      `List (Trail_force_ne DOT, `Named constructor_name) ; `Named variable_name ;
+    ]
+  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 "assign" `Left LEFT_ARROW
+
+  let tuple = make_name "tuple" [
+      `List (Separated_nene COMMA, `Lower)
+    ]
+
+  let name = make_name "name" [`Token TILDE ; `Current]
+
+  let main_hierarchy_name = "expression_main"
+
+  let main_hierarchy = O.name_hierarchy main_hierarchy_name "Eh" [
+      [tuple] ;
+      [type_annotation] ;
+      [lt ; le ; gt ; eq ; neq] ;
+      [assignment] ;
+      [cons] ;
+      [addition ; substraction] ;
+      [multiplication ; division] ;
+      [application] ;
+      [data_structure] ;
+      [name] ;
+      [arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ;
+      [paren "bottom" expression_name] ;
+  ] []
+
+  let no_sequence_expression = O.name_hierarchy no_seq_name "Es" [
+      [let_in ; fun_ ; record ; ite ; it ; match_with] ;
+      [make_name "main" [`Named main_hierarchy_name]] ;
+    ] []
+
+  let no_match_expression = O.name_hierarchy no_match_name "Em" [
+      [let_in ; fun_ ; record ; ite ; it ] ;
+      [make_name "main" [`Named main_hierarchy_name]] ;
+    ] []
+
+  let expression = O.name_hierarchy expression_name "E" [
+      [sequence] ;
+      [let_in ; fun_ ; record ; ite ; it ; match_with] ;
+      [make_name "main" [`Named main_hierarchy_name]] ;
+    ] []
+
+  let singletons = List.map O.rule_singleton [record_element ; match_clause]
+end
+
+module Type_expression = struct
+
+  open Token
+  open O
+
+  let record_element : O.rule = make_name "t_record_element" [
+      make_name "" [`Named variable_name ; `Token COLON ; `Named type_expression_name]
+    ]
+
+  let record : O.n_operator = make_name "record" [
+      `Token LBRACKET ;
+      `List (Trail SEMICOLON, `Named record_element.name) ;
+      `Token RBRACKET ;
+    ]
+
+  let application = empty_infix "application" `Right
+
+  let tuple = make_name "tuple" [
+      `List (Separated_nene COMMA, `Lower)
+    ]
+
+  let type_variable : O.n_operator = make_name "variable" [ `Named variable_name ]
+
+  let restricted_type_expression = O.name_hierarchy restricted_type_expression_name "Tr" [
+      [application] ;
+      [type_variable] ;
+      [paren "paren" type_expression_name] ;
+    ] []
+
+  let type_expression = O.name_hierarchy type_expression_name "T" [
+      [record] ;
+      [tuple] ;
+      [application] ;
+      [type_variable] ;
+      [paren "paren" type_expression_name]
+    ] []
+
+  let singletons = [O.rule_singleton record_element]
+
+end
+
+module Program = struct
+
+  open Token
+  open O
+
+  let statement_name = "statement"
+
+  let program : O.rule = make_name program_name [make_name "" [
+      `List (Trail_option DOUBLE_SEMICOLON, statement_name)
+    ]]
+
+  let param_name = "param"
+
+  let param : O.rule = make_name param_name [
+      make_name "restricted_pattern" [ `Named Pattern.restricted_pattern_name ] ;
+      make_name "implicit_named_param" [ `Token TILDE ; `Named variable_name ] ;
+    ]
+
+  let type_annotation_name = "type_annotation_"
+  let type_annotation : O.rule = make_name type_annotation_name [
+      make_name "" [ `Token COLON ; `Named type_expression_name ] ;
+    ]
+
+  let let_content_name = "let_content"
+  let let_content : O.rule = make_name let_content_name [
+      make_name "" [
+        `Named variable_name ;
+        `List (Naked, param_name) ;
+        `Option type_annotation_name ;
+        `Token EQUAL ;
+        `Named expression_name ;
+      ] ;
+    ]
+
+  let statement : O.rule = make_name statement_name [
+      make_name "variable_declaration" [`Token LET ; `Named let_content_name] ;
+      make_name "init_declaration" [`Token LET_INIT ; `Named let_content_name] ;
+      make_name "entry_declaration" [`Token LET_ENTRY ; `Named let_content_name] ;
+      make_name "type_declaration" [`Token TYPE ; `Named variable_name ; `Token EQUAL ; `Named type_expression_name] ;
+    ]
+
+  let singletons = List.map O.rule_singleton [
+      let_content ;
+      type_annotation ;
+      program ;
+      statement ;
+      param ;
+    ]
+
+end
+
+let language = O.language program_name (
+    variable :: constructor :: int :: unit :: string :: tz ::
+    Program.singletons @
+    Pattern.singletons @
+    Expression.singletons @
+    Type_expression.singletons
+  ) [
+    Pattern.main ;
+    Pattern.restricted_pattern ;
+    Expression.main_hierarchy ;
+    Expression.no_sequence_expression ;
+    Expression.no_match_expression ;
+    Expression.expression ;
+    Type_expression.restricted_type_expression ;
+    Type_expression.type_expression ;
+  ]
+
+let () =
+  let argn = Array.length Sys.argv in
+  if argn = 1 then exit 1 ;
+  let arg = Sys.argv.(1) in
+  match arg with
+  | "parser" -> (
+    Format.printf "%a@.%a\n" PP_helpers.comment "Full Grammar" Print_Grammar.language language
+  )
+  | "ast" -> (
+    Format.printf "%a@.%a\n" PP_helpers.comment "AST" Print_AST.language language
+  )
+  | _ -> exit 1
+

parser/camligo/lex/dune

@@ -0,0 +1,54 @@
+(library
+  (name lex)
+  (public_name ligo.multifix.lex)
+  (libraries
+    simple-utils
+    tezos-utils
+  )
+  (modules token token_type lexer)
+)
+
+(executable
+  (name generator)
+  (libraries
+    str
+    simple-utils
+  )
+  (modules generator)
+  (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 ))
+)
+
+(rule
+  (targets token.mly)
+  (deps generator.exe)
+  (action (system "./generator.exe mly > token.mly"))
+)
+
+(rule
+  (targets token.ml)
+  (deps generator.exe)
+  (action (system "./generator.exe ml > token.ml"))
+)
+
+(rule
+  (targets lexer.mll)
+  (deps generator.exe)
+  (action (system "./generator.exe mll > lexer.mll"))
+)
+
+(rule
+  (targets token_type.ml token_type.mli)
+  (deps token.mly)
+  (action (system "menhir --only-tokens token.mly --base token_type"))
+)
+
+(alias
+  (name lexer.mll)
+  (deps token.ml)
+)
+
+(rule
+  (targets lexer.ml)
+  (deps    token.ml lexer.mll)
+  (action  (system "ocamllex lexer.mll"))
+)

parser/camligo/lex/generator.ml

@@ -0,0 +1,185 @@
+type pre_token = {
+  name : string ;
+  pattern : string ;
+}
+
+let make name pattern = { name ; pattern }
+
+let keyword = fun k ->
+  let regexp = Str.regexp "[^0-9a-zA-Z]" in
+  let constructor_name =
+    Str.global_replace regexp "_"
+    @@ String.uppercase_ascii k
+  in
+  make constructor_name k
+let symbol = fun sym name -> make name sym
+
+module Print_mly = struct
+  open Format
+
+  let token = fun ppf pre_token ->
+    fprintf ppf "%%token %s" pre_token.name
+
+  let tokens = fun ppf tokens ->
+    let open Simple_utils.PP_helpers in
+    fprintf ppf "%%token EOF\n" ;
+    fprintf ppf "%%token <int> INT\n" ;
+    fprintf ppf "%%token <int> NAT\n" ;
+    fprintf ppf "%%token <int> TZ\n" ;
+    fprintf ppf "%%token <string> STRING\n" ;
+    fprintf ppf "%%token <string> NAME\n" ;
+    fprintf ppf "%%token <string> CONSTRUCTOR_NAME\n" ;
+    fprintf ppf "\n%a\n\n" (list_sep token (const "\n")) tokens ;
+    fprintf ppf "%%%%\n"
+end
+
+module Print_mll = struct
+  open Format
+
+  let token = fun ppf {name;pattern} ->
+    fprintf ppf "| \"%s\" { %s }" pattern name
+
+  let pre =
+    {pre|{
+  open Token
+
+  exception Error of string
+  exception Unexpected_character of string
+}
+
+(* This rule analyzes a single line and turns it into a stream of
+   tokens. *)
+
+rule token = parse
+(*
+  | "//" ([^ '\n']* ) (['\n' '\r']+)
+    { Lexing.new_line lexbuf ; token lexbuf }
+*)
+| ('\r'? '\n' '\r'?)
+  { Lexing.new_line lexbuf; token lexbuf }
+| '"' { string "" lexbuf }
+| [' ' '\t']
+    { token lexbuf }
+| (['0'-'9']+ as i) 'p'
+    { NAT (int_of_string i) }
+| (['0'-'9']+ as n) '.' (['0'-'9']['0'-'9'] as d) "tz" { TZ ((int_of_string n) * 100 + (int_of_string d)) }
+| (['0'-'9']+ as i)
+    { INT (int_of_string i) }
+|pre}
+  let post =
+    {post|
+| (['a'-'z''_']['a'-'z''A'-'Z''0'-'9''_']*) as v
+    { NAME v }
+| (['A'-'Z']['a'-'z''A'-'Z''0'-'9''_']*) as v
+    { CONSTRUCTOR_NAME v }
+| eof { EOF }
+| "(*" { comment 1 lexbuf }
+| _
+    { raise (Unexpected_character (Printf.sprintf "At offset %d: unexpected character.\n" (Lexing.lexeme_start lexbuf))) }
+
+and string s = parse
+  | "\\\"" { string (s ^ "\"") lexbuf }
+  | "\\\\" { string (s ^ "\\") lexbuf }
+  | '"' { STRING s }
+  | eof                         { raise (Unexpected_character "missing string terminator") }
+  | _ as c                      { string (s ^ (String.make 1 c)) lexbuf }
+
+
+and comment n = parse
+  | "*)"                        { if n = 1 then token lexbuf else comment (n - 1) lexbuf }
+  | "(*"                        { comment (n + 1) lexbuf }
+  | '"' ( [^ '"' '\\'] | ( '\\' [^ '"'] ) ) '"' { comment n lexbuf }
+  | eof                         { raise (Unexpected_character "missing comment terminator") }
+  | ('\r'? '\n' '\r'?)          { Lexing.new_line lexbuf; comment n lexbuf }
+  | _                           { comment n lexbuf }
+
+|post}
+  let tokens = fun ppf tokens ->
+    let open Simple_utils.PP_helpers in
+    fprintf ppf "%s%a\n%s" pre (list_sep token (const "\n")) tokens post
+end
+
+module Print_ml = struct
+  open Format
+
+  let token = fun ppf {name} ->
+    fprintf ppf "  | %s -> \"%s\"" name name
+
+  let pre =
+    {pre|include Token_type
+
+let to_string : token -> string = function
+  | STRING _ -> "STRING"
+  | NAME _ -> "NAME s"
+  | CONSTRUCTOR_NAME _ -> "CONSTRUCTOR_NAME s"
+  | INT _ -> "INT n"
+  | NAT _ -> "NAT n"
+  | TZ _ -> "TZ n"
+  | EOF -> "EOF"
+|pre}
+
+  let tokens = fun ppf tokens ->
+    let open Simple_utils.PP_helpers in
+    fprintf ppf "%s%a" pre (list_sep token (const "\n")) tokens
+end
+
+let tokens = [
+  keyword "let%init" ;
+  keyword "let%entry" ;
+  keyword "let" ;
+  keyword "type" ;
+  keyword "in" ;
+  keyword "if" ;
+  keyword "then" ;
+  keyword "else" ;
+  (* keyword "block" ;
+   * keyword "for" ;
+   * keyword "const" ; *)
+  keyword "fun" ;
+  keyword "match" ;
+  keyword "with" ;
+  symbol "()" "UNIT" ;
+  symbol "+" "PLUS" ;
+  symbol "~" "TILDE" ;
+  symbol "->" "ARROW" ;
+  symbol "<-" "LEFT_ARROW" ;
+  symbol "<=" "LE" ;
+  symbol "<>" "UNEQUAL" ;
+  symbol "<" "LT" ;
+  symbol ">" "GT" ;
+  symbol "-" "MINUS" ;
+  symbol "*" "TIMES" ;
+  symbol "/" "DIV" ;
+  symbol "=" "EQUAL" ;
+  symbol "|" "VBAR" ;
+  symbol "[" "LSQUARE" ;
+  symbol "]" "RSQUARE" ;
+  symbol "(" "LPAREN" ;
+  symbol ")" "RPAREN" ;
+  symbol "{" "LBRACKET" ;
+  symbol "}" "RBRACKET" ;
+  symbol ";;" "DOUBLE_SEMICOLON" ;
+  symbol ";" "SEMICOLON" ;
+  symbol "::" "DOUBLE_COLON" ;
+  symbol ":" "COLON" ;
+  symbol "," "COMMA" ;
+  symbol "." "DOT" ;
+]
+
+let () =
+  let argn = Array.length Sys.argv in
+  if argn = 1 then exit 1 ;
+  let arg = Sys.argv.(1) in
+    let open Simple_utils.PP_helpers in
+  match arg with
+  | "mll" -> (
+    Format.printf "%a@.%a\n" comment "Generated .mll" Print_mll.tokens tokens
+  )
+  | "mly" -> (
+    Format.printf "%a@.%a\n" comment "Generated .mly" Print_mly.tokens tokens
+  )
+  | "ml" -> (
+    Format.printf "%a@.%a\n" comment "Generated .ml" Print_ml.tokens tokens
+  )
+  | _ -> exit 1
+

parser/camligo/location.ml

@@ -0,0 +1,25 @@
+type file_location = {
+  filename : string ;
+  start_line : int ;
+  start_column : int ;
+  end_line : int ;
+  end_column : int ;
+}
+
+type virtual_location = string
+
+type t =
+  | File of file_location
+  | Virtual of virtual_location
+
+let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t =
+  let filename = start_pos.pos_fname in
+  let start_line = start_pos.pos_lnum in
+  let end_line = end_pos.pos_lnum in
+  let start_column = start_pos.pos_cnum - start_pos.pos_bol in
+  let end_column = end_pos.pos_cnum - end_pos.pos_bol in
+  File { filename ; start_line ; start_column ; end_line ; end_column }
+
+let virtual_location s = Virtual s
+let dummy = virtual_location "dummy"
+

parser/camligo/parser_camligo.ml

@@ -0,0 +1,3 @@
+module Ast = Ast
+module Parser = Parser
+module User = User

parser/camligo/pre_parser.mly

@@ -0,0 +1,72 @@
+%{
+    open Ast
+%}
+
+%start <Ast.entry_point> entry_point
+
+%%
+
+naked_list(X):
+  | { [] }
+  | x = X xs = naked_list(X) { x :: xs }
+
+naked_list_ne(X):
+  | x = X { [ x ] }
+  | x = X xs = naked_list_ne(X) { x :: xs }
+
+trail_list(separator, X):
+  | { [] }
+  | trail_list_content(separator, X) { $1 }
+
+trail_list_content(separator, X):
+  | x = trail_list_last(separator, X) { x }
+  | x = X separator xs = trail_list_content(separator, X) { x :: xs }
+
+trail_list_last(separator, X):
+  | x = X option(separator) { [ x ] }
+
+trail_force_list(separator, X):
+  | { [] }
+  | x = X separator xs = trail_force_list(separator, X) { x :: xs }
+
+trail_force_list_ne(separator, X):
+  | x = X separator { [ x ] }
+  | x = X separator xs = trail_force_list_ne(separator, X) { x :: xs }
+
+trail_option_list(separator, X):
+  | { [] }
+  | trail_option_list_content(separator, X) { $1 }
+
+trail_option_list_content(separator, X):
+  | x = trail_option_list_last(separator, X) { x }
+  | x = X option(separator) xs = trail_option_list_content(separator, X) { x :: xs }
+
+trail_option_list_last(separator, X):
+  | x = X option(separator) { [ x ] }
+
+lead_list_ne(separator, X):
+  | separator x = X { [x] }
+  | separator x = X xs = lead_list_ne(separator, X) { x :: xs }
+
+lead_list(separator, X):
+  | { [] }
+  | lead_list_content(separator, X) { $1 }
+
+lead_list_content(separator, X):
+  | x = lead_list_first(separator, X) { x }
+  | xs = lead_list_content(separator, X) separator x = X { xs @ [ x ] }
+
+lead_list_first (separator, X):
+  | option(separator) x = X { [ x ] }
+
+separated_list_ne(separator, X):
+  | x = X { [x] }
+  | x = X separator xs = separated_list_ne(separator, X) { x :: xs }
+
+separated_list_nene(separator, X):
+  | x = X separator y = X { [x ; y] }
+  | x = X separator xs = separated_list_nene(separator, X) { x :: xs }
+
+
+%inline wrap(X):
+  | x = X { let loc = Location.make $startpos $endpos in Location.wrap ~loc x }

parser/camligo/user.ml

@@ -0,0 +1,40 @@
+open! Trace
+
+let parse_file (source: string) : Ast.entry_point result =
+  (* let pp_input =
+   *   let prefix = Filename.(source |> basename |> remove_extension)
+   *   and suffix = ".pp.ligo"
+   *   in prefix ^ suffix in
+   *
+   * let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s"
+   *                               source pp_input in
+   * let%bind () = sys_command cpp_cmd in
+   *
+   * let%bind channel =
+   *   generic_try (simple_error "error opening file") @@
+   *   (fun () -> open_in pp_input) in *)
+  let%bind channel =
+    generic_try (simple_error "error opening file") @@
+    (fun () -> open_in source) in
+  let lexbuf = Lexing.from_channel channel in
+  let module Lexer = Lex.Lexer in
+  (specific_try (fun () -> fun e ->
+      let error s () =
+        let start = Lexing.lexeme_start_p lexbuf in
+        let end_ = Lexing.lexeme_end_p lexbuf in
+        let str () = Format.sprintf
+          "at \"%s\" from (%d, %d) to (%d, %d)\n"
+          (Lexing.lexeme lexbuf)
+          start.pos_lnum (start.pos_cnum - start.pos_bol)
+          end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
+        error s str () in
+      match e with
+      | Parser.Error -> (fun () -> error (thunk "Parse") ())
+      | Lexer.Error s -> (fun () -> error (fun () -> "Lexer " ^ s) ())
+      | Lexer.Unexpected_character s -> error (fun () -> "Unexpected char " ^ s) (* TODO: this allows injection of ANSI escape codes in error messages, fix this. *)
+      | _ -> simple_error "unrecognized parse_ error"
+     )) @@ (fun () ->
+      let raw = Parser.entry_point Lexer.token lexbuf in
+      raw
+    ) >>? fun raw ->
+  ok raw

parser/dune

@@ -0,0 +1,14 @@
+(library
+  (name parser)
+  (public_name ligo.parser)
+  (libraries
+    simple-utils
+    tezos-utils
+    parser_pascaligo
+    parser_camligo
+  )
+  (preprocess
+    (pps simple-utils.ppx_let_generalized)
+  )
+  (flags (:standard -open Simple_utils ))
+)

parser/parser.ml

@@ -0,0 +1,116 @@
+open Trace
+
+module Pascaligo = Parser_pascaligo
+module Camligo = Parser_camligo
+
+open Parser_pascaligo
+module AST_Raw = Parser_pascaligo.AST
+
+
+let parse_file (source: string) : AST_Raw.t result =
+  let pp_input =
+    let prefix = Filename.(source |> basename |> remove_extension)
+    and suffix = ".pp.ligo"
+    in prefix ^ suffix in
+
+  let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s"
+                               source pp_input in
+  let%bind () = sys_command cpp_cmd in
+
+  let%bind channel =
+    generic_try (simple_error "error opening file") @@
+    (fun () -> open_in pp_input) in
+  let lexbuf = Lexing.from_channel channel in
+  let module Lexer = Lexer.Make(LexToken) in
+  let Lexer.{read ; close} =
+    Lexer.open_token_stream None in
+  specific_try (fun () -> function
+      | Parser.Error -> (
+          let start = Lexing.lexeme_start_p lexbuf in
+          let end_ = Lexing.lexeme_end_p lexbuf in
+          let str = Format.sprintf
+              "Parse error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n"
+              (Lexing.lexeme lexbuf)
+              start.pos_lnum (start.pos_cnum - start.pos_bol)
+              end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
+              start.pos_fname source
+          in
+          simple_error str
+        )
+      | exn ->
+          let start = Lexing.lexeme_start_p lexbuf in
+          let end_ = Lexing.lexeme_end_p lexbuf in
+          let str = Format.sprintf
+              "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n"
+              (Printexc.to_string exn)
+              (Lexing.lexeme lexbuf)
+              start.pos_lnum (start.pos_cnum - start.pos_bol)
+              end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
+              start.pos_fname source
+          in
+          simple_error str
+    ) @@ (fun () ->
+      let raw = Parser.contract read lexbuf in
+      close () ;
+      raw
+    ) >>? fun raw ->
+  ok raw
+
+let parse_string (s:string) : AST_Raw.t result =
+  let lexbuf = Lexing.from_string s in
+  let module Lexer = Lexer.Make(LexToken) in
+  let Lexer.{read ; close} =
+    Lexer.open_token_stream None in
+  specific_try (fun () -> function
+      | Parser.Error -> (
+          let start = Lexing.lexeme_start_p lexbuf in
+          let end_ = Lexing.lexeme_end_p lexbuf in
+          let str = Format.sprintf
+              "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n"
+              (Lexing.lexeme lexbuf)
+              start.pos_lnum (start.pos_cnum - start.pos_bol)
+              end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
+          simple_error str
+        )
+      | _ -> simple_error "unrecognized parse_ error"
+    ) @@ (fun () ->
+      let raw = Parser.contract read lexbuf in
+      close () ;
+      raw
+    ) >>? fun raw ->
+  ok raw
+
+let parse_expression (s:string) : AST_Raw.expr result =
+  let lexbuf = Lexing.from_string s in
+  let module Lexer = Lexer.Make(LexToken) in
+  let Lexer.{read ; close} =
+    Lexer.open_token_stream None in
+  specific_try (fun () -> function
+      | Parser.Error -> (
+          let start = Lexing.lexeme_start_p lexbuf in
+          let end_ = Lexing.lexeme_end_p lexbuf in
+          let str = Format.sprintf
+              "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n"
+              (Lexing.lexeme lexbuf)
+              start.pos_lnum (start.pos_cnum - start.pos_bol)
+              end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
+          simple_error str
+        )
+      | exn ->
+          let start = Lexing.lexeme_start_p lexbuf in
+          let end_ = Lexing.lexeme_end_p lexbuf in
+          let str = Format.sprintf
+              "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In expression \"%s|%s\"\n"
+              (Printexc.to_string exn)
+              (Lexing.lexeme lexbuf)
+              start.pos_lnum (start.pos_cnum - start.pos_bol)
+              end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
+              start.pos_fname s
+          in
+          simple_error str
+    ) @@ (fun () ->
+      let raw = Parser.interactive_expr read lexbuf in
+      close () ;
+      raw
+    ) >>? fun raw ->
+  ok raw

parser/pascaligo/.Lexer.ml.tag

@@ -0,0 +1 @@
+ocamlc: -w -42