Initial LIGO interpreter version

src/main/compile/dune

@@ -6,6 +6,7 @@
     tezos-utils
     parser
     simplify
+    interpreter
     ast_simplified
     self_ast_simplified
     typer_new

src/main/compile/of_typed.ml

@@ -27,3 +27,5 @@ let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> As
 
 let pretty_print ppf program =
   Ast_typed.PP.program ppf program
+
+let some_interpret = Interpreter.dummy

src/passes/6-interpreter/dune

@@ -0,0 +1,14 @@
+(library
+  (name interpreter)
+  (public_name ligo.interpreter)
+  (libraries
+    simple-utils
+    tezos-utils
+    ast_typed
+    ligo_interpreter
+  )
+  (preprocess
+    (pps ppx_let bisect_ppx --conditional)
+  )
+  (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
+)

src/passes/6-interpreter/interpreter.ml

@@ -0,0 +1,344 @@
+open Trace
+open Ligo_interpreter.Types
+include Stage_common.Types
+
+module Env = Ligo_interpreter.Environment
+
+let apply_comparison : Ast_typed.constant -> value list -> value result =
+  fun c operands -> match (c,operands) with
+    | ( comp , [ V_Ct (C_int a'      ) ; V_Ct (C_int b'      ) ] )
+    | ( comp , [ V_Ct (C_nat a'      ) ; V_Ct (C_nat b'      ) ] )
+    | ( comp , [ V_Ct (C_mutez a'    ) ; V_Ct (C_mutez b'    ) ] )
+    | ( comp , [ V_Ct (C_timestamp a') ; V_Ct (C_timestamp b') ] ) ->
+      let f_op = match comp with
+        | C_EQ -> Int.equal
+        | C_NEQ -> fun a b -> not (Int.equal a b)
+        | C_LT -> (<)
+        | C_LE -> (<=)
+        | C_GT -> (>)
+        | C_GE -> (>=)
+        | _ -> failwith "apply compare must be called with a comparative constant" in
+      ok @@ V_Ct (C_bool (f_op a' b'))
+
+    | ( comp     , [ V_Ct (C_string a'  ) ; V_Ct (C_string b'  ) ] )
+    | ( comp     , [ V_Ct (C_address a' ) ; V_Ct (C_address b' ) ] )
+    | ( comp     , [ V_Ct (C_key_hash a') ; V_Ct (C_key_hash b') ] ) ->
+      let f_op = match comp with
+        | C_EQ -> fun a b -> (String.compare a b = 0)
+        | C_NEQ -> fun a b -> (String.compare a b != 0)
+        (* the above might not be alligned with Michelson interpreter. Do we care ? *)
+        | C_LT -> fun a b -> (String.compare a b < 0)
+        | C_LE -> fun a b -> (String.compare a b <= 0)
+        | C_GT -> fun a b -> (String.compare a b > 0)
+        | C_GE -> fun a b -> (String.compare a b >= 0)
+        | _ -> failwith "apply compare must be called with a comparative constant" in
+      ok @@ V_Ct (C_bool (f_op a' b'))
+
+    | ( comp     , [ V_Ct (C_bytes a'  ) ; V_Ct (C_bytes b'  ) ] ) ->
+      let f_op = match comp with
+        | C_EQ -> fun a b -> (Bytes.compare a b = 0)
+        | C_NEQ -> fun a b -> (Bytes.compare a b != 0)
+        (* the above might not be alligned with Michelson interpreter. Do we care ? *)
+        | C_LT -> fun a b -> (Bytes.compare a b < 0)
+        | C_LE -> fun a b -> (Bytes.compare a b <= 0)
+        | C_GT -> fun a b -> (Bytes.compare a b > 0)
+        | C_GE -> fun a b -> (Bytes.compare a b >= 0)
+        | _ -> failwith "apply compare must be called with a comparative constant" in
+      ok @@ V_Ct (C_bool (f_op a' b'))
+    | _ -> simple_fail "unsupported comparison"
+
+(* applying those operators does not involve extending the environment *)
+let rec apply_operator : Ast_typed.constant -> value list -> value result =
+  fun c operands ->
+  let return_ct v = ok @@ V_Ct v in
+  let return_none () = ok @@ V_Construct ("None" , V_Ct C_unit) in
+  let return_some v  = ok @@ V_Construct ("Some" , v) in
+  ( match (c,operands) with
+    (* nullary *)
+    | ( C_NONE , [] ) -> return_none ()
+    | ( C_UNIT , [] ) -> ok @@ V_Ct C_unit
+    | ( C_NIL  , [] ) -> ok @@ V_List []
+    (* unary *)
+    | ( C_FAILWITH , [ V_Ct (C_string a') ] ) ->
+      (*TODO This raise is here until we properly implement effects*)
+      raise (Temprorary_hack a')
+      (*TODO This raise is here until we properly implement effects*)
+    | ( C_NOT    , [ V_Ct (C_bool a'  ) ] ) -> return_ct @@ C_bool (not a')
+    | ( C_INT    , [ V_Ct (C_nat a')    ] ) -> return_ct @@ C_int a'
+    | ( C_ABS    , [ V_Ct (C_int a')    ] ) -> return_ct @@ C_int (abs a')
+    | ( C_NEG    , [ V_Ct (C_int a')    ] ) -> return_ct @@ C_int (-a')
+    | ( C_SOME   , [ v                  ] ) -> return_some v
+    | ( C_IS_NAT , [ V_Ct (C_int a')    ] ) ->
+      if a' > 0 then return_some @@ V_Ct (C_nat a')
+      else return_none ()
+    (* binary *)
+    | ( (C_EQ | C_NEQ | C_LT | C_LE | C_GT | C_GE) , _ ) -> apply_comparison c operands
+    | ( C_SUB    , [ V_Ct (C_int a' | C_nat a') ; V_Ct (C_int b' | C_nat b') ] ) -> return_ct @@ C_int (a' - b')
+    | ( C_CONS   , [ v ; V_List vl ] ) -> ok @@ V_List (v::vl)
+    | ( C_ADD    , [ V_Ct (C_int a'  ) ; V_Ct (C_int b'  ) ] ) -> return_ct @@ C_int   (a' + b')
+    | ( C_ADD    , [ V_Ct (C_nat a'  ) ; V_Ct (C_nat b'  ) ] ) -> return_ct @@ C_nat   (a' + b')
+    | ( C_MUL    , [ V_Ct (C_int a'  ) ; V_Ct (C_int b'  ) ] ) -> return_ct @@ C_int   (a' * b')
+    | ( C_MUL    , [ V_Ct (C_nat a'  ) ; V_Ct (C_nat b'  ) ] ) -> return_ct @@ C_nat   (a' * b')
+    | ( C_MUL    , [ V_Ct (C_nat a'  ) ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_mutez (a' * b')
+    | ( C_MUL    , [ V_Ct (C_mutez a') ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_mutez (a' * b')
+    | ( C_DIV    , [ V_Ct (C_int a'  ) ; V_Ct (C_int b'  ) ] ) -> return_ct @@ C_int   (a' / b')
+    | ( C_DIV    , [ V_Ct (C_nat a'  ) ; V_Ct (C_nat b'  ) ] ) -> return_ct @@ C_nat   (a' / b')
+    | ( C_DIV    , [ V_Ct (C_mutez a') ; V_Ct (C_nat b'  ) ] ) -> return_ct @@ C_mutez (a' / b')
+    | ( C_DIV    , [ V_Ct (C_mutez a') ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_nat   (a' / b')
+    | ( C_CONCAT , [ V_Ct (C_string a') ; V_Ct (C_string b') ] ) -> return_ct @@ C_string (a' ^ b')
+    | ( C_CONCAT , [ V_Ct (C_bytes a' ) ; V_Ct (C_bytes b' ) ] ) -> return_ct @@ C_bytes  (Bytes.cat a' b')
+    | ( C_OR     , [ V_Ct (C_bool a'  ) ; V_Ct (C_bool b'  ) ] ) -> return_ct @@ C_bool   (a' || b')
+    | ( C_AND    , [ V_Ct (C_bool a'  ) ; V_Ct (C_bool b'  ) ] ) -> return_ct @@ C_bool   (a' && b')
+    | ( C_XOR    , [ V_Ct (C_bool a'  ) ; V_Ct (C_bool b'  ) ] ) -> return_ct @@ C_bool   ( (a' || b') && (not (a' && b')) ) 
+    | ( C_LIST_MAP , [ V_Func_val (arg_name, body, env) ; V_List (elts) ] ) ->
+      let%bind elts' = bind_map_list
+        (fun elt ->
+          let env' = Env.extend env (arg_name,elt) in
+          eval body env')
+        elts in
+      ok @@ V_List elts'
+    | ( C_LIST_ITER , [ V_Func_val (arg_name, body, env) ; V_List (elts) ] ) ->
+      bind_fold_list
+        (fun _ elt ->
+          let env' = Env.extend env (arg_name,elt) in
+          eval body env'
+        )
+        (V_Ct C_unit) elts
+    (* tertiary *)
+    | ( C_LIST_FOLD , [ V_Func_val (arg_name, body, env) ; V_List (elts) ; init ] ) ->
+      bind_fold_list
+        (fun prev elt ->
+          let fold_args = V_Record (LMap.of_list [(Label "0",prev) ; (Label "1",elt)]) in
+          let env' = Env.extend env (arg_name,  fold_args) in
+          eval body env'
+        )
+        init elts
+    | _ ->
+      let () = Format.printf "%a\n" Stage_common.PP.constant c in
+      let () = List.iter ( fun e -> Format.printf "%s\n" (Ligo_interpreter.PP.pp_value e)) operands in
+      simple_fail "Unsupported constant op"
+  )
+
+(*
+| C_NOW
+| C_ASSERTION
+| C_ASSERT_INFERRED
+| C_UPDATE
+| C_ITER
+| C_FOLD_WHILE
+| C_CONTINUE
+| C_STOP
+| C_FOLD
+| C_SUB
+| C_MOD
+| C_SIZE
+| C_SLICE
+| C_BYTES_PACK
+| C_BYTES_UNPACK
+| C_PAIR
+X| C_CAR
+X| C_CDR
+X| C_LEFT
+X| C_RIGHT
+| C_SET_EMPTY
+| C_SET_LITERAL
+| C_SET_ADD
+| C_SET_REMOVE
+| C_SET_ITER
+| C_SET_FOLD
+| C_SET_MEM
+| C_MAP
+| C_MAP_EMPTY
+| C_MAP_LITERAL
+| C_MAP_GET
+| C_MAP_GET_FORCE
+| C_MAP_ADD
+| C_MAP_REMOVE
+| C_MAP_UPDATE
+| C_MAP_ITER
+| C_MAP_MAP
+| C_MAP_FOLD
+| C_MAP_MEM
+| C_MAP_FIND
+| C_MAP_FIND_OPT
+| C_BIG_MAP
+| C_BIG_MAP_EMPTY
+| C_BIG_MAP_LITERAL
+x| C_LIST_CONS -> To remove ? seems unused
+| C_SHA256
+| C_SHA512
+| C_BLAKE2b
+| C_HASH
+| C_HASH_KEY
+| C_CHECK_SIGNATURE
+| C_CHAIN_ID
+| C_CALL
+| C_CONTRACT
+| C_CONTRACT_ENTRYPOINT
+| C_AMOUNT
+| C_BALANCE
+| C_SOURCE
+| C_SENDER
+| C_ADDRESS
+| C_SELF_ADDRESS
+| C_IMPLICIT_ACCOUNT
+| C_SET_DELEGATE
+| C_STEPS_TO_QUOTA
+*)
+
+(*interpreter*)
+and eval_literal : Ast_typed.literal -> value result = function
+  | Literal_unit     -> ok @@ V_Ct (C_unit)
+  | Literal_int i    -> ok @@ V_Ct (C_int i)
+  | Literal_nat n    -> ok @@ V_Ct (C_nat n)
+  | Literal_string s -> ok @@ V_Ct (C_string s)
+  | Literal_bytes s  -> ok @@ V_Ct (C_bytes s)
+  | Literal_bool b   -> ok @@ V_Ct (C_bool b)
+  | Literal_mutez t  -> ok @@ V_Ct (C_mutez t)
+  | _ -> simple_fail "Unsupported literal"
+
+and eval : Ast_typed.expression -> env -> value result
+  = fun term env ->
+    match term with
+    | E_application ({expression = f; _}, args) -> (
+      let%bind f' = match f with
+        | E_variable f -> Env.lookup env f
+        | _ -> eval f env in
+      match f' with
+      | V_Func_val (arg_names, body, f_env) ->
+        let%bind args' = eval args.expression env in
+        let f_env' = Env.extend f_env (arg_names, args') in
+        eval body f_env'
+      | _ -> simple_fail "trying to apply on something that is not a function"
+    )
+    | E_lambda { binder; body;} ->
+      ok @@ V_Func_val (binder,body.expression,env)
+    | E_let_in { binder; rhs; result; _} ->
+      let%bind rhs' = eval rhs.expression env in
+      eval result.expression (Env.extend env (binder,rhs'))
+    | E_map kvlist | E_big_map kvlist ->
+      let%bind kvlist' = bind_map_list
+        (fun kv -> bind_map_pair (fun (el:Ast_typed.annotated_expression) -> eval el.expression env) kv)
+        kvlist in
+      ok @@ V_Map kvlist'
+    | E_list expl ->
+      let%bind expl' = bind_map_list
+        (fun (exp:Ast_typed.annotated_expression) -> eval exp.expression env)
+        expl in
+      ok @@ V_List expl'
+    | E_literal l ->
+      eval_literal l
+    | E_variable var ->
+      Env.lookup env var
+    | E_record recmap ->
+      let%bind lv' = bind_map_list
+        (fun (label,(v:Ast_typed.annotated_expression)) ->
+          let%bind v' = eval v.expression env in
+          ok (label,v'))
+        (LMap.to_kv_list recmap) in
+      ok @@ V_Record (LMap.of_list lv')
+    | E_record_accessor (record,label) -> (
+      let%bind record' = eval record.expression env in
+      match record' with
+      | V_Record recmap ->
+        let%bind a = trace_option (simple_error "unknown record field") @@
+          LMap.find_opt label recmap in
+        ok a
+      | _ -> simple_fail "trying to access a non-record"
+    )
+    | E_record_update (record, (l,field)) -> (
+      let%bind record' = eval record.expression env in
+      match record' with
+      | V_Record recmap ->
+        if LMap.mem l recmap then
+          let%bind field' = eval field.expression env in
+          ok @@ V_Record (LMap.add l field' recmap)
+        else
+          simple_fail "field l does not exist in record"
+      | _ -> simple_fail "this expression isn't a record"
+    )
+    | E_constant (op, operands) -> (
+      let%bind operands' = bind_map_list
+        (fun (ae:Ast_typed.annotated_expression) -> eval ae.expression env)
+        operands in
+      apply_operator op operands'
+    )
+    | E_constructor (Constructor c, v) ->
+      let%bind v' = eval v.expression env in
+      ok @@ V_Construct (c,v')
+    | E_matching (e , cases) -> (
+      let%bind e' = eval e.expression env in
+      match cases, e' with
+      | Match_list cases , V_List [] ->
+        eval cases.match_nil.expression env
+      | Match_list cases , V_List (head::tail) ->
+        let (head_var,tail_var,body,_) = cases.match_cons in
+        let env' = Env.extend (Env.extend env (head_var,head)) (tail_var, V_List tail) in
+        eval body.expression env'
+      | Match_variant (case_list , _) , V_Construct (matched_c , proj) ->
+        let ((_, var) , body) =
+          List.find
+            (fun case ->
+              let (Constructor c , _) = fst case in
+              String.equal matched_c c)
+            case_list in
+        let env' = Env.extend env (var, proj) in
+        eval body.expression env'
+      | Match_bool cases , V_Ct (C_bool true) ->
+        eval cases.match_true.expression env
+      | Match_bool cases , V_Ct (C_bool false) ->
+        eval cases.match_false.expression env
+      | Match_option cases, V_Construct ("Some" , proj) ->
+        let (var,body,_) = cases.match_some in
+        let env' = Env.extend env (var,proj) in
+        eval body.expression env'
+      | Match_option cases, V_Construct ("None" , V_Ct C_unit) ->
+        eval cases.match_none.expression env
+      | _ -> simple_fail "not yet supported case"
+        (* ((ctor,name),body) *)
+    )
+    (**********************************************
+    This is not necessary after Ast simplification
+    ***********************************************)
+    | E_tuple el ->
+      let%bind lv = bind_mapi_list
+        (fun i (el:Ast_typed.annotated_expression) ->
+          let%bind el' = eval el.expression env in
+          ok (Label (string_of_int i), el'))
+        el in
+      ok @@ V_Record (LMap.of_list lv)
+    | E_tuple_accessor (tuple,i) -> (
+      let%bind record' = eval tuple.expression env in
+      match record' with
+      | V_Record recmap ->
+        let label = Label (string_of_int i) in
+        let%bind a = trace_option (simple_error "out of tuple range") @@
+          LMap.find_opt label recmap in
+        ok a
+      | _ -> simple_fail "trying to access a non-record"
+    )
+    (**********************************************
+    This is not necessary after Ast simplification
+    ***********************************************)
+    | E_look_up _ | E_loop _ | E_set _ | E_sequence _ | E_assign  _->
+      let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in
+      simple_fail serr
+
+let dummy : Ast_typed.program -> string result =
+  fun prg ->
+    let%bind (res,_) = bind_fold_list
+      (fun (pp,top_env) el ->
+        let (Ast_typed.Declaration_constant (named_exp, _, _)) = Location.unwrap el in
+        let%bind v =
+        (*TODO This TRY-CATCH is here until we properly implement effects*)
+        try
+          eval named_exp.annotated_expression.expression top_env
+        with Temprorary_hack s -> ok @@ V_Failure s
+        (*TODO This TRY-CATCH is here until we properly implement effects*)
+        in
+        let pp' = pp^"\n val "^(Var.to_name named_exp.name)^" = "^(Ligo_interpreter.PP.pp_value v) in
+        let top_env' = Env.extend top_env (named_exp.name, v) in
+        ok @@ (pp',top_env')
+      )
+      ("",Env.empty_env) prg in
+    ok @@ res

src/passes/6-interpreter/interpreter.mli

@@ -0,0 +1,3 @@
+open Trace
+
+val dummy : Ast_typed.program -> string result

src/stages/ligo_interpreter/PP.ml

@@ -0,0 +1,38 @@
+open Types
+
+let rec pp_value : value -> string = function
+  | V_Ct (C_int i) -> Format.asprintf "%i : int" i
+  | V_Ct (C_nat n) -> Format.asprintf "%i : nat" n
+  | V_Ct (C_string s) -> Format.asprintf "\"%s\" : string" s
+  | V_Ct (C_unit) -> Format.asprintf "unit"
+  | V_Ct (C_bool true) -> Format.asprintf "true"
+  | V_Ct (C_bool false) -> Format.asprintf "false"
+  | V_Ct (C_bytes b) -> Format.asprintf "0x%a : bytes" Hex.pp (Hex.of_bytes b)
+  | V_Ct (C_mutez i) -> Format.asprintf "%i : mutez" i 
+  | V_Ct _ -> Format.asprintf "PP, TODO"
+  | V_Failure s -> Format.asprintf "\"%s\" : failure " s
+  | V_Record recmap ->
+    let content = LMap.fold (fun label field prev ->
+      let (Label l) = label in
+      Format.asprintf "%s ; %s = (%s)" prev l (pp_value field))
+      recmap "" in
+    Format.asprintf "{ %s }" content
+  | V_Func_val _ -> Format.asprintf "<fun>"
+  | V_Construct (name,v) -> Format.asprintf "%s(%s)" name (pp_value v)
+  | V_List vl ->
+    Format.asprintf "[ %s ]" @@
+      List.fold_left (fun prev v -> Format.asprintf "%s ; %s" prev (pp_value v)) "" vl
+  | V_Map vmap ->
+    Format.asprintf "[ %s ]" @@
+      List.fold_left (fun prev (k,v) -> Format.asprintf "%s ; %s -> %s" prev (pp_value k) (pp_value v)) "" vmap
+  | V_Set slist ->
+    Format.asprintf "{ %s }" @@
+      List.fold_left (fun prev v -> Format.asprintf "%s ; %s" prev (pp_value v)) "" slist
+
+let pp_env : env -> unit = fun env ->
+  let () = Format.printf "{ #elements : %i\n" @@ Env.cardinal env in
+  let () = Env.iter (fun var v ->
+    Format.printf "\t%s -> %s\n" (Var.to_name var) (pp_value v))
+  env in
+  let () = Format.printf "\n}\n" in
+  ()

src/stages/ligo_interpreter/dune

@@ -0,0 +1,14 @@
+(library
+  (name ligo_interpreter)
+  (public_name ligo.ligo_interpreter)
+  (libraries
+    simple-utils
+    tezos-utils
+    ast_typed
+    stage_common
+  )
+  (preprocess
+    (pps ppx_let bisect_ppx --conditional)
+  )
+  (flags (:standard -open Simple_utils))
+)

src/stages/ligo_interpreter/environment.ml

@@ -0,0 +1,14 @@
+open Trace
+open Types
+
+let extend :
+  env -> (expression_variable * value) -> env
+    = fun env (var,exp) -> Env.add var exp env
+
+let lookup :
+  env -> expression_variable -> value result
+    = fun env var -> match Env.find_opt var env with
+      | Some res -> ok res
+      | None -> simple_fail "TODO: not found in env"
+
+let empty_env = Env.empty

src/stages/ligo_interpreter/ligo_interpreter.ml

@@ -0,0 +1,3 @@
+module Types = Types
+module PP = PP
+module Environment = Environment

src/stages/ligo_interpreter/types.ml

@@ -0,0 +1,40 @@
+include Stage_common.Types
+
+(*types*)
+module Env = Map.Make(
+  struct
+    type t = expression_variable
+    let compare a b = Var.compare a b
+  end
+)
+
+(*TODO temporary hack to handle failwiths *)
+exception Temprorary_hack of string
+
+type env = value Env.t
+
+and constant_val =
+  | C_unit
+  | C_bool of bool
+  | C_int of int
+  | C_nat of int
+  | C_timestamp of int
+  | C_mutez of int
+  | C_string of string
+  | C_bytes of bytes
+  | C_address of string
+  | C_signature of string
+  | C_key of string
+  | C_key_hash of string
+  | C_chain_id of string
+  | C_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
+
+and value =
+  | V_Func_val of (expression_variable * Ast_typed.expression * env)
+  | V_Ct of constant_val
+  | V_List of value list
+  | V_Record of value label_map
+  | V_Map of (value * value) list
+  | V_Set of value list
+  | V_Construct of (string * value)
+  | V_Failure of string (*temporary*)

src/test/contracts/interpret_test.mligo

@@ -0,0 +1,150 @@
+let lambda_call =
+  let a = 3 in
+  let foo: (int -> int) =
+    fun (i : int) -> i * i
+  in
+  foo (a + 1)
+
+let higher_order1 =
+  let a = 2 in
+  let foo: (int -> int -> int -> int) =
+    fun (i:int) (j:int) (k:int) -> a + i + j + 0
+  in
+  let bar = (foo 1 2) in
+  bar 3
+
+let higher_order2 =
+  let a = 2 in
+  let foo: (int -> int) =
+    fun (i:int) ->
+      let b = 2 in
+      let bar : (int -> int) =
+        fun (i:int) -> i + a + b
+      in bar i
+  in foo 1
+
+let concats =
+  0x70 ^ 0x70
+
+type foo_record = {
+     a : string ;
+     b : string ;
+}
+let record_concat =
+  let ab : foo_record = { a = "a" ; b = "b" } in
+  ab.a ^ ab.b
+
+let record_patch =
+  let ab : foo_record = { a = "a" ; b = "b" } in
+  {ab with b = "c"}
+
+type bar_record = {
+     f : int -> int ;
+     arg : int ;
+}
+let record_lambda =
+  let a = 1 in
+  let foo : (int -> int) = fun (i:int) -> a+(i*2) in
+  let farg : bar_record = { f = foo ; arg = 2 } in
+  farg.f farg.arg
+
+type foo_variant =
+| Foo
+| Bar of int
+| Baz of string
+
+let variant_exp =
+  (Foo, Bar 1, Baz "b")
+
+let variant_match =
+  let a = Bar 1 in
+  match a with
+  | Foo -> 1
+  | Bar(i) -> 2
+  | Baz(s) -> 3
+
+/* UNSUPPORTED
+type bar_variant =
+| Baz
+| Buz of int * int
+| Biz of int * int * string
+let long_variant_match =
+  let a = Biz (1,2,"Biz") in
+  match a with
+  | Baz -> "Baz"
+  | Buz(a,b) -> "Buz"
+  | Biz(a,b,c) -> c
+*/
+
+let bool_match =
+  let b = true in
+  match b with
+  | true -> 1
+  | false -> 2
+
+let list_match =
+  let a = [ 1 ; 2 ; 3 ; 4 ] in
+  match a with
+  | hd :: tl -> hd::a
+  | [] -> a
+
+let tuple_proj =
+  let (a,b) = (true,false) in
+  a or b
+
+let list_const =
+  let a = [1 ; 2 ; 3 ; 4] in
+  0 :: a
+
+type foobar = int option
+
+let options_match_some =
+  let a = Some 0 in
+  match a with
+  | Some(i) -> i
+  | None -> 1
+
+let options_match_none =
+  let a : foobar = None in
+  match a with
+  | Some(i) -> i
+  | None -> 0
+
+let is_nat_nat =
+  let i : int = 1 in
+  let j : int = -1 in
+  (Michelson.is_nat i, Michelson.is_nat j)
+
+let abs_int = abs (-5)
+
+let nat_int = int (5n)
+
+let map_list =
+  let a = [1 ; 2 ; 3 ; 4] in
+  let add_one: (int -> int) = fun (i : int) -> i + 1 in
+  List.map add_one a
+
+let fail_alone = failwith "you failed"
+
+let iter_list_fail =
+  let a = [1 ; 2 ; 3 ; 4] in
+  let check_something: (int -> unit) = fun (i : int) ->
+    if i = 2 then failwith "you failed"
+    else ()
+  in
+  List.iter check_something a
+
+let fold_list =
+  let a = [1 ; 2 ; 3 ; 4] in
+  let acc : (int * int -> int) =
+    fun (prev, el : int * int) -> prev + el in
+  List.fold acc a 0
+
+let comparison_int =
+  (1 > 2, 2 > 1, 1 >=2 , 2 >= 1)
+
+let comparison_string =
+  ("foo" = "bar", "baz" = "baz")
+
+let divs : (int * nat * tez * nat) =
+  (1/2 , 1n/2n , 1tz/2n , 1tz/2tz)

vendors/ligo-utils/simple-utils/trace.ml

@@ -555,6 +555,7 @@ let bind_concat (l1:'a list result) (l2: 'a list result) =
   ok @@ (l1' @ l2')
 
 let bind_map_list f lst = bind_list (List.map f lst)
+let bind_mapi_list f lst = bind_list (List.mapi f lst)
 
 let rec bind_map_list_seq f lst = match lst with
   | [] -> ok []