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

Merge branch '2-support-for-cameligo-in-the-binary' into 'dev'

Browse Source 
Resolve "Support for Cameligo in the binary"

See merge request ligolang/ligo!7
This commit is contained in:
Gabriel Alfour 2019-06-01 13:49:27 +00:00
commit 51e231d71b
34 changed files with 1246 additions and 1010 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/ast_simplified/PP.ml
View File

@ -30,7 +30,7 @@ let literal ppf (l:literal) = match l with
| Literal_address s -> fprintf ppf "@%S" s | Literal_address s -> fprintf ppf "@%S" s
| Literal_operation _ -> fprintf ppf "Operation(...bytes)" | Literal_operation _ -> fprintf ppf "Operation(...bytes)"
let rec expression ppf (e:expression) = match e with let rec expression ppf (e:expression) = match Location.unwrap e with
| E_literal l -> literal ppf l | E_literal l -> literal ppf l
| E_variable name -> fprintf ppf "%s" name | E_variable name -> fprintf ppf "%s" name
| E_application (f, arg) -> fprintf ppf "(%a)@(%a)" expression f expression arg | E_application (f, arg) -> fprintf ppf "(%a)@(%a)" expression f expression arg

106
src/ast_simplified/combinators.ml
View File

@ -35,76 +35,79 @@ let t_map key value = (T_constant ("map", [key ; value]))
let make_name (s : string) : name = s let make_name (s : string) : name = s
let e_var (s : string) : expression = E_variable s let e_var ?loc (s : string) : expression = Location.wrap ?loc @@ E_variable s
let e_literal ?loc l : expression = Location.wrap ?loc @@ E_literal l
let e_unit ?loc () : expression = Location.wrap ?loc @@ E_literal (Literal_unit)
let e_int ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_int n)
let e_nat ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_nat n)
let e_bool ?loc b : expression = Location.wrap ?loc @@ E_literal (Literal_bool b)
let e_string ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_string s)
let e_address ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_address s)
let e_tez ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_tez s)
let e_bytes ?loc b : expression = Location.wrap ?loc @@ E_literal (Literal_bytes (Bytes.of_string b))
let e_record ?loc map : expression = Location.wrap ?loc @@ E_record map
let e_tuple ?loc lst : expression = Location.wrap ?loc @@ E_tuple lst
let e_some ?loc s : expression = Location.wrap ?loc @@ E_constant ("SOME", [s])
let e_none ?loc () : expression = Location.wrap ?loc @@ E_constant ("NONE", [])
let e_map_update ?loc k v old : expression = Location.wrap ?loc @@ E_constant ("MAP_UPDATE" , [k ; v ; old])
let e_map ?loc lst : expression = Location.wrap ?loc @@ E_map lst
let e_list ?loc lst : expression = Location.wrap ?loc @@ E_list lst
let e_pair ?loc a b : expression = Location.wrap ?loc @@ E_tuple [a; b]
let e_constructor ?loc s a : expression = Location.wrap ?loc @@ E_constructor (s , a)
let e_matching ?loc a b : expression = Location.wrap ?loc @@ E_matching (a , b)
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
let e_accessor ?loc a b = Location.wrap ?loc @@ E_accessor (a , b)
let e_accessor_props ?loc a b = e_accessor ?loc a (List.map (fun x -> Access_record x) b)
let e_variable ?loc v = Location.wrap ?loc @@ E_variable v
let e_failwith ?loc v = Location.wrap ?loc @@ E_failwith v
let e_skip ?loc () = Location.wrap ?loc @@ E_skip
let e_loop ?loc cond body = Location.wrap ?loc @@ E_loop (cond , body)
let e_sequence ?loc a b = Location.wrap ?loc @@ E_sequence (a , b)
let e_let_in ?loc binder rhs result = Location.wrap ?loc @@ E_let_in { binder ; rhs ; result }
let e_annotation ?loc expr ty = Location.wrap ?loc @@ E_annotation (expr , ty)
let e_application ?loc a b = Location.wrap ?loc @@ E_application (a , b)
let e_binop ?loc name a b = Location.wrap ?loc @@ E_constant (name , [a ; b])
let e_constant ?loc name lst = Location.wrap ?loc @@ E_constant (name , lst)
let e_look_up ?loc x y = Location.wrap ?loc @@ E_look_up (x , y)
let e_assign ?loc a b c = Location.wrap ?loc @@ E_assign (a , b , c)
let e_unit () : expression = E_literal (Literal_unit) let make_option_typed ?loc e t_opt =
let e_int n : expression = E_literal (Literal_int n)
let e_nat n : expression = E_literal (Literal_nat n)
let e_bool b : expression = E_literal (Literal_bool b)
let e_string s : expression = E_literal (Literal_string s)
let e_address s : expression = E_literal (Literal_address s)
let e_tez s : expression = E_literal (Literal_tez s)
let e_bytes b : expression = E_literal (Literal_bytes (Bytes.of_string b))
let e_record map : expression = E_record map
let e_tuple lst : expression = E_tuple lst
let e_some s : expression = E_constant ("SOME", [s])
let e_none : expression = E_constant ("NONE", [])
let e_map_update k v old : expression = E_constant ("MAP_UPDATE" , [k ; v ; old])
let e_map lst : expression = E_map lst
let e_list lst : expression = E_list lst
let e_pair a b : expression = E_tuple [a; b]
let e_constructor s a : expression = E_constructor (s , a)
let e_match a b : expression = E_matching (a , b)
let e_match_bool a b c : expression = e_match a (Match_bool {match_true = b ; match_false = c})
let e_accessor a b = E_accessor (a , b)
let e_accessor_props a b = e_accessor a (List.map (fun x -> Access_record x) b)
let e_variable v = E_variable v
let e_failwith v = E_failwith v
let e_skip = E_skip
let e_loop cond body = E_loop (cond , body)
let e_sequence a b = E_sequence (a , b)
let e_let_in binder rhs result = E_let_in { binder ; rhs ; result }
let e_annotation expr ty = E_annotation (expr , ty)
let e_application a b = E_application (a , b)
let e_binop name a b = E_constant (name , [a ; b])
let make_option_typed e t_opt =
match t_opt with match t_opt with
| None -> e | None -> e
| Some t -> e_annotation e t | Some t -> e_annotation ?loc e t
let ez_e_record lst = let ez_e_record ?loc lst =
let aux prev (k, v) = SMap.add k v prev in let aux prev (k, v) = SMap.add k v prev in
let map = List.fold_left aux SMap.empty lst in let map = List.fold_left aux SMap.empty lst in
e_record map e_record ?loc map
let e_typed_none t_opt = let e_typed_none ?loc t_opt =
let type_annotation = t_option t_opt in let type_annotation = t_option t_opt in
e_annotation e_none type_annotation e_annotation ?loc (e_none ?loc ()) type_annotation
let e_typed_list lst t = let e_typed_list ?loc lst t =
e_annotation (e_list lst) (t_list t) e_annotation ?loc (e_list lst) (t_list t)
let e_map lst k v = e_annotation (e_map lst) (t_map k v) let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v)
let e_lambda (binder : string) let e_lambda ?loc (binder : string)
(input_type : type_expression option) (input_type : type_expression option)
(output_type : type_expression option) (output_type : type_expression option)
(result : expression) (result : expression)
: expression = : expression =
E_lambda { Location.wrap ?loc @@ E_lambda {
binder = (make_name binder , input_type) ; binder = (make_name binder , input_type) ;
input_type = input_type ; input_type = input_type ;
output_type = output_type ; output_type = output_type ;
result ; result ;
} }
let e_record (lst : (string * expr) list) : expression = let e_record ?loc map = Location.wrap ?loc @@ E_record map
let aux prev (k, v) = SMap.add k v prev in
let map = List.fold_left aux SMap.empty lst in let e_ez_record ?loc (lst : (string * expr) list) : expression =
E_record map let map = SMap.of_list lst in
e_record ?loc map
let get_e_accessor = fun t -> let get_e_accessor = fun t ->
match t with match t with
@ -130,3 +133,10 @@ let get_e_list = fun t ->
match t with match t with
| E_list lst -> ok lst | E_list lst -> ok lst
| _ -> simple_fail "not a pair" | _ -> simple_fail "not a pair"
let get_e_failwith = fun e ->
match Location.unwrap e with
| E_failwith fw -> ok fw
| _ -> simple_fail "not a failwith"
let is_e_failwith e = to_bool @@ get_e_failwith e

6
src/ast_simplified/misc.ml
View File

@ -35,7 +35,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
Format.asprintf "\n@[<v>- %a@;- %a]" PP.expression a PP.expression b Format.asprintf "\n@[<v>- %a@;- %a]" PP.expression a PP.expression b
in in
trace (fun () -> error (thunk "not equal") error_content ()) @@ trace (fun () -> error (thunk "not equal") error_content ()) @@
match (a , b) with match (Location.unwrap a , Location.unwrap b) with
| E_literal a , E_literal b -> | E_literal a , E_literal b ->
assert_literal_eq (a, b) assert_literal_eq (a, b)
| E_literal _ , _ -> | E_literal _ , _ ->
@ -113,8 +113,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
) )
| E_list _, _ -> | E_list _, _ ->
simple_fail "comparing list with other stuff" simple_fail "comparing list with other stuff"
| (E_annotation (a , _) , b) -> assert_value_eq (a , b) | (E_annotation (a , _) , _b') -> assert_value_eq (a , b)
| (a , E_annotation (b , _)) -> assert_value_eq (a , b) | (_a' , E_annotation (b , _)) -> assert_value_eq (a , b)
| (E_variable _, _) | (E_lambda _, _) | (E_variable _, _) | (E_lambda _, _)
| (E_application _, _) | (E_let_in _, _) | (E_application _, _) | (E_let_in _, _)
| (E_accessor _, _) | (E_accessor _, _)

4
src/ast_simplified/types.ml
View File

@ -42,7 +42,7 @@ and let_in = {
result : expr ; result : expr ;
} }
and expression = and expression' =
(* Base *) (* Base *)
| E_literal of literal | E_literal of literal
| E_constant of (name * expr list) (* For language constants, like (Cons hd tl) or (plus i j) *) | E_constant of (name * expr list) (* For language constants, like (Cons hd tl) or (plus i j) *)
@ -72,6 +72,8 @@ and expression =
(* Annotate *) (* Annotate *)
| E_annotation of expr * type_expression | E_annotation of expr * type_expression
and expression = expression' Location.wrap
and access = and access =
| Access_tuple of int | Access_tuple of int
| Access_record of string | Access_record of string

8
src/ast_typed/combinators.ml
View File

@ -2,7 +2,13 @@ open Trace
open Types open Types
let make_t type_value' simplified = { type_value' ; simplified } let make_t type_value' simplified = { type_value' ; simplified }
let make_a_e expression type_annotation environment = { expression ; type_annotation ; dummy_field = () ; environment } let make_a_e ?(location = Location.generated) expression type_annotation environment = {
expression ;
type_annotation ;
dummy_field = () ;
environment ;
location ;
}
let make_n_e name a_e = { name ; annotated_expression = a_e } let make_n_e name a_e = { name ; annotated_expression = a_e }
let make_n_t type_name type_value = { type_name ; type_value } let make_n_t type_name type_value = { type_name ; type_value }

11
src/ast_typed/types.ml
View File

@ -34,10 +34,11 @@ and small_environment = (environment * type_environment)
and full_environment = small_environment List.Ne.t and full_environment = small_environment List.Ne.t
and annotated_expression = { and annotated_expression = {
expression: expression ; expression : expression ;
type_annotation: tv ; type_annotation : tv ;
environment: full_environment ; environment : full_environment ;
dummy_field: unit ; location : Location.t ;
dummy_field : unit ;
} }
and named_expression = { and named_expression = {
@ -162,6 +163,6 @@ let get_entry (p:program) (entry : string) : annotated_expression result =
let get_functional_entry (p:program) (entry : string) : (lambda * type_value) result = let get_functional_entry (p:program) (entry : string) : (lambda * type_value) result =
let%bind entry = get_entry p entry in let%bind entry = get_entry p entry in
match entry.expression with match entry.expression with
| E_lambda l -> ok (l, entry.type_annotation) | E_lambda l -> ok (l , entry.type_annotation)
| _ -> simple_fail "given entry point is not functional" | _ -> simple_fail "given entry point is not functional"

99
src/bin/cli.ml
View File

@ -11,95 +11,76 @@ let main =
let term = Term.(const print_endline $ const "Ligo needs a command. Do ligo --help") in let term = Term.(const print_endline $ const "Ligo needs a command. Do ligo --help") in
(term , Term.info "ligo") (term , Term.info "ligo")
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
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
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
let syntax =
let open Arg in
let info =
let docv = "SYNTAX" in
let doc = "$(docv) is the syntax that will be used. Currently supported syntaxes are \"pascaligo\" and \"cameligo\". \"pascaligo\" is the default." in
info ~docv ~doc [] in
value @@ opt string "pascaligo" info
let compile_file = let compile_file =
let f source entry_point = let f source entry_point syntax =
toplevel @@ toplevel @@
let%bind contract = let%bind contract =
trace (simple_error "compile michelson") @@ trace (simple_error "compile michelson") @@
Ligo.Contract.compile_contract_file source entry_point in Ligo.Run.compile_contract_file source entry_point syntax in
Format.printf "Contract:\n%s\n" contract ; Format.printf "Contract:\n%s\n" contract ;
ok () ok ()
in in
let term = let term =
let source = Term.(const f $ source $ entry_point $ syntax) in
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 let docs = "Compile contracts." in
(term , Term.info ~docs "compile-contract") (term , Term.info ~docs "compile-contract")
let compile_parameter = let compile_parameter =
let f source entry_point expression = let f source entry_point expression syntax =
toplevel @@ toplevel @@
let%bind value = let%bind value =
trace (simple_error "compile-input") @@ trace (simple_error "compile-input") @@
Ligo.Contract.compile_contract_parameter source entry_point expression in Ligo.Run.compile_contract_parameter source entry_point expression syntax in
Format.printf "Input:\n%s\n" value; Format.printf "Input:\n%s\n" value;
ok () ok ()
in in
let term = let term =
let source = Term.(const f $ source $ entry_point $ expression $ syntax) in
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 let docs = "Compile contracts parameters." in
(term , Term.info ~docs "compile-parameter") (term , Term.info ~docs "compile-parameter")
let compile_storage = let compile_storage =
let f source entry_point expression = let f source entry_point expression syntax =
toplevel @@ toplevel @@
let%bind value = let%bind value =
trace (simple_error "compile-storage") @@ trace (simple_error "compile-storage") @@
Ligo.Contract.compile_contract_storage source entry_point expression in Ligo.Run.compile_contract_storage source entry_point expression syntax in
Format.printf "Storage:\n%s\n" value; Format.printf "Storage:\n%s\n" value;
ok () ok ()
in in
let term = let term =
let source = Term.(const f $ source $ entry_point $ expression $ syntax) in
let open Arg in
let docv = "SOURCE_FILE" in
let doc = "$(docv) is the path to the .ligo file of the contract." in
let info = info ~docv ~doc [] in
required @@ pos 0 (some string) None info in
let entry_point =
let open Arg in
let docv = "ENTRY_POINT" in
let doc = "$(docv) is the entry-point of the contract." in
let info = info ~docv ~doc [] in
required @@ pos 1 (some string) None info in
let expression =
let open Arg in
let docv = "EXPRESSION" in
let doc = "$(docv) is the expression that will be compiled." in
let info = info ~docv ~doc [] in
required @@ pos 2 (some string) None info in
Term.(const f $ source $ entry_point $ expression) in
let docs = "Compile contracts storage." in let docs = "Compile contracts storage." in
(term , Term.info ~docs "compile-storage") (term , Term.info ~docs "compile-storage")

2
src/contracts/counter.mligo
View File

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

3
src/contracts/type-alias.ligo Normal file
View File

@ -0,0 +1,3 @@
type toto is int
const foo : toto = 23

301
src/main/main.ml
View File

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

22
src/main/run_mini_c.ml
View File

@ -22,14 +22,6 @@ let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) :
Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in
ok (Ex_typed_value (output_ty, output)) ok (Ex_typed_value (output_ty, output))
let run_node (program:program) (input:Michelson.t) : Michelson.t result =
let%bind compiled = translate_program program "main" in
let%bind (Ex_typed_value (output_ty, output)) = run_aux compiled input in
let%bind output =
Trace.trace_tzresult_lwt (simple_error "error unparsing output") @@
Memory_proto_alpha.unparse_michelson_data output_ty output in
ok output
let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:value) : value result = let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:value) : value result =
let%bind compiled = let%bind compiled =
let error = let error =
@ -45,17 +37,3 @@ let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:v
let%bind ex_ty_value = run_aux ?options compiled input_michelson in let%bind ex_ty_value = run_aux ?options compiled input_michelson in
let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in
ok result ok result
let run (program:program) (input:value) : value result =
let%bind input_michelson = translate_value input in
let%bind compiled = translate_program program "main" in
let%bind ex_ty_value = run_aux compiled input_michelson in
let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in
ok result
let expression_to_value (e:expression) : value result =
match (Combinators.Expression.get_content e) with
| E_literal v -> ok v
| _ -> fail
@@ error (thunk "not a value")
@@ (fun () -> Format.asprintf "%a" PP.expression e)

24
src/main/run_simplified.ml Normal file
View File

@ -0,0 +1,24 @@
open Trace
let run_simplityped
?options
?(debug_mini_c = false) ?(debug_michelson = false)
(program : Ast_typed.program) (entry : string)
(input : Ast_simplified.expression) : Ast_simplified.expression result =
let%bind typed_input =
let env =
let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with
| Declaration_constant (_ , (_ , post_env)) -> post_env
in
Typer.type_expression env input in
let%bind typed_result =
Run_typed.run_typed ?options ~debug_mini_c ~debug_michelson entry program typed_input in
let%bind annotated_result = Typer.untype_expression typed_result in
ok annotated_result
let evaluate_simplityped (program : Ast_typed.program) (entry : string)
: Ast_simplified.expression result =
let%bind typed_result = Run_typed.evaluate_typed entry program in
let%bind annotated_result = Typer.untype_expression typed_result in
ok annotated_result

97
src/main/contract.ml → src/main/run_source.ml
View File

@ -59,13 +59,60 @@ let transpile_value
let%bind r = Run_mini_c.run_entry f input in let%bind r = Run_mini_c.run_entry f input in
ok r ok r
let compile_contract_file : string -> string -> string result = fun source entry_point -> let parsify_pascaligo = fun source ->
let%bind raw = let%bind raw =
trace (simple_error "parsing") @@ trace (simple_error "parsing") @@
Parser.parse_file source in Parser.Pascaligo.parse_file source in
let%bind simplified = let%bind simplified =
trace (simple_error "simplifying") @@ trace (simple_error "simplifying") @@
Simplify.Pascaligo.simpl_program raw in Simplify.Pascaligo.simpl_program raw in
ok simplified
let parsify_expression_pascaligo = fun source ->
let%bind raw =
trace (simple_error "parsing expression") @@
Parser.Pascaligo.parse_expression source in
let%bind simplified =
trace (simple_error "simplifying expression") @@
Simplify.Pascaligo.simpl_expression raw in
ok simplified
let parsify_ligodity = fun source ->
let%bind raw =
trace (simple_error "parsing") @@
Parser.Ligodity.parse_file source in
let%bind simplified =
trace (simple_error "simplifying") @@
Simplify.Ligodity.simpl_program raw in
ok simplified
let parsify_expression_ligodity = fun source ->
let%bind raw =
trace (simple_error "parsing expression") @@
Parser.Ligodity.parse_expression source in
let%bind simplified =
trace (simple_error "simplifying expression") @@
Simplify.Ligodity.simpl_expression raw in
ok simplified
let parsify = fun syntax source ->
let%bind parsify = match syntax with
| "pascaligo" -> ok parsify_pascaligo
| "cameligo" -> ok parsify_ligodity
| _ -> simple_fail "unrecognized parser"
in
parsify source
let parsify_expression = fun syntax source ->
let%bind parsify = match syntax with
| "pascaligo" -> ok parsify_expression_pascaligo
| "cameligo" -> ok parsify_expression_ligodity
| _ -> simple_fail "unrecognized parser"
in
parsify source
let compile_contract_file : string -> string -> string -> string result = fun source entry_point syntax ->
let%bind simplified = parsify syntax source in
let%bind () = let%bind () =
assert_entry_point_defined simplified entry_point in assert_entry_point_defined simplified entry_point in
let%bind typed = let%bind typed =
@ -81,14 +128,9 @@ let compile_contract_file : string -> string -> string result = fun source entry
Format.asprintf "%a" Michelson.pp_stripped michelson in Format.asprintf "%a" Michelson.pp_stripped michelson in
ok str ok str
let compile_contract_parameter : string -> string -> string -> string result = fun source entry_point expression -> let compile_contract_parameter : string -> string -> string -> string -> string result = fun source entry_point expression syntax ->
let%bind (program , parameter_tv) = let%bind (program , parameter_tv) =
let%bind raw = let%bind simplified = parsify syntax source in
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 () = let%bind () =
assert_entry_point_defined simplified entry_point in assert_entry_point_defined simplified entry_point in
let%bind typed = let%bind typed =
@ -99,13 +141,8 @@ let compile_contract_parameter : string -> string -> string -> string result = f
ok (typed , param_ty) ok (typed , param_ty)
in in
let%bind expr = 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%bind typed =
let%bind simplified = parsify_expression syntax expression in
let env = let env =
let last_declaration = Location.unwrap List.(hd @@ rev program) in let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with match last_declaration with
@ -129,14 +166,9 @@ let compile_contract_parameter : string -> string -> string -> string result = f
ok expr ok expr
let compile_contract_storage : string -> string -> string -> string result = fun source entry_point expression -> let compile_contract_storage : string -> string -> string -> string -> string result = fun source entry_point expression syntax ->
let%bind (program , storage_tv) = let%bind (program , storage_tv) =
let%bind raw = let%bind simplified = parsify syntax source in
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 () = let%bind () =
assert_entry_point_defined simplified entry_point in assert_entry_point_defined simplified entry_point in
let%bind typed = let%bind typed =
@ -147,12 +179,7 @@ let compile_contract_storage : string -> string -> string -> string result = fun
ok (typed , storage_ty) ok (typed , storage_ty)
in in
let%bind expr = let%bind expr =
let%bind raw = let%bind simplified = parsify_expression syntax expression in
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%bind typed =
let env = let env =
let last_declaration = Location.unwrap List.(hd @@ rev program) in let last_declaration = Location.unwrap List.(hd @@ rev program) in
@ -175,3 +202,17 @@ let compile_contract_storage : string -> string -> string -> string result = fun
ok str ok str
in in
ok expr ok expr
let type_file ?(debug_simplify = false) ?(debug_typed = false)
syntax (path:string) : Ast_typed.program result =
let%bind simpl = parsify syntax path in
(if debug_simplify then
Format.(printf "Simplified : %a\n%!" Ast_simplified.PP.program simpl)
) ;
let%bind typed =
trace (simple_error "typing") @@
Typer.type_program simpl in
(if debug_typed then (
Format.(printf "Typed : %a\n%!" Ast_typed.PP.program typed)
)) ;
ok typed

64
src/main/run_typed.ml Normal file
View File

@ -0,0 +1,64 @@
open Trace
let transpile_value
(e:Ast_typed.annotated_expression) : Mini_c.value result =
let%bind f =
let open Transpiler in
let (f , _) = functionalize e in
let%bind main = translate_main f in
ok main
in
let input = Mini_c.Combinators.d_unit in
let%bind r = Run_mini_c.run_entry f input in
ok r
let evaluate_typed (entry:string) (program:Ast_typed.program) : Ast_typed.annotated_expression result =
trace (simple_error "easy evaluate typed") @@
let%bind result =
let%bind mini_c_main =
Transpiler.translate_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
Transpiler.untranspile result typed_main.type_annotation in
ok typed_result
let run_typed
?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string)
(program:Ast_typed.program) (input:Ast_typed.annotated_expression) : Ast_typed.annotated_expression result =
let%bind () =
let open Ast_typed in
let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in
let%bind (arg_ty , _) =
trace_strong (simple_error "entry-point doesn't have a function type") @@
get_t_function @@ get_type_annotation d.annotated_expression in
Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input))
in
let%bind mini_c_main =
trace (simple_error "transpile mini_c entry") @@
Transpiler.translate_entry program entry in
(if debug_mini_c then
Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main)
) ;
let%bind mini_c_value = transpile_value input in
let%bind mini_c_result =
let error =
let title () = "run Mini_c" in
let content () =
Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main
in
error title content in
trace error @@
Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in
let%bind typed_result =
let%bind main_result_type =
let%bind typed_main = Ast_typed.get_functional_entry program entry in
match (snd typed_main).type_value' with
| T_function (_, result) -> ok result
| _ -> simple_fail "main doesn't have fun type" in
Transpiler.untranspile mini_c_result main_result_type in
ok typed_result

98
src/parser/ligodity.ml Normal file
View File

@ -0,0 +1,98 @@
open Trace
open Parser_ligodity
module Parser = Parser_ligodity.Parser
module AST = Parser_ligodity.AST
let parse_file (source: string) : AST.t result =
(* let pp_input =
* let prefix = Filename.(source |> basename |> remove_extension)
* and suffix = ".pp.ligo"
* in prefix ^ suffix in *)
(* let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s"
* source pp_input in
* let%bind () = sys_command cpp_cmd in *)
let pp_input =
source
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 read = Lexer.get_token in
specific_try (function
| Parser.Error -> (
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Parse error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
start.pos_fname source
in
simple_error str
)
| exn ->
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n"
(Printexc.to_string exn)
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
start.pos_fname source
in
simple_error str
) @@ (fun () -> Parser.program read lexbuf) >>? fun raw ->
ok raw
let parse_string (s:string) : AST.t result =
let lexbuf = Lexing.from_string s in
let read = Lexer.get_token in
specific_try (function
| Parser.Error -> (
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Parse error at \"%s\" from (%d, %d) to (%d, %d)\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
simple_error str
)
| _ -> simple_error "unrecognized parse_ error"
) @@ (fun () -> Parser.program read lexbuf) >>? fun raw ->
ok raw
let parse_expression (s:string) : AST.expr result =
let lexbuf = Lexing.from_string s in
let read = Lexer.get_token in
specific_try (function
| Parser.Error -> (
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Parse error at \"%s\" from (%d, %d) to (%d, %d)\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in
simple_error str
)
| exn ->
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let str = Format.sprintf
"Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In expression \"%s|%s\"\n"
(Printexc.to_string exn)
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
start.pos_fname s
in
simple_error str
) @@ (fun () -> Parser.expr read lexbuf) >>? fun raw ->
ok raw

12
src/parser/ligodity/AST.ml
View File

@ -116,7 +116,7 @@ and declaration =
(* Non-recursive values *) (* Non-recursive values *)
and let_binding = { and let_binding = {
variable : variable; bindings : pattern list;
lhs_type : (colon * type_expr) option; lhs_type : (colon * type_expr) option;
eq : equal; eq : equal;
let_rhs : expr let_rhs : expr
@ -327,7 +327,7 @@ and let_in = {
and fun_expr = { and fun_expr = {
kwd_fun : kwd_fun; kwd_fun : kwd_fun;
param : variable; params : pattern list;
p_annot : (colon * type_expr) option; p_annot : (colon * type_expr) option;
arrow : arrow; arrow : arrow;
body : expr body : expr
@ -544,8 +544,8 @@ and print_terminator = function
Some semi -> print_token semi ";" Some semi -> print_token semi ";"
| None -> () | None -> ()
and print_let_binding {variable; lhs_type; eq; let_rhs} = and print_let_binding {bindings; lhs_type; eq; let_rhs} =
print_var variable; List.iter print_pattern bindings;
(match lhs_type with (match lhs_type with
None -> () None -> ()
| Some (colon, type_expr) -> | Some (colon, type_expr) ->
@ -737,10 +737,10 @@ and print_let_in (bind: let_in) =
print_expr body print_expr body
and print_fun_expr {value; _} = and print_fun_expr {value; _} =
let {kwd_fun; param; p_annot; arrow; body} = value in let {kwd_fun; params; p_annot; arrow; body} = value in
print_token kwd_fun "fun"; print_token kwd_fun "fun";
(match p_annot with (match p_annot with
None -> print_var param None -> List.iter print_pattern params
| Some (colon, type_expr) -> | Some (colon, type_expr) ->
print_token colon ":"; print_token colon ":";
print_type_expr type_expr); print_type_expr type_expr);

5
src/parser/ligodity/AST.mli
View File

@ -125,7 +125,7 @@ and declaration =
(* Non-recursive values *) (* Non-recursive values *)
and let_binding = { (* p = e p : t = e *) and let_binding = { (* p = e p : t = e *)
variable : variable; bindings : pattern list;
lhs_type : (colon * type_expr) option; lhs_type : (colon * type_expr) option;
eq : equal; eq : equal;
let_rhs : expr let_rhs : expr
@ -336,7 +336,7 @@ and let_in = {
and fun_expr = { and fun_expr = {
kwd_fun : kwd_fun; kwd_fun : kwd_fun;
param : variable; params : pattern list;
p_annot : (colon * type_expr) option; p_annot : (colon * type_expr) option;
arrow : arrow; arrow : arrow;
body : expr body : expr
@ -486,3 +486,4 @@ val unpar : expr -> expr
val print_projection : projection -> unit val print_projection : projection -> unit
val print_pattern : pattern -> unit val print_pattern : pattern -> unit
val print_expr : expr -> unit

201
src/parser/ligodity/Parser.mly
View File

@ -7,10 +7,10 @@ open AST
module VMap = Utils.String.Map module VMap = Utils.String.Map
let ghost_of value = Region.{region=ghost; value} (*let ghost_of value = Region.{region=ghost; value}*)
let ghost = Region.ghost let ghost = Region.ghost
let fail_syn_unif type1 type2 : 'a = (* let fail_syn_unif type1 type2 : 'a =
let reg = AST.region_of_type_expr type1 in let reg = AST.region_of_type_expr type1 in
let reg = reg#compact ~file:false `Byte in let reg = reg#compact ~file:false `Byte in
let value = let value =
@ -25,167 +25,31 @@ let mk_component rank =
let par = {lpar=ghost; inside = ghost_of num; rpar=ghost} let par = {lpar=ghost; inside = ghost_of num; rpar=ghost}
in Component (ghost_of par) in Component (ghost_of par)
let rec mk_field_path (rank, tail) = let rec mk_field_path (rank, tail) =
let head = mk_component rank in let head = mk_component rank in
match tail with match tail with
[] -> head, [] [] -> head, []
| hd::tl -> mk_field_path (hd,tl) |> Utils.nsepseq_cons head ghost | hd::tl -> mk_field_path (hd,tl) |> Utils.nsepseq_cons head ghost
let mk_projection fresh (path : int Utils.nseq) = { let mk_projection fresh (path : int Utils.nseq) = {
struct_name = fresh; struct_name = fresh;
selector = ghost; selector = ghost;
field_path = Utils.nsepseq_rev (mk_field_path path) field_path = Utils.nsepseq_rev (mk_field_path path)
} } *)
let rec sub_rec fresh path (map, rank) pattern =
let path' = Utils.nseq_cons rank path in
let map' = split fresh map path' pattern
in map', rank+1
and split fresh map path = function
PTuple t -> let apply = sub_rec fresh path in
Utils.nsepseq_foldl apply (map,1) t.value |> fst
| PPar p -> split fresh map path p.value.inside
| PVar v -> if VMap.mem v.value map
then
let err =
Region.{value="Non-linear pattern."; region=v.region}
in (Lexer.prerr ~kind:"Syntactical" err; exit 1)
else
let proj = mk_projection fresh path
in VMap.add v.value (None, proj) map
| PWild _ -> map
| PUnit _ -> let anon = Utils.gen_sym () in
let unit = ghost, TAlias (ghost_of "unit")
and proj = mk_projection fresh path
in VMap.add anon (Some unit, proj) map
| PRecord {region; _}
| PConstr {region; _}
| PTyped {region; _} ->
let err = Region.{value="Not implemented yet."; region}
in (Lexer.prerr ~kind:"Syntactical" err; exit 1)
| p -> let _, _, map = split_pattern p in map
and split_pattern = function
PPar p -> split_pattern p.value.inside
| PVar v -> v, None, VMap.empty
| PWild _ -> Utils.gen_sym () |> ghost_of, None, VMap.empty
| PUnit _ -> let fresh = Utils.gen_sym () |> ghost_of in
let unit = TAlias (ghost_of "unit")
in fresh, Some unit, VMap.empty
| PTyped {value=p; _} ->
let var', type', map = split_pattern p.pattern in
(match type' with
None -> var', Some p.type_expr, map
| Some t when t = p.type_expr -> var', Some t, map (* hack *)
| Some t -> fail_syn_unif t p.type_expr)
| PTuple t ->
let fresh = Utils.gen_sym () |> ghost_of
and init = VMap.empty, 1 in
let apply (map, rank) pattern =
split fresh map (rank,[]) pattern, rank+1 in
let map = Utils.nsepseq_foldl apply init t.value |> fst
in fresh, None, map
| PRecord {region; _}
| PConstr {region; _} ->
let err = Region.{value="Not implemented yet."; region}
in (Lexer.prerr ~kind:"Syntactical" err; exit 1)
| PInt {region; _} | PTrue region
| PFalse region | PString {region; _}
| PList Sugar {region; _} | PList PCons {region; _} ->
let err = Region.{value="Incomplete pattern."; region}
in (Lexer.prerr ~kind:"Syntactical" err; exit 1)
let mk_let_bindings =
let apply var (lhs_type, proj) =
let new_bind = {
variable = ghost_of var;
lhs_type;
eq = ghost;
let_rhs = EProj (ghost_of proj)} in
let new_let = Let (ghost_of (ghost, new_bind))
in Utils.nseq_cons new_let
in VMap.fold apply
let mk_let_in_bindings =
let apply var (lhs_type, proj) acc =
let binding = {
variable = ghost_of var;
lhs_type;
eq = ghost;
let_rhs = EProj (ghost_of proj)} in
let let_in = {
kwd_let = ghost;
binding;
kwd_in = ghost;
body = acc}
in ELetIn (ghost_of let_in)
in VMap.fold apply
(* We rewrite "fun p -> e" into "fun x -> match x with p -> e" *) (* We rewrite "fun p -> e" into "fun x -> match x with p -> e" *)
let norm_fun_expr patterns expr =
let apply pattern expr =
match pattern with
PVar var ->
let fun_expr = {
kwd_fun = ghost;
param = var;
p_annot = None;
arrow = ghost;
body = expr}
in EFun (ghost_of fun_expr)
| PTyped p ->
let pattern = p.value.pattern
and type_expr = p.value.type_expr in
let fresh = Utils.gen_sym () |> ghost_of in
let clause = {pattern; arrow=ghost; rhs=expr} in
let clause = ghost_of clause in
let cases = ghost_of (clause, []) in
let case = {
kwd_match = ghost;
expr = EVar fresh;
opening = With ghost;
lead_vbar = None;
cases;
closing = End ghost} in
let case = ECase (ghost_of case) in
let fun_expr = {
kwd_fun = ghost;
param = fresh;
p_annot = Some (p.value.colon, type_expr);
arrow = ghost;
body = case}
in EFun (ghost_of fun_expr)
| _ -> let fresh = Utils.gen_sym () |> ghost_of in
let clause = {pattern; arrow=ghost; rhs=expr} in
let clause = ghost_of clause in
let cases = ghost_of (clause, []) in
let case = {
kwd_match = ghost;
expr = EVar fresh;
opening = With ghost;
lead_vbar = None;
cases;
closing = End ghost} in
let case = ECase (ghost_of case) in
let fun_expr = {
kwd_fun = ghost;
param = fresh;
p_annot = None;
arrow = ghost;
body = case}
in EFun (ghost_of fun_expr)
in Utils.nseq_foldr apply patterns expr
(* END HEADER *) (* END HEADER *)
%} %}
(* Entry points *) (* Entry points *)
%start program %start program expr
%type <AST.t> program %type <AST.t> program
%type <AST.expr> expr
%% %%
@ -330,7 +194,7 @@ declarations:
declaration: declaration:
reg(kwd(LetEntry) entry_binding {$1,$2}) { LetEntry $1, [] } reg(kwd(LetEntry) entry_binding {$1,$2}) { LetEntry $1, [] }
| reg(type_decl) { TypeDecl $1, [] } | reg(type_decl) { TypeDecl $1, [] }
| let_declaration { $1 } | let_declaration { $1, [] }
(* Type declarations *) (* Type declarations *)
@ -415,36 +279,33 @@ field_decl:
entry_binding: entry_binding:
ident nseq(sub_irrefutable) type_annotation? eq expr { ident nseq(sub_irrefutable) type_annotation? eq expr {
let let_rhs = norm_fun_expr $2 $5 in let let_rhs = $5 in
{variable = $1; lhs_type=$3; eq=$4; let_rhs} let pattern = PVar $1 in
let (hd , tl) = $2 in
{bindings = pattern :: hd :: tl; lhs_type=$3; eq=$4; let_rhs}
} }
| ident type_annotation? eq fun_expr(expr) { | ident type_annotation? eq fun_expr(expr) {
{variable = $1; lhs_type=$2; eq=$3; let_rhs=$4} } let pattern = PVar $1 in
{bindings = [pattern]; lhs_type=$2; eq=$3; let_rhs=$4} }
(* Top-level non-recursive definitions *) (* Top-level non-recursive definitions *)
let_declaration: let_declaration:
reg(kwd(Let) let_binding {$1,$2}) { reg(kwd(Let) let_binding {$1,$2}) {
let kwd_let, (binding, map) = $1.value in let kwd_let, binding = $1.value in
let let0 = Let {$1 with value = kwd_let, binding} Let {$1 with value = kwd_let, binding}
in mk_let_bindings map (let0,[])
} }
let_binding: let_binding:
ident nseq(sub_irrefutable) type_annotation? eq expr { ident nseq(sub_irrefutable) type_annotation? eq expr {
let let_rhs = norm_fun_expr $2 $5 in let let_rhs = $5 in
let map = VMap.empty in let ident_pattern = PVar $1 in
{variable=$1; lhs_type=$3; eq=$4; let_rhs}, map let (hd , tl) = $2 in
{bindings= (ident_pattern :: hd :: tl); lhs_type=$3; eq=$4; let_rhs}
} }
| irrefutable type_annotation? eq expr { | irrefutable type_annotation? eq expr {
let variable, type_opt, map = split_pattern $1 in let pattern = $1 in
match type_opt, $2 with {bindings = [pattern]; lhs_type=$2; eq=$3; let_rhs=$4}
Some type1, Some (_,type2) when type1 <> type2 ->
fail_syn_unif type1 type2
| Some type1, None ->
let lhs_type = Some (ghost, type1) in
{variable; lhs_type; eq=$3; let_rhs=$4}, map
| _ -> {variable; lhs_type=$2; eq=$3; let_rhs=$4}, map
} }
type_annotation: type_annotation:
@ -590,13 +451,23 @@ case_clause(right_expr):
let_expr(right_expr): let_expr(right_expr):
reg(kwd(Let) let_binding kwd(In) right_expr {$1,$2,$3,$4}) { reg(kwd(Let) let_binding kwd(In) right_expr {$1,$2,$3,$4}) {
let kwd_let, (binding, map), kwd_in, body = $1.value in let kwd_let, binding , kwd_in, body = $1.value in
let body = mk_let_in_bindings map body in
let let_in = {kwd_let; binding; kwd_in; body} let let_in = {kwd_let; binding; kwd_in; body}
in ELetIn {region=$1.region; value=let_in} } in ELetIn {region=$1.region; value=let_in} }
fun_expr(right_expr): fun_expr(right_expr):
kwd(Fun) nseq(irrefutable) arrow right_expr { norm_fun_expr $2 $4 } reg(kwd(Fun) nseq(irrefutable) arrow right_expr {$1,$2,$3,$4}) {
let kwd_fun, bindings, arrow, body = $1.value in
let (hd , tl) = bindings in
let f = {
kwd_fun ;
params = hd :: tl ;
p_annot = None ;
arrow ;
body ;
} in
EFun { region=$1.region; value=f }
}
disj_expr_level: disj_expr_level:
reg(disj_expr) { ELogic (BoolExpr (Or $1)) } reg(disj_expr) { ELogic (BoolExpr (Or $1)) }

116
src/parser/parser.ml
View File

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

114
src/parser/pascaligo.ml Normal file
View File

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

14
src/simplify/camligo.ml
View File

@ -206,7 +206,7 @@ and ifthenelse
let%bind cond' = bind_map_location expression cond in let%bind cond' = bind_map_location expression cond in
let%bind branch_true' = bind_map_location expression branch_true in let%bind branch_true' = bind_map_location expression branch_true in
let%bind branch_false' = bind_map_location expression branch_false in let%bind branch_false' = bind_map_location expression branch_false in
ok @@ O.(e_match_bool (unwrap cond') (unwrap branch_true') (unwrap branch_false')) ok @@ O.(e_matching_bool (unwrap cond') (unwrap branch_true') (unwrap branch_false'))
and ifthen and ifthen
: (I.expression Location.wrap * I.expression Location.wrap) -> O.expression result : (I.expression Location.wrap * I.expression Location.wrap) -> O.expression result
@ -214,7 +214,7 @@ and ifthen
let (cond , branch_true) = it in let (cond , branch_true) = it in
let%bind cond' = bind_map_location expression cond in let%bind cond' = bind_map_location expression cond in
let%bind branch_true' = bind_map_location expression branch_true in let%bind branch_true' = bind_map_location expression branch_true in
ok @@ O.(e_match_bool (unwrap cond') (unwrap branch_true') (e_unit ())) ok @@ O.(e_matching_bool (unwrap cond') (unwrap branch_true') (e_unit ()))
and match_ and match_
: I.expression Location.wrap * I.e_match_clause Location.wrap list -> O.expression result : I.expression Location.wrap * I.e_match_clause Location.wrap list -> O.expression result
@ -231,7 +231,7 @@ and match_
ok (x' , y') in ok (x' , y') in
bind_map_list aux clauses in bind_map_list aux clauses in
let%bind matching = match_clauses clauses' in let%bind matching = match_clauses clauses' in
ok O.(e_match expr' matching) ok O.(e_matching expr' matching)
and record and record
= fun r -> = fun r ->
@ -244,7 +244,7 @@ and record
in in
let%bind r' = bind_map_list (bind_map_location aux) r in let%bind r' = bind_map_list (bind_map_location aux) r in
let lst = List.map ((fun (x, y) -> unwrap x, unwrap y) >| unwrap) r' in let lst = List.map ((fun (x, y) -> unwrap x, unwrap y) >| unwrap) r' in
ok @@ O.(e_record lst) ok @@ O.(e_ez_record lst)
and expression_main : I.expression_main Location.wrap -> O.expression result = fun em -> and expression_main : I.expression_main Location.wrap -> O.expression result = fun em ->
let return x = ok @@ x in let return x = ok @@ x in
@ -334,13 +334,13 @@ and expression_main : I.expression_main Location.wrap -> O.expression result = f
and identifier_application : (string Location.wrap) list * string Location.wrap -> O.expression option -> _ result = fun (lst , v) param_opt -> and identifier_application : (string Location.wrap) list * string Location.wrap -> O.expression option -> _ result = fun (lst , v) param_opt ->
let constant_name = String.concat "." ((List.map unwrap lst) @ [unwrap v]) in let constant_name = String.concat "." ((List.map unwrap lst) @ [unwrap v]) in
match List.assoc_opt constant_name constants , param_opt with match List.assoc_opt constant_name constants , param_opt with
| Some s , None -> ok O.(E_constant (s , [])) | Some s , None -> ok O.(e_constant s [])
| Some s , Some param -> ( | Some s , Some param -> (
let params = let params =
match param with match Location.unwrap param with
| E_tuple lst -> lst | E_tuple lst -> lst
| _ -> [ param ] in | _ -> [ param ] in
ok O.(E_constant (s , params)) ok O.(e_constant s params)
) )
| None , param_opt -> ( | None , param_opt -> (
let%bind () = let%bind () =

406
src/simplify/ligodity.ml
View File

@ -19,6 +19,35 @@ let get_value : 'a Raw.reg -> 'a = fun x -> x.value
open Operators.Simplify.Ligodity open Operators.Simplify.Ligodity
let r_split = Location.r_split
let rec pattern_to_var : Raw.pattern -> _ = fun p ->
match p with
| Raw.PPar p -> pattern_to_var p.value.inside
| Raw.PVar v -> ok v
| _ -> simple_fail "not a var"
let rec pattern_to_typed_var : Raw.pattern -> _ = fun p ->
match p with
| Raw.PPar p -> pattern_to_typed_var p.value.inside
| Raw.PTyped tp -> (
let tp = tp.value in
let%bind v = pattern_to_var tp.pattern in
ok (v , Some tp.type_expr)
)
| Raw.PVar v -> ok (v , None)
| _ -> simple_fail "not a var"
let rec expr_to_typed_expr : Raw.expr -> _ = fun e ->
match e with
| EPar e -> expr_to_typed_expr e.value.inside
| EAnnot a -> ok (fst a.value , Some (snd a.value))
| _ -> ok (e , None)
let patterns_to_var : Raw.pattern list -> _ = fun ps ->
let%bind () = Assert.assert_list_size ps 1 in
pattern_to_var @@ List.hd ps
let rec simpl_type_expression : Raw.type_expr -> type_expression result = let rec simpl_type_expression : Raw.type_expr -> type_expression result =
function function
| TPar x -> simpl_type_expression x.value.inside | TPar x -> simpl_type_expression x.value.inside
@ -79,9 +108,10 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result
ok @@ T_tuple lst ok @@ T_tuple lst
let rec simpl_expression : let rec simpl_expression :
?te_annot:type_expression -> Raw.expr -> expr result = fun ?te_annot t -> Raw.expr -> expr result = fun t ->
let return x = ok @@ make_option_typed x te_annot in let return x = ok x in
let simpl_projection = fun (p:Raw.projection) -> let simpl_projection = fun (p:Raw.projection Region.reg) ->
let (p , loc) = r_split p in
let var = let var =
let name = p.struct_name.value in let name = p.struct_name.value in
e_variable name in e_variable name in
@ -95,107 +125,136 @@ let rec simpl_expression :
Access_tuple (Z.to_int (snd index.value)) Access_tuple (Z.to_int (snd index.value))
in in
List.map aux @@ npseq_to_list path in List.map aux @@ npseq_to_list path in
return @@ E_accessor (var, path') return @@ e_accessor ~loc var path'
in in
let mk_let_in binder rhs result =
E_let_in {binder; rhs; result} in
trace (
let title () = "simplifying expression" in
let message () = "" in
let data = [
("expression" , thunk @@ Format.asprintf "%a" (PP_helpers.printer Raw.print_expr) t)
] in
error ~data title message
) @@
match t with match t with
| Raw.ELetIn e -> ( | Raw.ELetIn e -> (
let Raw.{binding; body; _} = e.value in let Raw.{binding ; body ; _} = e.value in
let Raw.{variable; lhs_type; let_rhs; _} = binding in let Raw.{bindings ; lhs_type ; let_rhs ; _} = binding in
let%bind type_annotation = bind_map_option let%bind variable = patterns_to_var bindings in
(fun (_,type_expr) -> simpl_type_expression type_expr) let%bind ty_opt =
bind_map_option
(fun (_ , type_expr) -> simpl_type_expression type_expr)
lhs_type in lhs_type in
let%bind rhs = simpl_expression ?te_annot:type_annotation let_rhs in let%bind rhs = simpl_expression let_rhs in
let rhs' =
match ty_opt with
| None -> rhs
| Some ty -> e_annotation rhs ty in
let%bind body = simpl_expression body in let%bind body = simpl_expression body in
return @@ mk_let_in (variable.value , None) rhs body return @@ e_let_in (variable.value , None) rhs' body
) )
| Raw.EAnnot a -> ( | Raw.EAnnot a -> (
let (expr , type_expr) = a.value in let (a , loc) = r_split a in
match te_annot with let (expr , type_expr) = a in
| None -> ( let%bind expr' = simpl_expression expr in
let%bind te_annot = simpl_type_expression type_expr in let%bind type_expr' = simpl_type_expression type_expr in
let%bind expr' = simpl_expression ~te_annot expr in return @@ e_annotation ~loc expr' type_expr'
ok expr'
)
| Some _ -> simple_fail "no double annotation"
) )
| EVar c -> ( | EVar c -> (
let c' = c.value in let c' = c.value in
match List.assoc_opt c' constants with match List.assoc_opt c' constants with
| None -> return @@ E_variable c.value | None -> return @@ e_variable c.value
| Some s -> return @@ E_constant (s , []) | Some s -> return @@ e_constant s []
) )
| ECall x -> ( | ECall x -> (
let (e1, e2) = x.value in let ((e1 , e2) , loc) = r_split x in
let%bind args = bind_map_list simpl_expression (nseq_to_list e2) in let%bind args = bind_map_list simpl_expression (nseq_to_list e2) in
match e1 with match e1 with
| EVar f -> | EVar f -> (
(match List.assoc_opt f.value constants with let (f , f_loc) = r_split f in
| None -> match List.assoc_opt f constants with
| None -> (
let%bind arg = simpl_tuple_expression (nseq_to_list e2) in let%bind arg = simpl_tuple_expression (nseq_to_list e2) in
return @@ E_application (e_variable f.value, arg) return @@ e_application ~loc (e_variable ~loc:f_loc f) arg
| Some s -> return @@ E_constant (s , args)) )
| e1 -> | Some s -> return @@ e_constant ~loc s args
let%bind e1' = simpl_expression e1 in )
let%bind arg = simpl_tuple_expression (nseq_to_list e2) in | e1 -> (
return @@ E_application (e1' , arg) let%bind e1' = simpl_expression e1 in
let%bind arg = simpl_tuple_expression (nseq_to_list e2) in
return @@ e_application ~loc e1' arg
)
) )
| EPar x -> simpl_expression ?te_annot x.value.inside | EPar x -> simpl_expression x.value.inside
| EUnit _ -> return @@ E_literal Literal_unit | EUnit reg -> (
| EBytes x -> return @@ E_literal (Literal_bytes (Bytes.of_string @@ fst x.value)) let (_ , loc) = r_split reg in
| ETuple tpl -> simpl_tuple_expression ?te_annot @@ (npseq_to_list tpl.value) return @@ e_literal ~loc Literal_unit
| ERecord r -> )
| EBytes x -> (
let (x , loc) = r_split x in
return @@ e_literal ~loc (Literal_bytes (Bytes.of_string @@ fst x))
)
| ETuple tpl -> simpl_tuple_expression @@ (npseq_to_list tpl.value)
| ERecord r -> (
let (r , loc) = r_split r in
let%bind fields = bind_list let%bind fields = bind_list
@@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v)) @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v))
@@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr)) @@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
@@ pseq_to_list r.value.elements in @@ pseq_to_list r.elements in
let aux prev (k, v) = SMap.add k v prev in let map = SMap.of_list fields in
return @@ E_record (List.fold_left aux SMap.empty fields) return @@ e_record ~loc map
| EProj p' -> (
let p = p'.value in
simpl_projection p
) )
| EConstr c -> | EProj p -> simpl_projection p
let (c, args) = c.value in | EConstr c -> (
let ((c_name , args) , loc) = r_split c in
let (c_name , _c_loc) = r_split c_name in
let args = let args =
match args with match args with
None -> [] None -> []
| Some arg -> [arg] in | Some arg -> [arg] in
let%bind arg = simpl_tuple_expression @@ args in let%bind arg = simpl_tuple_expression @@ args in
return @@ E_constructor (c.value, arg) return @@ e_constructor ~loc c_name arg
)
| EArith (Add c) -> | EArith (Add c) ->
simpl_binop ?te_annot "ADD" c.value simpl_binop "ADD" c
| EArith (Sub c) -> | EArith (Sub c) ->
simpl_binop ?te_annot "SUB" c.value simpl_binop "SUB" c
| EArith (Mult c) -> | EArith (Mult c) ->
simpl_binop ?te_annot "TIMES" c.value simpl_binop "TIMES" c
| EArith (Div c) -> | EArith (Div c) ->
simpl_binop ?te_annot "DIV" c.value simpl_binop "DIV" c
| EArith (Mod c) -> | EArith (Mod c) ->
simpl_binop ?te_annot "MOD" c.value simpl_binop "MOD" c
| EArith (Int n) -> | EArith (Int n) -> (
let n = Z.to_int @@ snd @@ n.value in let (n , loc) = r_split n in
return @@ E_literal (Literal_int n) let n = Z.to_int @@ snd @@ n in
| EArith (Nat n) -> return @@ e_literal ~loc (Literal_int n)
let n = Z.to_int @@ snd @@ n.value in )
return @@ E_literal (Literal_nat n) | EArith (Nat n) -> (
| EArith (Mtz n) -> let (n , loc) = r_split n in
let n = Z.to_int @@ snd @@ n.value in let n = Z.to_int @@ snd @@ n in
return @@ E_literal (Literal_tez n) return @@ e_literal ~loc (Literal_nat n)
)
| EArith (Mtz n) -> (
let (n , loc) = r_split n in
let n = Z.to_int @@ snd @@ n in
return @@ e_literal ~loc (Literal_tez n)
)
| EArith _ -> simple_fail "arith: not supported yet" | EArith _ -> simple_fail "arith: not supported yet"
| EString (String s) -> | EString (String s) -> (
let (s , loc) = r_split s in
let s' = let s' =
let s = s.value in let s = s in
String.(sub s 1 ((length s) - 2)) String.(sub s 1 ((length s) - 2))
in in
return @@ E_literal (Literal_string s') return @@ e_literal ~loc (Literal_string s')
)
| EString _ -> simple_fail "string: not supported yet" | EString _ -> simple_fail "string: not supported yet"
| ELogic l -> simpl_logic_expression ?te_annot l | ELogic l -> simpl_logic_expression l
| EList l -> simpl_list_expression ?te_annot l | EList l -> simpl_list_expression l
| ECase c -> | ECase c -> (
let%bind e = simpl_expression c.value.expr in let (c , loc) = r_split c in
let%bind e = simpl_expression c.expr in
let%bind lst = let%bind lst =
let aux (x : Raw.expr Raw.case_clause) = let aux (x : Raw.expr Raw.case_clause) =
let%bind expr = simpl_expression x.rhs in let%bind expr = simpl_expression x.rhs in
@ -203,96 +262,154 @@ let rec simpl_expression :
bind_list bind_list
@@ List.map aux @@ List.map aux
@@ List.map get_value @@ List.map get_value
@@ npseq_to_list c.value.cases.value in @@ npseq_to_list c.cases.value in
let%bind cases = simpl_cases lst in let default_action () =
return @@ E_matching (e, cases) let%bind cases = simpl_cases lst in
| EFun lamb -> return @@ e_matching ~loc e cases in
let%bind input_type = bind_map_option (* Hack to take care of patterns introduced by `parser/ligodity/Parser.mly` in "norm_fun_expr" *)
(fun (_,type_expr) -> simpl_type_expression type_expr) match lst with
lamb.value.p_annot in | [ (pattern , rhs) ] -> (
let body, body_type = match pattern with
match lamb.value.body with | Raw.PPar p -> (
EAnnot {value = expr, type_expr} -> expr, Some type_expr let p' = p.value.inside in
| expr -> expr, None in match p' with
let%bind output_type = | Raw.PTyped x -> (
bind_map_option simpl_type_expression body_type in let x' = x.value in
let%bind result = simpl_expression body in match x'.pattern with
let binder = lamb.value.param.value, input_type in | Raw.PVar y ->
let lambda = {binder; input_type; output_type; result = result} let var_name = y.value in
in return @@ E_lambda lambda let%bind type_expr = simpl_type_expression x'.type_expr in
| ESeq s -> return @@ e_let_in (var_name , Some type_expr) e rhs
let items : Raw.expr list = pseq_to_list s.value.elements in | _ -> default_action ()
)
| _ -> default_action ()
)
| _ -> default_action ()
)
| _ -> default_action ()
)
| EFun lamb -> simpl_fun lamb
| ESeq s -> (
let (s , loc) = r_split s in
let items : Raw.expr list = pseq_to_list s.elements in
(match items with (match items with
[] -> return @@ E_skip [] -> return @@ e_skip ~loc ()
| expr::more -> | expr::more ->
let expr' = simpl_expression expr in let expr' = simpl_expression expr in
let apply (e1: Raw.expr) (e2: expression Trace.result) = let apply (e1: Raw.expr) (e2: expression Trace.result) =
let%bind a = simpl_expression e1 in let%bind a = simpl_expression e1 in
let%bind e2' = e2 in let%bind e2' = e2 in
return @@ E_sequence (a, e2') return @@ e_sequence a e2'
in List.fold_right apply more expr') in List.fold_right apply more expr')
| ECond c -> )
let c = c.value in | ECond c -> (
let (c , loc) = r_split c in
let%bind expr = simpl_expression c.test in let%bind expr = simpl_expression c.test in
let%bind match_true = simpl_expression c.ifso in let%bind match_true = simpl_expression c.ifso in
let%bind match_false = simpl_expression c.ifnot in let%bind match_false = simpl_expression c.ifnot in
return @@ E_matching (expr, (Match_bool {match_true; match_false})) return @@ e_matching ~loc expr (Match_bool {match_true; match_false})
)
and simpl_fun lamb' : expr result =
let return x = ok x in
let (lamb , loc) = r_split lamb' in
let%bind args' =
let args = lamb.params in
let%bind p_args = bind_map_list pattern_to_typed_var args in
let aux ((var : Raw.variable) , ty_opt) =
match var.value , ty_opt with
| "storage" , None ->
ok (var , T_variable "storage")
| _ , None ->
simple_fail "untyped function parameter"
| _ , Some ty -> (
let%bind ty' = simpl_type_expression ty in
ok (var , ty')
)
in
bind_map_list aux p_args
in
let arguments_name = "arguments" in
let (binder , input_type) =
let type_expression = T_tuple (List.map snd args') in
(arguments_name , type_expression) in
let%bind (body , body_type) = expr_to_typed_expr lamb.body in
let%bind output_type =
bind_map_option simpl_type_expression body_type in
let%bind result = simpl_expression body in
let wrapped_result =
let aux = fun i ((name : Raw.variable) , ty) wrapped ->
let accessor = e_accessor (e_variable arguments_name) [ Access_tuple i ] in
e_let_in (name.value , Some ty) accessor wrapped
in
let wraps = List.mapi aux args' in
List.fold_right' (fun x f -> f x) result wraps in
return @@ e_lambda ~loc binder (Some input_type) output_type wrapped_result
and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result = and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
let return x = ok @@ make_option_typed x te_annot in let return x = ok @@ make_option_typed x te_annot in
match t with match t with
| BoolExpr (False _) -> | BoolExpr (False reg) -> (
return @@ E_literal (Literal_bool false) let loc = Location.lift reg in
| BoolExpr (True _) -> return @@ e_literal ~loc (Literal_bool false)
return @@ E_literal (Literal_bool true) )
| BoolExpr (True reg) -> (
let loc = Location.lift reg in
return @@ e_literal ~loc (Literal_bool true)
)
| BoolExpr (Or b) -> | BoolExpr (Or b) ->
simpl_binop ?te_annot "OR" b.value simpl_binop "OR" b
| BoolExpr (And b) -> | BoolExpr (And b) ->
simpl_binop ?te_annot "AND" b.value simpl_binop "AND" b
| BoolExpr (Not b) -> | BoolExpr (Not b) ->
simpl_unop ?te_annot "NOT" b.value simpl_unop "NOT" b
| CompExpr (Lt c) -> | CompExpr (Lt c) ->
simpl_binop ?te_annot "LT" c.value simpl_binop "LT" c
| CompExpr (Gt c) -> | CompExpr (Gt c) ->
simpl_binop ?te_annot "GT" c.value simpl_binop "GT" c
| CompExpr (Leq c) -> | CompExpr (Leq c) ->
simpl_binop ?te_annot "LE" c.value simpl_binop "LE" c
| CompExpr (Geq c) -> | CompExpr (Geq c) ->
simpl_binop ?te_annot "GE" c.value simpl_binop "GE" c
| CompExpr (Equal c) -> | CompExpr (Equal c) ->
simpl_binop ?te_annot "EQ" c.value simpl_binop "EQ" c
| CompExpr (Neq c) -> | CompExpr (Neq c) ->
simpl_binop ?te_annot "NEQ" c.value simpl_binop "NEQ" c
and simpl_list_expression ?te_annot (t:Raw.list_expr) : expression result = and simpl_list_expression (t:Raw.list_expr) : expression result =
let return x = ok @@ make_option_typed x te_annot in let return x = ok @@ x in
match t with match t with
| Cons c -> | Cons c -> simpl_binop "CONS" c
simpl_binop ?te_annot "CONS" c.value | List lst -> (
| List lst -> let (lst , loc) = r_split lst in
let%bind lst' = let%bind lst' =
bind_map_list simpl_expression @@ bind_map_list simpl_expression @@
pseq_to_list lst.value.elements in pseq_to_list lst.elements in
return @@ E_list lst' return @@ e_list ~loc lst'
)
and simpl_binop ?te_annot (name:string) (t:_ Raw.bin_op) : expression result = and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
let return x = ok @@ make_option_typed x te_annot in let return x = ok @@ x in
let%bind a = simpl_expression t.arg1 in let (args , loc) = r_split t in
let%bind b = simpl_expression t.arg2 in let%bind a = simpl_expression args.arg1 in
return @@ E_constant (name, [a;b]) let%bind b = simpl_expression args.arg2 in
return @@ e_constant ~loc name [ a ; b ]
and simpl_unop ?te_annot (name:string) (t:_ Raw.un_op) : expression result = and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
let return x = ok @@ make_option_typed x te_annot in let return x = ok @@ x in
let (t , loc) = r_split t in
let%bind a = simpl_expression t.arg in let%bind a = simpl_expression t.arg in
return @@ E_constant (name, [a]) return @@ e_constant ~loc name [ a ]
and simpl_tuple_expression ?te_annot (lst:Raw.expr list) : expression result = and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result =
let return x = ok @@ make_option_typed x te_annot in let return x = ok @@ x in
match lst with match lst with
| [] -> return @@ E_literal Literal_unit | [] -> return @@ e_literal ?loc Literal_unit
| [hd] -> simpl_expression ?te_annot hd | [hd] -> simpl_expression hd
| lst -> | lst ->
let%bind lst = bind_list @@ List.map simpl_expression lst in let%bind lst = bind_list @@ List.map simpl_expression lst in
return @@ E_tuple lst return @@ e_tuple ?loc lst
and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fun t -> and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fun t ->
let open! Raw in let open! Raw in
@ -302,16 +419,37 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu
let {name;type_expr} : Raw.type_decl = x.value in let {name;type_expr} : Raw.type_decl = x.value in
let%bind type_expression = simpl_type_expression type_expr in let%bind type_expression = simpl_type_expression type_expr in
ok @@ loc x @@ Declaration_type (name.value , type_expression) ok @@ loc x @@ Declaration_type (name.value , type_expression)
| LetEntry _ -> simple_fail "no entry point yet" | LetEntry x (* -> simple_fail "no entry point yet" *)
| Let x -> ( | Let x -> (
let _, binding = x.value in let _ , binding = x.value in
let {variable ; lhs_type ; let_rhs} = binding in let {bindings ; lhs_type ; let_rhs} = binding in
let%bind type_annotation = bind_map_option let%bind (var , args) =
(fun (_,type_expr) -> simpl_type_expression type_expr) let%bind (hd , tl) = match bindings with
lhs_type in | [] -> simple_fail "let without bindgings"
let%bind rhs = simpl_expression ?te_annot:type_annotation let_rhs in | hd :: tl -> ok (hd , tl)
let name = variable.value in in
ok @@ loc x @@ (Declaration_constant (name , type_annotation , rhs)) let%bind var = pattern_to_var hd in
ok (var , tl)
in
match args with
| [] -> (
let%bind lhs_type' = bind_map_option
(fun (_ , te) -> simpl_type_expression te) lhs_type in
let%bind rhs' = simpl_expression let_rhs in
ok @@ loc x @@ (Declaration_constant (var.value , lhs_type' , rhs'))
)
| _ -> (
let fun_ = {
kwd_fun = Region.ghost ;
params = args ;
p_annot = lhs_type ;
arrow = Region.ghost ;
body = let_rhs ;
} in
let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in
let%bind rhs' = simpl_expression rhs in
ok @@ loc x @@ (Declaration_constant (var.value , None , rhs'))
)
) )
and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -> and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t ->
@ -392,4 +530,4 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
) )
let simpl_program : Raw.ast -> program result = fun t -> let simpl_program : Raw.ast -> program result = fun t ->
bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl bind_list @@ List.map simpl_declaration @@ List.rev @@ nseq_to_list t.decl

322
src/simplify/pascaligo.ml
View File

@ -16,16 +16,18 @@ let get_value : 'a Raw.reg -> 'a = fun x -> x.value
open Operators.Simplify.Pascaligo open Operators.Simplify.Pascaligo
let r_split = Location.r_split
let return expr = ok @@ fun expr'_opt -> let return expr = ok @@ fun expr'_opt ->
let expr = expr in let expr = expr in
match expr'_opt with match expr'_opt with
| None -> ok @@ expr | None -> ok @@ expr
| Some expr' -> ok @@ e_sequence expr expr' | Some expr' -> ok @@ e_sequence expr expr'
let return_let_in binder rhs = ok @@ fun expr'_opt -> let return_let_in ?loc binder rhs = ok @@ fun expr'_opt ->
match expr'_opt with match expr'_opt with
| None -> simple_fail "missing return" (* Hard to explain. Shouldn't happen in prod. *) | None -> simple_fail "missing return" (* Hard to explain. Shouldn't happen in prod. *)
| Some expr' -> ok @@ e_let_in binder rhs expr' | Some expr' -> ok @@ e_let_in ?loc binder rhs expr'
let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
match t with match t with
@ -88,11 +90,12 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result
let rec simpl_expression (t:Raw.expr) : expr result = let rec simpl_expression (t:Raw.expr) : expr result =
let return x = ok x in let return x = ok x in
let simpl_projection = fun (p:Raw.projection) -> let simpl_projection = fun (p : Raw.projection Region.reg) ->
let (p' , loc) = r_split p in
let var = let var =
let name = p.struct_name.value in let name = p'.struct_name.value in
e_variable name in e_variable name in
let path = p.field_path in let path = p'.field_path in
let path' = let path' =
let aux (s:Raw.selection) = let aux (s:Raw.selection) =
match s with match s with
@ -100,97 +103,112 @@ let rec simpl_expression (t:Raw.expr) : expr result =
| Component index -> Access_tuple (Z.to_int (snd index.value)) | Component index -> Access_tuple (Z.to_int (snd index.value))
in in
List.map aux @@ npseq_to_list path in List.map aux @@ npseq_to_list path in
return @@ E_accessor (var, path') return @@ e_accessor ~loc var path'
in in
match t with match t with
| EAnnot a -> ( | EAnnot a -> (
let (expr , type_expr) = a.value in let ((expr , type_expr) , loc) = r_split a in
let%bind expr' = simpl_expression expr in let%bind expr' = simpl_expression expr in
let%bind type_expr' = simpl_type_expression type_expr in let%bind type_expr' = simpl_type_expression type_expr in
return @@ e_annotation expr' type_expr' return @@ e_annotation ~loc expr' type_expr'
) )
| EVar c -> ( | EVar c -> (
let c' = c.value in let (c' , loc) = r_split c in
match List.assoc_opt c' constants with match List.assoc_opt c' constants with
| None -> return @@ E_variable c.value | None -> return @@ e_variable ~loc c.value
| Some s -> return @@ E_constant (s , []) | Some s -> return @@ e_constant ~loc s []
) )
| ECall x -> ( | ECall x -> (
let (name, args) = x.value in let ((name, args) , loc) = r_split x in
let f = name.value in let (f , f_loc) = r_split name in
let args' = npseq_to_list args.value.inside in let (args , args_loc) = r_split args in
let args' = npseq_to_list args.inside in
match List.assoc_opt f constants with match List.assoc_opt f constants with
| None -> | None ->
let%bind arg = simpl_tuple_expression args' in let%bind arg = simpl_tuple_expression ~loc:args_loc args' in
return @@ E_application (e_variable f, arg) return @@ e_application ~loc (e_variable ~loc:f_loc f) arg
| Some s -> | Some s ->
let%bind lst = bind_map_list simpl_expression args' in let%bind lst = bind_map_list simpl_expression args' in
return @@ E_constant (s , lst) return @@ e_constant ~loc s lst
) )
| EPar x -> simpl_expression x.value.inside | EPar x -> simpl_expression x.value.inside
| EUnit _ -> return @@ E_literal Literal_unit | EUnit reg ->
| EBytes x -> return @@ E_literal (Literal_bytes (Bytes.of_string @@ fst x.value)) let loc = Location.lift reg in
return @@ e_literal ~loc Literal_unit
| EBytes x ->
let (x' , loc) = r_split x in
return @@ e_literal ~loc (Literal_bytes (Bytes.of_string @@ fst x'))
| ETuple tpl -> | ETuple tpl ->
let (Raw.TupleInj tpl') = tpl in let (Raw.TupleInj tpl') = tpl in
simpl_tuple_expression let (tpl' , loc) = r_split tpl' in
@@ npseq_to_list tpl'.value.inside simpl_tuple_expression ~loc @@ npseq_to_list tpl'.inside
| ERecord r -> | ERecord r ->
let%bind fields = bind_list let%bind fields = bind_list
@@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v)) @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v))
@@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr)) @@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
@@ pseq_to_list r.value.elements in @@ pseq_to_list r.value.elements in
let aux prev (k, v) = SMap.add k v prev in let aux prev (k, v) = SMap.add k v prev in
return @@ E_record (List.fold_left aux SMap.empty fields) return @@ e_record (List.fold_left aux SMap.empty fields)
| EProj p' -> ( | EProj p -> simpl_projection p
let p = p'.value in | EConstr (ConstrApp c) -> (
simpl_projection p let ((c, args) , loc) = r_split c in
let (args , args_loc) = r_split args in
let%bind arg =
simpl_tuple_expression ~loc:args_loc
@@ npseq_to_list args.inside in
return @@ e_constructor ~loc c.value arg
) )
| EConstr (ConstrApp c) ->
let (c, args) = c.value in
let%bind arg =
simpl_tuple_expression
@@ npseq_to_list args.value.inside in
return @@ E_constructor (c.value, arg)
| EConstr (SomeApp a) -> | EConstr (SomeApp a) ->
let (_, args) = a.value in let ((_, args) , loc) = r_split a in
let (args , args_loc) = r_split args in
let%bind arg = let%bind arg =
simpl_tuple_expression simpl_tuple_expression ~loc:args_loc
@@ npseq_to_list args.value.inside in @@ npseq_to_list args.inside in
return @@ E_constant ("SOME", [arg]) return @@ e_constant ~loc "SOME" [arg]
| EConstr (NoneExpr _) -> | EConstr (NoneExpr reg) -> (
return @@ E_constant ("NONE" , []) let loc = Location.lift reg in
return @@ e_none ~loc ()
)
| EArith (Add c) -> | EArith (Add c) ->
simpl_binop "ADD" c.value simpl_binop "ADD" c
| EArith (Sub c) -> | EArith (Sub c) ->
simpl_binop "SUB" c.value simpl_binop "SUB" c
| EArith (Mult c) -> | EArith (Mult c) ->
simpl_binop "TIMES" c.value simpl_binop "TIMES" c
| EArith (Div c) -> | EArith (Div c) ->
simpl_binop "DIV" c.value simpl_binop "DIV" c
| EArith (Mod c) -> | EArith (Mod c) ->
simpl_binop "MOD" c.value simpl_binop "MOD" c
| EArith (Int n) -> | EArith (Int n) -> (
let n = Z.to_int @@ snd @@ n.value in let (n , loc) = r_split n in
return @@ E_literal (Literal_int n) let n = Z.to_int @@ snd n in
| EArith (Nat n) -> return @@ e_literal ~loc (Literal_int n)
let n = Z.to_int @@ snd @@ n.value in )
return @@ E_literal (Literal_nat n) | EArith (Nat n) -> (
| EArith (Mtz n) -> let (n , loc) = r_split n in
let n = Z.to_int @@ snd @@ n.value in let n = Z.to_int @@ snd @@ n in
return @@ E_literal (Literal_tez n) return @@ e_literal ~loc (Literal_nat n)
)
| EArith (Mtz n) -> (
let (n , loc) = r_split n in
let n = Z.to_int @@ snd @@ n in
return @@ e_literal ~loc (Literal_tez n)
)
| EArith _ -> simple_fail "arith: not supported yet" | EArith _ -> simple_fail "arith: not supported yet"
| EString (String s) -> | EString (String s) ->
let (s , loc) = r_split s in
let s' = let s' =
let s = s.value in (* S contains quotes *)
String.(sub s 1 ((length s) - 2)) String.(sub s 1 ((length s) - 2))
in in
return @@ E_literal (Literal_string s') return @@ e_literal ~loc (Literal_string s')
| EString _ -> simple_fail "string: not supported yet" | EString _ -> simple_fail "string: not supported yet"
| ELogic l -> simpl_logic_expression l | ELogic l -> simpl_logic_expression l
| EList l -> simpl_list_expression l | EList l -> simpl_list_expression l
| ESet _ -> simple_fail "set: not supported yet" | ESet _ -> simple_fail "set: not supported yet"
| ECase c -> | ECase c -> (
let%bind e = simpl_expression c.value.expr in let (c , loc) = r_split c in
let%bind e = simpl_expression c.expr in
let%bind lst = let%bind lst =
let aux (x : Raw.expr Raw.case_clause) = let aux (x : Raw.expr Raw.case_clause) =
let%bind expr = simpl_expression x.rhs in let%bind expr = simpl_expression x.rhs in
@ -198,84 +216,103 @@ let rec simpl_expression (t:Raw.expr) : expr result =
bind_list bind_list
@@ List.map aux @@ List.map aux
@@ List.map get_value @@ List.map get_value
@@ npseq_to_list c.value.cases.value in @@ npseq_to_list c.cases.value in
let%bind cases = simpl_cases lst in let%bind cases = simpl_cases lst in
return @@ E_matching (e, cases) return @@ e_matching ~loc e cases
| EMap (MapInj mi) -> )
| EMap (MapInj mi) -> (
let (mi , loc) = r_split mi in
let%bind lst = let%bind lst =
let lst = List.map get_value @@ pseq_to_list mi.value.elements in let lst = List.map get_value @@ pseq_to_list mi.elements in
let aux : Raw.binding -> (expression * expression) result = fun b -> let aux : Raw.binding -> (expression * expression) result = fun b ->
let%bind src = simpl_expression b.source in let%bind src = simpl_expression b.source in
let%bind dst = simpl_expression b.image in let%bind dst = simpl_expression b.image in
ok (src, dst) in ok (src, dst) in
bind_map_list aux lst in bind_map_list aux lst in
return (E_map lst) return @@ e_map ~loc lst
| EMap (MapLookUp lu) -> )
let%bind path = match lu.value.path with | EMap (MapLookUp lu) -> (
| Name v -> return (E_variable v.value) let (lu , loc) = r_split lu in
| Path p -> simpl_projection p.value let%bind path = match lu.path with
| Name v -> (
let (v , loc) = r_split v in
return @@ e_variable ~loc v
)
| Path p -> simpl_projection p
in in
let%bind index = simpl_expression lu.value.index.value.inside in let%bind index = simpl_expression lu.index.value.inside in
return (E_look_up (path, index)) return @@ e_look_up ~loc path index
)
and simpl_logic_expression (t:Raw.logic_expr) : expression result = and simpl_logic_expression (t:Raw.logic_expr) : expression result =
let return x = ok x in let return x = ok x in
match t with match t with
| BoolExpr (False _) -> | BoolExpr (False reg) -> (
return @@ E_literal (Literal_bool false) let loc = Location.lift reg in
| BoolExpr (True _) -> return @@ e_literal ~loc (Literal_bool false)
return @@ E_literal (Literal_bool true) )
| BoolExpr (True reg) -> (
let loc = Location.lift reg in
return @@ e_literal ~loc (Literal_bool true)
)
| BoolExpr (Or b) -> | BoolExpr (Or b) ->
simpl_binop "OR" b.value simpl_binop "OR" b
| BoolExpr (And b) -> | BoolExpr (And b) ->
simpl_binop "AND" b.value simpl_binop "AND" b
| BoolExpr (Not b) -> | BoolExpr (Not b) ->
simpl_unop "NOT" b.value simpl_unop "NOT" b
| CompExpr (Lt c) -> | CompExpr (Lt c) ->
simpl_binop "LT" c.value simpl_binop "LT" c
| CompExpr (Gt c) -> | CompExpr (Gt c) ->
simpl_binop "GT" c.value simpl_binop "GT" c
| CompExpr (Leq c) -> | CompExpr (Leq c) ->
simpl_binop "LE" c.value simpl_binop "LE" c
| CompExpr (Geq c) -> | CompExpr (Geq c) ->
simpl_binop "GE" c.value simpl_binop "GE" c
| CompExpr (Equal c) -> | CompExpr (Equal c) ->
simpl_binop "EQ" c.value simpl_binop "EQ" c
| CompExpr (Neq c) -> | CompExpr (Neq c) ->
simpl_binop "NEQ" c.value simpl_binop "NEQ" c
and simpl_list_expression (t:Raw.list_expr) : expression result = and simpl_list_expression (t:Raw.list_expr) : expression result =
let return x = ok x in let return x = ok x in
match t with match t with
| Cons c -> | Cons c ->
simpl_binop "CONS" c.value simpl_binop "CONS" c
| List lst -> | List lst -> (
let (lst , loc) = r_split lst in
let%bind lst' = let%bind lst' =
bind_map_list simpl_expression @@ bind_map_list simpl_expression @@
pseq_to_list lst.value.elements in pseq_to_list lst.elements in
return @@ E_list lst' return @@ e_list ~loc lst'
| Nil _ -> )
return @@ E_list [] | Nil reg -> (
let loc = Location.lift reg in
return @@ e_list ~loc []
)
and simpl_binop (name:string) (t:_ Raw.bin_op) : expression result = and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
let return x = ok x in let return x = ok x in
let (t , loc) = r_split t in
let%bind a = simpl_expression t.arg1 in let%bind a = simpl_expression t.arg1 in
let%bind b = simpl_expression t.arg2 in let%bind b = simpl_expression t.arg2 in
return @@ E_constant (name, [a;b]) return @@ e_constant ~loc name [ a ; b ]
and simpl_unop (name:string) (t:_ Raw.un_op) : expression result = and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
let return x = ok x in let return x = ok x in
let (t , loc) = r_split t in
let%bind a = simpl_expression t.arg in let%bind a = simpl_expression t.arg in
return @@ E_constant (name, [a]) return @@ e_constant ~loc name [ a ]
and simpl_tuple_expression (lst:Raw.expr list) : expression result = and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result =
let return x = ok x in let return x = ok x in
match lst with match lst with
| [] -> return @@ E_literal Literal_unit | [] -> return @@ e_literal Literal_unit
| [hd] -> simpl_expression hd | [hd] -> simpl_expression hd
| lst -> | lst -> (
let%bind lst = bind_list @@ List.map simpl_expression lst in let%bind lst = bind_list @@ List.map simpl_expression lst in
return @@ E_tuple lst return @@ e_tuple ?loc lst
)
and simpl_local_declaration : Raw.local_decl -> _ result = fun t -> and simpl_local_declaration : Raw.local_decl -> _ result = fun t ->
match t with match t with
@ -284,26 +321,28 @@ and simpl_local_declaration : Raw.local_decl -> _ result = fun t ->
and simpl_lambda_declaration : Raw.lambda_decl -> _ result = fun l -> and simpl_lambda_declaration : Raw.lambda_decl -> _ result = fun l ->
match l with match l with
| FunDecl f -> | FunDecl f -> (
let%bind (name , e) = simpl_fun_declaration (f.value) in let (f , loc) = r_split f in
return_let_in name e let%bind (name , e) = simpl_fun_declaration ~loc f in
return_let_in ~loc name e
)
| ProcDecl _ -> simple_fail "no local procedure yet" | ProcDecl _ -> simple_fail "no local procedure yet"
| EntryDecl _ -> simple_fail "no local entry-point yet" | EntryDecl _ -> simple_fail "no local entry-point yet"
and simpl_data_declaration : Raw.data_decl -> _ result = fun t -> and simpl_data_declaration : Raw.data_decl -> _ result = fun t ->
match t with match t with
| LocalVar x -> | LocalVar x ->
let x = x.value in let (x , loc) = r_split x in
let name = x.name.value in let name = x.name.value in
let%bind t = simpl_type_expression x.var_type in let%bind t = simpl_type_expression x.var_type in
let%bind expression = simpl_expression x.init in let%bind expression = simpl_expression x.init in
return_let_in (name , Some t) expression return_let_in ~loc (name , Some t) expression
| LocalConst x -> | LocalConst x ->
let x = x.value in let (x , loc) = r_split x in
let name = x.name.value in let name = x.name.value in
let%bind t = simpl_type_expression x.const_type in let%bind t = simpl_type_expression x.const_type in
let%bind expression = simpl_expression x.init in let%bind expression = simpl_expression x.init in
return_let_in (name , Some t) expression return_let_in ~loc (name , Some t) expression
and simpl_param : Raw.param_decl -> (type_name * type_expression) result = fun t -> and simpl_param : Raw.param_decl -> (type_name * type_expression) result = fun t ->
match t with match t with
@ -318,7 +357,7 @@ and simpl_param : Raw.param_decl -> (type_name * type_expression) result = fun t
let%bind type_expression = simpl_type_expression c.param_type in let%bind type_expression = simpl_type_expression c.param_type in
ok (type_name , type_expression) ok (type_name , type_expression)
and simpl_fun_declaration : Raw.fun_decl -> ((name * type_expression option) * expression) result = fun x -> and simpl_fun_declaration : loc:_ -> Raw.fun_decl -> ((name * type_expression option) * expression) result = fun ~loc x ->
let open! Raw in let open! Raw in
let {name;param;ret_type;local_decls;block;return} : fun_decl = x in let {name;param;ret_type;local_decls;block;return} : fun_decl = x in
(match npseq_to_list param.value.inside with (match npseq_to_list param.value.inside with
@ -338,12 +377,8 @@ and simpl_fun_declaration : Raw.fun_decl -> ((name * type_expression option) * e
let%bind result = let%bind result =
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in bind_fold_right_list aux result body in
let expression = E_lambda { let expression : expression = e_lambda ~loc binder (Some input_type)
binder = (binder , Some input_type) ; (Some output_type) result in
input_type = Some input_type ;
output_type = Some output_type ;
result
} in
let type_annotation = Some (T_function (input_type, output_type)) in let type_annotation = Some (T_function (input_type, output_type)) in
ok ((name , type_annotation) , expression) ok ((name , type_annotation) , expression)
) )
@ -355,7 +390,7 @@ and simpl_fun_declaration : Raw.fun_decl -> ((name * type_expression option) * e
(arguments_name , type_expression) in (arguments_name , type_expression) in
let%bind tpl_declarations = let%bind tpl_declarations =
let aux = fun i x -> let aux = fun i x ->
let expr = E_accessor (E_variable arguments_name , [ Access_tuple i ]) in let expr = e_accessor (e_variable arguments_name) [ Access_tuple i ] in
let type_ = Some (snd x) in let type_ = Some (snd x) in
let ass = return_let_in (fst x , type_) expr in let ass = return_let_in (fst x , type_) expr in
ass ass
@ -372,24 +407,20 @@ and simpl_fun_declaration : Raw.fun_decl -> ((name * type_expression option) * e
let%bind result = let%bind result =
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in bind_fold_right_list aux result body in
let expression = E_lambda { let expression = e_lambda ~loc binder (Some input_type) (Some output_type) result in
binder = (binder , Some input_type) ;
input_type = Some input_type ;
output_type = Some output_type ;
result
} in
let type_annotation = Some (T_function (input_type, output_type)) in let type_annotation = Some (T_function (input_type, output_type)) in
ok ((name.value , type_annotation) , expression) ok ((name.value , type_annotation) , expression)
) )
) )
and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fun t -> and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fun t ->
let open! Raw in let open! Raw in
let loc : 'a . 'a Raw.reg -> _ -> _ = fun x v -> Location.wrap ~loc:(File x.region) v in
match t with match t with
| TypeDecl x -> | TypeDecl x -> (
let {name;type_expr} : Raw.type_decl = x.value in let (x , loc) = r_split x in
let {name;type_expr} : Raw.type_decl = x in
let%bind type_expression = simpl_type_expression type_expr in let%bind type_expression = simpl_type_expression type_expr in
ok @@ loc x @@ Declaration_type (name.value , type_expression) ok @@ Location.wrap ~loc (Declaration_type (name.value , type_expression))
)
| ConstDecl x -> | ConstDecl x ->
let simpl_const_decl = fun {name;const_type;init} -> let simpl_const_decl = fun {name;const_type;init} ->
let%bind expression = simpl_expression init in let%bind expression = simpl_expression init in
@ -398,11 +429,11 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu
ok @@ Declaration_constant (name.value , type_annotation , expression) ok @@ Declaration_constant (name.value , type_annotation , expression)
in in
bind_map_location simpl_const_decl (Location.lift_region x) bind_map_location simpl_const_decl (Location.lift_region x)
| LambdaDecl (FunDecl x) -> | LambdaDecl (FunDecl x) -> (
let aux f x = let (x , loc) = r_split x in
let%bind ((name , ty_opt) , expr) = f x in let%bind ((name , ty_opt) , expr) = simpl_fun_declaration ~loc x in
ok @@ Declaration_constant (name , ty_opt , expr) in ok @@ Location.wrap ~loc (Declaration_constant (name , ty_opt , expr))
bind_map_location (aux simpl_fun_declaration) (Location.lift_region x) )
| LambdaDecl (ProcDecl _) -> simple_fail "no proc declaration yet" | LambdaDecl (ProcDecl _) -> simple_fail "no proc declaration yet"
| LambdaDecl (EntryDecl _)-> simple_fail "no entry point yet" | LambdaDecl (EntryDecl _)-> simple_fail "no entry point yet"
@ -418,7 +449,10 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
let%bind expr = simpl_expression e.value.fail_expr in let%bind expr = simpl_expression e.value.fail_expr in
return @@ e_failwith expr return @@ e_failwith expr
) )
| Skip _ -> return @@ e_skip | Skip reg -> (
let loc = Location.lift reg in
return @@ e_skip ~loc ()
)
| Loop (While l) -> | Loop (While l) ->
let l = l.value in let l = l.value in
let%bind cond = simpl_expression l.cond in let%bind cond = simpl_expression l.cond in
@ -427,8 +461,8 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
return @@ e_loop cond body return @@ e_loop cond body
| Loop (For _) -> | Loop (For _) ->
simple_fail "no for yet" simple_fail "no for yet"
| Cond c -> | Cond c -> (
let c = c.value in let (c , loc) = r_split c in
let%bind expr = simpl_expression c.test in let%bind expr = simpl_expression c.test in
let%bind match_true = match c.ifso with let%bind match_true = match c.ifso with
| ClauseInstr i -> simpl_instruction_block i | ClauseInstr i -> simpl_instruction_block i
@ -438,9 +472,10 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
| ClauseBlock b -> simpl_statements @@ fst b.value.inside in | ClauseBlock b -> simpl_statements @@ fst b.value.inside in
let%bind match_true = match_true None in let%bind match_true = match_true None in
let%bind match_false = match_false None in let%bind match_false = match_false None in
return @@ E_matching (expr, (Match_bool {match_true; match_false})) return @@ e_matching expr ~loc (Match_bool {match_true; match_false})
)
| Assign a -> ( | Assign a -> (
let a = a.value in let (a , loc) = r_split a in
let%bind value_expr = match a.rhs with let%bind value_expr = match a.rhs with
| Expr e -> simpl_expression e | Expr e -> simpl_expression e
| NoneExpr _ -> simple_fail "no none assignments yet" | NoneExpr _ -> simple_fail "no none assignments yet"
@ -448,7 +483,7 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
match a.lhs with match a.lhs with
| Path path -> ( | Path path -> (
let (name , path') = simpl_path path in let (name , path') = simpl_path path in
return @@ E_assign (name , path' , value_expr) return @@ e_assign ~loc name path' value_expr
) )
| MapPath v -> ( | MapPath v -> (
let v' = v.value in let v' = v.value in
@ -458,11 +493,11 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
let%bind key_expr = simpl_expression v'.index.value.inside in let%bind key_expr = simpl_expression v'.index.value.inside in
let old_expr = e_variable name.value in let old_expr = e_variable name.value in
let expr' = e_map_update key_expr value_expr old_expr in let expr' = e_map_update key_expr value_expr old_expr in
return @@ E_assign (name.value , [] , expr') return @@ e_assign ~loc name.value [] expr'
) )
) )
| CaseInstr c -> ( | CaseInstr c -> (
let c = c.value in let (c , loc) = r_split c in
let%bind expr = simpl_expression c.expr in let%bind expr = simpl_expression c.expr in
let%bind cases = let%bind cases =
let aux (x : Raw.instruction Raw.case_clause Raw.reg) = let aux (x : Raw.instruction Raw.case_clause Raw.reg) =
@ -473,25 +508,25 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
@@ List.map aux @@ List.map aux
@@ npseq_to_list c.cases.value in @@ npseq_to_list c.cases.value in
let%bind m = simpl_cases cases in let%bind m = simpl_cases cases in
return @@ E_matching (expr, m) return @@ e_matching ~loc expr m
) )
| RecordPatch r -> ( | RecordPatch r -> (
let r = r.value in let r = r.value in
let (name , access_path) = simpl_path r.path in let (name , access_path) = simpl_path r.path in
let%bind inj = bind_list let%bind inj = bind_list
@@ List.map (fun (x:Raw.field_assign) -> let%bind e = simpl_expression x.field_expr in ok (x.field_name.value, e)) @@ List.map (fun (x:Raw.field_assign Region.reg) ->
@@ List.map (fun (x:_ Raw.reg) -> x.value) let (x , loc) = r_split x in
let%bind e = simpl_expression x.field_expr in ok (x.field_name.value, e , loc)
)
@@ pseq_to_list r.record_inj.value.elements in @@ pseq_to_list r.record_inj.value.elements in
let%bind expr = let%bind expr =
let aux = fun (access , v) -> let aux = fun (access , v , loc) ->
E_assign (name , access_path @ [ Access_record access ] , v) in e_assign ~loc name (access_path @ [ Access_record access ]) v in
let assigns = List.map aux inj in let assigns = List.map aux inj in
match assigns with match assigns with
| [] -> simple_fail "empty record patch" | [] -> simple_fail "empty record patch"
| hd :: tl -> ( | hd :: tl -> (
let aux acc cur = let aux acc cur = e_sequence (acc) (cur) in
e_sequence (acc) (cur)
in
ok @@ List.fold_left aux hd tl ok @@ List.fold_left aux hd tl
) )
in in
@ -499,15 +534,16 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
) )
| MapPatch _ -> simple_fail "no map patch yet" | MapPatch _ -> simple_fail "no map patch yet"
| SetPatch _ -> simple_fail "no set patch yet" | SetPatch _ -> simple_fail "no set patch yet"
| MapRemove r -> | MapRemove r -> (
let v = r.value in let (v , loc) = r_split r in
let key = v.key in let key = v.key in
let%bind map = match v.map with let%bind map = match v.map with
| Name v -> ok v.value | Name v -> ok v.value
| _ -> simple_fail "no complex map remove yet" in | _ -> simple_fail "no complex map remove yet" in
let%bind key' = simpl_expression key in let%bind key' = simpl_expression key in
let expr = E_constant ("MAP_REMOVE", [key' ; e_variable map]) in let expr = e_constant ~loc "MAP_REMOVE" [key' ; e_variable map] in
return @@ E_assign (map , [] , expr) return @@ e_assign ~loc map [] expr
)
| SetRemove _ -> simple_fail "no set remove yet" | SetRemove _ -> simple_fail "no set remove yet"
and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p -> and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->

2
src/simplify/simplify.ml
View File

@ -1,3 +1,3 @@
module Pascaligo = Pascaligo module Pascaligo = Pascaligo
module Camligo = Camligo module Camligo = Camligo
(*module Ligodity = Ligodity*) module Ligodity = Ligodity

4
src/test/bin_tests.ml
View File

@ -1,10 +1,10 @@
open Trace open Trace
open Ligo open Ligo.Run
open Test_helpers open Test_helpers
let compile_contract_basic () : unit result = let compile_contract_basic () : unit result =
let%bind _ = let%bind _ =
Contract.compile_contract_file "./contracts/dispatch-counter.ligo" "main" compile_contract_file "./contracts/dispatch-counter.ligo" "main" "pascaligo"
in in
ok () ok ()

12
src/test/coase_tests.ml
View File

@ -1,9 +1,11 @@
(* Copyright Coase, Inc 2019 *) (* Copyright Coase, Inc 2019 *)
open Trace open Trace
open Ligo open Ligo.Run
open Test_helpers open Test_helpers
let type_file = type_file "pascaligo"
let get_program = let get_program =
let s = ref None in let s = ref None in
fun () -> match !s with fun () -> match !s with
@ -31,7 +33,7 @@ let card_ez owner = card (e_address owner)
let make_cards assoc_lst = let make_cards assoc_lst =
let card_id_ty = t_nat in let card_id_ty = t_nat in
e_map assoc_lst card_id_ty card_ty e_typed_map assoc_lst card_id_ty card_ty
let card_pattern (coeff , qtt) = let card_pattern (coeff , qtt) =
ez_e_record [ ez_e_record [
@ -51,7 +53,7 @@ let card_pattern_ez (coeff , qtt) =
let make_card_patterns lst = let make_card_patterns lst =
let card_pattern_id_ty = t_nat in let card_pattern_id_ty = t_nat in
let assoc_lst = List.mapi (fun i x -> (e_nat i , x)) lst in let assoc_lst = List.mapi (fun i x -> (e_nat i , x)) lst in
e_map assoc_lst card_pattern_id_ty card_pattern_ty e_typed_map assoc_lst card_pattern_id_ty card_pattern_ty
let storage cards_patterns cards next_id = let storage cards_patterns cards next_id =
ez_e_record [ ez_e_record [
@ -208,9 +210,9 @@ let sell () =
e_pair sell_action storage e_pair sell_action storage
in in
let make_expecter : int -> expression -> unit result = fun n result -> let make_expecter : int -> expression -> unit result = fun n result ->
let%bind (ops , storage) = get_e_pair result in let%bind (ops , storage) = get_e_pair @@ Location.unwrap result in
let%bind () = let%bind () =
let%bind lst = get_e_list ops in let%bind lst = get_e_list @@ Location.unwrap ops in
Assert.assert_list_size lst 1 in Assert.assert_list_size lst 1 in
let expected_storage = let expected_storage =
let cards = List.hds @@ cards_ez first_owner n in let cards = List.hds @@ cards_ez first_owner n in

30
src/test/heap_tests.ml
View File

@ -1,7 +1,9 @@
open Trace open Trace
open Ligo open Ligo.Run
open Test_helpers open Test_helpers
let type_file = type_file "pascaligo"
let get_program = let get_program =
let s = ref None in let s = ref None in
fun () -> match !s with fun () -> match !s with
@ -12,8 +14,8 @@ let get_program =
ok program ok program
) )
let a_heap_ez ?value_type (content:(int * AST_Typed.ae) list) = let a_heap_ez ?value_type (content:(int * Ast_typed.ae) list) =
let open AST_Typed.Combinators in let open Ast_typed.Combinators in
let content = let content =
let aux = fun (x, y) -> e_a_empty_nat x, y in let aux = fun (x, y) -> e_a_empty_nat x, y in
List.map aux content in List.map aux content in
@ -24,7 +26,7 @@ let a_heap_ez ?value_type (content:(int * AST_Typed.ae) list) =
e_a_empty_map content (t_nat ()) value_type e_a_empty_map content (t_nat ()) value_type
let ez lst = let ez lst =
let open AST_Typed.Combinators in let open Ast_typed.Combinators in
let value_type = t_pair let value_type = t_pair
(t_int ()) (t_int ())
(t_string ()) (t_string ())
@ -46,11 +48,11 @@ let dummy n =
let is_empty () : unit result = let is_empty () : unit result =
let%bind program = get_program () in let%bind program = get_program () in
let aux n = let aux n =
let open AST_Typed.Combinators in let open Ast_typed.Combinators in
let input = dummy n in let input = dummy n in
let%bind result = easy_run_typed "is_empty" program input in let%bind result = run_typed "is_empty" program input in
let expected = e_a_empty_bool (n = 0) in let expected = e_a_empty_bool (n = 0) in
AST_Typed.assert_value_eq (expected, result) Ast_typed.assert_value_eq (expected, result)
in in
let%bind _ = bind_list let%bind _ = bind_list
@@ List.map aux @@ List.map aux
@ -60,15 +62,15 @@ let is_empty () : unit result =
let get_top () : unit result = let get_top () : unit result =
let%bind program = get_program () in let%bind program = get_program () in
let aux n = let aux n =
let open AST_Typed.Combinators in let open Ast_typed.Combinators in
let input = dummy n in let input = dummy n in
match n, easy_run_typed "get_top" program input with match n, run_typed "get_top" program input with
| 0, Trace.Ok _ -> simple_fail "unexpected success" | 0, Trace.Ok _ -> simple_fail "unexpected success"
| 0, _ -> ok () | 0, _ -> ok ()
| _, result -> | _, result ->
let%bind result' = result in let%bind result' = result in
let expected = e_a_empty_pair (e_a_empty_int 1) (e_a_empty_string "1") in let expected = e_a_empty_pair (e_a_empty_int 1) (e_a_empty_string "1") in
AST_Typed.assert_value_eq (expected, result') Ast_typed.assert_value_eq (expected, result')
in in
let%bind _ = bind_list let%bind _ = bind_list
@@ List.map aux @@ List.map aux
@ -79,7 +81,7 @@ let pop_switch () : unit result =
let%bind program = get_program () in let%bind program = get_program () in
let aux n = let aux n =
let input = dummy n in let input = dummy n in
match n, easy_run_typed "pop_switch" program input with match n, run_typed "pop_switch" program input with
| 0, Trace.Ok _ -> simple_fail "unexpected success" | 0, Trace.Ok _ -> simple_fail "unexpected success"
| 0, _ -> ok () | 0, _ -> ok ()
| _, result -> | _, result ->
@ -89,7 +91,7 @@ let pop_switch () : unit result =
@@ tl @@ tl
@@ range (n + 1) @@ range (n + 1)
) in ) in
AST_Typed.assert_value_eq (expected, result') Ast_typed.assert_value_eq (expected, result')
in in
let%bind _ = bind_list let%bind _ = bind_list
@@ List.map aux @@ List.map aux
@ -100,9 +102,9 @@ let pop () : unit result =
let%bind program = get_program () in let%bind program = get_program () in
let aux n = let aux n =
let input = dummy n in let input = dummy n in
(match easy_run_typed "pop" program input with (match run_typed "pop" program input with
| Trace.Ok (output , _) -> ( | Trace.Ok (output , _) -> (
Format.printf "\nPop output on %d : %a\n" n AST_Typed.PP.annotated_expression output ; Format.printf "\nPop output on %d : %a\n" n Ast_typed.PP.annotated_expression output ;
) )
| Errors errs -> ( | Errors errs -> (
Format.printf "\nPop output on %d : error\n" n) ; Format.printf "\nPop output on %d : error\n" n) ;

29
src/test/integration_tests.ml
View File

@ -1,14 +1,15 @@
open Trace open Trace
open Ligo open Ligo.Run
open Test_helpers open Test_helpers
open Ast_simplified.Combinators open Ast_simplified.Combinators
let mtype_file path : Ast_typed.program result = let mtype_file ?debug_simplify ?debug_typed = type_file ?debug_simplify ?debug_typed "cameligo"
let%bind raw = Parser.Camligo.User.parse_file path in let type_file = type_file "pascaligo"
let%bind simpl = Simplify.Camligo.main raw in
let%bind typed = Ligo.Typer.type_program (Location.unwrap simpl) in let type_alias () : unit result =
ok typed let%bind program = type_file "./contracts/type-alias.ligo" in
expect_eq_evaluate program "foo" (e_int 23)
let function_ () : unit result = let function_ () : unit result =
let%bind program = type_file "./contracts/function.ligo" in let%bind program = type_file "./contracts/function.ligo" in
@ -148,6 +149,9 @@ let include_ () : unit result =
let record_ez_int names n = let record_ez_int names n =
ez_e_record @@ List.map (fun x -> x, e_int n) names ez_e_record @@ List.map (fun x -> x, e_int n) names
let tuple_ez_int names n =
e_tuple @@ List.map (fun _ -> e_int n) names
let multiple_parameters () : unit result = let multiple_parameters () : unit result =
let%bind program = type_file "./contracts/multiple-parameters.ligo" in let%bind program = type_file "./contracts/multiple-parameters.ligo" in
let aux ((name : string) , make_input , make_output) = let aux ((name : string) , make_input , make_output) =
@ -155,9 +159,9 @@ let multiple_parameters () : unit result =
expect_eq_n program name make_input make_output' expect_eq_n program name make_input make_output'
in in
let%bind _ = bind_list @@ List.map aux [ let%bind _ = bind_list @@ List.map aux [
("ab", record_ez_int ["a";"b"], fun n -> 2 * n) ; ("ab", tuple_ez_int ["a";"b"], fun n -> 2 * n) ;
("abcd", record_ez_int ["a";"b";"c";"d"], fun n -> 4 * n + 2) ; ("abcd", tuple_ez_int ["a";"b";"c";"d"], fun n -> 4 * n + 2) ;
("abcde", record_ez_int ["a";"b";"c";"d";"e"], fun n -> 2 * n + 3) ; ("abcde", tuple_ez_int ["a";"b";"c";"d";"e"], fun n -> 2 * n + 3) ;
] in ] in
ok () ok ()
@ -249,7 +253,7 @@ let map () : unit result =
let ez lst = let ez lst =
let open Ast_simplified.Combinators in let open Ast_simplified.Combinators in
let lst' = List.map (fun (x, y) -> e_int x, e_int y) lst in let lst' = List.map (fun (x, y) -> e_int x, e_int y) lst in
e_map lst' t_int t_int e_typed_map lst' t_int t_int
in in
let%bind () = let%bind () =
let make_input = fun n -> ez [(23, n) ; (42, 4)] in let make_input = fun n -> ez [(23, n) ; (42, 4)] in
@ -436,8 +440,8 @@ let dispatch_counter_contract () : unit result =
expect_eq_n program "main" make_input make_expected expect_eq_n program "main" make_input make_expected
let basic_mligo () : unit result = let basic_mligo () : unit result =
let%bind typed = mtype_file "./contracts/basic.mligo" in let%bind typed = mtype_file ~debug_simplify:true "./contracts/basic.mligo" in
let%bind result = Ligo.easy_evaluate_typed "foo" typed in let%bind result = evaluate_typed "foo" typed in
Ligo.AST_Typed.assert_value_eq (Ligo.AST_Typed.Combinators.e_a_empty_int (42 + 127), result) Ligo.AST_Typed.assert_value_eq (Ligo.AST_Typed.Combinators.e_a_empty_int (42 + 127), result)
let counter_mligo () : unit result = let counter_mligo () : unit result =
@ -453,6 +457,7 @@ let guess_the_hash_mligo () : unit result =
expect_eq_n program "main" make_input make_expected expect_eq_n program "main" make_input make_expected
let main = "Integration (End to End)", [ let main = "Integration (End to End)", [
test "type alias" type_alias ;
test "function" function_ ; test "function" function_ ;
test "assign" assign ; test "assign" assign ;
test "declaration local" declaration_local ; test "declaration local" declaration_local ;

6
src/test/test_helpers.ml
View File

@ -3,7 +3,7 @@ open! Trace
let test name f = let test name f =
Alcotest.test_case name `Quick @@ fun () -> Alcotest.test_case name `Quick @@ fun () ->
let result = let result =
trace (fun () -> error (thunk "running test") (fun () -> name) ()) @@ trace (fun () -> error (thunk "running test") (thunk name) ()) @@
f () in f () in
match result with match result with
| Ok ((), annotations) -> ignore annotations; () | Ok ((), annotations) -> ignore annotations; ()
@ -20,7 +20,7 @@ let expect ?options program entry_point input expecter =
let content () = Format.asprintf "Entry_point: %s" entry_point in let content () = Format.asprintf "Entry_point: %s" entry_point in
error title content in error title content in
trace run_error @@ trace run_error @@
Ligo.easy_run_typed_simplified ~debug_michelson:true ?options entry_point program input in Ligo.Run.run_simplityped ~debug_michelson:true ?options program entry_point input in
expecter result expecter result
let expect_eq ?options program entry_point input expected = let expect_eq ?options program entry_point input expected =
@ -41,7 +41,7 @@ let expect_evaluate program entry_point expecter =
let content () = Format.asprintf "Entry_point: %s" entry_point in let content () = Format.asprintf "Entry_point: %s" entry_point in
error title content in error title content in
trace error @@ trace error @@
let%bind result = Ligo.easy_evaluate_typed_simplified entry_point program in let%bind result = Ligo.Run.evaluate_simplityped program entry_point in
expecter result expecter result
let expect_eq_evaluate program entry_point expected = let expect_eq_evaluate program entry_point expected =

12
src/transpiler/transpiler.ml
View File

@ -469,7 +469,7 @@ let translate_main (l:AST.lambda) : anon_function result =
| E_literal (D_function f) -> ok f | E_literal (D_function f) -> ok f
| _ -> simple_fail "main is not a function" | _ -> simple_fail "main is not a function"
(* From a non-functional expression [expr], build the functional expression [fun () -> expr] *) (* From an expression [expr], build the expression [fun () -> expr] *)
let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value = let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value =
let t = e.type_annotation in let t = e.type_annotation in
let open! AST in let open! AST in
@ -511,16 +511,6 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result =
open Combinators open Combinators
let rec exp x n =
if n = 0
then 1
else
let exp' = exp (x * x) (n / 2) in
let m = if n mod 2 = 0 then 1 else x in
m * exp'
let exp2 = exp 2
let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result = let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result =
let open Append_tree in let open Append_tree in
let rec aux tv : (string * value * AST.type_value) result= let rec aux tv : (string * value * AST.type_value) result=

84
src/typer/typer.ml
View File

@ -29,7 +29,7 @@ module Errors = struct
let wrong_arity (n:string) (expected:int) (actual:int) () = let wrong_arity (n:string) (expected:int) (actual:int) () =
let title () = "wrong arity" in let title () = "wrong arity" in
let full () = let full () =
Format.asprintf "Wrong number of args passed to [%s]. Expected was %d, received was %d." Format.asprintf "Wrong number of args passed to [%s]. Expected was %d, received was %d"
n expected actual n expected actual
in in
error title full () error title full ()
@ -204,13 +204,20 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
match tv_opt with match tv_opt with
| None -> ok () | None -> ok ()
| Some tv' -> O.assert_type_value_eq (tv' , tv) in | Some tv' -> O.assert_type_value_eq (tv' , tv) in
ok @@ make_a_e expr tv e in let location = Location.get_location ae in
ok @@ make_a_e ~location expr tv e in
let main_error = let main_error =
let title () = "typing expression" in let title () = "typing expression" in
let content () = Format.asprintf "Expression: %a\nLog: %s\n" I.PP.expression ae (L.get()) in let content () =
match L.get () with
| "" ->
Format.asprintf "Expression: %a\n" I.PP.expression ae
| l ->
Format.asprintf "Expression: %a\nLog: %s\n" I.PP.expression ae l
in
error title content in error title content in
trace main_error @@ trace main_error @@
match ae with match Location.unwrap ae with
(* Basic *) (* Basic *)
| E_failwith _ -> simple_fail "can't type failwith in isolation" | E_failwith _ -> simple_fail "can't type failwith in isolation"
| E_variable name -> | E_variable name ->
@ -357,16 +364,31 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
} -> ( } -> (
let%bind input_type = let%bind input_type =
let%bind input_type = let%bind input_type =
trace_option (simple_error "no input type provided") @@ (* Hack to take care of let_in introduced by `simplify/ligodity.ml` in ECase's hack *)
input_type in let default_action () = simple_fail "no input type provided" in
match input_type with
| Some ty -> ok ty
| None -> (
match Location.unwrap result with
| I.E_let_in li -> (
match Location.unwrap li.rhs with
| I.E_variable name when name = (fst binder) -> (
match snd li.binder with
| Some ty -> ok ty
| None -> default_action ()
)
| _ -> default_action ()
)
| _ -> default_action ()
)
in
evaluate_type e input_type in evaluate_type e input_type in
let%bind output_type = let%bind output_type =
let%bind output_type = bind_map_option (evaluate_type e) output_type
trace_option (simple_error "no output type provided") @@ in
output_type in
evaluate_type e output_type in
let e' = Environment.add_ez_binder (fst binder) input_type e in let e' = Environment.add_ez_binder (fst binder) input_type e in
let%bind result = type_expression ~tv_opt:output_type e' result in let%bind result = type_expression ?tv_opt:output_type e' result in
let output_type = result.type_annotation in
return (E_lambda {binder = fst binder;input_type;output_type;result}) (t_function input_type output_type ()) return (E_lambda {binder = fst binder;input_type;output_type;result}) (t_function input_type output_type ())
) )
| E_constant (name, lst) -> | E_constant (name, lst) ->
@ -394,7 +416,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
let%bind ex' = type_expression e ex in let%bind ex' = type_expression e ex in
match m with match m with
(* Special case for assert-like failwiths. TODO: CLEAN THIS. *) (* Special case for assert-like failwiths. TODO: CLEAN THIS. *)
| I.Match_bool { match_false ; match_true = E_failwith fw } -> ( | I.Match_bool { match_false ; match_true } when I.is_e_failwith match_true -> (
let%bind fw = I.get_e_failwith match_true in
let%bind fw' = type_expression e fw in let%bind fw' = type_expression e fw in
let%bind mf' = type_expression e match_false in let%bind mf' = type_expression e match_false in
let%bind () = let%bind () =
@ -526,55 +549,54 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
match e.expression with match e.expression with
| E_literal l -> | E_literal l ->
let%bind l = untype_literal l in let%bind l = untype_literal l in
return (E_literal l) return (e_literal l)
| E_constant (n, lst) -> | E_constant (n, lst) ->
let%bind lst' = bind_list let%bind lst' = bind_map_list untype_expression lst in
@@ List.map untype_expression lst in return (e_constant n lst')
return (E_constant (n, lst'))
| E_variable n -> | E_variable n ->
return (E_variable n) return (e_variable n)
| E_application (f, arg) -> | E_application (f, arg) ->
let%bind f' = untype_expression f in let%bind f' = untype_expression f in
let%bind arg' = untype_expression arg in let%bind arg' = untype_expression arg in
return (E_application (f', arg')) return (e_application f' arg')
| E_lambda {binder;input_type;output_type;result} -> | E_lambda {binder;input_type;output_type;result} ->
let%bind input_type = untype_type_value input_type in let%bind input_type = untype_type_value input_type in
let%bind output_type = untype_type_value output_type in let%bind output_type = untype_type_value output_type in
let%bind result = untype_expression result in let%bind result = untype_expression result in
return (E_lambda {binder = (binder , Some input_type);input_type = Some input_type;output_type = Some output_type;result}) return (e_lambda binder (Some input_type) (Some output_type) result)
| E_tuple lst -> | E_tuple lst ->
let%bind lst' = bind_list let%bind lst' = bind_list
@@ List.map untype_expression lst in @@ List.map untype_expression lst in
return (E_tuple lst') return (e_tuple lst')
| E_tuple_accessor (tpl, ind) -> | E_tuple_accessor (tpl, ind) ->
let%bind tpl' = untype_expression tpl in let%bind tpl' = untype_expression tpl in
return (E_accessor (tpl', [Access_tuple ind])) return (e_accessor tpl' [Access_tuple ind])
| E_constructor (n, p) -> | E_constructor (n, p) ->
let%bind p' = untype_expression p in let%bind p' = untype_expression p in
return (E_constructor (n, p')) return (e_constructor n p')
| E_record r -> | E_record r ->
let%bind r' = bind_smap let%bind r' = bind_smap
@@ SMap.map untype_expression r in @@ SMap.map untype_expression r in
return (E_record r') return (e_record r')
| E_record_accessor (r, s) -> | E_record_accessor (r, s) ->
let%bind r' = untype_expression r in let%bind r' = untype_expression r in
return (E_accessor (r', [Access_record s])) return (e_accessor r' [Access_record s])
| E_map m -> | E_map m ->
let%bind m' = bind_map_list (bind_map_pair untype_expression) m in let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
return (E_map m') return (e_map m')
| E_list lst -> | E_list lst ->
let%bind lst' = bind_map_list untype_expression lst in let%bind lst' = bind_map_list untype_expression lst in
return (E_list lst') return (e_list lst')
| E_look_up dsi -> | E_look_up dsi ->
let%bind dsi' = bind_map_pair untype_expression dsi in let%bind (a , b) = bind_map_pair untype_expression dsi in
return (E_look_up dsi') return (e_look_up a b)
| E_matching (ae, m) -> | E_matching (ae, m) ->
let%bind ae' = untype_expression ae in let%bind ae' = untype_expression ae in
let%bind m' = untype_matching untype_expression m in let%bind m' = untype_matching untype_expression m in
return (E_matching (ae', m')) return (e_matching ae' m')
| E_failwith ae -> | E_failwith ae ->
let%bind ae' = untype_expression ae in let%bind ae' = untype_expression ae in
return (E_failwith ae') return (e_failwith ae')
| E_sequence _ | E_sequence _
| E_loop _ | E_loop _
| E_assign _ -> simple_fail "not possible to untranspile statements yet" | E_assign _ -> simple_fail "not possible to untranspile statements yet"
@ -582,7 +604,7 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
let%bind tv = untype_type_value rhs.type_annotation in let%bind tv = untype_type_value rhs.type_annotation in
let%bind rhs = untype_expression rhs in let%bind rhs = untype_expression rhs in
let%bind result = untype_expression result in let%bind result = untype_expression result in
return (E_let_in {binder = (binder , Some tv);rhs;result}) return (e_let_in (binder , (Some tv)) rhs result)
and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matching) result = fun f m -> and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matching) result = fun f m ->
let open I in let open I in

8
vendors/ligo-utils/simple-utils/location.ml vendored
View File

@ -22,16 +22,22 @@ let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t =
let virtual_location s = Virtual s let virtual_location s = Virtual s
let dummy = virtual_location "dummy" let dummy = virtual_location "dummy"
let generated = virtual_location "generated"
type 'a wrap = { type 'a wrap = {
wrap_content : 'a ; wrap_content : 'a ;
location : t ; location : t ;
} }
let wrap ~loc wrap_content = { wrap_content ; location = loc } let wrap ?(loc = generated) wrap_content = { wrap_content ; location = loc }
let get_location x = x.location
let unwrap { wrap_content ; _ } = wrap_content let unwrap { wrap_content ; _ } = wrap_content
let map f x = { x with wrap_content = f x.wrap_content } let map f x = { x with wrap_content = f x.wrap_content }
let pp_wrap f ppf { wrap_content ; _ } = Format.fprintf ppf "%a" f wrap_content let pp_wrap f ppf { wrap_content ; _ } = Format.fprintf ppf "%a" f wrap_content
let lift_region : 'a Region.reg -> 'a wrap = fun x -> let lift_region : 'a Region.reg -> 'a wrap = fun x ->
wrap ~loc:(File x.region) x.value wrap ~loc:(File x.region) x.value
let lift : Region.region -> t = fun x -> File x
let r_extract : 'a Region.reg -> t = fun x -> File x.region
let r_split : 'a Region.reg -> ('a * t) = fun x -> x.value , File x.region

27
vendors/ligo-utils/simple-utils/trace.ml vendored
View File

@ -131,10 +131,10 @@ let mk_error
let data' = let data' =
let aux (key , value) = (key , `String (value ())) in let aux (key , value) = (key , `String (value ())) in
X_option.map (fun x -> ("data" , `Assoc (List.map aux x))) data in X_option.map (fun x -> ("data" , `Assoc (List.map aux x))) data in
let message' = X_option.map (fun x -> ("message " , `String (x ()))) message in let message' = X_option.map (fun x -> ("message" , `String (x ()))) message in
`Assoc (X_option.collapse_list [ error_code' ; title' ; message' ; data' ]) `Assoc (X_option.collapse_list [ error_code' ; title' ; message' ; data' ])
let error title message () = mk_error ~title:(title) ~message:(message) () let error ?data ?error_code title message () = mk_error ?data ?error_code ~title:(title) ~message:(message) ()
(** (**
Helpers that ideally shouldn't be used in production. Helpers that ideally shouldn't be used in production.
@ -467,12 +467,27 @@ module Assert = struct
end end
let json_of_error = J.to_string let json_of_error = J.to_string
let error_pp out (e : error) = let error_pp out (e : error) =
let open JSON_string_utils in let open JSON_string_utils in
let message = e |> member "message" |> string || "(no message)" in let message =
let title = e |> member "title" |> string || "(no title)" in let opt = e |> member "message" |> string in
let error_code = e |> member "error_code" |> int |> string_of_int || "no error code" in X_option.unopt ~default:"" opt in
Format.fprintf out "%s (%s): %s" title error_code message let error_code =
let error_code = e |> member "error_code" in
match error_code with
| `Null -> ""
| _ -> " (" ^ (J.to_string error_code) ^ ")" in
let title =
let opt = e |> member "title" |> string in
X_option.unopt ~default:"" opt in
let data =
let data = e |> member "data" in
match data with
| `Null -> ""
| _ -> J.to_string data in
Format.fprintf out "%s (%s): %s. %s" title error_code message data
let error_pp_short out (e : error) = let error_pp_short out (e : error) =
let open JSON_string_utils in let open JSON_string_utils in

3
vendors/ligo-utils/simple-utils/x_option.ml vendored
View File

@ -27,8 +27,7 @@ let to_list = function
| None -> [] | None -> []
| Some x -> [ x ] | Some x -> [ x ]
let collapse_list = fun l -> let collapse_list = fun l ->
List.concat List.concat @@ List.map to_list l
@@ List.map to_list l
(* Combinators *) (* Combinators *)
let bind_eager_or = fun a b -> match (a , b) with let bind_eager_or = fun a b -> match (a , b) with