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

add ligo

Browse Source 
remove old lib_ligo

modified ligo opam
This commit is contained in:
Galfour 2019-03-13 14:07:17 +00:00
parent ff48226748
commit 84dbf1f7ee
30 changed files with 2051 additions and 1545 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/lib_ligo/meta-michelson/.gitignore vendored
View File

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

30
src/lib_ligo/meta-michelson/alpha_wrap.ml
View File

@ -1,30 +0,0 @@
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

310
src/lib_ligo/meta-michelson/contract.ml
View File

@ -1,310 +0,0 @@
open Misc
open Tezos_utils.Error_monad
open Memory_proto_alpha
open Alpha_context
open Script_ir_translator
open Script_typed_ir
module Option = Tezos_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 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 int = Int_t None
let nat_k = Nat_key None
let big_map k v = Big_map_t (k, v, None)
let signature = Signature_t None
let bool = Bool_t None
let mutez = Mutez_t None
let string = String_t None
let string_k = String_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 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 (Failure "nat_to_int") @@ Script_int.to_int n
let tez n = Option.unopt_exn (Failure "Values.tez") @@ Tez.of_mutez @@ Int64.of_int n
let left a = L a
let right b = R b
end

9
src/lib_ligo/meta-michelson/dune
View File

@ -1,9 +0,0 @@
(library
(name meta_michelson)
(public_name meta-michelson)
(libraries
tezos-utils
michelson-parser
tezos-micheline
)
)

7
src/lib_ligo/meta-michelson/json.ml
View File

@ -1,7 +0,0 @@
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)

22
src/lib_ligo/meta-michelson/meta-michelson.opam
View File

@ -1,22 +0,0 @@
name: "meta-michelson"
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"
dev-repo: "git+https://gitlab.com/gabriel.alfour/tezos.git"
license: "MIT"
depends: [
"ocamlfind" { build }
"dune" { build & >= "1.0.1" }
"tezos-utils"
"michelson-parser"
]
build: [
[ "dune" "build" "-p" name "-j" jobs ]
[ "mv" "src/lib_ligo/meta-michelson/meta-michelson.install" "." ]
]
url {
src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz"
}

4
src/lib_ligo/meta-michelson/meta_michelson.ml
View File

@ -1,4 +0,0 @@
module Wrap = Michelson_wrap
module Contract = Contract
let init_environment = Misc.init_environment

514
src/lib_ligo/meta-michelson/michelson_wrap.ml
View File

@ -1,514 +0,0 @@
open Tezos_utils.Memory_proto_alpha
module AC = Alpha_context
module Types = Contract.Types
module Option = Tezos_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

300
src/lib_ligo/meta-michelson/misc.ml
View File

@ -1,300 +0,0 @@
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)
(Tezos_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) ->
Parameters_repr.{ 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 = Alpha_context.Block_header.{
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

18
src/lib_ligo/meta-michelson/streams.ml
View File

@ -1,18 +0,0 @@
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

6
src/lib_ligo/src/helpers/.gitignore vendored
View File

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

33
src/lib_ligo/src/helpers/dictionary.ml
View File

@ -1,33 +0,0 @@
open Trace
type ('a, 'b) t = ('a * 'b) list
let get_exn x y = List.assoc y x
let get x y = generic_try (simple_error "Dictionry.get") @@ fun () -> get_exn x y
let set ?equal lst a b =
let equal : 'a -> 'a -> bool =
Option.unopt
~default:(=) equal
in
let rec aux acc = function
| [] -> List.rev acc
| (key, _)::tl when equal key a -> aux ((key, b) :: acc) tl
| hd::tl -> aux (hd :: acc) tl
in
aux [] lst
let del ?equal lst a =
let equal : 'a -> 'a -> bool =
Option.unopt
~default:(=) equal
in
let rec aux acc = function
| [] -> List.rev acc
| (key, _)::tl when equal key a -> aux acc tl
| hd::tl -> aux (hd :: acc) tl
in
aux [] lst
let to_list x = x

16
src/lib_ligo/src/helpers/dictionary.mli
View File

@ -1,16 +0,0 @@
open Trace
type ('a, 'b) t
val get_exn : ('a, 'b) t -> 'a -> 'b
val get : ('a, 'b) t -> 'a -> 'b result
val set :
?equal:('a -> 'a -> bool) ->
('a, 'b) t -> 'a -> 'b -> ('a, 'b) t
val del :
?equal:('a -> 'a -> bool) ->
('a, 'b) t -> 'a -> ('a, 'b) t
val to_list : ('a, 'b) t -> ('a * 'b) list

8
src/lib_ligo/src/helpers/dune
View File

@ -1,8 +0,0 @@
(library
(libraries
tezos-base
tezos-utils
)
(name ligo_helpers)
(public_name ligo-helpers)
)

53
src/lib_ligo/src/helpers/environment.ml
View File

@ -1,53 +0,0 @@
module type PARAMETER = sig
type key
type value
val key_cmp : key -> key -> int
val value_cmp : value -> value -> int
end
let parameter (type key value) ?key_cmp ?value_cmp () : (module PARAMETER with type key = key and type value = value) =
(module struct
type nonrec key = key
type nonrec value = value
let key_cmp = Option.unopt ~default:compare key_cmp
let value_cmp = Option.unopt ~default:compare value_cmp
end)
let int_parameter = (parameter () : (module PARAMETER with type key = int and type value = int))
module INT_PARAMETER = (val ((parameter () : (module PARAMETER with type key = int and type value = int))))
module type ENVIRONMENT = sig
type key
type value
type t
val empty : t
val get_opt : t -> key -> value option
val gets : t -> key -> value list
val set : t -> key -> value -> t
val del : t -> key -> t
end
module Make(P:PARAMETER) : ENVIRONMENT with type key = P.key and type value = P.value = struct
type key = P.key
type value = P.value
type t = (key * value) list
let empty : t = []
let gets lst k =
let kvs = List.filter (fun (k', _) -> P.key_cmp k k' = 0) lst in
List.map snd kvs
let get_opt lst k = match gets lst k with
| [] -> None
| v :: _ -> Some v
let set lst k v = (k, v) :: lst
let del lst k =
let rec aux acc = function
| [] -> List.rev acc
| (key, _) :: tl when P.key_cmp key k = 0 -> List.rev acc @ tl
| hd :: tl -> aux (hd :: acc) tl in
aux [] lst
end

24
src/lib_ligo/src/helpers/location.ml
View File

@ -1,24 +0,0 @@
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"

3
src/lib_ligo/src/helpers/option.ml
View File

@ -1,3 +0,0 @@
let unopt ~default = function
| None -> default
| Some x -> x

157
src/lib_ligo/src/helpers/trace.ml
View File

@ -1,157 +0,0 @@
type error = {
message : string ;
title : string ;
}
type 'a result =
Ok of 'a
| Errors of error list
let ok x = Ok x
let fail err = Errors [err]
let simple_error str = {
message = "" ;
title = str ;
}
let error title message = { title ; message }
let simple_fail str = fail @@ simple_error str
let map f = function
| Ok x -> f x
| Errors _ as e -> e
let apply f = function
| Ok x -> Ok (f x)
| Errors _ as e -> e
let (>>?) x f = map f x
let (>>|?) = apply
module Let_syntax = struct
let bind m ~f = m >>? f
end
let trace err = function
| Ok _ as o -> o
| Errors errs -> Errors (err :: errs)
let trace_option error = function
| None -> fail error
| Some s -> ok s
let rec bind_list = function
| [] -> ok []
| hd :: tl -> (
hd >>? fun hd ->
bind_list tl >>? fun tl ->
ok @@ hd :: tl
)
let bind_or (a, b) =
match a with
| Ok x -> ok x
| _ -> b
let bind_lr (type a b) ((a : a result), (b:b result)) : [`Left of a | `Right of b] result =
match (a, b) with
| Ok x, _ -> ok @@ `Left x
| _, Ok x -> ok @@ `Right x
| _, Errors b -> Errors b
let bind_and (a, b) =
a >>? fun a ->
b >>? fun b ->
ok (a, b)
module AE = Tezos_utils.Memory_proto_alpha.Alpha_environment
module TP = Tezos_base__TzPervasives
let of_tz_error (err:Tezos_utils.Error_monad.error) : error =
let str = Tezos_utils.Error_monad.(to_string err) in
error "alpha error" str
let of_alpha_tz_error err = of_tz_error (AE.Ecoproto_error err)
let trace_alpha_tzresult err : 'a AE.Error_monad.tzresult -> 'a result =
function
| Result.Ok x -> ok x
| Error errs -> Errors (err :: List.map of_alpha_tz_error errs)
let trace_alpha_tzresult_lwt error (x:_ AE.Error_monad.tzresult Lwt.t) : _ result =
trace_alpha_tzresult error @@ Lwt_main.run x
let trace_tzresult err =
function
| Result.Ok x -> ok x
| Error errs -> Errors (err :: List.map of_tz_error errs)
let trace_tzresult_lwt err (x:_ TP.Error_monad.tzresult Lwt.t) : _ result =
trace_tzresult err @@ Lwt_main.run x
let generic_try err f =
try (
ok @@ f ()
) with _ -> fail err
let specific_try handler f =
try (
ok @@ f ()
) with exn -> fail (handler exn)
let sequence f lst =
let rec aux acc = function
| hd :: tl -> (
match f hd with
| Ok x -> aux (x :: acc) tl
| Errors _ as errs -> errs
)
| [] -> ok @@ List.rev acc in
aux [] lst
let error_pp fmt error =
if error.message = ""
then Format.fprintf fmt "%s" error.title
else Format.fprintf fmt "%s : %s" error.title error.message
let error_pp_short fmt error =
Format.fprintf fmt "%s" error.title
let errors_pp =
Format.pp_print_list
~pp_sep:Format.pp_print_newline
error_pp
let errors_pp_short =
Format.pp_print_list
~pp_sep:Format.pp_print_newline
error_pp_short
let pp_to_string pp () x =
Format.fprintf Format.str_formatter "%a" pp x ;
Format.flush_str_formatter ()
let errors_to_string = pp_to_string errors_pp
module Assert = struct
let assert_true ~msg = function
| true -> ok ()
| false -> simple_fail msg
let assert_equal_int ?msg a b =
let msg = Option.unopt ~default:"not equal int" msg in
assert_true ~msg (a = b)
let assert_list_size ~msg lst n =
assert_true ~msg (List.length lst = n)
let assert_list_size_2 ~msg = function
| [a;b] -> ok (a, b)
| _ -> simple_fail msg
let assert_list_size_1 ~msg = function
| [a] -> ok a
| _ -> simple_fail msg
end

21
src/lib_ligo/src/helpers/wrap.ml
View File

@ -1,21 +0,0 @@
module Make (P : sig type meta end) = struct
type meta = P.meta
type 'value t = {
value : 'value ;
meta : meta ;
}
let make meta value = { value ; meta }
let value t = t.value
let meta t = t.meta
let apply : ('a -> 'b) -> 'a t -> 'b = fun f x -> f x.value
end
module Location = struct
include Make(struct type meta = Location.t end)
let make_f f : loc:_ -> _ -> _ t = fun ~loc x -> make loc (f x)
let make ~loc x : _ t = make loc x
let update_location ~loc t = {t with meta = loc}
end

1
src/ligo/bin/cli.ml Normal file
View File

@ -0,0 +1 @@
let () = print_int 42

8
src/ligo/bin/dune Normal file
View File

@ -0,0 +1,8 @@
(executable
(name cli)
(public_name ligo)
(package ligo)
(preprocess
(pps ppx_let)
)
)

20
src/ligo/dune Normal file
View File

@ -0,0 +1,20 @@
(ocamllex
(modules lexer))
(menhir
(modules parser))
(library
(name ligo)
(public_name ligo)
(libraries
tezos-utils
tezos-micheline
meta-michelson
ligo-helpers
)
(preprocess
(pps ppx_let)
)
(flags (:standard -w +1..62-4-44-40-42-9@39@33 ))
)

76
src/ligo/lexer.mll Normal file
View File

@ -0,0 +1,76 @@
{
open Parser
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 }
| [' ' '\t']
{ token lexbuf }
| '"' ( [^ '"' '\\'] | ( '\\' [^ '"'] ) ) as s '"'
{ STRING s }
| "let" { LET }
| "if" { IF }
(* | "then" { THEN } *)
| "elseif" { ELSEIF }
| "else" { ELSE }
(* | "in" { IN } *)
| "type" { TYPE }
| "function" { FUNCTION }
| "while"
{ WHILE }
| "foreach"
{ FOREACH }
| "of"
{ OF }
| (['a'-'z']['a'-'z''A'-'Z''0'-'9''_']+) as v
{ VAR_NAME v }
| (['A'-'Z']['a'-'z''A'-'Z''0'-'9''_']+) as t
{ TYPE_NAME t }
(* | ['0'-'9']+'.'['0'-'9']* as i { FLOAT (float_of_string i) } *)
| ['0'-'9']+ as i
{ INT (int_of_string i) }
(*
| '+' { PLUS }
| '-' { MINUS }
| '*' { TIMES }
| '/' { DIV }
| ";;" { DOUBLE_SEMICOLON }
*)
| '=' { EQUAL }
| ',' { COMMA }
| ';' { SEMICOLON }
| ':' { COLON }
| '&'
{ AND }
| '|'
{ AND }
| '.'
{ DOT }
| '@'
{ AT }
| '('
{ LPAREN }
| ')'
{ RPAREN }
(*
| '[' { LSQUARE }
| ']' { RSQUARE }
*)
| '{'
{ LBRACKET }
| '}'
{ RBRACKET }
| eof { EOF }
| _
{ raise (Unexpected_character (Printf.sprintf "At offset %d: unexpected character.\n" (Lexing.lexeme_start lexbuf))) }

5
src/ligo/ligo.ml Normal file
View File

@ -0,0 +1,5 @@
include Main
module Mini_c = Mini_c
module Parser = Parser
module Lexer = Lexer

9
src/lib_ligo/src/helpers/ligo-helpers.opam → src/ligo/ligo.opam
View File

@ -1,4 +1,3 @@
name: "ligo-helpers"
opam-version: "2.0"
version: "1.0"
maintainer: "gabriel.alfour@gmail.com"
@ -10,14 +9,16 @@ license: "MIT"
depends: [
"ocamlfind" { build }
"dune" { build & >= "1.0.1" }
"meta-michelson"
"menhir"
"ppx_let"
"tezos-utils"
"tezos-base"
"meta-michelson"
"ligo-helpers"
]
build: [
[ "dune" "build" "-p" name "-j" jobs ]
[ "mv" "src/lib_ligo/src/helpers/ligo-helpers.install" "." ]
]
url {
src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz"
}

461
src/ligo/main.ml Normal file
View File

@ -0,0 +1,461 @@
(* -*- compile-command: "cd .. ; dune build -p ligo" -*- *)
open Ligo_helpers
open Trace
module Untyped = struct
module WrapLocation = Wrap.Location
let wrap = Wrap.Location.make
module Type = struct
type name = string
type base = [
| `Unit
| `Bool
| `Int
| `Nat
]
let unit : base = `Unit
let bool : base = `Bool
let int : base = `Int
let nat : base = `Nat
type 'a node = [
| `Pair of 'a * 'a
| `Or of 'a * 'a
]
type expression_ast = [
| expression node
| base
| `Name of name
]
and expression = expression_ast WrapLocation.t
let pair ~loc a b : expression = wrap ~loc (`Pair(a,b))
let union ~loc a b : expression = wrap ~loc (`Or(a,b))
let name ~loc s : expression =
wrap ~loc (match s with
| "Unit" -> (unit :> expression_ast)
| "Bool" -> (bool :> expression_ast)
| "Int" -> (int :> expression_ast)
| "Nat" -> (nat :> expression_ast)
| s -> `Name s)
end
module Value = struct
type name = string
type function_name = string
type constant = [
| `Int of int
]
type expression = [
| `Variable of name
| `Pair of expression * expression
| `Application of expression * expression
| `Constant of constant
] WrapLocation.t
type assignment = [
| `Let of name * expression
| `Type of Type.name * Type.expression
| `Function of function_name * Type.expression * block
] WrapLocation.t
and statement = [
| `Assignment of assignment
| `ForEach of name * expression * block
| `While of expression * block
| `Condition of expression * block * (expression * block) list * block option
] WrapLocation.t
and block = statement list WrapLocation.t
and program = assignment list WrapLocation.t
type 'a wrapper = loc:Location.t -> 'a -> 'a WrapLocation.t
let int = (WrapLocation.make_f (fun a -> `Constant (`Int a)) : loc:_ -> _ -> expression)
let constatn = (WrapLocation.make_f (fun a -> `Constant a) : loc:_ -> _ -> expression)
let variable = (WrapLocation.make_f (fun a -> `Variable a) : loc:_ -> _ -> expression)
let pair = (WrapLocation.make_f (fun a -> `Pair a) : loc:_ -> _ -> expression)
let application = (WrapLocation.make_f (fun a -> `Application a) : loc:_ -> _ -> expression)
let let_ = (WrapLocation.make_f (fun a -> `Let a) : loc:_ -> _ -> assignment)
let type_ = (WrapLocation.make_f (fun a -> `Type a) : loc:_ -> _ -> assignment)
let fun_ = (WrapLocation.make_f (fun a -> `Function a) : loc:_ -> _ -> assignment)
let assignment = (WrapLocation.make_f (fun a -> `Assignment a) : loc:_ -> _ -> statement)
let foreach = (WrapLocation.make_f (fun a -> `ForEach a) : loc:_ -> _ -> statement)
let while_ = (WrapLocation.make_f (fun a -> `While a) : loc:_ -> _ -> statement)
let elseif x : (expression * block) = x
let else_ x : block = x
let if_ = (WrapLocation.make_f (fun a -> `Condition a) : loc:_ -> _ -> statement)
let block = (WrapLocation.make : loc:_ -> _ -> block)
let program = (WrapLocation.make : loc:_ -> _ -> program)
end
end
module Typed = struct
module Type = struct
module WrapLocation = Wrap.Location
let wrap = WrapLocation.make
type name = string
type base = [
| `Unit
| `Bool
| `Int
| `Nat
]
let unit : base = `Unit
let bool : base = `Bool
let int : base = `Int
let nat : base = `Nat
type 'a node = [
| `Pair of 'a * 'a
| `Or of 'a * 'a
]
type value = [
| value node
| base
]
type expression_ast = [
| expression node
| base
| `Name of name
]
and expression = expression_ast
let rec of_untyped (x:Untyped.Type.expression) : expression = match x.value with
| `Pair(a, b) -> `Pair(of_untyped a, of_untyped b)
| `Or(a, b) -> `Or(of_untyped a, of_untyped b)
| `Int as s -> s
| `Unit as s -> s
| `Nat as s -> s
| `Bool as s -> s
| `Name _ as s -> s
let pair_v a b : value = `Pair(a,b)
let union_v a b : value = `Or(a,b)
let pair_e a b : expression = `Pair(a,b)
let union_e a b : expression = `Or(a,b)
let name : string -> expression = function
| "Unit" -> (unit :> expression_ast)
| "Bool" -> (bool :> expression_ast)
| "Int" -> (int :> expression_ast)
| "Nat" -> (nat :> expression_ast)
| s -> `Name s
module Environment = Environment.Make(val (
Environment.parameter () :
(module Environment.PARAMETER
with type key = name
and type value = value)))
let rec eval (env:Environment.t) : expression -> value result = function
| `Name x -> (
trace_option (simple_error "name doesn't exist in environment") @@
Environment.get_opt env x
)
| `Pair (a, b) -> (
eval env a >>? fun a ->
eval env b >>? fun b ->
ok (`Pair (a, b))
)
| `Or (a, b) -> (
eval env a >>? fun a ->
eval env b >>? fun b ->
ok (`Or (a, b))
)
| `Bool as x -> ok x
| `Unit as x -> ok x
| `Nat as x -> ok x
| `Int as x -> ok x
end
module Value = struct
module WrapLocation = Wrap.Location
let wrap = WrapLocation.make
module WrapTypeLocation = Wrap.Make(struct type meta = (Type.value * Location.t) end)
let wrap_tl = WrapTypeLocation.make
let type_of (x:'a WrapTypeLocation.t) : Type.value = fst x.meta
type name = string
type function_name = string
type constant = [
| `Int of int
]
type 'a node = [
| `Constant of constant
| `Pair of 'a * 'a
]
let int n = `Constant (`Int n)
type value = value node
type expression = [
| expression node
| `Variable of name
] WrapTypeLocation.t
let variable n = `Variable n
let pair a b = `Pair (a, b)
type assignment = [
| `Let of name * expression
| `Type of Type.name * Type.value
| `Function of function_name * Type.value * block * Type.value
] WrapLocation.t
and statement = assignment
and block = statement list
and toplevel_statement = assignment
and program = toplevel_statement list
module Environment = Environment.Make(val (
Environment.parameter () :
(module Environment.PARAMETER
with type key = name
and type value = Type.value)))
end
module Environment = struct
type type_environment = Type.Environment.t
type value_environment = Value.Environment.t
type t = {
type_environment : type_environment ;
value_environment : value_environment ;
}
let empty = {
type_environment = Type.Environment.empty ;
value_environment = Value.Environment.empty ;
}
let add_type env
name type_value =
{ env with
type_environment =
Type.Environment.set env.type_environment name type_value }
let add_variable env
name type_value =
{ env with
value_environment =
Value.Environment.set env.value_environment name type_value }
end
end
module Typecheck = struct
module UV = Untyped.Value
module UT = Untyped.Type
module TV = Typed.Value
module TT = Typed.Type
type env = Typed.Environment.t
type ty = Typed.Type.value
let typecheck_constant (constant:UV.constant) : _ = match constant with
| `Int n -> (`Int, `Int n)
let rec typecheck_expression (env:env) (e:UV.expression) : (TV.expression) result =
match e.value with
| `Constant c -> (
let (ty, value) = typecheck_constant c in
ok (TV.wrap_tl (ty, e.meta) (`Constant value))
)
| `Variable n -> (
trace_option (simple_error "variable doesn't exist in env")
@@ TV.Environment.get_opt env.value_environment n >>? fun ty ->
ok (TV.wrap_tl (ty, e.meta) (TV.variable n))
)
| `Pair(a, b) -> (
typecheck_expression env a >>? fun a ->
typecheck_expression env b >>? fun b ->
let ty = TT.pair_v (TV.type_of a) (TV.type_of b) in
ok (TV.wrap_tl (ty, e.meta) (TV.pair a b))
)
| `Application _ -> simple_fail "Application isn't supported yet"
let rec typecheck_assignment (env:env) (u:UV.assignment) : (env * TV.assignment) result =
match u.value with
| `Let(name, expression) -> (
typecheck_expression env expression >>? fun expression ->
let ass : TV.assignment = TV.wrap ~loc:u.meta (`Let(name, expression)) in
let env = Typed.Environment.add_variable env name (TV.type_of expression) in
ok (env, ass)
)
| `Type(name, expression) -> (
TT.eval env.type_environment (TT.of_untyped expression) >>? fun value ->
let env = Typed.Environment.add_type env name value in
let ass : TV.assignment = TV.wrap ~loc:u.meta (`Type(name, value)) in
ok (env, ass)
)
| `Function(name, type_expression, block) -> (
TT.eval env.type_environment (TT.of_untyped type_expression) >>? fun type_value ->
let env = Typed.Environment.add_variable env "input" type_value in
typecheck_block env block >>? fun (env, block) ->
let ty =
match TV.Environment.get_opt env.value_environment "output" with
| None -> `Unit
| Some x -> x in
let ass : TV.assignment = TV.wrap ~loc:u.meta (`Function(name, type_value, block, ty)) in
ok (env, ass)
)
and typecheck_statement (env:env) (s:Untyped.Value.statement) : (env * Typed.Value.statement) result =
match s.value with
| `Assignment a -> typecheck_assignment env a
| `Condition (_bool_expr, _block, _elseifs, _else_opt) -> simple_fail "conditions aren't supported yet"
| `ForEach _ -> simple_fail "foreach is not supported yet"
| `While _ -> simple_fail "while is not supported yet"
and typecheck_block (env:env) (b:Untyped.Value.block) : (env * Typed.Value.block) result =
let rec aux env = function
| [] -> ok (env, [])
| hd :: tl -> (
typecheck_statement env hd >>? fun (env, hd) ->
aux env tl >>? fun (env, tl) ->
ok (env, hd :: tl)
) in
aux env b.value
let typecheck_program ?(env=Typed.Environment.empty) (u:Untyped.Value.program) : Typed.Value.program result =
let rec aux env = function
| [] -> ok []
| hd :: tl -> (
typecheck_assignment env hd >>? fun (env, hd) ->
aux env tl >>? fun tl ->
ok (hd :: tl)
) in
aux env u.value
end
module Transpile = struct
open Mini_c
open Typed
let rec translate_type : Type.value -> Mini_c.type_value result = function
| `Bool -> ok (`Base Bool)
| `Int -> ok (`Base Int)
| `Nat -> ok (`Base Nat)
| `Unit -> ok (`Base Unit)
| `Pair(a, b) -> (
translate_type a >>? fun a ->
translate_type b >>? fun b ->
ok (`Pair(a, b))
)
| `Or(a, b) -> (
translate_type a >>? fun a ->
translate_type b >>? fun b ->
ok (`Or(a, b))
)
let rec translate_expression (e:Value.expression) : Mini_c.expression result =
let%bind (e' : Mini_c.expression') = match e.value with
| `Constant (`Int n) -> ok (Literal (`Int n))
| `Variable n -> ok (Var n)
| `Pair (a, b) -> (
translate_expression a >>? fun a ->
translate_expression b >>? fun b ->
ok (Predicate("Pair", [a ; b]))
) in
let%bind (t : Mini_c.type_value) = translate_type @@ fst e.meta in
ok (e', t)
let rec translate_assignment (ass:Value.assignment)
: Mini_c.assignment option result = match ass.value with
| `Let(x, expr) -> (
translate_expression expr >>? fun expr ->
ok (Some (Variable(x, expr)))
)
| `Function(name, input_ty, body, output_ty) -> (
translate_type input_ty >>? fun input ->
translate_type output_ty >>? fun output ->
block body >>? fun body ->
let ass = Fun(name, {input ; output ; body}) in
ok (Some ass)
)
| `Type _ -> ok None
and statement (st:Value.statement)
: Mini_c.statement option result =
translate_assignment st >>? fun a ->
let ass = match a with
| Some a -> Some (Assignment a)
| None -> None in
ok ass
and block : Value.block -> Mini_c.block result = function
| [] -> ok []
| hd :: tl -> (
statement hd >>? fun st_opt ->
let sts = match st_opt with
| Some x -> [x]
| None -> [] in
block tl >>? fun (new_sts) ->
ok (sts @ new_sts)
)
let translate_toplevel_statement = translate_assignment
let rec program : Value.program -> Mini_c.program result = function
| [] -> ok []
| hd :: tl -> (
translate_assignment hd >>? fun ass_opt ->
let asss = match ass_opt with
| Some x -> [x]
| None -> [] in
program tl >>? fun (new_asss) ->
ok (asss @ new_asss)
)
let of_mini_c : Mini_c.value -> Value.value result = function
| `Int n -> ok (Value.int n)
| _ -> simple_fail "unknown value"
let to_mini_c : Value.value -> Mini_c.value result = function
| `Constant (`Int n) -> ok (`Int n)
| _ -> simple_fail "unknown value"
let program_to_michelson (p:Value.program) =
let%bind program_mini_c = program p in
let%bind program = Mini_c.Translate_program.translate program_mini_c in
ok program.body
end
module Run = struct
open Typed.Value
let run (program : program) (input : value) : value result =
Transpile.program program >>? fun program_mini_c ->
Transpile.to_mini_c input >>? fun input_mini_c ->
(* Format.printf "%a\n" Mini_c.PP.program program_mini_c ; *)
Mini_c.Run.run program_mini_c input_mini_c >>? fun output_mini_c ->
Transpile.of_mini_c output_mini_c >>? fun output ->
ok output
end

1079
src/ligo/mini_c.ml Normal file
View File

File diff suppressed because it is too large Load Diff

200
src/ligo/parser.mly Normal file
View File

@ -0,0 +1,200 @@
%{
module Location = Ligo_helpers.Location
open Main.Untyped
open Value
%}
%token EOF
%token <int> INT
//%token <float> FLOAT
%token <string> STRING
%token <string> VAR_NAME
%token <string> FUNCTION_NAME
%token <string> TYPE_NAME
//%token PLUS MINUS TIMES DIV
%token COLON SEMICOLON /* DOUBLE_SEMICOLON */ COMMA AT EQUAL DOT
%token OR AND
%token LPAREN RPAREN
%token LBRACKET RBRACKET
%token IF ELSEIF ELSE // THEN
%token FOREACH OF WHILE
%token LET TYPE FUNCTION
// toto.tata @ 3 + 4 = 2 ; printf (lel)
//%left COLON
%left COMMA
%left AT
%left OR
%left AND
//%left EQUAL
//%left PLUS MINUS /* lowest precedence */
//%left TIMES DIV /* medium precedence */
%left DOT
%start <Main.Untyped.Value.program> main
%%
main:
| sts = assignment+ EOF
{
let loc = Location.make $startpos $endpos in
program ~loc sts
}
assignment:
| LET v = VAR_NAME EQUAL e = expr SEMICOLON
{
let loc = Location.make $startpos $endpos in
let_ ~loc (v, e)
}
| FUNCTION f = VAR_NAME COLON t = type_expr EQUAL b = block SEMICOLON
{
let loc = Location.make $startpos $endpos in
fun_ ~loc (f, t, b)
}
| TYPE n = TYPE_NAME EQUAL t = type_expr SEMICOLON
{
let loc = Location.make $startpos $endpos in
type_ ~loc (n, t)
}
statement:
| ass = assignment
{
let loc = Location.make $startpos $endpos in
assignment ~loc ass
}
| FOREACH var = VAR_NAME OF iterator = expr body = block
{
let loc = Location.make $startpos $endpos in
foreach ~loc (var, iterator, body)
}
| WHILE cond = expr body = block
{
let loc = Location.make $startpos $endpos in
while_ ~loc (cond, body)
}
| IF e = expr b = block eis = else_if* eo = else_?
{
let loc = Location.make $startpos $endpos in
if_ ~loc (e, b, eis, eo)
}
else_if:
| ELSEIF LPAREN cond = expr RPAREN body = block
{
elseif (cond, body)
}
else_:
| ELSE body = block
{
else_ body
}
block:
| LBRACKET sts = statement+ RBRACKET
{
let loc = Location.make $startpos $endpos in
block ~loc sts
}
expr:
| i = INT
{
let loc = Location.make $startpos $endpos in
Value.int ~loc i
}
(*
| f = FLOAT
{
let loc = Location.make $startpos $endpos in
make ~loc @@ literal @@ Float f
}
| s = STRING
{
let loc = Location.make $startpos $endpos in
make ~loc @@ literal @@ String s
}
*)
| v = VAR_NAME
{
let loc = Location.make $startpos $endpos in
variable ~loc v
}
| LPAREN e = expr RPAREN
{
let loc = Location.make $startpos $endpos in
WrapLocation.update_location ~loc e
}
| e1 = expr COMMA e2 = expr
{
let loc = Location.make $startpos $endpos in
Value.pair ~loc (e1, e2)
}
| e1 = expr AT e2 = expr
{
let loc = Location.make $startpos $endpos in
application ~loc (e1, e2)
}
| e1 = expr DOT e2 = expr
{
let loc = Location.make $startpos $endpos in
application ~loc (e2, e1)
}
(*
| e = expr COLON t = type_expr
{
let loc = Location.make $startpos $endpos in
make ~loc @@ cast e t
}
| e1 = expr PLUS e2 = expr
{
let loc = Location.make $startpos $endpos in
make ~loc @@ primitive Plus [e1 ; e2]
}
| e1 = expr MINUS e2 = expr
{
let loc = Location.make $startpos $endpos in
make ~loc @@ primitive Minus [e1 ; e2]
}
| e1 = expr TIMES e2 = expr
{
let loc = Location.make $startpos $endpos in
make ~loc @@ primitive Times [e1 ; e2]
}
| e1 = expr DIV e2 = expr
{
let loc = Location.make $startpos $endpos in
make ~loc @@ primitive Div [e1 ; e2]
}
| e1 = expr EQUAL e2 = expr
{
let loc = Location.make $startpos $endpos in
make ~loc @@ primitive Equal [e1 ; e2]
}
| e = expr DOT v = VAR_NAME
{
let loc = Location.make $startpos $endpos in
make ~loc @@ dot e v
}
*)
type_expr:
| t = TYPE_NAME
{
let loc = Location.make $startpos $endpos in
Type.(name ~loc t)
}
| t1 = type_expr AND t2 = type_expr
{
let loc = Location.make $startpos $endpos in
Type.(pair ~loc t1 t2)
}
| t1 = type_expr OR t2 = type_expr
{
let loc = Location.make $startpos $endpos in
Type.(union ~loc t1 t2)
}

10
src/ligo/test/dune Normal file
View File

@ -0,0 +1,10 @@
(executable
(name test)
(libraries
ligo
alcotest
)
(preprocess
(pps ppx_let)
)
)

186
src/ligo/test/test.ml Normal file
View File

@ -0,0 +1,186 @@
(* -*- compile-command: "cd .. ; dune runtest" -*- *)
open Ligo_helpers.Trace
open Ligo
let test name f =
Alcotest.test_case name `Quick @@ fun _sw ->
match f () with
| Ok () -> ()
| Errors errs ->
Format.printf "Errors : {\n%a}\n%!" errors_pp errs ;
raise Alcotest.Test_error
open Mini_c
open Combinators
let simple_int_program body : program = [
Fun("main", function_int body)
]
let run_int program n =
Run.run program (`Int n) >>? function
| `Int n -> ok n
| _ -> simple_fail "run_int : output not int"
let neg () =
let program : program = simple_int_program [
assign_variable "output" @@ neg_int (var_int "input") ;
assign_variable "output" @@ neg_int (var_int "output") ;
assign_variable "output" @@ neg_int (var_int "output") ;
] in
run_int program 42 >>? fun output ->
Assert.assert_equal_int (-42) output >>? fun () ->
ok ()
let multiple_variables () =
let program = simple_int_program [
assign_variable "a" @@ neg_int (var_int "input") ;
assign_variable "b" @@ neg_int (var_int "a") ;
assign_variable "c" @@ neg_int (var_int "b") ;
assign_variable "d" @@ neg_int (var_int "c") ;
assign_variable "output" @@ neg_int (var_int "d") ;
] in
run_int program 42 >>? fun output ->
Assert.assert_equal_int (-42) output >>? fun () ->
ok ()
let arithmetic () =
let expression = add_int (var_int "input") (neg_int (var_int "input")) in
let program = simple_int_program [
Assignment (Variable ("a", expression)) ;
Assignment (Variable ("b", var_int "a")) ;
Assignment (Variable ("output", var_int "b")) ;
] in
let test n =
run_int program n >>? fun output ->
Assert.assert_equal_int 0 output >>? fun () ->
ok ()
in
let%bind _assert = bind_list @@ List.map test [42 ; 150 ; 0 ; -42] in
ok ()
let quote_ () =
let program = simple_int_program [
assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "input") (int 42)] ;
assign_function "g" @@ function_int [assign_variable "output" @@ neg_int (var_int "input")] ;
assign_variable "output" @@ apply_int (type_f_int @@ var "g") @@ apply_int (type_f_int @@ var "f") (var_int "input") ;
] in
let%bind output = run_int program 42 in
let%bind _ = Assert.assert_equal_int (-84) output in
ok ()
let function_ () =
let program = simple_int_program [
assign_variable "a" @@ int 42 ;
assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "input") (var_int "a")] ;
let env = Environment.Small.of_list ["a", t_int] in
assign_variable "output" @@ apply_int (type_closure_int env @@ var "f") (var_int "input") ;
] in
let%bind output = run_int program 100 in
let%bind _ = Assert.assert_equal_int 142 output in
ok ()
let functions_ () =
let program = simple_int_program [
assign_variable "a" @@ int 42 ;
assign_variable "b" @@ int 144 ;
assign_function "f" @@ function_int [
assign_variable "output" @@ add_int (var_int "input") (var_int "a")
] ;
assign_function "g" @@ function_int [
assign_variable "output" @@ add_int (var_int "input") (var_int "b")
] ;
let env_f = Environment.Small.of_list ["a", t_int] in
let env_g = Environment.Small.of_list ["b", t_int] in
assign_variable "output" @@ add_int
(apply_int (type_closure_int env_f @@ var "f") (var_int "input"))
(apply_int (type_closure_int env_g @@ var "g") (var_int "input"))
] in
let%bind output = run_int program 100 in
let%bind _ = Assert.assert_equal_int 386 output in
ok ()
let rich_function () =
let program = simple_int_program [
assign_variable "a" @@ int 42 ;
assign_variable "b" @@ int 144 ;
assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "a") (var_int "b")] ;
let env = Environment.Small.of_list [("a", t_int) ; ("b", t_int)] in
assign_variable "output" @@ apply_int (type_closure_int env @@ var "f") (var_int "input") ;
] in
let test n =
let%bind output = run_int program n in
let%bind _ = Assert.assert_equal_int 186 output in
ok () in
let%bind _assert = bind_list @@ List.map test [42 ; 150 ; 0 ; -42] in
ok ()
let main = "Mini_c", [
test "basic.neg" neg ;
test "basic.variables" multiple_variables ;
test "basic.arithmetic" arithmetic ;
test "basic.quote" quote_ ;
test "basic.function" function_ ;
test "basic.functions" functions_ ;
test "basic.rich_function" rich_function ;
]
(* module Ligo = struct
* let parse_file (source:string) : Ligo.Untyped.Value.program result =
* let channel = open_in source in
* let lexbuf = Lexing.from_channel channel in
* specific_try (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
* )
* | Lexer.Unexpected_character s -> simple_error s
* | Lexer.Error _ -> simple_error "lexer error"
* | _ -> simple_error "unrecognized parse_ error"
* ) @@ (fun () -> Parser.main Lexer.token lexbuf) >>? fun program_ast ->
* ok program_ast
*
* let run (source:string) (input:Ligo.Typed.Value.value) : Ligo.Typed.Value.value result =
* parse_file source >>? fun program_ast ->
* Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program ->
* Ligo.Run.run typed_program input >>? fun output ->
* ok output
*
* let assert_value_int : Ligo.Typed.Value.value -> int result = function
* | `Constant (`Int n) -> ok n
* | _ -> simple_fail "not an int"
*
* let basic () : unit result =
* run "./contracts/toto.ligo" (Ligo.Typed.Value.int 42) >>? fun output ->
* assert_value_int output >>? fun output ->
* Assert.assert_equal_int 42 output >>? fun () ->
* ok ()
*
* let display_basic () : unit result =
* parse_file "./contracts/toto.ligo" >>? fun program_ast ->
* Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program ->
* Ligo.Transpile.program_to_michelson typed_program >>? fun node ->
* let node = Tezos_utils.Cast.flatten_node node in
* let str = Tezos_utils.Cast.node_to_string node in
* Format.printf "Program:\n%s\n%!" str ;
* ok ()
*
* let main = "Ligo", [
* test "basic" basic ;
* test "basic.display" display_basic ;
* ]
* end *)
let () =
(* Printexc.record_backtrace true ; *)
Alcotest.run "LIGO" [
main ;
] ;
()