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

Merge branch 'master' of gitlab.com:gabriel.alfour/tezos

Browse Source
This commit is contained in:
Christian Rinderknecht 2019-04-24 11:54:21 +02:00
commit 340d32eca1
No known key found for this signature in database
GPG Key ID: 9446816CFD267040
97 changed files with 2054 additions and 1287 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
.gitlab-ci.yml
View File

@ -1,6 +1,7 @@
before_script:
- apt-get update -qq
- apt-get -y -qq install libhidapi-dev libcap-dev libev-dev bubblewrap
# rsync is needed by opam to sync a package installed from a local directory with the copy in ~/.opam
- apt-get -y -qq install rsync libhidapi-dev libcap-dev libev-dev bubblewrap
- wget https://github.com/ocaml/opam/releases/download/2.0.1/opam-2.0.1-x86_64-linux -O opam-2.0.1-x86_64-linux
- cp opam-2.0.1-x86_64-linux /usr/local/bin/opam
- chmod +x /usr/local/bin/opam
@ -19,9 +20,9 @@ before_script:
default-job:
script:
- (cd src/lib_utils && ls -a && opam install -y --working-dir .)
- (cd src/ligo && ls -a && opam install -y --working-dir .)
- (cd src/ligo && ls -a && dune build && dune build -p ligo && dune build @ligo-test)
- (cd src/lib_utils && opam install -y --build-test --working-dir .)
- (cd src/ligo && opam install -y --build-test --working-dir .)
- (cd src/ligo && dune build && dune build -p ligo && dune build @ligo-test)
artifacts:
paths:
- src/ligo/bin/cli.ml
@ -30,3 +31,8 @@ default-job:
install-from-repo-job:
script:
- opam install -y ligo
# Used in the IDE
#- opam install -y user-setup
#- opam install -y merlin
#- opam install -y ocp-indent
#- opam user-setup install

2
src/lib_utils/PP.ml
View File

@ -23,6 +23,8 @@ let option = fun f ppf opt ->
| Some x -> fprintf ppf "Some(%a)" f x
| None -> fprintf ppf "None"
let int = fun ppf n -> fprintf ppf "%d" n
let map = fun f pp ppf x ->
pp ppf (f x)

4
src/lib_utils/function.ml
View File

@ -1,2 +1,6 @@
let compose = fun f g x -> f (g x)
let (>|) = compose
let compose_2 = fun f g x y -> f (g x y)
let compose_3 = fun f g x y z -> f (g x y z)
let compose_4 = fun f g a b c d -> f (g a b c d)

14
src/lib_utils/trace.ml
View File

@ -135,6 +135,10 @@ let rec bind_list = function
bind_list tl >>? fun tl ->
ok @@ hd :: tl
)
let bind_ne_list = fun (hd , tl) ->
hd >>? fun hd ->
bind_list tl >>? fun tl ->
ok @@ (hd , tl)
let bind_smap (s:_ X_map.String.t) =
let open X_map.String in
@ -154,6 +158,9 @@ let bind_fold_smap f init (smap : _ X_map.String.t) =
let bind_map_smap f smap = bind_smap (X_map.String.map f smap)
let bind_map_list f lst = bind_list (List.map f lst)
let bind_map_ne_list : _ -> 'a X_list.Ne.t -> 'b X_list.Ne.t result = fun f lst -> bind_ne_list (X_list.Ne.map f lst)
let bind_iter_list : (_ -> unit result) -> _ list -> unit result = fun f lst ->
bind_map_list f lst >>? fun _ -> ok ()
let bind_location (x:_ Location.wrap) =
x.wrap_content >>? fun wrap_content ->
@ -168,6 +175,13 @@ let bind_fold_list f init lst =
in
List.fold_left aux (ok init) lst
let bind_fold_right_list f init lst =
let aux x y =
x >>? fun x ->
f x y
in
X_list.fold_right' aux (ok init) lst
let bind_find_map_list error f lst =
let rec aux lst =
match lst with

1
src/lib_utils/tree.ml
View File

@ -94,6 +94,7 @@ module Append = struct
| Empty -> empty
| Full x -> fold' leaf node x
let rec assoc_opt' : ('a * 'b) t' -> 'a -> 'b option = fun t k ->
match t with
| Leaf (k', v) when k = k' -> Some v

33
src/lib_utils/x_option.ml
View File

@ -4,3 +4,36 @@ let lr (a , b) = match (a , b) with
| Some x , _ -> Some (`Left x)
| None , Some x -> Some (`Right x)
| _ -> None
(* TODO: recursive terminal *)
let rec bind_list = fun lst ->
match lst with
| [] -> Some []
| hd :: tl -> (
match hd with
| None -> None
| Some hd' -> (
match bind_list tl with
| None -> None
| Some tl' -> Some (hd' :: tl')
)
)
let bind_pair = fun (a , b) ->
a >>= fun a' ->
b >>= fun b' ->
Some (a' , b')
let bind_map_list = fun f lst -> bind_list (X_list.map f lst)
let bind_map_pair = fun f (a , b) -> bind_pair (f a , f b)
let bind_smap (s:_ X_map.String.t) =
let open X_map.String in
let aux k v prev =
prev >>= fun prev' ->
v >>= fun v' ->
Some (add k v' prev') in
fold aux s (Some empty)
let bind_map_smap f smap = bind_smap (X_map.String.map f smap)

15
src/lib_utils/x_tezos_micheline.ml
View File

@ -18,6 +18,13 @@ module Michelson = struct
let i_comment s : michelson = prim ~annot:["\"" ^ s ^ "\""] I_NOP
let contract parameter storage code =
seq [
prim ~children:[parameter] K_parameter ;
prim ~children:[storage] K_storage ;
prim ~children:[code] K_code ;
]
let int n : michelson = Int (0, n)
let string s : michelson = String (0, s)
let bytes s : michelson = Bytes (0, s)
@ -47,6 +54,7 @@ module Michelson = struct
let i_if a b = prim ~children:[a;b] I_IF
let i_if_none a b = prim ~children:[a;b] I_IF_NONE
let i_if_left a b = prim ~children:[a;b] I_IF_LEFT
let i_failwith = prim I_FAILWITH
let i_assert_some = i_if_none (seq [i_failwith]) (seq [])
@ -71,6 +79,13 @@ module Michelson = struct
let node = printable string_of_prim canonical in
print_expr ppf node
let pp_stripped ppf (michelson:michelson) =
let open Micheline_printer in
let michelson' = strip_nops @@ strip_annots michelson in
let canonical = strip_locations michelson' in
let node = printable string_of_prim canonical in
print_expr ppf node
let pp_naked ppf m =
let naked = strip_annots m in
pp ppf naked

103
src/ligo/ast_simplified/PP.ml Normal file
View File

@ -0,0 +1,103 @@
open Types
open PP_helpers
open Format
let list_sep_d x = list_sep x (const " , ")
let smap_sep_d x = smap_sep x (const " , ")
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_string s -> fprintf ppf "%S" s
| Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
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
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
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 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_fail ae -> fprintf ppf "fail with (%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_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)

435
src/ligo/ast_simplified/ast_simplified.ml
View File

@ -1,430 +1,7 @@
module SMap = Map.String
include Types
include Misc
type name = string
type type_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_type of named_type_expression
| Declaration_constant of named_expression
(* | Macro_declaration of macro_declaration *)
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)
and access =
| Access_tuple of int
| Access_record of string
and access_path = access list
and literal =
| Literal_unit
| Literal_bool of bool
| Literal_int of int
| Literal_nat of int
| Literal_string of string
| Literal_bytes of bytes
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_fail of ae
| I_record_patch of name * access_path * (string * 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
and matching_instr = b matching
and matching_expr = annotated_expression matching
let ae expression = {expression ; type_annotation = None}
let annotated_expression expression type_annotation = {expression ; type_annotation}
open Trace
module PP = struct
open PP_helpers
open Format
let list_sep_d x = list_sep x (const " , ")
let smap_sep_d x = smap_sep x (const " , ")
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_string s -> fprintf ppf "%S" s
| Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
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
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
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 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 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_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_fail ae -> fprintf ppf "fail with (%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_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)
end
module Rename = struct
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
module Combinators = struct
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_unit : type_expression = T_constant ("unit", [])
let t_option o : type_expression = T_constant ("option", [o])
let t_list t : type_expression = T_constant ("list", [t])
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_ez_record (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_record map
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 e_annotated_expression ?type_annotation expression = {expression ; type_annotation}
let 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_bytes b : expression = E_literal (Literal_bytes (Bytes.of_string b))
let e_lambda (binder : string)
(input_type : type_expression)
(output_type : type_expression)
(result : expression)
(body : block)
: expression =
E_lambda {
binder = (name binder) ;
input_type = input_type ;
output_type = output_type ;
result = (ae result) ;
body ;
}
let e_tuple (lst : ae list) : expression = E_tuple lst
let ez_e_tuple (lst : expression list) : expression =
e_tuple (List.map (fun e -> ae e) lst)
let e_constructor (s : string) (e : ae) : expression = E_constructor (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, ae e)) lst)
end
module Types = Types
module Misc = Misc
module PP = PP
module Combinators = Combinators

134
src/ligo/ast_simplified/combinators.ml Normal file
View File

@ -0,0 +1,134 @@
open Types
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 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_unit : type_expression = T_constant ("unit", [])
let t_option o : type_expression = T_constant ("option", [o])
let t_list t : type_expression = T_constant ("list", [t])
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_ez_record (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_record map
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_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_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_unit : annotated_expression = make_e_a_full (e_unit ()) t_unit
let e_a_constructor s a : annotated_expression = make_e_a (e_constructor s a)
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_none t_opt =
let type_annotation = t_option t_opt in
make_e_a ~type_annotation e_none
let e_a_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)

249
src/ligo/ast_simplified/misc.ml Normal file
View File

@ -0,0 +1,249 @@
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_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"
let rec assert_value_eq (a, b: (value*value)) : unit result =
let error_content () =
Format.asprintf "%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 @@ 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 *)

117
src/ligo/ast_simplified/types.ml Normal file
View File

@ -0,0 +1,117 @@
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)
and access =
| Access_tuple of int
| Access_record of string
and access_path = access list
and literal =
| Literal_unit
| Literal_bool of bool
| Literal_int of int
| Literal_nat of int
| Literal_string of string
| Literal_bytes of bytes
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_fail of ae
| I_record_patch of name * access_path * (string * 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

8
src/ligo/ast_typed/PP.ml
View File

@ -66,9 +66,15 @@ 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)} ->
@ -97,7 +103,7 @@ and instruction ppf (i:instruction) = match i with
let declaration ppf (d:declaration) =
match d with
| Declaration_constant {name ; annotated_expression = ae} ->
| Declaration_constant ({name ; annotated_expression = ae} , _) ->
fprintf ppf "const %s = %a" name annotated_expression ae
let program ppf (p:program) =

32
src/ligo/ast_typed/combinators.ml
View File

@ -55,6 +55,18 @@ let get_t_tuple (t:type_value) : type_value list result = match t.type_value' wi
| 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"
@ -67,6 +79,7 @@ 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 assert_t_map (t:type_value) : unit result =
match t.type_value' with
| T_constant ("map", [_ ; _]) -> ok ()
@ -77,6 +90,15 @@ let assert_t_list (t:type_value) : unit result =
| 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"
@ -146,9 +168,17 @@ let get_a_bool (t:annotated_expression) =
| E_literal (Literal_bool b) -> ok b
| _ -> simple_fail "not a bool"
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
open Environment
let env_sum_type ?(env = full_empty)
?(name = "a_sum_type")
(lst : (string * element) list) =
(lst : (string * type_value) list) =
add_type name (make_t_ez_sum lst) env

25
src/ligo/ast_typed/environment.ml
View File

@ -1,32 +1,36 @@
open Types
type element = type_value
type element = environment_element
let make_element : type_value -> full_environment -> element =
fun type_value source_environment -> {type_value ; source_environment}
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 -> element -> t -> t = fun k v -> map_type_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 -> element option = fun k x -> List.assoc_opt k (get_type_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_type : string -> element -> t -> t = fun k v -> List.Ne.hd_map (Small.add_type k v)
let add_ez : string -> type_value -> t -> t = fun k v e -> List.Ne.hd_map (Small.add k (make_element v e)) 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 -> element option = fun k x -> List.Ne.find_map (Small.get_type_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 -> (element * element) option = fun k x -> (* Left is the constructor, right is the sum type *)
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
@ -43,14 +47,17 @@ module PP = struct
let list_sep_scope x = list_sep x (const " | ")
let assoc = fun ppf (k , tv) ->
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 assoc (const " , ")) lst
fprintf ppf "E[%a]" (list_sep environment_element (const " , ")) lst
let type_environment = fun ppf lst ->
fprintf ppf "T[%a]" (list_sep assoc (const " , ")) 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"

6
src/ligo/ast_typed/misc.ml
View File

@ -85,12 +85,16 @@ module Free_variables = struct
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_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

16
src/ligo/ast_typed/types.ml
View File

@ -6,6 +6,7 @@ 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
@ -13,10 +14,14 @@ type 'a type_name_map = 'a SMap.t
type program = declaration Location.wrap list
and declaration =
| Declaration_constant of named_expression
| Declaration_constant of (named_expression * full_environment)
(* | Macro_declaration of macro_declaration *)
and environment = (string * type_value) list
and environment_element = {
type_value : type_value ;
source_environment : full_environment ;
}
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
@ -43,7 +48,7 @@ and type_value' =
| T_sum of tv_map
| T_record of tv_map
| T_constant of type_name * tv list
| T_function of tv * tv
| T_function of (tv * tv)
and type_value = {
type_value' : type_value' ;
@ -124,7 +129,8 @@ and 'a matching =
match_none : 'a ;
match_some : (name * type_value) * 'a ;
}
| Match_tuple of name list * 'a
| Match_tuple of (name list * 'a)
| Match_variant of (((constructor_name * name) * 'a) list * type_value)
and matching_instr = b matching
@ -135,7 +141,7 @@ 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 ({name ; annotated_expression} , _) when entry = name -> Some annotated_expression
| Declaration_constant _ -> None
in
let%bind result =

90
src/ligo/bin/cli.ml
View File

@ -1,3 +1,4 @@
open Cmdliner
open Trace
let toplevel x =
@ -6,29 +7,68 @@ let toplevel x =
| Errors ss ->
Format.printf "Errors: %a\n%!" errors_pp @@ List.map (fun f -> f()) ss
let main () =
let l = Array.length Sys.argv in
let%bind () =
if l < 2
then simple_fail "Pass a command"
else ok () in
let command = Sys.argv.(1) in
(* Format.printf "Processing command %s (%d)\n" command l ; *)
match command with
| "compile" -> (
let%bind () =
if l <> 4
then simple_fail "Bad number of argument to compile"
else ok () in
let source = Sys.argv.(2) in
let entry_point = Sys.argv.(3) in
(* Format.printf "Compiling %s from %s\n%!" entry_point source ; *)
let%bind michelson =
trace (simple_error "compile michelson") @@
Ligo.compile_file source entry_point in
Format.printf "Program : %a\n" Micheline.Michelson.pp michelson ;
ok ()
)
| _ -> simple_fail "Bad command"
let main =
let term = Term.(const print_endline $ const "Ligo needs a command. Do ligo --help") in
(term , Term.info "ligo")
let () = toplevel @@ main ()
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_expression =
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 () = Term.exit @@ Term.eval_choice main [compile_file ; compile_expression]

1
src/ligo/bin/dune
View File

@ -3,6 +3,7 @@
(public_name ligo)
(libraries
tezos-utils
cmdliner
ligo
)
(package ligo)

2
src/ligo/compiler/compiler.ml
View File

@ -2,3 +2,5 @@ module Uncompiler = Uncompiler
module Program = Compiler_program
module Type = Compiler_type
module Environment = Compiler_environment
include Program

86
src/ligo/compiler/compiler_program.ml
View File

@ -10,7 +10,7 @@ open Memory_proto_alpha.Script_ir_translator
open Operators.Compiler
let get_predicate : string -> expression list -> predicate result = fun s lst ->
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 -> (
@ -23,6 +23,18 @@ let get_predicate : string -> expression list -> predicate result = fun s lst ->
| _ -> 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
| x -> simple_fail ("predicate \"" ^ x ^ "\" doesn't exist")
)
@ -181,7 +193,7 @@ and translate_expression ?(first=false) (expr:expression) : michelson result =
let first = first && i = 0 in
translate_expression ~first e in
bind_list @@ List.mapi aux lst in
let%bind predicate = get_predicate str lst in
let%bind predicate = get_predicate str ty lst in
let%bind code = match (predicate, List.length lst) with
| Constant c, 0 -> ok @@ virtual_push_first @@ seq @@ lst' @ [
c ;
@ -264,6 +276,59 @@ and translate_expression ?(first=false) (expr:expression) : michelson result =
]) in
return code
)
| E_if_none (c, n, (_ , s)) -> (
let%bind c' = translate_expression c in
let%bind n' = translate_expression n in
let%bind s' = translate_expression s in
let%bind restrict = Compiler_environment.to_michelson_restrict s.environment in
let%bind code = ok (seq [
c' ; i_unpair ;
i_if_none n' (seq [
i_pair ;
s' ;
restrict ;
])
;
]) in
return code
)
| E_if_left (c, (_ , l), (_ , r)) -> (
let%bind c' = translate_expression c in
let%bind l' = translate_expression l in
let%bind r' = translate_expression r in
let%bind restrict_l = Compiler_environment.to_michelson_restrict l.environment in
let%bind restrict_r = Compiler_environment.to_michelson_restrict r.environment in
let%bind code = ok (seq [
c' ; i_unpair ;
i_if_left (seq [
i_swap ; dip i_pair ;
l' ;
i_comment "restrict left" ;
dip restrict_l ;
]) (seq [
i_swap ; dip i_pair ;
r' ;
i_comment "restrict right" ;
dip restrict_r ;
])
;
]) in
return code
)
| E_let_in (_, expr , body) -> (
let%bind expr' = translate_expression expr in
let%bind body' = translate_expression body in
let%bind restrict = Compiler_environment.to_michelson_restrict body.environment in
let%bind code = ok (seq [
expr' ;
i_unpair ;
i_swap ; dip i_pair ;
body' ;
i_comment "restrict let" ;
dip restrict ;
]) in
return code
)
in
ok code
@ -277,7 +342,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
| S_environment_restrict ->
Compiler_environment.to_michelson_restrict w_env.pre_environment
| S_environment_add _ ->
simple_fail "not ready yet"
simple_fail "add not ready yet"
(* | S_environment_add (name, tv) ->
* Environment.to_michelson_add (name, tv) w_env.pre_environment *)
| S_declaration (s, expr) ->
@ -490,7 +555,7 @@ type compiled_program = {
body : michelson ;
}
let translate_program (p:program) (entry:string) : compiled_program result =
let get_main : program -> string -> anon_function_content result = fun p entry ->
let is_main (((name , expr), _):toplevel_statement) =
match Combinators.Expression.(get_content expr , get_type expr)with
| (E_function f , T_function _)
@ -505,12 +570,25 @@ let translate_program (p:program) (entry:string) : compiled_program result =
trace_option (simple_error "no functional entry") @@
Tezos_utils.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_content = 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_contract : program -> string -> michelson result = fun p e ->
let%bind main = get_main p e in
let%bind (param_ty , storage_ty) = Combinators.get_t_pair main.input in
let%bind param_michelson = Compiler_type.type_ param_ty in
let%bind storage_michelson = Compiler_type.type_ storage_ty in
let%bind { body = code } = translate_program p e in
let contract = Michelson.contract param_michelson storage_michelson code in
ok contract
let translate_entry (p:anon_function) : compiled_program result =
let {input;output} : anon_function_content = p.content in
let%bind body =

3
src/ligo/compiler/compiler_type.ml
View File

@ -85,7 +85,6 @@ module Ty = struct
let%bind (Ex_ty t') = type_ t in
ok @@ Ex_ty Contract_types.(option t')
and environment_small' = let open Append_tree in function
| Leaf (_, x) -> type_ x
| Node {a;b} ->
@ -98,7 +97,7 @@ module Ty = struct
| Full x -> environment_small' x
and environment = function
| [] | [Empty] -> simple_fail "Schema.Big.to_ty"
| [] | [Empty] -> ok @@ Ex_ty Contract_types.unit
| [a] -> environment_small a
| Empty :: b -> environment b
| a::b ->

9
src/ligo/contracts/match.ligo
View File

@ -12,7 +12,7 @@ function match_option (const o : option(int)) : int is
begin
case o of
| None -> skip
| Some(s) -> skip // result := s
| Some(s) -> result := s
end
end with result
@ -22,3 +22,10 @@ function match_expr_bool (const i : int) : int is
| 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

10
src/ligo/contracts/super-counter.ligo Normal file
View File

@ -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 : operation),
case p of
| Increment n -> s + n
| Decrement n -> s - n
end)

9
src/ligo/contracts/variant-matching.ligo Normal file
View File

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

8
src/ligo/contracts/variant.ligo Normal file
View File

@ -0,0 +1,8 @@
type foobar is
| Foo of int
| Bar of bool
const foo : foobar = Foo (42)
const bar : foobar = Bar (True)

9
src/ligo/dune
View File

@ -14,14 +14,7 @@
tezos-utils
tezos-micheline
meta_michelson
ligo_parser
multifix
ast_typed
ast_simplified
mini_c
operators
compiler
run
main
)
(preprocess
(pps tezos-utils.ppx_let_generalized)

235
src/ligo/ligo.ml
View File

@ -1,234 +1 @@
open Ligo_parser
module Parser = Parser
module Lexer = Lexer
module AST_Raw = 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
open Trace
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 -o %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
)
| _ ->
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Unrecognized 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
) @@ (fun () ->
let raw = Parser.contract read lexbuf in
close () ;
raw
) >>? fun raw ->
ok raw
let parse (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
)
| _ -> simple_error "unrecognized parse_ error"
) @@ (fun () ->
let raw = Parser.interactive_expr read lexbuf in
close () ;
raw
) >>? fun raw ->
ok raw
let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.simpl_program p
let simplify_expr (e:AST_Raw.expr) : Ast_simplified.annotated_expression result = Simplify.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, t) = functionalize e in
let%bind main = translate_main f t 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 = 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 = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed")
let easy_run_typed
?(debug_mini_c = false) (entry:string)
(program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.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.content)
) ;
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.content
in
error title content in
trace error @@
Run.Mini_c.run_entry 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_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 = 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") @@
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
include Main

4
src/ligo/ligo.opam
View File

@ -1,3 +1,4 @@
name: "ligo"
opam-version: "2.0"
version: "1.0"
maintainer: "gabriel.alfour@gmail.com"
@ -13,11 +14,12 @@ depends: [
"menhir"
"ppx_let"
"tezos-utils"
"getopt"
"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 {

132
src/ligo/main/contract.ml Normal file
View File

@ -0,0 +1,132 @@
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, t) = functionalize e in
let%bind main = translate_main f t 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 () =
assert_valid_entry_point typed entry_point in
let%bind mini_c =
trace (simple_error "transpiling") @@
Transpiler.translate_program typed in
let%bind michelson =
trace (simple_error "compiling") @@
Compiler.translate_contract mini_c entry_point 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

20
src/ligo/main/dune Normal file
View File

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

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

@ -0,0 +1,188 @@
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, t) = functionalize e in
let%bind main = translate_main f t 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) (entry:string)
(program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.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.content)
) ;
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.content
in
error title content in
trace error @@
Run_mini_c.run_entry 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) (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.content)
) ;
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.content
in
error title content in
trace error @@
Run_mini_c.run_entry 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

0
src/ligo/run/from_mini_c.ml → src/ligo/main/run_mini_c.ml
View File

11
src/ligo/mini_c/PP.ml
View File

@ -72,14 +72,19 @@ and expression' ppf (e:expression') = match e with
| 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 (Combinators.Expression.get_content e)
expression' ppf e.content
and expression_with_type : _ -> expression -> _ = fun ppf e ->
fprintf ppf "%a : %a"
expression' (Combinators.Expression.get_content e)
type_ (Combinators.Expression.get_type e)
expression' e.content
type_ e.type_value
and function_ ppf ({binder ; input ; output ; body ; result ; capture_type}:anon_function_content) =
fprintf ppf "fun[%s] (%s:%a) : %a %a return %a"

14
src/ligo/mini_c/combinators.ml
View File

@ -95,6 +95,19 @@ let get_or (v:value) = match v with
| 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_last_statement ((b', _):block) : statement result =
let aux lst = match lst with
| [] -> simple_fail "get_last: empty list"
@ -107,6 +120,7 @@ let t_nat : type_value = T_base Base_nat
let t_function x y : type_value = T_function ( x , y )
let t_shallow_closure x y z : type_value = T_shallow_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 =
let content : anon_function_content = {

1
src/ligo/mini_c/mini_c.ml
View File

@ -6,4 +6,5 @@ module Combinators = struct
include Combinators
include Combinators_smart
end
include Combinators
module Environment = Environment

3
src/ligo/mini_c/types.ml
View File

@ -64,6 +64,9 @@ and expression' =
| 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' ;

0
src/ligo/multifix/.gitignore → src/ligo/parser/camligo/.gitignore vendored
View File

4
src/ligo/multifix/dune → src/ligo/parser/camligo/dune
View File

@ -1,6 +1,6 @@
(library
(name multifix)
(public_name ligo.multifix)
(name parser_camligo)
(public_name ligo.parser.camligo)
(libraries
tezos-utils
lex

0
src/ligo/multifix/generator.ml → src/ligo/parser/camligo/generator.ml
View File

0
src/ligo/multifix/lex/dune → src/ligo/parser/camligo/lex/dune
View File

0
src/ligo/multifix/lex/generator.ml → src/ligo/parser/camligo/lex/generator.ml
View File

0
src/ligo/multifix/location.ml → src/ligo/parser/camligo/location.ml
View File

0
src/ligo/multifix/pre_parser.mly → src/ligo/parser/camligo/pre_parser.mly
View File

0
src/ligo/multifix/user.ml → src/ligo/parser/camligo/user.ml
View File

12
src/ligo/parser/dune Normal file
View File

@ -0,0 +1,12 @@
(library
(name parser)
(public_name ligo.parser)
(libraries
tezos-utils
parser_pascaligo
parser_camligo
)
(preprocess
(pps tezos-utils.ppx_let_generalized)
)
)

104
src/ligo/parser/parser.ml Normal file
View File

@ -0,0 +1,104 @@
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 -o %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
)
| _ ->
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Unrecognized 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
) @@ (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
)
| _ -> simple_error "unrecognized parse_ error"
) @@ (fun () ->
let raw = Parser.interactive_expr read lexbuf in
close () ;
raw
) >>? fun raw ->
ok raw

0
src/ligo/ligo_parser/.Lexer.ml.tag → src/ligo/parser/pascaligo/.Lexer.ml.tag
View File

0
src/ligo/ligo_parser/.LexerMain.tag → src/ligo/parser/pascaligo/.LexerMain.tag
View File

0
src/ligo/ligo_parser/.Parser.mly.tag → src/ligo/parser/pascaligo/.Parser.mly.tag
View File

0
src/ligo/ligo_parser/.ParserMain.tag → src/ligo/parser/pascaligo/.ParserMain.tag
View File

0
src/ligo/ligo_parser/.gitignore → src/ligo/parser/pascaligo/.gitignore vendored
View File

0
src/ligo/ligo_parser/.gitlab-ci.yml → src/ligo/parser/pascaligo/.gitlab-ci.yml
View File

0
src/ligo/ligo_parser/.links → src/ligo/parser/pascaligo/.links
View File

2
src/ligo/ligo_parser/AST.ml → src/ligo/parser/pascaligo/AST.ml
View File

@ -646,6 +646,7 @@ and arguments = tuple_injection
and pattern =
PCons of (pattern, cons) nsepseq reg
| PConstr of (constr * pattern reg) reg
| PVar of Lexer.lexeme reg
| PWild of wild
| PInt of (Lexer.lexeme * Z.t) reg
@ -792,6 +793,7 @@ let pattern_to_region = function
| PList Sugar {region; _}
| PList PNil region
| PList Raw {region; _}
| PConstr {region; _}
| PTuple {region; _} -> region
let local_decl_to_region = function

1
src/ligo/ligo_parser/AST.mli → src/ligo/parser/pascaligo/AST.mli
View File

@ -630,6 +630,7 @@ and arguments = tuple_injection
and pattern =
PCons of (pattern, cons) nsepseq reg
| PConstr of (constr * pattern reg) reg
| PVar of Lexer.lexeme reg
| PWild of wild
| PInt of (Lexer.lexeme * Z.t) reg

0
src/ligo/ligo_parser/Error.mli → src/ligo/parser/pascaligo/Error.mli
View File

0
src/ligo/ligo_parser/EvalOpt.ml → src/ligo/parser/pascaligo/EvalOpt.ml
View File

0
src/ligo/ligo_parser/EvalOpt.mli → src/ligo/parser/pascaligo/EvalOpt.mli
View File

0
src/ligo/ligo_parser/FQueue.ml → src/ligo/parser/pascaligo/FQueue.ml
View File

0
src/ligo/ligo_parser/FQueue.mli → src/ligo/parser/pascaligo/FQueue.mli
View File

0
src/ligo/ligo_parser/LexToken.mli → src/ligo/parser/pascaligo/LexToken.mli
View File

0
src/ligo/ligo_parser/LexToken.mll → src/ligo/parser/pascaligo/LexToken.mll
View File

0
src/ligo/ligo_parser/Lexer.mli → src/ligo/parser/pascaligo/Lexer.mli
View File

0
src/ligo/ligo_parser/Lexer.mll → src/ligo/parser/pascaligo/Lexer.mll
View File

0
src/ligo/ligo_parser/LexerLog.ml → src/ligo/parser/pascaligo/LexerLog.ml
View File

0
src/ligo/ligo_parser/LexerLog.mli → src/ligo/parser/pascaligo/LexerLog.mli
View File

0
src/ligo/ligo_parser/LexerMain.ml → src/ligo/parser/pascaligo/LexerMain.ml
View File

0
src/ligo/ligo_parser/Markup.ml → src/ligo/parser/pascaligo/Markup.ml
View File

0
src/ligo/ligo_parser/Markup.mli → src/ligo/parser/pascaligo/Markup.mli
View File

0
src/ligo/ligo_parser/ParToken.mly → src/ligo/parser/pascaligo/ParToken.mly
View File

11
src/ligo/ligo_parser/Parser.mly → src/ligo/parser/pascaligo/Parser.mly
View File

@ -1075,6 +1075,7 @@ core_pattern:
| C_None { PNone $1 }
| list_patt { PList $1 }
| tuple_patt { PTuple $1 }
| constr_patt { PConstr $1 }
| C_Some par(core_pattern) {
let region = cover $1 $2.region
in PSome {region; value = $1,$2}}
@ -1089,3 +1090,13 @@ cons_pattern:
tuple_patt:
par(nsepseq(core_pattern,COMMA)) { $1 }
constr_patt:
Constr core_pattern {
let second =
let region = pattern_to_region $2 in
{region; value=$2}
in
let region = cover $1.region second.region in
let value = ($1 , second) in
{region; value}}

6
src/ligo/ligo_parser/ParserLog.ml → src/ligo/parser/pascaligo/ParserLog.ml
View File

@ -682,6 +682,12 @@ and print_pattern = function
| PSome psome -> print_psome psome
| PList pattern -> print_list_pattern pattern
| PTuple ptuple -> print_ptuple ptuple
| PConstr pattern -> print_constr_pattern pattern
and print_constr_pattern {value; _} =
let (constr, args) = value in
print_constr constr ;
print_pattern args.value ;
and print_psome {value; _} =
let c_Some, patterns = value in

1
src/ligo/ligo_parser/ParserLog.mli → src/ligo/parser/pascaligo/ParserLog.mli
View File

@ -6,3 +6,4 @@ val mode : [`Byte | `Point] ref
val print_tokens : AST.t -> unit
val print_path : AST.path -> unit
val print_pattern : AST.pattern -> unit

0
src/ligo/ligo_parser/ParserMain.ml → src/ligo/parser/pascaligo/ParserMain.ml
View File

0
src/ligo/ligo_parser/Stubs/Tezos_utils.ml → src/ligo/parser/pascaligo/Stubs/Tezos_utils.ml
View File

0
src/ligo/ligo_parser/Tests/a.ligo → src/ligo/parser/pascaligo/Tests/a.ligo
View File

0
src/ligo/ligo_parser/Tests/crowdfunding.ligo → src/ligo/parser/pascaligo/Tests/crowdfunding.ligo
View File

0
src/ligo/ligo_parser/Utils.ml → src/ligo/parser/pascaligo/Utils.ml
View File

0
src/ligo/ligo_parser/Utils.mli → src/ligo/parser/pascaligo/Utils.mli
View File

0
src/ligo/ligo_parser/check_dot_git_is_dir.sh → src/ligo/parser/pascaligo/check_dot_git_is_dir.sh
View File

26
src/ligo/ligo_parser/dune → src/ligo/parser/pascaligo/dune
View File

@ -7,11 +7,11 @@
(flags -la 1 --explain --external-tokens LexToken))
(library
(name ligo_parser)
(public_name ligo.parser)
(name parser_pascaligo)
(public_name ligo.parser.pascaligo)
(modules AST FQueue Markup pascaligo Utils Version Lexer Error Parser ParserLog LexToken)
(modules_without_implementation Error)
(libraries
getopt
hex
str
uutf
@ -23,17 +23,17 @@
;; Les deux directives (rule) qui suivent sont pour le dev local.
;; Il suffit de faire "dune build Parser.exe" pour avoir un Parser.exe dans le dossier.
;; Pour le purger, il faut faire "dune clean".
(rule
(targets Parser.exe)
(deps ParserMain.exe)
(action (copy ParserMain.exe Parser.exe))
(mode promote-until-clean))
;(rule
; (targets Parser.exe)
; (deps ParserMain.exe)
; (action (copy ParserMain.exe Parser.exe))
; (mode promote-until-clean))
(rule
(targets Lexer.exe)
(deps LexerMain.exe)
(action (copy LexerMain.exe Lexer.exe))
(mode promote-until-clean))
;(rule
; (targets Lexer.exe)
; (deps LexerMain.exe)
; (action (copy LexerMain.exe Lexer.exe))
; (mode promote-until-clean))
(rule
(targets Version.ml)

0
src/ligo/ligo_parser/ligo_parser.ml → src/ligo/parser/pascaligo/pascaligo.ml
View File

1
src/ligo/run/run.ml
View File

@ -1 +0,0 @@
module Mini_c = From_mini_c

11
src/ligo/simplify_multifix.ml → src/ligo/simplify/camligo.ml
View File

@ -1,7 +1,8 @@
open Trace
open Function
module I = Multifix.Ast
module I = Parser.Camligo.Ast
module O = Ast_simplified
open O.Combinators
let unwrap : type a . a Location.wrap -> a = Location.unwrap
@ -81,10 +82,10 @@ and expression_record : _ -> O.annotated_expression result = fun r ->
let open Map.String in
List.fold_left (fun prec (k , v) -> add k v prec) empty lst
in
ok @@ O.(ae @@ E_record e_map)
ok @@ O.(make_e_a @@ E_record e_map)
and expression_main : I.expression_main -> O.annotated_expression result = fun em ->
let return x = ok O.(ae x) in
let return x = ok @@ make_e_a x in
let simple_binop name ab =
let%bind (a' , b') = bind_map_pair (bind_map_location expression_main) ab in
return @@ E_constant (name, [unwrap a' ; unwrap b']) in
@ -102,7 +103,7 @@ and expression_main : I.expression_main -> O.annotated_expression result = fun e
| None -> ok (unwrap e').expression
| Some _ -> simple_fail "can't double annotate" in
let%bind te' = bind_map_location restricted_type_expression te in
ok @@ O.annotated_expression e'' (Some (unwrap te'))
ok @@ make_e_a_full e'' (unwrap te')
| Eh_lt ab ->
simple_binop "LT" ab
| Eh_gt ab ->
@ -173,7 +174,7 @@ let let_content : I.let_content -> _ result = fun (Let_content (n, args, ty_opt,
let%bind ty' =
let (I.Type_annotation_ ty') = unwrap ty in
bind_map_location type_expression ty' in
let ae = O.annotated_expression e'' (Some (unwrap ty')) in
let ae = make_e_a_full e'' (unwrap ty') in
ok @@ O.Declaration_constant {name = (unwrap n) ; annotated_expression = ae}
let statement : I.statement -> O.declaration result = fun s ->

14
src/ligo/simplify/dune Normal file
View File

@ -0,0 +1,14 @@
(library
(name simplify)
(public_name ligo.simplify)
(libraries
tezos-utils
parser
ast_simplified
operators
)
(preprocess
(pps tezos-utils.ppx_let_generalized)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Tezos_utils ))
)

153
src/ligo/simplify.ml → src/ligo/simplify/pascaligo.ml
View File

@ -1,6 +1,10 @@
open Trace
open Ast_simplified
module Raw = Ligo_parser.AST
module Raw = Parser.Pascaligo.AST
module SMap = Map.String
open Combinators
let nseq_to_list (hd, tl) = hd :: tl
let npseq_to_list (hd, tl) = hd :: (List.map snd tl)
@ -73,11 +77,11 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result
ok @@ T_tuple lst
let rec simpl_expression (t:Raw.expr) : ae result =
let return x = ok @@ ae x in
let return x = ok @@ make_e_a x in
let simpl_projection = fun (p:Raw.projection) ->
let var =
let name = p.struct_name.value in
ae @@ E_variable name in
make_e_a @@ E_variable name in
let path = p.field_path in
let path' =
let aux (s:Raw.selection) =
@ -86,13 +90,13 @@ let rec simpl_expression (t:Raw.expr) : ae result =
| Component index -> Access_tuple (Z.to_int (snd index.value))
in
List.map aux @@ npseq_to_list path in
ok @@ ae @@ E_accessor (var, path')
ok @@ make_e_a @@ E_accessor (var, path')
in
match t with
| EVar c ->
if c.value = "unit"
then ok @@ ae @@ E_literal Literal_unit
else ok @@ ae @@ E_variable c.value
then ok @@ make_e_a @@ E_literal Literal_unit
else ok @@ make_e_a @@ E_variable c.value
| ECall x -> (
let (name, args) = x.value in
let f = name.value in
@ -100,17 +104,17 @@ let rec simpl_expression (t:Raw.expr) : ae result =
match List.assoc_opt f constants with
| None ->
let%bind arg = simpl_tuple_expression args' in
ok @@ ae @@ E_application (ae @@ E_variable f, arg)
ok @@ make_e_a @@ E_application (make_e_a @@ E_variable f, arg)
| Some arity ->
let%bind _arity =
trace (simple_error "wrong arity for constants") @@
Assert.assert_equal_int arity (List.length args') in
let%bind lst = bind_map_list simpl_expression args' in
ok @@ ae @@ E_constant (f, lst)
ok @@ make_e_a @@ E_constant (f, lst)
)
| EPar x -> simpl_expression x.value.inside
| EUnit _ -> ok @@ ae @@ E_literal Literal_unit
| EBytes x -> ok @@ ae @@ E_literal (Literal_bytes (Bytes.of_string @@ fst x.value))
| EUnit _ -> ok @@ make_e_a @@ E_literal Literal_unit
| EBytes x -> ok @@ make_e_a @@ E_literal (Literal_bytes (Bytes.of_string @@ fst x.value))
| ETuple tpl ->
let (Raw.TupleInj tpl') = tpl in
simpl_tuple_expression
@ -121,7 +125,7 @@ let rec simpl_expression (t:Raw.expr) : ae result =
@@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
@@ npseq_to_list r.value.fields in
let aux prev (k, v) = SMap.add k v prev in
ok @@ ae @@ E_record (List.fold_left aux SMap.empty fields)
ok @@ make_e_a @@ E_record (List.fold_left aux SMap.empty fields)
| EProj p' -> (
let p = p'.value in
simpl_projection p
@ -131,17 +135,17 @@ let rec simpl_expression (t:Raw.expr) : ae result =
let%bind arg =
simpl_tuple_expression
@@ npseq_to_list args.value.inside in
ok @@ ae @@ E_constructor (c.value, arg)
ok @@ make_e_a @@ E_constructor (c.value, arg)
| EConstr (SomeApp a) ->
let (_, args) = a.value in
let%bind arg =
simpl_tuple_expression
@@ npseq_to_list args.value.inside in
ok @@ ae @@ E_constant ("SOME", [arg])
ok @@ make_e_a @@ E_constant ("SOME", [arg])
| EConstr (NoneExpr n) ->
let type_expr = n.value.inside.opt_type in
let%bind type_expr' = simpl_type_expression type_expr in
ok @@ annotated_expression (E_constant ("NONE", [])) (Some (Combinators.t_option type_expr'))
ok @@ make_e_a_full (E_constant ("NONE", [])) (Combinators.t_option type_expr')
| EArith (Add c) ->
simpl_binop "ADD" c.value
| EArith (Sub c) ->
@ -150,13 +154,13 @@ let rec simpl_expression (t:Raw.expr) : ae result =
simpl_binop "TIMES" c.value
| EArith (Int n) ->
let n = Z.to_int @@ snd @@ n.value in
ok @@ ae @@ E_literal (Literal_int n)
ok @@ make_e_a @@ E_literal (Literal_int n)
| EArith (Nat n) ->
let n = Z.to_int @@ snd @@ n.value in
ok @@ ae @@ E_literal (Literal_nat n)
ok @@ make_e_a @@ E_literal (Literal_nat n)
| EArith _ -> simple_fail "arith: not supported yet"
| EString (String s) ->
ok @@ ae @@ E_literal (Literal_string s.value)
ok @@ make_e_a @@ E_literal (Literal_string s.value)
| EString _ -> simple_fail "string: not supported yet"
| ELogic l -> simpl_logic_expression l
| EList l -> simpl_list_expression l
@ -172,11 +176,11 @@ let rec simpl_expression (t:Raw.expr) : ae result =
@@ List.map get_value
@@ npseq_to_list c.value.cases.value in
let%bind cases = simpl_cases lst in
ok @@ ae @@ E_matching (e, cases)
ok @@ make_e_a @@ E_matching (e, cases)
| EMap (MapInj mi) ->
let%bind lst =
let lst = List.map get_value @@ pseq_to_list mi.value.elements in
let aux : Raw.binding -> (ae * ae) result = fun b ->
let aux : Raw.binding -> (annotated_expression * annotated_expression) result = fun b ->
let%bind src = simpl_expression b.source in
let%bind dst = simpl_expression b.image in
ok (src, dst) in
@ -190,12 +194,12 @@ let rec simpl_expression (t:Raw.expr) : ae result =
let%bind index = simpl_expression lu.value.index.value.inside in
return (E_look_up (path, index))
and simpl_logic_expression (t:Raw.logic_expr) : ae result =
and simpl_logic_expression (t:Raw.logic_expr) : annotated_expression result =
match t with
| BoolExpr (False _) ->
ok @@ ae @@ E_literal (Literal_bool false)
ok @@ make_e_a @@ E_literal (Literal_bool false)
| BoolExpr (True _) ->
ok @@ ae @@ E_literal (Literal_bool true)
ok @@ make_e_a @@ E_literal (Literal_bool true)
| BoolExpr (Or b) ->
simpl_binop "OR" b.value
| BoolExpr (And b) ->
@ -215,7 +219,7 @@ and simpl_logic_expression (t:Raw.logic_expr) : ae result =
| CompExpr (Neq c) ->
simpl_binop "NEQ" c.value
and simpl_list_expression (t:Raw.list_expr) : ae result =
and simpl_list_expression (t:Raw.list_expr) : annotated_expression result =
match t with
| Cons c ->
simpl_binop "CONS" c.value
@ -223,29 +227,29 @@ and simpl_list_expression (t:Raw.list_expr) : ae result =
let%bind lst' =
bind_map_list simpl_expression @@
pseq_to_list lst.value.elements in
ok (ae (E_list lst'))
ok (make_e_a (E_list lst'))
| Nil n ->
let n' = n.value.inside in
let%bind t' = simpl_type_expression n'.list_type in
let e' = E_list [] in
ok (annotated_expression e' (Some (Combinators.t_list t')))
ok (make_e_a_full e' (t_list t'))
and simpl_binop (name:string) (t:_ Raw.bin_op) : ae result =
and simpl_binop (name:string) (t:_ Raw.bin_op) : annotated_expression result =
let%bind a = simpl_expression t.arg1 in
let%bind b = simpl_expression t.arg2 in
ok @@ ae @@ E_constant (name, [a;b])
ok @@ make_e_a @@ E_constant (name, [a;b])
and simpl_unop (name:string) (t:_ Raw.un_op) : ae result =
and simpl_unop (name:string) (t:_ Raw.un_op) : annotated_expression result =
let%bind a = simpl_expression t.arg in
ok @@ ae @@ E_constant (name, [a])
ok @@ make_e_a @@ E_constant (name, [a])
and simpl_tuple_expression (lst:Raw.expr list) : ae result =
and simpl_tuple_expression (lst:Raw.expr list) : annotated_expression result =
match lst with
| [] -> ok @@ ae @@ E_literal Literal_unit
| [] -> ok @@ make_e_a @@ E_literal Literal_unit
| [hd] -> simpl_expression hd
| lst ->
let%bind lst = bind_list @@ List.map simpl_expression lst in
ok @@ ae @@ E_tuple lst
ok @@ make_e_a @@ E_tuple lst
and simpl_local_declaration (t:Raw.local_decl) : (instruction * named_expression) result =
match t with
@ -421,7 +425,7 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
ok @@ I_assignment {name = name.value ; annotated_expression = value_expr}
)
| Path path -> (
let err_content () = Format.asprintf "%a" (PP_helpers.printer Ligo_parser.ParserLog.print_path) path in
let err_content () = Format.asprintf "%a" (PP_helpers.printer Parser.Pascaligo.ParserLog.print_path) path in
fail @@ (fun () -> error (thunk "no path assignments") err_content ())
)
| MapPath v -> (
@ -430,8 +434,8 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
| Name name -> ok name
| _ -> simple_fail "no complex map assignments yet" in
let%bind key_expr = simpl_expression v'.index.value.inside in
let old_expr = ae @@ E_variable name.value in
let expr' = ae @@ E_constant ("MAP_UPDATE", [key_expr ; value_expr ; old_expr]) in
let old_expr = make_e_a @@ E_variable name.value in
let expr' = make_e_a @@ E_constant ("MAP_UPDATE", [key_expr ; value_expr ; old_expr]) in
ok @@ I_assignment {name = name.value ; annotated_expression = expr'}
)
)
@ -452,7 +456,7 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
let%bind record = match r.path with
| Name v -> ok v.value
| path -> (
let err_content () = Format.asprintf "%a" (PP_helpers.printer Ligo_parser.ParserLog.print_path) path in
let err_content () = Format.asprintf "%a" (PP_helpers.printer Parser.Pascaligo.ParserLog.print_path) path in
fail @@ (fun () -> error (thunk "no complex record patch yet") err_content ())
)
in
@ -471,37 +475,60 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
| Name v -> ok v.value
| _ -> simple_fail "no complex map remove yet" in
let%bind key' = simpl_expression key in
let expr = E_constant ("MAP_REMOVE", [key' ; ae (E_variable map)]) in
ok @@ I_assignment {name = map ; annotated_expression = ae expr}
let expr = E_constant ("MAP_REMOVE", [key' ; make_e_a (E_variable map)]) in
ok @@ I_assignment {name = map ; annotated_expression = make_e_a expr}
| SetRemove _ -> simple_fail "no set remove yet"
and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t ->
let open Raw in
let get_var (t:Raw.pattern) = match t with
| PVar v -> ok v.value
| _ -> simple_fail "not a var"
| _ ->
let error =
let title () = "not a var" in
let content () = Format.asprintf "%a" (PP_helpers.printer Parser.Pascaligo.ParserLog.print_pattern) t in
error title content
in
fail error
in
let%bind _assert =
trace_strong (simple_error "only pattern with two cases supported now") @@
Assert.assert_equal_int 2 (List.length t) in
let ((pa, ba), (pb, bb)) = List.(hd t, hd @@ tl t) in
let uncons p = match p with
| PCons {value = (hd, _)} -> ok hd
| _ -> simple_fail "uncons fail" in
let%bind (pa, pb) = bind_map_pair uncons (pa, pb) in
match (pa, ba), (pb, bb) with
| (PFalse _, f), (PTrue _, t)
| (PTrue _, t), (PFalse _, f) -> ok @@ Match_bool {match_true = t ; match_false = f}
| (PSome v, some), (PNone _, none)
| (PNone _, none), (PSome v, some) -> (
let get_tuple (t:Raw.pattern) = match t with
| PCons v -> npseq_to_list v.value
| PTuple v -> npseq_to_list v.value.inside
| x -> [ x ]
in
let get_single (t:Raw.pattern) =
let t' = get_tuple t in
let%bind () =
trace_strong (simple_error "not single") @@
Assert.assert_list_size t' 1 in
ok (List.hd t') in
let get_constr (t:Raw.pattern) = match t with
| PConstr v ->
let%bind var = get_single (snd v.value).value >>? get_var in
ok ((fst v.value).value , var)
| _ -> simple_fail "not a constr"
in
let%bind patterns =
let aux (x , y) =
let xs = get_tuple x in
trace_strong (simple_error "no tuple in patterns yet") @@
Assert.assert_list_size xs 1 >>? fun () ->
ok (List.hd xs , y)
in
bind_map_list aux t in
match patterns with
| [(PFalse _ , f) ; (PTrue _ , t)]
| [(PTrue _ , t) ; (PFalse _ , f)] -> ok @@ Match_bool {match_true = t ; match_false = f}
| [(PSome v , some) ; (PNone _ , none)]
| [(PNone _ , none) ; (PSome v , some)] -> (
let (_, v) = v.value in
let%bind v = match v.value.inside with
| PVar v -> ok v.value
| _ -> simple_fail "complex none patterns not supported yet" in
ok @@ Match_option {match_none = none ; match_some = (v, some) }
)
| (PCons c, cons), (PList (PNil _), nil)
| (PList (PNil _), nil), (PCons c, cons) ->
| [(PCons c , cons) ; (PList (PNil _) , nil)]
| [(PList (PNil _) , nil) ; (PCons c, cons)] ->
let%bind (a, b) =
match c.value with
| a, [(_, b)] ->
@ -511,9 +538,21 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
| _ -> simple_fail "complex list patterns not supported yet"
in
ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil}
| _ ->
let error () = simple_error "multi-level patterns not supported yet" () in
fail error
| lst ->
trace (simple_error "weird patterns not supported yet") @@
let%bind constrs =
let aux (x , y) =
let error =
let title () = "Pattern" in
let content () =
Format.asprintf "Pattern : %a" (PP_helpers.printer Parser.Pascaligo.ParserLog.print_pattern) x in
error title content in
let%bind x' =
trace error @@
get_constr x in
ok (x' , y) in
bind_map_list aux lst in
ok @@ Match_variant constrs
and simpl_instruction_block : Raw.instruction -> block result = fun t ->
match t with

2
src/ligo/simplify/simplify.ml Normal file
View File

@ -0,0 +1,2 @@
module Pascaligo = Pascaligo
module Camligo = Camligo

2
src/ligo/test/compiler_tests.ml
View File

@ -5,7 +5,7 @@ open Test_helpers
let run_entry_int (e:anon_function) (n:int) : int result =
let param : value = D_int n in
let%bind result = Run.Mini_c.run_entry e param in
let%bind result = Main.Run_mini_c.run_entry e param in
match result with
| D_int n -> ok n
| _ -> simple_fail "result is not an int"

636
src/ligo/test/integration_tests.ml
View File

@ -2,157 +2,80 @@ open Trace
open Ligo
open Test_helpers
let pass (source:string) : unit result =
let%bind raw =
trace (simple_error "parsing") @@
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
ok ()
let basic () : unit result =
pass "./contracts/toto.ligo"
open Ast_simplified.Combinators
let function_ () : unit result =
let%bind _ = pass "./contracts/function.ligo" in
let%bind _ = easy_run_main "./contracts/function.ligo" "2" in
ok ()
let%bind program = type_file "./contracts/function.ligo" in
let make_expect = fun n -> n in
expect_n_int program "main" make_expect
let complex_function () : unit result =
let%bind program = type_file "./contracts/function-complex.ligo" in
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_main_typed program input in
let%bind result' =
trace (simple_error "bad result") @@
get_a_int result in
Assert.assert_equal_int (3 * n + 2) result'
let make_expect = fun n -> (3 * n + 2) in
expect_n_int program "main" make_expect
let variant () : unit result =
let%bind program = type_file "./contracts/variant.ligo" in
let%bind () =
let expected = e_a_constructor "Foo" (e_a_int 42) in
expect_evaluate program "foo" expected in
let%bind () =
let expected = e_a_constructor "Bar" (e_a_bool true) in
expect_evaluate program "bar" expected in
ok ()
let variant_matching () : unit result =
let%bind program = type_file "./contracts/variant-matching.ligo" in
let%bind () =
let make_input = fun n -> e_a_constructor "Foo" (e_a_int n) in
let make_expected = e_a_int in
expect_n program "fb" make_input make_expected
in
let%bind _ = bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
ok ()
let closure () : unit result =
let%bind program = type_file "./contracts/closure.ligo" in
let%bind _foo = trace (simple_error "test foo") @@
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_typed "foo" program input in
let expected = e_a_empty_int ( 2 * n ) in
AST_Typed.assert_value_eq (expected, result)
in
bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
let%bind _toto = trace (simple_error "toto") @@
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_typed "toto" program input in
let expected = e_a_empty_int ( 4 * n ) in
AST_Typed.assert_value_eq (expected, result)
in
bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
let%bind () =
let make_expect = fun n -> (2 * n) in
expect_n_int program "foo" make_expect
in
let%bind _ =
let make_expect = fun n -> (4 * n) in
expect_n_int program "toto" make_expect
in
ok ()
let shadow () : unit result =
let%bind program = type_file "./contracts/shadow.ligo" in
let%bind _foo = trace (simple_error "test foo") @@
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_typed "foo" program input in
let expected = e_a_empty_int 0 in
AST_Typed.assert_value_eq (expected, result)
in
bind_list
@@ List.map aux
@@ [3 ; 2 ; 0 ; 42 ; 163 ; -1] in
ok ()
let make_expect = fun _ -> 0 in
expect_n_int program "foo" make_expect
let higher_order () : unit result =
let%bind program = type_file "./contracts/high-order.ligo" in
let%bind _foo = trace (simple_error "test foo") @@
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_typed "foobar" program input in
let expected = e_a_empty_int ( n ) in
AST_Typed.assert_value_eq (expected, result)
in
bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
ok ()
let make_expect = fun n -> n in
expect_n_int program "foobar" make_expect
let shared_function () : unit result =
let%bind program = type_file "./contracts/function-shared.ligo" in
let%bind _inc = trace (simple_error "test inc") @@
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_typed "inc" program input in
let expected = e_a_empty_int ( n + 1 ) in
AST_Typed.assert_value_eq (expected, result)
in
bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
let%bind _double_inc = trace (simple_error "test double_inc") @@
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_typed "double_inc" program input in
let expected = e_a_empty_int ( n + 2 ) in
AST_Typed.assert_value_eq (expected, result)
in
bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
let%bind _foo = trace (simple_error "test foo") @@
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_typed "foo" program input in
let expected = e_a_empty_int ( 2 * n + 3 ) in
AST_Typed.assert_value_eq (expected, result)
in
bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
let%bind () =
let make_expect = fun n -> (n + 1) in
expect_n_int program "inc" make_expect
in
let%bind () =
let make_expect = fun n -> (n + 2) in
expect_n_int program "double_inc" make_expect
in
let%bind () =
let make_expect = fun n -> (2 * n + 3) in
expect_n_int program "foo" make_expect
in
ok ()
let bool_expression () : unit result =
let%bind program = type_file "./contracts/boolean_operators.ligo" in
let aux (name, f) =
let aux b =
let open AST_Typed.Combinators in
let input = e_a_empty_bool b in
let%bind result = easy_run_typed name program input in
let%bind result' =
trace (simple_error "bad result") @@
get_a_bool result in
Assert.assert_equal_bool (f b) result'
in
let%bind _ = bind_list
@@ List.map aux [true;false] in
ok ()
in
let%bind _ = bind_list
@@ List.map aux
@@ [
let%bind _ =
let aux (name , f) = expect_b_bool program name f in
bind_map_list aux [
("or_true", fun b -> b || true) ;
("or_false", fun b -> b || false) ;
("and_true", fun b -> b && true) ;
@ -162,64 +85,32 @@ let bool_expression () : unit result =
let arithmetic () : unit result =
let%bind program = type_file "./contracts/arithmetic.ligo" in
let aux (name, f) =
let aux n =
let open AST_Typed.Combinators in
let input = if name = "int_op" then e_a_empty_nat n else e_a_empty_int n in
let%bind result = easy_run_typed name program input in
AST_Typed.assert_value_eq (f n, result)
in
let%bind _ = bind_list
@@ List.map aux [0 ; 42 ; 128] in
ok ()
in
let%bind _ =
let open AST_Typed.Combinators in
bind_list
@@ List.map aux
@@ [
("plus_op", fun n -> e_a_empty_int (n + 42)) ;
("minus_op", fun n -> e_a_empty_int (n - 42)) ;
("times_op", fun n -> e_a_empty_int (n * 42)) ;
("int_op", fun n -> e_a_empty_int n) ;
let aux (name , f) = expect_n_int program name f in
bind_map_list aux [
("plus_op", fun n -> (n + 42)) ;
("minus_op", fun n -> (n - 42)) ;
("times_op", fun n -> (n * 42)) ;
] in
let%bind () = expect_n_pos program "int_op" e_a_nat e_a_int in
ok ()
let unit_expression () : unit result =
let%bind program = type_file "./contracts/unit.ligo" in
let open AST_Typed.Combinators in
let%bind result = easy_evaluate_typed "u" program in
let%bind () =
trace (simple_error "result isn't unit") @@
get_a_unit result in
ok ()
expect_evaluate program "u" e_a_unit
let include_ () : unit result =
let%bind program = type_file "./contracts/includer.ligo" in
let%bind result = easy_evaluate_typed "bar" program in
let%bind n =
trace (simple_error "Include failed") @@
AST_Typed.Combinators.get_a_int result in
Assert.assert_equal_int 144 n
expect_evaluate program "bar" (e_a_int 144)
let record_ez_int names n =
let open AST_Typed.Combinators in
ez_e_a_empty_record @@ List.map (fun x -> x, e_a_empty_int n) names
ez_e_a_record @@ List.map (fun x -> x, e_a_int n) names
let multiple_parameters () : unit result =
let%bind program = type_file "./contracts/multiple-parameters.ligo" in
let inputs = [0 ; 2 ; 42 ; 163 ; -1] in
let aux (name, input_f, output_f) =
let aux n =
let input = input_f n in
let%bind result = easy_run_typed name program input in
let%bind result' = AST_Typed.Combinators.get_a_int result in
let expected = output_f n in
let%bind _ = Assert.assert_equal_int expected result' in
ok ()
in
let%bind _ = bind_list @@ List.map aux inputs in
ok ()
let aux ((name : string) , make_input , make_output) =
let make_output' = fun n -> e_a_int @@ make_output n in
expect_n program name make_input make_output'
in
let%bind _ = bind_list @@ List.map aux [
("ab", record_ez_int ["a";"b"], fun n -> 2 * n) ;
@ -230,341 +121,225 @@ let multiple_parameters () : unit result =
let record () : unit result =
let%bind program = type_file "./contracts/record.ligo" in
let%bind _foobar =
let%bind result = easy_evaluate_typed "fb" program in
let expect = record_ez_int ["foo";"bar"] 0 in
AST_Typed.assert_value_eq (expect, result)
let%bind () =
let expected = record_ez_int ["foo" ; "bar"] 0 in
expect_evaluate program "fb" expected
in
let%bind _projection =
let aux n =
let input = record_ez_int ["foo";"bar"] n in
let%bind result = easy_run_typed "projection" program input in
let expect = AST_Typed.Combinators.e_a_empty_int (2 * n) in
AST_Typed.assert_value_eq (expect, result)
in
bind_list @@ List.map aux [0 ; -42 ; 144]
let%bind () =
let make_input = record_ez_int ["foo" ; "bar"] in
let make_expected = fun n -> e_a_int (2 * n) in
expect_n program "projection" make_input make_expected
in
let%bind _big =
let%bind result = easy_evaluate_typed "br" program in
let expect = record_ez_int ["a";"b";"c";"d";"e"] 23 in
AST_Typed.assert_value_eq (expect, result)
let%bind () =
let expected = record_ez_int ["a";"b";"c";"d";"e"] 23 in
expect_evaluate program "br" expected
in
ok ()
let tuple () : unit result =
let%bind program = type_file "./contracts/tuple.ligo" in
let ez n =
let open AST_Typed.Combinators in
e_a_empty_tuple (List.map e_a_empty_int n) in
let%bind _foobar =
trace (simple_error "foobar") (
let%bind result = easy_evaluate_typed "fb" program in
let expect = ez [0 ; 0] in
AST_Typed.assert_value_eq (expect, result)
)
e_a_tuple (List.map e_a_int n) in
let%bind () =
let expected = ez [0 ; 0] in
expect_evaluate program "fb" expected
in
let%bind _projection = trace (simple_error "projection") (
let aux n =
let input = ez [n ; n] in
let%bind result = easy_run_typed "projection" program input in
let expect = AST_Typed.Combinators.e_a_empty_int (2 * n) in
AST_Typed.assert_value_eq (expect, result)
in
bind_list @@ List.map aux [0 ; -42 ; 144]
)
let%bind () =
let make_input = fun n -> ez [n ; n] in
let make_expected = fun n -> e_a_int (2 * n) in
expect_n program "projection" make_input make_expected
in
let%bind _big =
let%bind result = easy_evaluate_typed "br" program in
let expect = ez [23 ; 23 ; 23 ; 23 ; 23] in
AST_Typed.assert_value_eq (expect, result)
let%bind () =
let expected = ez [23 ; 23 ; 23 ; 23 ; 23] in
expect_evaluate program "br" expected
in
ok ()
let option () : unit result =
let%bind program = type_file "./contracts/option.ligo" in
let open AST_Typed.Combinators in
let%bind _some = trace (simple_error "some") @@
let%bind result = easy_evaluate_typed "s" program in
let expect = e_a_empty_some (e_a_empty_int 42) in
AST_Typed.assert_value_eq (expect, result)
let%bind () =
let expected = e_a_some (e_a_int 42) in
expect_evaluate program "s" expected
in
let%bind _none = trace (simple_error "none") @@
let%bind result = easy_evaluate_typed "n" program in
let expect = e_a_empty_none (t_int ()) in
AST_Typed.assert_value_eq (expect, result)
let%bind () =
let expected = e_a_none t_int in
expect_evaluate program "n" expected
in
ok ()
let map () : unit result =
let%bind program = type_file "./contracts/map.ligo" in
let ez lst =
let open AST_Typed.Combinators in
let lst' = List.map (fun (x, y) -> e_a_empty_int x, e_a_empty_int y) lst in
e_a_empty_map lst' (t_int ()) (t_int ())
let open Ast_simplified.Combinators in
let lst' = List.map (fun (x, y) -> e_a_int x, e_a_int y) lst in
e_a_map lst' t_int t_int
in
let%bind _get_force = trace (simple_error "get_force") @@
let aux n =
let input = ez [(23, n) ; (42, 4)] in
let%bind result = easy_run_typed "gf" program input in
let expect = AST_Typed.Combinators.(e_a_empty_int n) in
AST_Typed.assert_value_eq (expect, result)
let%bind () =
let make_input = fun n -> ez [(23, n) ; (42, 4)] in
let make_expected = e_a_int in
expect_n program "gf" make_input make_expected
in
let%bind () =
let make_input = fun n -> ez List.(map (fun x -> (x, x)) @@ range n) in
let make_expected = e_a_nat in
expect_n_strict_pos_small program "size_" make_input make_expected
in
let%bind () =
let expected = ez [(23, 0) ; (42, 0)] in
expect_evaluate program "fb" expected
in
let%bind () =
let make_input = fun n ->
let m = ez [(23 , 0) ; (42 , 0)] in
e_a_tuple [(e_a_int n) ; m]
in
bind_map_list aux [0 ; 42 ; 51 ; 421 ; -3]
let make_expected = fun n -> ez [(23 , n) ; (42 , 0)] in
expect_n_pos_small program "set_" make_input make_expected
in
let%bind _size = trace (simple_error "size") @@
let aux n =
let input = ez List.(map (fun x -> (x, x)) @@ range n) in
let%bind result = easy_run_typed "size_" program input in
let expect = AST_Typed.Combinators.(e_a_empty_nat n) in
AST_Typed.assert_value_eq (expect, result)
in
bind_map_list aux [1 ; 10 ; 3]
let%bind () =
let make_input = fun n -> ez [(23, n) ; (42, 4)] in
let make_expected = fun _ -> e_a_some @@ e_a_int 4 in
expect_n program "get" make_input make_expected
in
let%bind _foobar = trace (simple_error "foobar") @@
let%bind result = easy_evaluate_typed "fb" program in
let expect = ez [(23, 0) ; (42, 0)] in
AST_Typed.assert_value_eq (expect, result)
let%bind () =
let expected = ez @@ List.map (fun x -> (x, 23)) [144 ; 51 ; 42 ; 120 ; 421] in
expect_evaluate program "bm" expected
in
let%bind _set = trace (simple_error "set") @@
let aux n =
let input =
let m = ez [(23, 0) ; (42, 0)] in
AST_Typed.Combinators.(e_a_empty_tuple [ e_a_empty_int n ; m ])
in
let%bind result = easy_run_typed "set_" program input in
let expect = ez [(23, n) ; (42, 0)] in
AST_Typed.assert_value_eq (expect, result)
in
bind_map_list aux [1 ; 10 ; 3]
in
let%bind _get = trace (simple_error "get") @@
let aux n =
let input = ez [(23, n) ; (42, 4)] in
let%bind result = easy_run_typed "get" program input in
let expect = AST_Typed.Combinators.(e_a_empty_some @@ e_a_empty_int 4) in
AST_Typed.assert_value_eq (expect, result)
in
bind_map_list aux [0 ; 42 ; 51 ; 421 ; -3]
in
let%bind _bigmap = trace (simple_error "bigmap") @@
let%bind result = easy_evaluate_typed "bm" program in
let expect = ez @@ List.map (fun x -> (x, 23)) [144 ; 51 ; 42 ; 120 ; 421] in
AST_Typed.assert_value_eq (expect, result)
in
let%bind _remove = trace (simple_error "rm") @@
let%bind () =
let input = ez [(23, 23) ; (42, 42)] in
let%bind result = easy_run_typed "rm" program input in
let expect = ez [23, 23] in
AST_Typed.assert_value_eq (expect, result)
let expected = ez [23, 23] in
expect program "rm" input expected
in
ok ()
let list () : unit result =
let%bind program = type_file "./contracts/list.ligo" in
let ez lst =
let open AST_Typed.Combinators in
let lst' = List.map e_a_empty_int lst in
e_a_empty_list lst' (t_int ())
let lst' = List.map e_a_int lst in
e_a_list lst' t_int
in
let%bind _size = trace (simple_error "size") @@
let aux n =
let input = ez (List.range n) in
let%bind result = easy_run_typed "size_" program input in
let expect = AST_Typed.Combinators.(e_a_empty_nat n) in
AST_Typed.assert_value_eq (expect, result)
in
bind_map_list aux [1 ; 10 ; 3]
let%bind () =
let make_input = fun n -> (ez @@ List.range n) in
let make_expected = e_a_nat in
expect_n_strict_pos_small program "size_" make_input make_expected
in
let%bind _foobar = trace (simple_error "foobar") @@
let%bind result = easy_evaluate_typed "fb" program in
let expect = ez [23 ; 42] in
AST_Typed.assert_value_eq (expect, result)
let%bind () =
let expected = ez [23 ; 42] in
expect_evaluate program "fb" expected
in
let%bind _biglist = trace (simple_error "biglist") @@
let%bind result = easy_evaluate_typed "bl" program in
let expect = ez [144 ; 51 ; 42 ; 120 ; 421] in
AST_Typed.assert_value_eq (expect, result)
let%bind () =
let expected = ez [144 ; 51 ; 42 ; 120 ; 421] in
expect_evaluate program "bl" expected
in
ok ()
let condition () : unit result =
let%bind program = type_file "./contracts/condition.ligo" in
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_main_typed program input in
let%bind result' =
trace (simple_error "bad result") @@
get_a_int result in
Assert.assert_equal_int (if n = 2 then 42 else 0) result'
in
let%bind _ = bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
ok ()
let make_input = e_a_int in
let make_expected = fun n -> e_a_int (if n = 2 then 42 else 0) in
expect_n program "main" make_input make_expected
let loop () : unit result =
let%bind program = type_file "./contracts/loop.ligo" in
let%bind _dummy = trace (simple_error "dummy") @@
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_nat n in
let%bind result = easy_run_typed "dummy" program input in
let expected = e_a_empty_nat n in
AST_Typed.assert_value_eq (expected, result)
in
let%bind _ = bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163] in
ok ()
let%bind () =
let make_input = e_a_nat in
let make_expected = e_a_nat in
expect_n_pos program "dummy" make_input make_expected
in
let%bind _counter = trace (simple_error "counter") @@
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_nat n in
let%bind result = easy_run_typed "counter" program input in
let expected = e_a_empty_nat n in
AST_Typed.assert_value_eq (expected, result)
in
let%bind _ = bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 12] in
ok ()
let%bind () =
let make_input = e_a_nat in
let make_expected = e_a_nat in
expect_n_pos_mid program "counter" make_input make_expected
in
let%bind _sum = trace (simple_error "sum") @@
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_nat n in
let%bind result = easy_run_typed "sum" program input in
let expected = e_a_empty_nat (n * (n + 1) / 2) in
AST_Typed.assert_value_eq (expected, result)
in
let%bind _ = bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 12] in
ok ()
let%bind () =
let make_input = e_a_nat in
let make_expected = fun n -> e_a_nat (n * (n + 1) / 2) in
expect_n_pos_mid program "sum" make_input make_expected
in
ok()
let matching () : unit result =
let%bind program = type_file "./contracts/match.ligo" in
let%bind _bool =
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_typed "match_bool" program input in
let%bind result' =
trace (simple_error "bad result") @@
get_a_int result in
Assert.assert_equal_int (if n = 2 then 42 else 0) result'
in
let%bind _ = bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
ok ()
let%bind () =
let make_input = e_a_int in
let make_expected = fun n -> e_a_int (if n = 2 then 42 else 0) in
expect_n program "match_bool" make_input make_expected
in
let%bind _expr_bool =
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_typed "match_expr_bool" program input in
let%bind result' =
trace (simple_error "bad result") @@
get_a_int result in
Assert.assert_equal_int (if n = 2 then 42 else 0) result'
in
let%bind _ = bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
ok ()
let%bind () =
let make_input = e_a_int in
let make_expected = fun n-> e_a_int (if n = 2 then 42 else 0) in
expect_n program "match_expr_bool" make_input make_expected
in
let%bind _option =
let%bind () =
let aux n =
let open AST_Typed.Combinators in
let input = match n with
| Some s -> e_a_empty_some (e_a_empty_int s)
| None -> e_a_empty_none (t_int ()) in
let%bind result = easy_run_typed "match_option" program input in
let%bind result' =
trace (simple_error "bad result") @@
get_a_int result in
Assert.assert_equal_int 23 result'
(* Assert.assert_equal_int (match n with None -> 23 | Some s -> s) result' *)
| Some s -> e_a_some (e_a_int s)
| None -> e_a_none t_int in
let expected = e_a_int (match n with
| Some s -> s
| None -> 23) in
trace (simple_error (Format.asprintf "on input %a" PP_helpers.(option int) n)) @@
expect program "match_option" input expected
in
let%bind _ = bind_list
@@ List.map aux
@@ [Some 0 ; Some 2 ; Some 42 ; Some 163 ; Some (-1) ; None] in
ok ()
bind_iter_list aux
[Some 0 ; Some 2 ; Some 42 ; Some 163 ; Some (-1) ; None]
in
let%bind () =
let aux n =
let input = match n with
| Some s -> e_a_some (e_a_int s)
| None -> e_a_none t_int in
let expected = e_a_int (match n with
| Some s -> s
| None -> 42) in
trace (simple_error (Format.asprintf "on input %a" PP_helpers.(option int) n)) @@
expect program "match_expr_option" input expected
in
bind_iter_list aux
[Some 0 ; Some 2 ; Some 42 ; Some 163 ; Some (-1) ; None]
in
ok ()
let declarations () : unit result =
let%bind program = type_file "./contracts/declarations.ligo" in
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_main_typed program input in
let%bind result' =
trace (simple_error "bad result") @@
get_a_int result in
Assert.assert_equal_int (42 + n) result'
in
let%bind _ = bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
ok ()
let make_input = e_a_int in
let make_expected = fun n -> e_a_int (42 + n) in
expect_n program "main" make_input make_expected
let quote_declaration () : unit result =
let%bind program = type_file "./contracts/quote-declaration.ligo" in
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_main_typed program input in
let%bind result' =
trace (simple_error "bad result") @@
get_a_int result in
Assert.assert_equal_int result' (42 + 2 * n)
in
let%bind _ = bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
ok ()
let make_input = e_a_int in
let make_expected = fun n -> e_a_int (42 + 2 * n) in
expect_n program "main" make_input make_expected
let quote_declarations () : unit result =
let%bind program = type_file "./contracts/quote-declarations.ligo" in
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_int n in
let%bind result = easy_run_main_typed program input in
let%bind result' =
trace (simple_error "bad result") @@
get_a_int result in
Assert.assert_equal_int result' (74 + 2 * n)
in
let%bind _ = bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
ok ()
let make_input = e_a_int in
let make_expected = fun n -> e_a_int (74 + 2 * n) in
expect_n program "main" make_input make_expected
let counter_contract () : unit result =
let%bind program = type_file "./contracts/counter.ligo" in
let aux n =
let open AST_Typed.Combinators in
let input = e_a_empty_pair (e_a_empty_int n) (e_a_empty_int 42) in
let%bind result = easy_run_main_typed program input in
let expected = e_a_empty_pair (e_a_empty_list [] (t_int ())) (e_a_empty_int (42 + n)) in
AST_Typed.assert_value_eq (result, expected)
in
let%bind _ = bind_list
@@ List.map aux
@@ [0 ; 2 ; 42 ; 163 ; -1] in
ok ()
let make_input = fun n-> e_a_pair (e_a_int n) (e_a_int 42) in
let make_expected = fun n -> e_a_pair (e_a_list [] t_operation) (e_a_int (42 + n)) in
expect_n program "main" make_input make_expected
let super_counter_contract () : unit result =
let%bind program = type_file "./contracts/super-counter.ligo" in
let make_input = fun n ->
let action = if n mod 2 = 0 then "Increment" else "Decrement" in
e_a_pair (e_a_constructor action (e_a_int n)) (e_a_int 42) in
let make_expected = fun n ->
let op = if n mod 2 = 0 then (+) else (-) in
e_a_pair (e_a_list [] t_operation) (e_a_int (op 42 n)) in
expect_n program "main" make_input make_expected
let main = "Integration (End to End)", [
test "basic" basic ;
test "function" function_ ;
test "complex function" complex_function ;
test "variant" variant ;
test "variant matching" variant_matching ;
test "closure" closure ;
test "shared function" shared_function ;
test "shadow" shadow ;
@ -585,5 +360,6 @@ let main = "Integration (End to End)", [
test "quote declarations" quote_declarations ;
test "#include directives" include_ ;
test "counter contract" counter_contract ;
test "super counter contract" super_counter_contract ;
test "higher order" higher_order ;
]

6
src/ligo/test/multifix_tests.ml
View File

@ -1,6 +1,6 @@
open Trace
open Test_helpers
open Ligo.Parser_multifix
open Parser.Camligo
let basic () : unit result =
let%bind _ = User.parse_file "./contracts/new-syntax.mligo" in
@ -8,12 +8,12 @@ let basic () : unit result =
let simplify () : unit result =
let%bind raw = User.parse_file "./contracts/basic.mligo" in
let%bind _simpl = Ligo.Simplify_multifix.main raw in
let%bind _simpl = Simplify.Camligo.main raw in
ok ()
let integration () : unit result =
let%bind raw = User.parse_file "./contracts/basic.mligo" in
let%bind simpl = Ligo.Simplify_multifix.main raw in
let%bind simpl = Simplify.Camligo.main raw in
let%bind typed = Ligo.Typer.type_program (Location.unwrap simpl) in
let%bind result = Ligo.easy_evaluate_typed "foo" typed in
Ligo.AST_Typed.assert_value_eq (Ligo.AST_Typed.Combinators.e_a_empty_int (42 + 127), result)

54
src/ligo/test/test_helpers.ml
View File

@ -10,3 +10,57 @@ let test name f =
| Errors errs ->
Format.printf "Errors : {\n%a}\n%!" errors_pp (List.rev (List.rev_map (fun f -> f ()) errs)) ;
raise Alcotest.Test_error
open Ast_simplified.Combinators
let expect program entry_point input expected =
let error =
let title () = "expect run" in
let content () = Format.asprintf "Entry_point: %s" entry_point in
error title content in
trace error @@
let%bind result = Ligo.easy_run_typed_simplified entry_point program input in
Ast_simplified.assert_value_eq (expected , result)
let expect_evaluate program entry_point expected =
let error =
let title () = "expect evaluate" in
let content () = Format.asprintf "Entry_point: %s" entry_point in
error title content in
trace error @@
let%bind result = Ligo.easy_evaluate_typed_simplified entry_point program in
Ast_simplified.assert_value_eq (expected , result)
let expect_n_aux lst program entry_point make_input make_expected =
Format.printf "expect_n aux\n%!" ;
let aux n =
let input = make_input n in
let expected = make_expected n in
let result = expect program entry_point input expected in
result
in
let%bind _ = bind_map_list aux lst in
ok ()
let expect_n = expect_n_aux [0 ; 2 ; 42 ; 163 ; -1]
let expect_n_pos = expect_n_aux [0 ; 2 ; 42 ; 163]
let expect_n_strict_pos = expect_n_aux [2 ; 42 ; 163]
let expect_n_pos_small = expect_n_aux [0 ; 2 ; 10]
let expect_n_strict_pos_small = expect_n_aux [2 ; 10]
let expect_n_pos_mid = expect_n_aux [0 ; 2 ; 10 ; 33]
let expect_b program entry_point make_expected =
let aux b =
let input = e_a_bool b in
let expected = make_expected b in
expect program entry_point input expected
in
let%bind _ = bind_map_list aux [false ; true] in
ok ()
let expect_n_int a b c =
expect_n a b e_a_int (fun n -> e_a_int (c n))
let expect_b_bool a b c =
let open Ast_simplified.Combinators in
expect_b a b (fun bool -> e_a_bool (c bool))

6
src/ligo/test/typer_tests.ml
View File

@ -8,7 +8,7 @@ module Simplified = Ligo.AST_Simplified
let int () : unit result =
let open Combinators in
let pre = ae @@ e_int 32 in
let pre = make_e_a @@ e_int 32 in
let open Typer in
let e = Environment.full_empty in
let%bind post = type_annotated_expression e pre in
@ -21,9 +21,9 @@ module TestExpressions = struct
let test_expression ?(env = Typer.Environment.full_empty)
(expr : expression)
(test_expected_ty : Typed.tv) =
let pre = Combinators.make_e_a @@ expr in
let open Typer in
let open! Typed in
let pre = ae @@ expr in
let%bind post = type_annotated_expression env pre in
let%bind () = assert_type_value_eq (post.type_annotation, test_expected_ty) in
ok ()
@ -53,7 +53,7 @@ module TestExpressions = struct
O.[("foo", t_int ()); ("bar", t_string ())]
in test_expression
~env:(E.env_sum_type variant_foo_bar)
I.(e_constructor "foo" (ae @@ e_int 32))
I.(e_constructor "foo" (make_e_a @@ e_int 32))
O.(make_t_ez_sum variant_foo_bar)
let record () : unit result =

8
src/ligo/run/dune → src/ligo/transpiler/dune
View File

@ -1,11 +1,11 @@
(library
(name run)
(public_name ligo.run)
(name transpiler)
(public_name ligo.transpiler)
(libraries
tezos-utils
meta_michelson
ast_typed
mini_c
compiler
operators
)
(preprocess
(pps tezos-utils.ppx_let_generalized)

116
src/ligo/transpiler.ml → src/ligo/transpiler/transpiler.ml
View File

@ -70,7 +70,7 @@ let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [
let lr_path = List.map (fun b -> if b then `Right else `Left) path in
let%bind (_ , lst) =
let aux = fun (ty , acc) cur ->
let%bind (a , b) = get_t_pair ty in
let%bind (a , b) = Mini_c.get_t_pair ty in
match cur with
| `Left -> ok (a , (a , `Left) :: acc)
| `Right -> ok (b , (b , `Right) :: acc) in
@ -89,10 +89,10 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string -
let node a b : (type_value * (type_value * [`Left | `Right]) list) result =
match%bind bind_lr (a, b) with
| `Left (t, acc) ->
let%bind (a, _) = get_t_pair t in
let%bind (a, _) = Mini_c.get_t_pair t in
ok @@ (t, (a, `Left) :: acc)
| `Right (t, acc) -> (
let%bind (_, b) = get_t_pair t in
let%bind (_, b) = Mini_c.get_t_pair t in
ok @@ (t, (b, `Right) :: acc)
) in
let error_content () =
@ -182,9 +182,28 @@ and translate_literal : AST.literal -> value = fun l -> match l with
| Literal_string s -> D_string s
| Literal_unit -> D_unit
and transpile_small_environment : AST.small_environment -> Environment.Small.t result = fun x ->
let x' = AST.Environment.Small.get_environment x in
let aux prec (name , (ele : AST.environment_element)) =
let%bind tv' = translate_type ele.type_value in
ok @@ Environment.Small.append (name , tv') prec
in
trace (simple_error "transpiling small environment") @@
bind_fold_right_list aux Append_tree.Empty x'
and transpile_environment : AST.full_environment -> Environment.t result = fun x ->
let%bind nlst = bind_map_ne_list transpile_small_environment x in
ok @@ List.Ne.to_list nlst
and tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t result = fun t ->
let%bind map_tv = get_t_sum t in
ok @@ Append_tree.of_list @@ kv_list_of_map map_tv
and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_expression) : expression result =
let%bind tv = translate_type ae.type_annotation in
let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv, env) in
let return ?(tv = tv) ?(env = env) expr =
(* let%bind env' = transpile_environment ae.environment in *)
ok @@ Combinators.Expression.make_tpl (expr, tv, env) in
let f = translate_annotated_expression env in
match ae.expression with
| E_literal l -> return @@ E_literal (translate_literal l)
@ -198,10 +217,9 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
let%bind b = translate_annotated_expression env b in
return @@ E_application (a, b)
| E_constructor (m, param) ->
let%bind param' = translate_annotated_expression env ae in
let%bind param' = translate_annotated_expression env param in
let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in
let%bind map_tv = get_t_sum ae.type_annotation in
let node_tv = Append_tree.of_list @@ kv_list_of_map map_tv in
let%bind node_tv = tree_of_sum ae.type_annotation in
let leaf (k, tv) : (expression' option * type_value) result =
if k = m then (
let%bind _ =
@ -282,11 +300,11 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
let node (a:expression result) b : expression result =
match%bind bind_lr (a, b) with
| `Left expr -> (
let%bind (tv, _) = get_t_pair @@ Combinators.Expression.get_type expr in
let%bind (tv, _) = Mini_c.get_t_pair @@ Expression.get_type expr in
return ~tv @@ E_constant ("CAR", [expr])
)
| `Right expr -> (
let%bind (_, tv) = get_t_pair @@ Combinators.Expression.get_type expr in
let%bind (_, tv) = Mini_c.get_t_pair @@ Expression.get_type expr in
return ~tv @@ E_constant ("CDR", [expr])
) in
let%bind expr =
@ -326,13 +344,74 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
| E_matching (expr, m) -> (
let%bind expr' = translate_annotated_expression env expr in
match m with
| AST.Match_bool {match_true ; match_false} ->
let%bind (t, f) = bind_map_pair (translate_annotated_expression env) (match_true, match_false) in
| Match_bool {match_true ; match_false} ->
let%bind (t , f) = bind_map_pair (translate_annotated_expression env) (match_true, match_false) in
return @@ E_Cond (expr', t, f)
| AST.Match_list _ | AST.Match_option _ | AST.Match_tuple (_, _) ->
simple_fail "only match bool exprs are translated yet"
| Match_option { match_none; match_some = ((name, tv), s) } ->
let%bind n = translate_annotated_expression env match_none in
let%bind (tv' , s') =
let%bind tv' = translate_type tv in
let env' = Environment.(add (name , tv') @@ extend env) in
let%bind s' = translate_annotated_expression env' s in
ok (tv' , s') in
return @@ E_if_none (expr' , n , ((name , tv') , s'))
| Match_variant (lst , variant) -> (
let%bind tree = tree_of_sum variant in
let%bind tree' = match tree with
| Empty -> simple_fail "match empty variant"
| Full x -> ok x in
let%bind tree'' =
let rec aux t =
match (t : _ Append_tree.t') with
| Leaf (name , tv) ->
let%bind tv' = translate_type tv in
ok (`Leaf name , tv')
| Node {a ; b} ->
let%bind a' = aux a in
let%bind b' = aux b in
let tv' = Mini_c.t_union (snd a') (snd b') in
ok (`Node (a' , b') , tv')
in aux tree'
in
let rec aux (acc , env) t =
let top =
match acc with
| None -> expr'
| Some x -> x in
match t with
| ((`Leaf constructor_name) , tv) -> (
let%bind ((_ , name) , body) =
trace_option (simple_error "not supposed to happen here: missing match clause") @@
List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
let env' = Environment.(add (name , tv) @@ extend env) in
let%bind body' = translate_annotated_expression env' body in
return ~env @@ E_let_in ((name , tv) , top , body')
)
| ((`Node (a , b)) , tv) ->
let%bind a' =
let%bind a_ty = get_t_left tv in
let a_var = "left" , a_ty in
let env' = Environment.(add a_var @@ extend env) in
let%bind e = aux ((Some (Expression.make (E_variable "left") a_ty env')) , env') a in
ok (a_var , e)
in
let%bind b' =
let%bind b_ty = get_t_right tv in
let b_var = "right" , b_ty in
let env' = Environment.(add b_var @@ extend env) in
let%bind e = aux ((Some (Expression.make (E_variable "right") b_ty env')) , env') b in
ok (b_var , e)
in
return ~env @@ E_if_left (top , a' , b')
in
aux (None , env) tree''
)
| AST.Match_list _ | AST.Match_tuple (_, _) ->
simple_fail "only match bool and option exprs are translated yet"
)
and translate_lambda_shallow : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result = fun env l ->
let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in
(* Shallow capture. Capture the whole environment. Extend it with a new scope. Append it the input. *)
@ -377,7 +456,7 @@ and translate_lambda env l =
let translate_declaration env (d:AST.declaration) : toplevel_statement result =
match d with
| Declaration_constant {name;annotated_expression} ->
| Declaration_constant ({name;annotated_expression} , _) ->
let%bind expression = translate_annotated_expression env annotated_expression in
let tv = Combinators.Expression.get_type expression in
let env' = Environment.add (name, tv) env in
@ -416,7 +495,7 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result =
match lst with
| [] -> None
| hd :: tl -> (
let (AST.Declaration_constant an) = temp_unwrap_loc hd in
let (AST.Declaration_constant (an , _)) = temp_unwrap_loc hd in
match an.name = name with
| true -> (
match an.annotated_expression.expression with
@ -433,8 +512,10 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result =
@@ aux [] lst in
ok (lst', l, tv) in
let l' = {l with body = lst' @ l.body} in
trace (simple_error "translating entry")
@@ translate_main l' tv
let r =
trace (simple_error "translating entry") @@
translate_main l' tv in
r
open Combinators
@ -486,7 +567,6 @@ let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
in
aux (tree, v)
let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression result =
let open! AST in
let return e = ok (make_a_e_empty e t) in

14
src/ligo/typer/dune Normal file
View File

@ -0,0 +1,14 @@
(library
(name typer)
(public_name ligo.typer)
(libraries
tezos-utils
ast_simplified
ast_typed
operators
)
(preprocess
(pps tezos-utils.ppx_let_generalized)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Tezos_utils ))
)

108
src/ligo/typer.ml → src/ligo/typer/typer.ml
View File

@ -73,8 +73,8 @@ and type_declaration env : I.declaration -> (environment * O.declaration option)
let%bind ae' =
trace (constant_declaration_error name annotated_expression) @@
type_annotated_expression env annotated_expression in
let env' = Environment.add name ae'.type_annotation env in
ok (env', Some (O.Declaration_constant (make_n_e name ae')))
let env' = Environment.add_ez name ae'.type_annotation env in
ok (env', Some (O.Declaration_constant ((make_n_e name ae') , env')))
and type_block_full (e:environment) (b:I.block) : (O.block * environment) result =
let aux (e, acc:(environment * O.instruction list)) (i:I.instruction) =
@ -106,18 +106,18 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc
| None, None -> simple_fail "Initial assignments need type annotation"
| Some _, None ->
let%bind annotated_expression = type_annotated_expression e annotated_expression in
let e' = Environment.add name annotated_expression.type_annotation e in
let e' = Environment.add_ez name annotated_expression.type_annotation e in
ok (e', [O.I_declaration (make_n_e name annotated_expression)])
| None, Some prev ->
let%bind annotated_expression = type_annotated_expression e annotated_expression in
let%bind _ =
O.assert_type_value_eq (annotated_expression.type_annotation, prev) in
O.assert_type_value_eq (annotated_expression.type_annotation, prev.type_value) in
ok (e, [O.I_assignment (make_n_e name annotated_expression)])
| Some _, Some prev ->
let%bind annotated_expression = type_annotated_expression e annotated_expression in
let%bind _assert = trace (simple_error "Annotation doesn't match environment")
@@ O.assert_type_value_eq (annotated_expression.type_annotation, prev) in
let e' = Environment.add name annotated_expression.type_annotation e in
@@ O.assert_type_value_eq (annotated_expression.type_annotation, prev.type_value) in
let e' = Environment.add_ez name annotated_expression.type_annotation e in
ok (e', [O.I_assignment (make_n_e name annotated_expression)])
)
| I_matching (ex, m) ->
@ -130,7 +130,7 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc
let%bind ty =
trace_option (simple_error "unbound variable in record_patch") @@
Environment.get_opt r e in
let tv = O.{type_name = r ; type_value = ty} in
let tv = O.{type_name = r ; type_value = ty.type_value} in
let aux ty access =
match access with
| I.Access_record s ->
@ -142,7 +142,7 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc
generic_try (simple_error "unbound tuple access in record_patch") @@
(fun () -> List.nth t i)
in
let%bind _assert = bind_fold_list aux ty (path @ [Access_record s]) in
let%bind _assert = bind_fold_list aux ty.type_value (path @ [Access_record s]) in
ok @@ O.I_patch (tv, path @ [Access_record s], ae')
in
let%bind lst' = bind_map_list aux lst in
@ -165,7 +165,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
let%bind match_none = f e match_none in
let (n, b) = match_some in
let n' = n, t_opt in
let e' = Environment.add n t_opt e in
let e' = Environment.add_ez n t_opt e in
let%bind b' = f e' b in
ok (O.Match_option {match_none ; match_some = (n', b')})
| Match_list {match_nil ; match_cons} ->
@ -174,8 +174,8 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
@@ get_t_list t in
let%bind match_nil = f e match_nil in
let (hd, tl, b) = match_cons in
let e' = Environment.add hd t_list e in
let e' = Environment.add tl t e' in
let e' = Environment.add_ez hd t_list e in
let e' = Environment.add_ez tl t e' in
let%bind b' = f e' b in
ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')})
| Match_tuple (lst, b) ->
@ -185,10 +185,54 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
let%bind lst' =
generic_try (simple_error "Matching tuple of different size")
@@ (fun () -> List.combine lst t_tuple) in
let aux prev (name, tv) = Environment.add name tv prev in
let aux prev (name, tv) = Environment.add_ez name tv prev in
let e' = List.fold_left aux e lst' in
let%bind b' = f e' b in
ok (O.Match_tuple (lst, b'))
| Match_variant lst ->
let%bind variant_opt =
let aux acc ((constructor_name , _) , _) =
let%bind (_ , variant) =
trace_option (simple_error "bad constructor") @@
Environment.get_constructor constructor_name e in
let%bind acc = match acc with
| None -> ok (Some variant)
| Some variant' -> (
Ast_typed.assert_type_value_eq (variant , variant') >>? fun () ->
ok (Some variant)
) in
ok acc in
trace (simple_error "in match variant") @@
bind_fold_list aux None lst in
let%bind variant =
trace_option (simple_error "empty variant") @@
variant_opt in
let%bind () =
let%bind variant_cases' = Ast_typed.Combinators.get_t_sum variant in
let variant_cases = List.map fst @@ Map.String.to_kv_list variant_cases' in
let match_cases = List.map (Function.compose fst fst) lst in
let test_case = fun c ->
Assert.assert_true (List.mem c match_cases)
in
let%bind () =
trace (simple_error "missing case match") @@
bind_iter_list test_case variant_cases in
let%bind () =
trace_strong (simple_error "redundant case match") @@
Assert.assert_true List.(length variant_cases = length match_cases) in
ok ()
in
let%bind lst' =
let aux ((constructor_name , name) , b) =
let%bind (constructor , _) =
trace_option (simple_error "bad constructor??") @@
Environment.get_constructor constructor_name e in
let e' = Environment.add_ez name constructor e in
let%bind b' = f e' b in
ok ((constructor_name , name) , b')
in
bind_map_list aux lst in
ok (O.Match_variant (lst' , variant))
and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
let return tv' = ok (make_t tv' (Some t)) in
@ -239,7 +283,7 @@ and type_annotated_expression : environment -> I.annotated_expression -> O.annot
let%bind tv' =
trace_option (unbound_variable e name)
@@ Environment.get_opt name e in
return (E_variable name) tv'
return (E_variable name) tv'.type_value
| E_literal (Literal_bool b) ->
return (E_literal (Literal_bool b)) (t_bool ())
| E_literal Literal_unit ->
@ -359,7 +403,7 @@ and type_annotated_expression : environment -> I.annotated_expression -> O.annot
} ->
let%bind input_type = evaluate_type e input_type in
let%bind output_type = evaluate_type e output_type in
let e' = Environment.add binder input_type e in
let e' = Environment.add_ez binder input_type e in
let%bind (body, e'') = type_block_full e' body in
let%bind result = type_annotated_expression e'' result in
return (E_lambda {binder;input_type;output_type;result;body}) (t_function input_type output_type ())
@ -387,12 +431,26 @@ and type_annotated_expression : environment -> I.annotated_expression -> O.annot
| E_matching (ex, m) -> (
let%bind ex' = type_annotated_expression e ex in
let%bind m' = type_match type_annotated_expression e ex'.type_annotation m in
let%bind tv = match m' with
| Match_bool {match_true ; match_false} ->
let%bind _ = O.assert_type_value_eq (match_true.type_annotation, match_false.type_annotation) in
ok match_true.type_annotation
| _ -> simple_fail "can only type match_bool expressions yet" in
return (E_matching (ex' , m')) tv
let tvs =
let aux (cur:O.value O.matching) =
match cur with
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = (_ , _ , match_cons) } -> [ match_nil ; match_cons ]
| Match_option { match_none ; match_some = (_ , match_some) } -> [ match_none ; match_some ]
| Match_tuple (_ , match_tuple) -> [ match_tuple ]
| Match_variant (lst , _) -> List.map snd lst in
List.map get_type_annotation @@ aux m' in
let aux prec cur =
let%bind () =
match prec with
| None -> ok ()
| Some cur' -> Ast_typed.assert_type_value_eq (cur , cur') in
ok (Some cur) in
let%bind tv_opt = bind_fold_list aux None tvs in
let%bind tv =
trace_option (simple_error "empty matching") @@
tv_opt in
return (O.E_matching (ex', m')) tv
)
and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) : (string * O.type_value) result =
@ -444,8 +502,8 @@ let untype_literal (l:O.literal) : I.literal result =
let rec untype_annotated_expression (e:O.annotated_expression) : (I.annotated_expression) result =
let open I in
let annotation = e.type_annotation.simplified in
let return e = ok @@ annotated_expression e annotation in
let type_annotation = e.type_annotation.simplified in
let return e = ok @@ I.Combinators.make_e_a ?type_annotation e in
match e.expression with
| E_literal l ->
let%bind l = untype_literal l in
@ -551,3 +609,9 @@ and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matchin
let%bind cons = f cons in
let match_cons = hd, tl, cons in
ok @@ Match_list {match_nil ; match_cons}
| Match_variant (lst , _) ->
let aux ((a,b),c) =
let%bind c' = f c in
ok ((a,b),c') in
let%bind lst' = bind_map_list aux lst in
ok @@ Match_variant lst'