2019-12-10 22:00:21 +04:00
|
|
|
open Trace
|
2019-05-13 00:56:22 +04:00
|
|
|
open Ast_simplified
|
|
|
|
|
|
|
|
module Raw = Parser.Pascaligo.AST
|
|
|
|
module SMap = Map.String
|
2019-11-19 17:25:48 +04:00
|
|
|
module SSet = Set.Make (String)
|
2019-05-13 00:56:22 +04:00
|
|
|
|
|
|
|
open Combinators
|
|
|
|
|
|
|
|
let nseq_to_list (hd, tl) = hd :: tl
|
|
|
|
let npseq_to_list (hd, tl) = hd :: (List.map snd tl)
|
|
|
|
let pseq_to_list = function
|
|
|
|
| None -> []
|
|
|
|
| Some lst -> npseq_to_list lst
|
|
|
|
let get_value : 'a Raw.reg -> 'a = fun x -> x.value
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
let is_compiler_generated name = String.contains (Var.to_name name) '#'
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-11-19 17:25:48 +04:00
|
|
|
let detect_local_declarations (for_body : expression) =
|
|
|
|
let%bind aux = Self_ast_simplified.fold_expression
|
2019-12-04 15:40:58 +04:00
|
|
|
(fun (nlist, cur_loop : expression_variable list * bool) (ass_exp : expression) ->
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
if cur_loop then
|
2019-11-19 17:25:48 +04:00
|
|
|
match ass_exp.expression with
|
|
|
|
| E_let_in {binder;rhs = _;result = _} ->
|
|
|
|
let (name,_) = binder in
|
|
|
|
ok (name::nlist, cur_loop)
|
2019-12-04 15:40:58 +04:00
|
|
|
| E_constant (C_MAP_FOLD, _)
|
|
|
|
| E_constant (C_SET_FOLD, _)
|
|
|
|
| E_constant (C_LIST_FOLD, _) -> ok @@ (nlist, false)
|
2019-11-19 17:25:48 +04:00
|
|
|
| _ -> ok (nlist, cur_loop)
|
|
|
|
else
|
|
|
|
ok @@ (nlist, cur_loop)
|
|
|
|
)
|
|
|
|
([], true)
|
|
|
|
for_body in
|
|
|
|
ok @@ fst aux
|
|
|
|
|
2019-12-04 15:40:58 +04:00
|
|
|
let detect_free_variables (for_body : expression) (local_decl_names : expression_variable list) =
|
2019-11-19 17:25:48 +04:00
|
|
|
let%bind captured_names = Self_ast_simplified.fold_expression
|
2019-12-04 15:40:58 +04:00
|
|
|
(fun (prev : expression_variable list) (ass_exp : expression) ->
|
2019-11-19 17:25:48 +04:00
|
|
|
match ass_exp.expression with
|
|
|
|
| E_assign ( name , _ , _ ) ->
|
|
|
|
if is_compiler_generated name then ok prev
|
|
|
|
else ok (name::prev)
|
2019-11-21 04:32:43 +04:00
|
|
|
| E_constant (n, [a;b])
|
2019-12-04 15:40:58 +04:00
|
|
|
when n=C_OR || n=C_AND || n=C_LT || n=C_GT ||
|
|
|
|
n=C_LE || n=C_GE || n=C_EQ || n=C_NEQ -> (
|
2019-11-21 04:32:43 +04:00
|
|
|
match (a.expression,b.expression) with
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
| E_variable na , E_variable nb ->
|
2019-11-21 04:32:43 +04:00
|
|
|
let ret = [] in
|
|
|
|
let ret = if not (is_compiler_generated na) then
|
|
|
|
na::ret else ret in
|
|
|
|
let ret = if not (is_compiler_generated nb) then
|
|
|
|
nb::ret else ret in
|
|
|
|
ok (ret@prev)
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
| E_variable n , _
|
2019-11-21 04:32:43 +04:00
|
|
|
| _ , E_variable n ->
|
|
|
|
if not (is_compiler_generated n) then
|
|
|
|
ok (n::prev) else ok prev
|
|
|
|
| _ -> ok prev)
|
2019-11-19 17:25:48 +04:00
|
|
|
| _ -> ok prev )
|
|
|
|
[]
|
|
|
|
for_body in
|
2019-12-04 15:40:58 +04:00
|
|
|
let captured_names = List.map (fun (s) -> Var.to_name s) captured_names in
|
|
|
|
let local_decl_names = List.map (fun (s) -> Var.to_name s) local_decl_names in
|
2019-11-19 17:25:48 +04:00
|
|
|
ok @@ SSet.elements
|
|
|
|
@@ SSet.diff (SSet.of_list captured_names) (SSet.of_list local_decl_names)
|
|
|
|
|
2019-06-04 18:12:17 +04:00
|
|
|
module Errors = struct
|
2019-06-13 18:57:40 +04:00
|
|
|
let unsupported_cst_constr p =
|
|
|
|
let title () = "constant constructor" in
|
|
|
|
let message () =
|
|
|
|
Format.asprintf "constant constructors are not supported yet" in
|
|
|
|
let pattern_loc = Raw.pattern_to_region p in
|
|
|
|
let data = [
|
2019-12-31 01:24:42 +04:00
|
|
|
("location",
|
2019-06-13 18:57:40 +04:00
|
|
|
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
|
|
|
|
] in
|
|
|
|
error ~data title message
|
|
|
|
|
2019-06-04 18:12:17 +04:00
|
|
|
let corner_case ~loc message =
|
|
|
|
let title () = "corner case" in
|
|
|
|
let content () = "We don't have a good error message for this case. \
|
|
|
|
We are striving find ways to better report them and \
|
|
|
|
find the use-cases that generate them. \
|
|
|
|
Please report this to the developers." in
|
|
|
|
let data = [
|
|
|
|
("location" , fun () -> loc) ;
|
|
|
|
("message" , fun () -> message) ;
|
|
|
|
] in
|
|
|
|
error ~data title content
|
|
|
|
|
|
|
|
let unknown_predefined_type name =
|
|
|
|
let title () = "type constants" in
|
|
|
|
let message () =
|
|
|
|
Format.asprintf "unknown predefined type \"%s\"" name.Region.value in
|
|
|
|
let data = [
|
2019-12-31 01:24:42 +04:00
|
|
|
("location",
|
2019-06-04 18:12:17 +04:00
|
|
|
fun () -> Format.asprintf "%a" Location.pp_lift @@ name.Region.region)
|
|
|
|
] in
|
|
|
|
error ~data title message
|
|
|
|
|
2019-06-05 19:51:06 +04:00
|
|
|
let unsupported_non_var_pattern p =
|
|
|
|
let title () = "pattern is not a variable" in
|
|
|
|
let message () =
|
|
|
|
Format.asprintf "non-variable patterns in constructors \
|
|
|
|
are not supported yet" in
|
|
|
|
let pattern_loc = Raw.pattern_to_region p in
|
|
|
|
let data = [
|
2019-12-31 01:24:42 +04:00
|
|
|
("location",
|
2019-06-05 19:51:06 +04:00
|
|
|
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
|
|
|
|
] in
|
|
|
|
error ~data title message
|
|
|
|
|
|
|
|
let only_constructors p =
|
|
|
|
let title () = "constructors in patterns" in
|
|
|
|
let message () =
|
|
|
|
Format.asprintf "currently, only constructors are supported in patterns" in
|
|
|
|
let pattern_loc = Raw.pattern_to_region p in
|
|
|
|
let data = [
|
2019-12-31 01:24:42 +04:00
|
|
|
("location",
|
2019-06-05 19:51:06 +04:00
|
|
|
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
|
|
|
|
] in
|
|
|
|
error ~data title message
|
|
|
|
|
|
|
|
let unsupported_tuple_pattern p =
|
|
|
|
let title () = "tuple pattern" in
|
|
|
|
let message () =
|
|
|
|
Format.asprintf "tuple patterns are not supported yet" in
|
|
|
|
let pattern_loc = Raw.pattern_to_region p in
|
|
|
|
let data = [
|
2019-12-31 01:24:42 +04:00
|
|
|
("location",
|
2019-09-21 13:30:41 +04:00
|
|
|
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) ;
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
(** TODO: The labelled arguments should be flowing from the CLI. *)
|
2019-09-21 13:30:41 +04:00
|
|
|
("pattern",
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
fun () -> Parser.Pascaligo.ParserLog.pattern_to_string
|
|
|
|
~offsets:true ~mode:`Point p)
|
2019-06-05 19:51:06 +04:00
|
|
|
] in
|
|
|
|
error ~data title message
|
|
|
|
|
|
|
|
let unsupported_deep_Some_patterns pattern =
|
|
|
|
let title () = "option patterns" in
|
|
|
|
let message () =
|
|
|
|
Format.asprintf "currently, only variables in Some constructors \
|
|
|
|
in patterns are supported" in
|
|
|
|
let pattern_loc = Raw.pattern_to_region pattern in
|
|
|
|
let data = [
|
2019-12-31 01:24:42 +04:00
|
|
|
("location",
|
2019-06-05 19:51:06 +04:00
|
|
|
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)
|
|
|
|
] in
|
|
|
|
error ~data title message
|
|
|
|
|
|
|
|
let unsupported_deep_list_patterns cons =
|
|
|
|
let title () = "lists in patterns" in
|
|
|
|
let message () =
|
|
|
|
Format.asprintf "currently, only empty lists and x::y \
|
|
|
|
are supported in patterns" in
|
|
|
|
let data = [
|
2019-12-31 01:24:42 +04:00
|
|
|
("location",
|
2019-06-05 19:51:06 +04:00
|
|
|
fun () -> Format.asprintf "%a" Location.pp_lift @@ cons.Region.region)
|
|
|
|
] in
|
|
|
|
error ~data title message
|
|
|
|
|
|
|
|
(* Logging *)
|
|
|
|
|
|
|
|
let simplifying_instruction t =
|
|
|
|
let title () = "simplifiying instruction" in
|
|
|
|
let message () = "" in
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
(** TODO: The labelled arguments should be flowing from the CLI. *)
|
2019-06-05 19:51:06 +04:00
|
|
|
let data = [
|
|
|
|
("instruction",
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
fun () -> Parser.Pascaligo.ParserLog.instruction_to_string
|
|
|
|
~offsets:true ~mode:`Point t)
|
2019-06-05 19:51:06 +04:00
|
|
|
] in
|
|
|
|
error ~data title message
|
2019-06-04 18:12:17 +04:00
|
|
|
end
|
|
|
|
|
|
|
|
open Errors
|
2019-05-23 16:16:12 +04:00
|
|
|
open Operators.Simplify.Pascaligo
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-05-28 19:36:14 +04:00
|
|
|
let r_split = Location.r_split
|
|
|
|
|
2020-01-09 20:26:07 +04:00
|
|
|
(* Statements can't be simplified in isolation. [a ; b ; c] can get
|
|
|
|
simplified either as [let x = expr in (b ; c)] if [a] is a [const x
|
|
|
|
= expr] declaration or as [sequence(a, sequence(b, c))] for
|
|
|
|
everything else. Because of this, simplifying sequences depend on
|
|
|
|
their contents. To avoid peeking in their contents, we instead
|
|
|
|
simplify sequences elements as functions from their next elements
|
|
|
|
to the actual result.
|
|
|
|
|
|
|
|
For [return_let_in], if there is no follow-up element, an error is
|
|
|
|
triggered, as you can't have [let x = expr in ...] with no [...]. A
|
|
|
|
cleaner option might be to add a [unit] instead of failing.
|
2019-09-10 14:42:49 +04:00
|
|
|
|
2020-01-09 20:26:07 +04:00
|
|
|
[return_statement] is used for non-let-in statements.
|
|
|
|
*)
|
2019-09-10 14:42:49 +04:00
|
|
|
|
2019-05-28 19:36:14 +04:00
|
|
|
let return_let_in ?loc binder rhs = ok @@ fun expr'_opt ->
|
2019-05-22 04:46:54 +04:00
|
|
|
match expr'_opt with
|
2019-06-04 18:12:17 +04:00
|
|
|
| None -> fail @@ corner_case ~loc:__LOC__ "missing return"
|
2019-05-28 19:36:14 +04:00
|
|
|
| Some expr' -> ok @@ e_let_in ?loc binder rhs expr'
|
2019-05-22 04:46:54 +04:00
|
|
|
|
2019-09-10 14:42:49 +04:00
|
|
|
let return_statement expr = ok @@ fun expr'_opt ->
|
|
|
|
match expr'_opt with
|
|
|
|
| None -> ok @@ expr
|
|
|
|
| Some expr' -> ok @@ e_sequence expr expr'
|
|
|
|
|
2019-05-13 00:56:22 +04:00
|
|
|
let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
|
|
|
|
match t with
|
2019-11-06 20:23:49 +04:00
|
|
|
TPar x -> simpl_type_expression x.value.inside
|
|
|
|
| TVar v -> (
|
2019-12-04 15:40:58 +04:00
|
|
|
match type_constants v.value with
|
|
|
|
| Ok (s,_) -> ok @@ make_t @@ T_constant s
|
|
|
|
| Error _ -> ok @@ make_t @@ T_variable (Var.of_name v.value)
|
2019-05-13 00:56:22 +04:00
|
|
|
)
|
|
|
|
| TFun x -> (
|
|
|
|
let%bind (a , b) =
|
|
|
|
let (a , _ , b) = x.value in
|
|
|
|
bind_map_pair simpl_type_expression (a , b) in
|
2019-12-04 15:40:58 +04:00
|
|
|
ok @@ make_t @@ T_arrow (a , b)
|
2019-05-13 00:56:22 +04:00
|
|
|
)
|
|
|
|
| TApp x ->
|
|
|
|
let (name, tuple) = x.value in
|
|
|
|
let lst = npseq_to_list tuple.value.inside in
|
2020-01-09 20:26:07 +04:00
|
|
|
let%bind lst =
|
|
|
|
bind_list @@ List.map simpl_type_expression lst in (** TODO: fix constant and operator*)
|
2019-05-23 16:16:12 +04:00
|
|
|
let%bind cst =
|
2019-12-04 15:40:58 +04:00
|
|
|
trace (unknown_predefined_type name) @@
|
|
|
|
type_operators name.value in
|
2019-12-24 15:20:39 +04:00
|
|
|
t_operator cst lst
|
2019-05-13 00:56:22 +04:00
|
|
|
| TProd p ->
|
|
|
|
let%bind tpl = simpl_list_type_expression
|
2019-09-10 14:42:49 +04:00
|
|
|
@@ npseq_to_list p.value in
|
2019-05-13 00:56:22 +04:00
|
|
|
ok tpl
|
|
|
|
| TRecord r ->
|
2019-09-10 14:42:49 +04:00
|
|
|
let aux = fun (x, y) ->
|
|
|
|
let%bind y = simpl_type_expression y in
|
|
|
|
ok (x, y)
|
|
|
|
in
|
2019-06-04 18:12:17 +04:00
|
|
|
let apply =
|
|
|
|
fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type) in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind lst = bind_list
|
|
|
|
@@ List.map aux
|
2019-06-04 18:12:17 +04:00
|
|
|
@@ List.map apply
|
2019-10-23 02:35:29 +04:00
|
|
|
@@ npseq_to_list r.value.ne_elements in
|
2019-12-04 15:40:58 +04:00
|
|
|
let m = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
|
|
|
|
ok @@ make_t @@ T_record m
|
2019-05-13 00:56:22 +04:00
|
|
|
| TSum s ->
|
|
|
|
let aux (v:Raw.variant Raw.reg) =
|
2019-05-17 18:29:22 +04:00
|
|
|
let args =
|
2019-11-06 20:23:49 +04:00
|
|
|
match v.value.arg with
|
2019-05-17 18:29:22 +04:00
|
|
|
None -> []
|
2019-11-06 20:23:49 +04:00
|
|
|
| Some (_, TProd product) -> npseq_to_list product.value
|
|
|
|
| Some (_, t_expr) -> [t_expr] in
|
2019-10-15 23:03:46 +04:00
|
|
|
let%bind te = simpl_list_type_expression @@ args in
|
2019-05-13 00:56:22 +04:00
|
|
|
ok (v.value.constr.value, te)
|
|
|
|
in
|
|
|
|
let%bind lst = bind_list
|
|
|
|
@@ List.map aux
|
|
|
|
@@ npseq_to_list s.value in
|
2019-12-04 15:40:58 +04:00
|
|
|
let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
|
|
|
|
ok @@ make_t @@ T_sum m
|
2019-05-13 00:56:22 +04:00
|
|
|
|
|
|
|
and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result =
|
|
|
|
match lst with
|
2019-06-07 00:49:36 +04:00
|
|
|
| [] -> ok @@ t_unit
|
2019-05-13 00:56:22 +04:00
|
|
|
| [hd] -> simpl_type_expression hd
|
|
|
|
| lst ->
|
|
|
|
let%bind lst = bind_list @@ List.map simpl_type_expression lst in
|
2019-12-04 15:40:58 +04:00
|
|
|
ok @@ make_t @@ T_tuple lst
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-09-10 14:42:49 +04:00
|
|
|
let simpl_projection : Raw.projection Region.reg -> _ = fun p ->
|
|
|
|
let (p' , loc) = r_split p in
|
|
|
|
let var =
|
2019-12-04 15:40:58 +04:00
|
|
|
let name = Var.of_name p'.struct_name.value in
|
2019-09-10 14:42:49 +04:00
|
|
|
e_variable name in
|
|
|
|
let path = p'.field_path in
|
|
|
|
let path' =
|
|
|
|
let aux (s:Raw.selection) =
|
|
|
|
match s with
|
|
|
|
| FieldName property -> Access_record property.value
|
|
|
|
| Component index -> Access_tuple (Z.to_int (snd index.value))
|
|
|
|
in
|
|
|
|
List.map aux @@ npseq_to_list path in
|
|
|
|
ok @@ e_accessor ~loc var path'
|
|
|
|
|
|
|
|
|
2019-05-23 10:22:58 +04:00
|
|
|
let rec simpl_expression (t:Raw.expr) : expr result =
|
|
|
|
let return x = ok x in
|
2019-05-13 00:56:22 +04:00
|
|
|
match t with
|
|
|
|
| EAnnot a -> (
|
2019-05-28 19:36:14 +04:00
|
|
|
let ((expr , type_expr) , loc) = r_split a in
|
2019-05-23 10:22:58 +04:00
|
|
|
let%bind expr' = simpl_expression expr in
|
|
|
|
let%bind type_expr' = simpl_type_expression type_expr in
|
2019-05-28 19:36:14 +04:00
|
|
|
return @@ e_annotation ~loc expr' type_expr'
|
2019-05-13 00:56:22 +04:00
|
|
|
)
|
|
|
|
| EVar c -> (
|
2019-05-28 19:36:14 +04:00
|
|
|
let (c' , loc) = r_split c in
|
2019-12-04 15:40:58 +04:00
|
|
|
match constants c' with
|
|
|
|
| Error _ -> return @@ e_variable ~loc (Var.of_name c.value)
|
|
|
|
| Ok (s,_) -> return @@ e_constant ~loc s []
|
2019-05-13 00:56:22 +04:00
|
|
|
)
|
|
|
|
| ECall x -> (
|
2019-11-14 23:12:41 +04:00
|
|
|
let ((f, args) , loc) = r_split x in
|
2019-05-28 19:36:14 +04:00
|
|
|
let (args , args_loc) = r_split args in
|
|
|
|
let args' = npseq_to_list args.inside in
|
2019-11-14 23:12:41 +04:00
|
|
|
match f with
|
|
|
|
| EVar name -> (
|
|
|
|
let (f_name , f_loc) = r_split name in
|
2019-12-04 15:40:58 +04:00
|
|
|
match constants f_name with
|
|
|
|
| Error _ ->
|
2019-11-14 23:12:41 +04:00
|
|
|
let%bind arg = simpl_tuple_expression ~loc:args_loc args' in
|
2019-12-04 15:40:58 +04:00
|
|
|
return @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg
|
|
|
|
| Ok (s,_) ->
|
2019-11-14 23:12:41 +04:00
|
|
|
let%bind lst = bind_map_list simpl_expression args' in
|
|
|
|
return @@ e_constant ~loc s lst
|
|
|
|
)
|
|
|
|
| f -> (
|
|
|
|
let%bind f' = simpl_expression f in
|
|
|
|
let%bind arg = simpl_tuple_expression ~loc:args_loc args' in
|
|
|
|
return @@ e_application ~loc f' arg
|
|
|
|
)
|
2019-05-13 00:56:22 +04:00
|
|
|
)
|
2019-05-23 10:22:58 +04:00
|
|
|
| EPar x -> simpl_expression x.value.inside
|
2019-05-28 19:36:14 +04:00
|
|
|
| EUnit reg ->
|
|
|
|
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'))
|
2019-05-13 00:56:22 +04:00
|
|
|
| ETuple tpl ->
|
2019-10-15 23:03:46 +04:00
|
|
|
let (tpl' , loc) = r_split tpl in
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_tuple_expression ~loc @@ npseq_to_list tpl'.inside
|
2019-05-13 00:56:22 +04:00
|
|
|
| ERecord r ->
|
|
|
|
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 (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
|
2019-11-06 20:23:49 +04:00
|
|
|
@@ npseq_to_list r.value.ne_elements in
|
2019-05-13 00:56:22 +04:00
|
|
|
let aux prev (k, v) = SMap.add k v prev in
|
2019-05-28 19:36:14 +04:00
|
|
|
return @@ e_record (List.fold_left aux SMap.empty fields)
|
|
|
|
| EProj p -> simpl_projection p
|
|
|
|
| EConstr (ConstrApp c) -> (
|
|
|
|
let ((c, args) , loc) = r_split c in
|
2019-06-11 19:10:27 +04:00
|
|
|
match args with
|
|
|
|
None -> simpl_tuple_expression []
|
|
|
|
| Some args ->
|
|
|
|
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
|
2019-05-28 19:36:14 +04:00
|
|
|
)
|
2019-05-13 00:56:22 +04:00
|
|
|
| EConstr (SomeApp a) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
let ((_, args) , loc) = r_split a in
|
|
|
|
let (args , args_loc) = r_split args in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind arg =
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_tuple_expression ~loc:args_loc
|
|
|
|
@@ npseq_to_list args.inside in
|
2019-12-04 15:40:58 +04:00
|
|
|
return @@ e_constant ~loc C_SOME [arg]
|
2019-05-28 19:36:14 +04:00
|
|
|
| EConstr (NoneExpr reg) -> (
|
|
|
|
let loc = Location.lift reg in
|
|
|
|
return @@ e_none ~loc ()
|
|
|
|
)
|
2019-05-13 00:56:22 +04:00
|
|
|
| EArith (Add c) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "ADD" c
|
2019-05-13 00:56:22 +04:00
|
|
|
| EArith (Sub c) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "SUB" c
|
2019-05-13 00:56:22 +04:00
|
|
|
| EArith (Mult c) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "TIMES" c
|
2019-05-13 00:56:22 +04:00
|
|
|
| EArith (Div c) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "DIV" c
|
2019-05-13 00:56:22 +04:00
|
|
|
| EArith (Mod c) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "MOD" c
|
|
|
|
| EArith (Int n) -> (
|
|
|
|
let (n , loc) = r_split n in
|
|
|
|
let n = Z.to_int @@ snd n in
|
|
|
|
return @@ e_literal ~loc (Literal_int n)
|
|
|
|
)
|
|
|
|
| EArith (Nat n) -> (
|
|
|
|
let (n , loc) = r_split n in
|
|
|
|
let n = Z.to_int @@ snd @@ n in
|
|
|
|
return @@ e_literal ~loc (Literal_nat n)
|
|
|
|
)
|
2019-10-27 20:50:24 +04:00
|
|
|
| EArith (Mutez n) -> (
|
2019-07-19 14:13:09 +04:00
|
|
|
let (n , loc) = r_split n in
|
|
|
|
let n = Z.to_int @@ snd @@ n in
|
2019-09-24 16:29:18 +04:00
|
|
|
return @@ e_literal ~loc (Literal_mutez n)
|
2019-07-19 14:13:09 +04:00
|
|
|
)
|
|
|
|
| EArith (Neg e) -> simpl_unop "NEG" e
|
2019-05-13 00:56:22 +04:00
|
|
|
| EString (String s) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
let (s , loc) = r_split s in
|
2019-05-13 00:56:22 +04:00
|
|
|
let s' =
|
2019-05-28 19:36:14 +04:00
|
|
|
(* S contains quotes *)
|
2019-06-04 18:12:17 +04:00
|
|
|
String.(sub s 1 (length s - 2))
|
2019-05-13 00:56:22 +04:00
|
|
|
in
|
2019-05-28 19:36:14 +04:00
|
|
|
return @@ e_literal ~loc (Literal_string s')
|
2019-10-07 19:16:03 +04:00
|
|
|
| EString (Cat bo) ->
|
|
|
|
let (bo , loc) = r_split bo in
|
|
|
|
let%bind sl = simpl_expression bo.arg1 in
|
|
|
|
let%bind sr = simpl_expression bo.arg2 in
|
|
|
|
return @@ e_string_cat ~loc sl sr
|
2019-05-23 10:22:58 +04:00
|
|
|
| ELogic l -> simpl_logic_expression l
|
|
|
|
| EList l -> simpl_list_expression l
|
2019-07-19 16:35:47 +04:00
|
|
|
| ESet s -> simpl_set_expression s
|
2019-10-18 16:47:04 +04:00
|
|
|
| ECond c ->
|
2019-10-18 16:32:58 +04:00
|
|
|
let (c , loc) = r_split c in
|
|
|
|
let%bind expr = simpl_expression c.test in
|
|
|
|
let%bind match_true = simpl_expression c.ifso in
|
|
|
|
let%bind match_false = simpl_expression c.ifnot in
|
2019-10-18 16:47:04 +04:00
|
|
|
return @@ e_matching expr ~loc (Match_bool {match_true; match_false})
|
2019-05-28 19:36:14 +04:00
|
|
|
| ECase c -> (
|
|
|
|
let (c , loc) = r_split c in
|
|
|
|
let%bind e = simpl_expression c.expr in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind lst =
|
|
|
|
let aux (x : Raw.expr Raw.case_clause) =
|
|
|
|
let%bind expr = simpl_expression x.rhs in
|
|
|
|
ok (x.pattern, expr) in
|
|
|
|
bind_list
|
|
|
|
@@ List.map aux
|
|
|
|
@@ List.map get_value
|
2019-05-28 19:36:14 +04:00
|
|
|
@@ npseq_to_list c.cases.value in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind cases = simpl_cases lst in
|
2019-05-28 19:36:14 +04:00
|
|
|
return @@ e_matching ~loc e cases
|
|
|
|
)
|
2019-10-21 15:04:28 +04:00
|
|
|
| EMap (MapInj mi) -> (
|
2019-05-28 19:36:14 +04:00
|
|
|
let (mi , loc) = r_split mi in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind lst =
|
2019-05-28 19:36:14 +04:00
|
|
|
let lst = List.map get_value @@ pseq_to_list mi.elements in
|
2019-06-04 18:12:17 +04:00
|
|
|
let aux : Raw.binding -> (expression * expression) result =
|
|
|
|
fun b ->
|
|
|
|
let%bind src = simpl_expression b.source in
|
|
|
|
let%bind dst = simpl_expression b.image in
|
|
|
|
ok (src, dst) in
|
2019-05-13 00:56:22 +04:00
|
|
|
bind_map_list aux lst in
|
2019-05-28 19:36:14 +04:00
|
|
|
return @@ e_map ~loc lst
|
|
|
|
)
|
2019-10-21 15:04:28 +04:00
|
|
|
| EMap (BigMapInj mi) -> (
|
|
|
|
let (mi , loc) = r_split mi in
|
|
|
|
let%bind lst =
|
|
|
|
let lst = List.map get_value @@ pseq_to_list mi.elements in
|
|
|
|
let aux : Raw.binding -> (expression * expression) result =
|
|
|
|
fun b ->
|
|
|
|
let%bind src = simpl_expression b.source in
|
|
|
|
let%bind dst = simpl_expression b.image in
|
|
|
|
ok (src, dst) in
|
|
|
|
bind_map_list aux lst in
|
|
|
|
return @@ e_big_map ~loc lst
|
|
|
|
)
|
2019-05-28 19:36:14 +04:00
|
|
|
| EMap (MapLookUp lu) -> (
|
|
|
|
let (lu , loc) = r_split lu in
|
|
|
|
let%bind path = match lu.path with
|
|
|
|
| Name v -> (
|
|
|
|
let (v , loc) = r_split v in
|
2019-12-04 15:40:58 +04:00
|
|
|
return @@ e_variable ~loc (Var.of_name v)
|
2019-05-28 19:36:14 +04:00
|
|
|
)
|
|
|
|
| Path p -> simpl_projection p
|
2019-05-13 00:56:22 +04:00
|
|
|
in
|
2019-05-28 19:36:14 +04:00
|
|
|
let%bind index = simpl_expression lu.index.value.inside in
|
|
|
|
return @@ e_look_up ~loc path index
|
|
|
|
)
|
2020-01-09 20:26:07 +04:00
|
|
|
| EFun f ->
|
2019-11-18 19:10:48 +04:00
|
|
|
let (f , loc) = r_split f in
|
2020-01-09 20:26:07 +04:00
|
|
|
let%bind (_ty_opt, f') = simpl_fun_expression ~loc f
|
|
|
|
in return @@ f'
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-05-23 10:22:58 +04:00
|
|
|
and simpl_logic_expression (t:Raw.logic_expr) : expression result =
|
|
|
|
let return x = ok x in
|
2019-05-13 00:56:22 +04:00
|
|
|
match t with
|
2019-05-28 19:36:14 +04:00
|
|
|
| BoolExpr (False reg) -> (
|
|
|
|
let loc = Location.lift reg in
|
|
|
|
return @@ e_literal ~loc (Literal_bool false)
|
|
|
|
)
|
|
|
|
| BoolExpr (True reg) -> (
|
|
|
|
let loc = Location.lift reg in
|
|
|
|
return @@ e_literal ~loc (Literal_bool true)
|
|
|
|
)
|
2019-05-13 00:56:22 +04:00
|
|
|
| BoolExpr (Or b) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "OR" b
|
2019-05-13 00:56:22 +04:00
|
|
|
| BoolExpr (And b) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "AND" b
|
2019-05-13 00:56:22 +04:00
|
|
|
| BoolExpr (Not b) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_unop "NOT" b
|
2019-05-13 00:56:22 +04:00
|
|
|
| CompExpr (Lt c) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "LT" c
|
2019-05-13 00:56:22 +04:00
|
|
|
| CompExpr (Gt c) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "GT" c
|
2019-05-13 00:56:22 +04:00
|
|
|
| CompExpr (Leq c) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "LE" c
|
2019-05-13 00:56:22 +04:00
|
|
|
| CompExpr (Geq c) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "GE" c
|
2019-05-13 00:56:22 +04:00
|
|
|
| CompExpr (Equal c) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "EQ" c
|
2019-05-13 00:56:22 +04:00
|
|
|
| CompExpr (Neq c) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "NEQ" c
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-05-23 10:22:58 +04:00
|
|
|
and simpl_list_expression (t:Raw.list_expr) : expression result =
|
|
|
|
let return x = ok x in
|
2019-05-13 00:56:22 +04:00
|
|
|
match t with
|
2019-11-06 20:23:49 +04:00
|
|
|
ECons c ->
|
2019-05-28 19:36:14 +04:00
|
|
|
simpl_binop "CONS" c
|
2019-11-06 20:23:49 +04:00
|
|
|
| EListComp lst ->
|
2019-05-28 19:36:14 +04:00
|
|
|
let (lst , loc) = r_split lst in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind lst' =
|
|
|
|
bind_map_list simpl_expression @@
|
2019-05-28 19:36:14 +04:00
|
|
|
pseq_to_list lst.elements in
|
|
|
|
return @@ e_list ~loc lst'
|
2019-11-06 20:23:49 +04:00
|
|
|
| ENil reg ->
|
2019-05-28 19:36:14 +04:00
|
|
|
let loc = Location.lift reg in
|
|
|
|
return @@ e_list ~loc []
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-07-19 16:35:47 +04:00
|
|
|
and simpl_set_expression (t:Raw.set_expr) : expression result =
|
|
|
|
match t with
|
|
|
|
| SetMem x -> (
|
|
|
|
let (x' , loc) = r_split x in
|
|
|
|
let%bind set' = simpl_expression x'.set in
|
|
|
|
let%bind element' = simpl_expression x'.element in
|
2019-12-04 15:40:58 +04:00
|
|
|
ok @@ e_constant ~loc C_SET_MEM [ element' ; set' ]
|
2019-07-19 16:35:47 +04:00
|
|
|
)
|
|
|
|
| SetInj x -> (
|
|
|
|
let (x' , loc) = r_split x in
|
|
|
|
let elements = pseq_to_list x'.elements in
|
|
|
|
let%bind elements' = bind_map_list simpl_expression elements in
|
|
|
|
ok @@ e_set ~loc elements'
|
|
|
|
)
|
|
|
|
|
2019-05-28 19:36:14 +04:00
|
|
|
and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
|
2019-05-23 10:22:58 +04:00
|
|
|
let return x = ok x in
|
2019-05-28 19:36:14 +04:00
|
|
|
let (t , loc) = r_split t in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind a = simpl_expression t.arg1 in
|
|
|
|
let%bind b = simpl_expression t.arg2 in
|
2019-12-04 15:40:58 +04:00
|
|
|
let%bind name = constants name in
|
2019-05-28 19:36:14 +04:00
|
|
|
return @@ e_constant ~loc name [ a ; b ]
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-05-28 19:36:14 +04:00
|
|
|
and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
|
2019-05-23 10:22:58 +04:00
|
|
|
let return x = ok x in
|
2019-05-28 19:36:14 +04:00
|
|
|
let (t , loc) = r_split t in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind a = simpl_expression t.arg in
|
2019-12-04 15:40:58 +04:00
|
|
|
let%bind name = constants name in
|
2019-05-28 19:36:14 +04:00
|
|
|
return @@ e_constant ~loc name [ a ]
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-05-28 19:36:14 +04:00
|
|
|
and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result =
|
2019-05-23 10:22:58 +04:00
|
|
|
let return x = ok x in
|
2019-05-13 00:56:22 +04:00
|
|
|
match lst with
|
2019-05-28 19:36:14 +04:00
|
|
|
| [] -> return @@ e_literal Literal_unit
|
2019-05-23 10:22:58 +04:00
|
|
|
| [hd] -> simpl_expression hd
|
2019-06-04 18:12:17 +04:00
|
|
|
| lst ->
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind lst = bind_list @@ List.map simpl_expression lst in
|
2019-05-28 19:36:14 +04:00
|
|
|
return @@ e_tuple ?loc lst
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-05-22 04:46:54 +04:00
|
|
|
and simpl_data_declaration : Raw.data_decl -> _ result = fun t ->
|
2019-05-13 00:56:22 +04:00
|
|
|
match t with
|
|
|
|
| LocalVar x ->
|
2019-05-28 19:36:14 +04:00
|
|
|
let (x , loc) = r_split x in
|
2019-05-13 00:56:22 +04:00
|
|
|
let name = x.name.value in
|
|
|
|
let%bind t = simpl_type_expression x.var_type in
|
2019-05-23 10:22:58 +04:00
|
|
|
let%bind expression = simpl_expression x.init in
|
2019-12-04 15:40:58 +04:00
|
|
|
return_let_in ~loc (Var.of_name name , Some t) expression
|
2019-05-13 00:56:22 +04:00
|
|
|
| LocalConst x ->
|
2019-05-28 19:36:14 +04:00
|
|
|
let (x , loc) = r_split x in
|
2019-05-13 00:56:22 +04:00
|
|
|
let name = x.name.value in
|
|
|
|
let%bind t = simpl_type_expression x.const_type in
|
2019-05-23 10:22:58 +04:00
|
|
|
let%bind expression = simpl_expression x.init in
|
2019-12-04 15:40:58 +04:00
|
|
|
return_let_in ~loc (Var.of_name name , Some t) expression
|
2019-11-18 19:10:48 +04:00
|
|
|
| LocalFun f ->
|
|
|
|
let (f , loc) = r_split f in
|
2020-01-09 20:26:07 +04:00
|
|
|
let%bind (binder, expr) = simpl_fun_decl ~loc f
|
|
|
|
in return_let_in ~loc binder expr
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-12-04 15:40:58 +04:00
|
|
|
and simpl_param : Raw.param_decl -> (expression_variable * type_expression) result =
|
2019-06-04 18:12:17 +04:00
|
|
|
fun t ->
|
2019-05-13 00:56:22 +04:00
|
|
|
match t with
|
|
|
|
| ParamConst c ->
|
|
|
|
let c = c.value in
|
2019-12-04 15:40:58 +04:00
|
|
|
let type_name = Var.of_name c.var.value in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind type_expression = simpl_type_expression c.param_type in
|
2019-05-23 10:22:58 +04:00
|
|
|
ok (type_name , type_expression)
|
2019-05-13 00:56:22 +04:00
|
|
|
| ParamVar v ->
|
|
|
|
let c = v.value in
|
2019-12-04 15:40:58 +04:00
|
|
|
let type_name = Var.of_name c.var.value in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind type_expression = simpl_type_expression c.param_type in
|
2019-05-23 10:22:58 +04:00
|
|
|
ok (type_name , type_expression)
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2020-01-09 20:26:07 +04:00
|
|
|
and simpl_fun_decl :
|
|
|
|
loc:_ -> Raw.fun_decl -> ((expression_variable * type_expression option) * expression) result =
|
2019-06-04 18:12:17 +04:00
|
|
|
fun ~loc x ->
|
2019-05-13 00:56:22 +04:00
|
|
|
let open! Raw in
|
2020-01-09 20:26:07 +04:00
|
|
|
let {fun_name;param;ret_type;block_with;return} : fun_decl = x in
|
2019-10-19 21:46:24 +04:00
|
|
|
let statements =
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
match block_with with
|
|
|
|
| Some (block,_) -> npseq_to_list block.value.statements
|
2019-10-19 21:46:24 +04:00
|
|
|
| None -> []
|
2019-10-19 20:11:18 +04:00
|
|
|
in
|
2019-10-17 20:46:40 +04:00
|
|
|
(match param.value.inside with
|
|
|
|
a, [] -> (
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind input = simpl_param a in
|
2019-05-23 10:22:58 +04:00
|
|
|
let (binder , input_type) = input in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind instructions = bind_list
|
|
|
|
@@ List.map simpl_statement
|
2019-10-19 21:46:24 +04:00
|
|
|
@@ statements in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind result = simpl_expression return in
|
|
|
|
let%bind output_type = simpl_type_expression ret_type in
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
let body = instructions in
|
2019-05-22 04:46:54 +04:00
|
|
|
let%bind result =
|
|
|
|
let aux prec cur = cur (Some prec) in
|
|
|
|
bind_fold_right_list aux result body in
|
2019-05-28 19:36:14 +04:00
|
|
|
let expression : expression = e_lambda ~loc binder (Some input_type)
|
|
|
|
(Some output_type) result in
|
2020-01-09 20:26:07 +04:00
|
|
|
let type_annotation =
|
|
|
|
Some (make_t @@ T_arrow (input_type, output_type)) in
|
|
|
|
ok ((Var.of_name fun_name.value, type_annotation), expression)
|
2019-05-13 00:56:22 +04:00
|
|
|
)
|
|
|
|
| lst -> (
|
2019-10-17 20:46:40 +04:00
|
|
|
let lst = npseq_to_list lst in
|
2020-01-09 20:26:07 +04:00
|
|
|
(* TODO wrong, should be fresh? *)
|
|
|
|
let arguments_name = Var.of_name "arguments" in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind params = bind_map_list simpl_param lst in
|
2019-05-23 10:22:58 +04:00
|
|
|
let (binder , input_type) =
|
|
|
|
let type_expression = T_tuple (List.map snd params) in
|
|
|
|
(arguments_name , type_expression) in
|
2019-05-22 04:46:54 +04:00
|
|
|
let%bind tpl_declarations =
|
2019-05-23 10:22:58 +04:00
|
|
|
let aux = fun i x ->
|
2020-01-09 20:26:07 +04:00
|
|
|
let expr =
|
|
|
|
e_accessor (e_variable arguments_name) [Access_tuple i] in
|
2019-12-04 15:40:58 +04:00
|
|
|
let type_variable = Some (snd x) in
|
|
|
|
let ass = return_let_in (fst x , type_variable) expr in
|
2019-05-13 00:56:22 +04:00
|
|
|
ass
|
|
|
|
in
|
2019-05-22 04:46:54 +04:00
|
|
|
bind_list @@ List.mapi aux params in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind instructions = bind_list
|
|
|
|
@@ List.map simpl_statement
|
2019-10-19 21:46:24 +04:00
|
|
|
@@ statements in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind result = simpl_expression return in
|
2019-05-22 04:46:54 +04:00
|
|
|
let%bind output_type = simpl_type_expression ret_type in
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
let body = tpl_declarations @ instructions in
|
2019-05-22 04:46:54 +04:00
|
|
|
let%bind result =
|
|
|
|
let aux prec cur = cur (Some prec) in
|
|
|
|
bind_fold_right_list aux result body in
|
2019-06-04 18:12:17 +04:00
|
|
|
let expression =
|
2019-12-04 15:40:58 +04:00
|
|
|
e_lambda ~loc binder (Some (make_t @@ input_type)) (Some output_type) result in
|
|
|
|
let type_annotation = Some (make_t @@ T_arrow (make_t input_type, output_type)) in
|
2020-01-09 20:26:07 +04:00
|
|
|
ok ((Var.of_name fun_name.value, type_annotation), expression)
|
2019-05-13 00:56:22 +04:00
|
|
|
)
|
|
|
|
)
|
2020-01-09 20:26:07 +04:00
|
|
|
|
|
|
|
and simpl_fun_expression :
|
|
|
|
loc:_ -> Raw.fun_expr -> (type_expression option * expression) result =
|
|
|
|
fun ~loc x ->
|
|
|
|
let open! Raw in
|
|
|
|
let {param;ret_type;return;_} : fun_expr = x in
|
|
|
|
let statements = [] in
|
|
|
|
(match param.value.inside with
|
|
|
|
a, [] -> (
|
|
|
|
let%bind input = simpl_param a in
|
|
|
|
let (binder , input_type) = input in
|
|
|
|
let%bind instructions = bind_list
|
|
|
|
@@ List.map simpl_statement
|
|
|
|
@@ statements in
|
|
|
|
let%bind result = simpl_expression return in
|
|
|
|
let%bind output_type = simpl_type_expression ret_type in
|
|
|
|
let body = instructions in
|
|
|
|
let%bind result =
|
|
|
|
let aux prec cur = cur (Some prec) in
|
|
|
|
bind_fold_right_list aux result body in
|
|
|
|
let expression : expression = e_lambda ~loc binder (Some input_type)
|
|
|
|
(Some output_type) result in
|
|
|
|
let type_annotation =
|
|
|
|
Some (make_t @@ T_arrow (input_type, output_type)) in
|
|
|
|
ok (type_annotation, expression)
|
|
|
|
)
|
|
|
|
| lst -> (
|
|
|
|
let lst = npseq_to_list lst in
|
|
|
|
(* TODO wrong, should be fresh? *)
|
|
|
|
let arguments_name = Var.of_name "arguments" in
|
|
|
|
let%bind params = bind_map_list simpl_param lst in
|
|
|
|
let (binder , input_type) =
|
|
|
|
let type_expression = T_tuple (List.map snd params) in
|
|
|
|
(arguments_name , type_expression) in
|
|
|
|
let%bind tpl_declarations =
|
|
|
|
let aux = fun i x ->
|
|
|
|
let expr =
|
|
|
|
e_accessor (e_variable arguments_name) [Access_tuple i] in
|
|
|
|
let type_variable = Some (snd x) in
|
|
|
|
let ass = return_let_in (fst x , type_variable) expr in
|
|
|
|
ass
|
|
|
|
in
|
|
|
|
bind_list @@ List.mapi aux params in
|
|
|
|
let%bind instructions = bind_list
|
|
|
|
@@ List.map simpl_statement
|
|
|
|
@@ statements in
|
|
|
|
let%bind result = simpl_expression return in
|
|
|
|
let%bind output_type = simpl_type_expression ret_type in
|
|
|
|
let body = tpl_declarations @ instructions in
|
|
|
|
let%bind result =
|
|
|
|
let aux prec cur = cur (Some prec) in
|
|
|
|
bind_fold_right_list aux result body in
|
|
|
|
let expression =
|
|
|
|
e_lambda ~loc binder (Some (make_t @@ input_type)) (Some output_type) result in
|
|
|
|
let type_annotation = Some (make_t @@ T_arrow (make_t input_type, output_type)) in
|
|
|
|
ok (type_annotation, expression)
|
|
|
|
)
|
|
|
|
)
|
|
|
|
|
2019-06-04 18:12:17 +04:00
|
|
|
and simpl_declaration : Raw.declaration -> declaration Location.wrap result =
|
|
|
|
fun t ->
|
2019-05-13 00:56:22 +04:00
|
|
|
let open! Raw in
|
|
|
|
match t with
|
2020-01-09 20:26:07 +04:00
|
|
|
| TypeDecl x ->
|
|
|
|
let decl, loc = r_split x in
|
|
|
|
let {name;type_expr} : Raw.type_decl = decl in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind type_expression = simpl_type_expression type_expr in
|
2020-01-09 20:26:07 +04:00
|
|
|
ok @@ Location.wrap ~loc (Declaration_type
|
|
|
|
(Var.of_name name.value, type_expression))
|
|
|
|
|
2019-05-13 00:56:22 +04:00
|
|
|
| ConstDecl x ->
|
|
|
|
let simpl_const_decl = fun {name;const_type;init} ->
|
|
|
|
let%bind expression = simpl_expression init in
|
|
|
|
let%bind t = simpl_type_expression const_type in
|
|
|
|
let type_annotation = Some t in
|
2020-01-09 20:26:07 +04:00
|
|
|
ok @@ Declaration_constant
|
|
|
|
(Var.of_name name.value, type_annotation, expression)
|
|
|
|
in bind_map_location simpl_const_decl (Location.lift_region x)
|
|
|
|
| FunDecl x ->
|
|
|
|
let decl, loc = r_split x in
|
|
|
|
let%bind ((name, ty_opt), expr) = simpl_fun_decl ~loc decl in
|
|
|
|
ok @@ Location.wrap ~loc (Declaration_constant (name, ty_opt, expr))
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-06-04 18:12:17 +04:00
|
|
|
and simpl_statement : Raw.statement -> (_ -> expression result) result =
|
|
|
|
fun s ->
|
2019-05-13 00:56:22 +04:00
|
|
|
match s with
|
|
|
|
| Instr i -> simpl_instruction i
|
2019-05-22 04:46:54 +04:00
|
|
|
| Data d -> simpl_data_declaration d
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-10-17 20:33:58 +04:00
|
|
|
and simpl_single_instruction : Raw.instruction -> (_ -> expression result) result =
|
2019-06-04 18:12:17 +04:00
|
|
|
fun t ->
|
2019-05-13 00:56:22 +04:00
|
|
|
match t with
|
2019-07-20 15:46:42 +04:00
|
|
|
| ProcCall x -> (
|
2019-11-14 23:12:41 +04:00
|
|
|
let ((f, args) , loc) = r_split x in
|
|
|
|
let (args , args_loc) = r_split args in
|
|
|
|
let args' = npseq_to_list args.inside in
|
|
|
|
match f with
|
|
|
|
| EVar name -> (
|
|
|
|
let (f_name , f_loc) = r_split name in
|
2019-12-04 15:40:58 +04:00
|
|
|
match constants f_name with
|
|
|
|
| Error _ ->
|
2019-11-14 23:12:41 +04:00
|
|
|
let%bind arg = simpl_tuple_expression ~loc:args_loc args' in
|
2019-12-04 15:40:58 +04:00
|
|
|
return_statement @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg
|
|
|
|
| Ok (s,_) ->
|
2019-11-14 23:12:41 +04:00
|
|
|
let%bind lst = bind_map_list simpl_expression args' in
|
|
|
|
return_statement @@ e_constant ~loc s lst
|
|
|
|
)
|
|
|
|
| f -> (
|
|
|
|
let%bind f' = simpl_expression f in
|
|
|
|
let%bind arg = simpl_tuple_expression ~loc:args_loc args' in
|
|
|
|
return_statement @@ e_application ~loc f' arg
|
2019-07-20 15:46:42 +04:00
|
|
|
)
|
2019-11-14 23:12:41 +04:00
|
|
|
)
|
2019-05-28 19:36:14 +04:00
|
|
|
| Skip reg -> (
|
|
|
|
let loc = Location.lift reg in
|
2019-09-10 14:42:49 +04:00
|
|
|
return_statement @@ e_skip ~loc ()
|
2019-05-28 19:36:14 +04:00
|
|
|
)
|
2019-05-13 00:56:22 +04:00
|
|
|
| Loop (While l) ->
|
|
|
|
let l = l.value in
|
|
|
|
let%bind cond = simpl_expression l.cond in
|
|
|
|
let%bind body = simpl_block l.block.value in
|
2019-05-22 04:46:54 +04:00
|
|
|
let%bind body = body None in
|
2019-09-10 14:42:49 +04:00
|
|
|
return_statement @@ e_loop cond body
|
2019-11-06 20:23:49 +04:00
|
|
|
| Loop (For (ForInt fi)) ->
|
2019-10-11 20:31:04 +04:00
|
|
|
let%bind loop = simpl_for_int fi.value in
|
2019-11-06 20:23:49 +04:00
|
|
|
let%bind loop = loop None in
|
2019-10-11 20:31:04 +04:00
|
|
|
return_statement @@ loop
|
2019-10-15 15:14:00 +04:00
|
|
|
| Loop (For (ForCollect fc)) ->
|
|
|
|
let%bind loop = simpl_for_collect fc.value in
|
2019-11-06 20:23:49 +04:00
|
|
|
let%bind loop = loop None in
|
2019-10-15 15:14:00 +04:00
|
|
|
return_statement @@ loop
|
2019-05-28 19:36:14 +04:00
|
|
|
| Cond c -> (
|
|
|
|
let (c , loc) = r_split c in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind expr = simpl_expression c.test in
|
|
|
|
let%bind match_true = match c.ifso with
|
2019-10-17 20:33:58 +04:00
|
|
|
ClauseInstr i ->
|
|
|
|
simpl_single_instruction i
|
|
|
|
| ClauseBlock b ->
|
|
|
|
match b with
|
|
|
|
LongBlock {value; _} ->
|
|
|
|
simpl_block value
|
|
|
|
| ShortBlock {value; _} ->
|
|
|
|
simpl_statements @@ fst value.inside in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind match_false = match c.ifnot with
|
2019-10-17 20:33:58 +04:00
|
|
|
ClauseInstr i ->
|
|
|
|
simpl_single_instruction i
|
|
|
|
| ClauseBlock b ->
|
|
|
|
match b with
|
|
|
|
LongBlock {value; _} ->
|
|
|
|
simpl_block value
|
|
|
|
| ShortBlock {value; _} ->
|
|
|
|
simpl_statements @@ fst value.inside in
|
2019-05-22 04:46:54 +04:00
|
|
|
let%bind match_true = match_true None in
|
|
|
|
let%bind match_false = match_false None in
|
2019-09-10 14:42:49 +04:00
|
|
|
return_statement @@ e_matching expr ~loc (Match_bool {match_true; match_false})
|
2019-05-28 19:36:14 +04:00
|
|
|
)
|
2019-05-13 00:56:22 +04:00
|
|
|
| Assign a -> (
|
2019-05-28 19:36:14 +04:00
|
|
|
let (a , loc) = r_split a in
|
2019-10-07 18:24:56 +04:00
|
|
|
let%bind value_expr = simpl_expression a.rhs in
|
2019-05-13 00:56:22 +04:00
|
|
|
match a.lhs with
|
|
|
|
| Path path -> (
|
|
|
|
let (name , path') = simpl_path path in
|
2019-09-10 14:42:49 +04:00
|
|
|
return_statement @@ e_assign ~loc name path' value_expr
|
2019-05-13 00:56:22 +04:00
|
|
|
)
|
|
|
|
| MapPath v -> (
|
|
|
|
let v' = v.value in
|
2019-10-08 18:41:47 +04:00
|
|
|
let%bind (varname,map,path) = match v'.path with
|
2019-12-04 15:40:58 +04:00
|
|
|
| Name name -> ok (name.value , e_variable (Var.of_name name.value), [])
|
2019-10-08 18:41:47 +04:00
|
|
|
| Path p ->
|
2019-10-08 20:20:32 +04:00
|
|
|
let (name,p') = simpl_path v'.path in
|
2019-10-13 22:15:50 +04:00
|
|
|
let%bind accessor = simpl_projection p in
|
2019-10-08 20:20:32 +04:00
|
|
|
ok @@ (name , accessor , p')
|
2019-10-08 18:41:47 +04:00
|
|
|
in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind key_expr = simpl_expression v'.index.value.inside in
|
2019-10-08 18:41:47 +04:00
|
|
|
let expr' = e_map_add key_expr value_expr map in
|
|
|
|
return_statement @@ e_assign ~loc varname path expr'
|
2019-05-13 00:56:22 +04:00
|
|
|
)
|
|
|
|
)
|
2019-05-22 04:46:54 +04:00
|
|
|
| CaseInstr c -> (
|
2019-05-28 19:36:14 +04:00
|
|
|
let (c , loc) = r_split c in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind expr = simpl_expression c.expr in
|
|
|
|
let%bind cases =
|
2019-10-24 11:58:33 +04:00
|
|
|
let aux (x : Raw.if_clause Raw.case_clause Raw.reg) =
|
|
|
|
let%bind case_clause =
|
|
|
|
match x.value.rhs with
|
|
|
|
ClauseInstr i ->
|
|
|
|
simpl_single_instruction i
|
|
|
|
| ClauseBlock b ->
|
|
|
|
match b with
|
|
|
|
LongBlock {value; _} ->
|
|
|
|
simpl_block value
|
|
|
|
| ShortBlock {value; _} ->
|
2019-10-24 12:29:41 +04:00
|
|
|
simpl_statements @@ fst value.inside in
|
|
|
|
let%bind case_clause = case_clause None in
|
|
|
|
ok (x.value.pattern, case_clause) in
|
2019-05-13 00:56:22 +04:00
|
|
|
bind_list
|
|
|
|
@@ List.map aux
|
|
|
|
@@ npseq_to_list c.cases.value in
|
|
|
|
let%bind m = simpl_cases cases in
|
2019-10-24 12:29:41 +04:00
|
|
|
return_statement @@ e_matching ~loc expr m
|
2019-05-22 04:46:54 +04:00
|
|
|
)
|
2019-05-13 00:56:22 +04:00
|
|
|
| RecordPatch r -> (
|
|
|
|
let r = r.value in
|
|
|
|
let (name , access_path) = simpl_path r.path in
|
2019-10-23 02:35:29 +04:00
|
|
|
|
|
|
|
let head, tail = r.record_inj.value.ne_elements in
|
|
|
|
|
|
|
|
let%bind tail' = bind_list
|
|
|
|
@@ List.map (fun (x: Raw.field_assign Region.reg) ->
|
2019-05-28 19:36:14 +04:00
|
|
|
let (x , loc) = r_split x in
|
2019-06-05 19:51:06 +04:00
|
|
|
let%bind e = simpl_expression x.field_expr
|
|
|
|
in ok (x.field_name.value, e , loc)
|
2019-05-28 19:36:14 +04:00
|
|
|
)
|
2019-10-23 02:35:29 +04:00
|
|
|
@@ List.map snd tail in
|
|
|
|
|
|
|
|
let%bind head' =
|
|
|
|
let (x , loc) = r_split head in
|
|
|
|
let%bind e = simpl_expression x.field_expr
|
|
|
|
in ok (x.field_name.value, e , loc) in
|
|
|
|
|
2019-05-22 04:46:54 +04:00
|
|
|
let%bind expr =
|
2019-05-28 19:36:14 +04:00
|
|
|
let aux = fun (access , v , loc) ->
|
2019-10-23 02:35:29 +04:00
|
|
|
e_assign ~loc name (access_path @ [Access_record access]) v in
|
|
|
|
|
|
|
|
let hd, tl = aux head', List.map aux tail' in
|
|
|
|
let aux acc cur = e_sequence acc cur in
|
|
|
|
ok @@ List.fold_left aux hd tl
|
2019-05-22 04:46:54 +04:00
|
|
|
in
|
2019-09-10 14:42:49 +04:00
|
|
|
return_statement @@ expr
|
2019-10-23 02:35:29 +04:00
|
|
|
)
|
2019-10-11 05:26:28 +04:00
|
|
|
| MapPatch patch -> (
|
|
|
|
let (map_p, loc) = r_split patch in
|
|
|
|
let (name, access_path) = simpl_path map_p.path in
|
2019-10-12 02:44:16 +04:00
|
|
|
let%bind inj = bind_list
|
|
|
|
@@ List.map (fun (x:Raw.binding Region.reg) ->
|
|
|
|
let x = x.value in
|
2019-10-11 05:26:28 +04:00
|
|
|
let (key, value) = x.source, x.image in
|
|
|
|
let%bind key' = simpl_expression key in
|
|
|
|
let%bind value' = simpl_expression value
|
2019-10-12 02:44:16 +04:00
|
|
|
in ok @@ (key', value')
|
2019-10-11 05:26:28 +04:00
|
|
|
)
|
2019-10-23 02:35:29 +04:00
|
|
|
@@ npseq_to_list map_p.map_inj.value.ne_elements in
|
2019-10-12 02:44:16 +04:00
|
|
|
let expr =
|
|
|
|
match inj with
|
|
|
|
| [] -> e_skip ~loc ()
|
|
|
|
| _ :: _ ->
|
2019-10-14 23:05:35 +04:00
|
|
|
let assigns = List.fold_right
|
|
|
|
(fun (key, value) map -> (e_map_add key value map))
|
2019-10-12 02:44:16 +04:00
|
|
|
inj
|
2019-12-04 15:40:58 +04:00
|
|
|
(e_accessor ~loc (e_variable (Var.of_name name)) access_path)
|
2019-10-12 02:44:16 +04:00
|
|
|
in e_assign ~loc name access_path assigns
|
|
|
|
in return_statement @@ expr
|
2019-10-11 05:26:28 +04:00
|
|
|
)
|
2019-10-10 04:08:58 +04:00
|
|
|
| SetPatch patch -> (
|
2019-10-11 00:35:38 +04:00
|
|
|
let (setp, loc) = r_split patch in
|
2019-10-10 04:08:58 +04:00
|
|
|
let (name , access_path) = simpl_path setp.path in
|
2019-10-12 00:10:08 +04:00
|
|
|
let%bind inj =
|
|
|
|
bind_list @@
|
|
|
|
List.map simpl_expression @@
|
2019-10-23 02:35:29 +04:00
|
|
|
npseq_to_list setp.set_inj.value.ne_elements in
|
2019-10-12 00:10:08 +04:00
|
|
|
let expr =
|
|
|
|
match inj with
|
|
|
|
| [] -> e_skip ~loc ()
|
|
|
|
| _ :: _ ->
|
2019-10-14 23:05:35 +04:00
|
|
|
let assigns = List.fold_right
|
2019-12-04 15:40:58 +04:00
|
|
|
(fun hd s -> e_constant C_SET_ADD [hd ; s])
|
|
|
|
inj (e_accessor ~loc (e_variable (Var.of_name name)) access_path) in
|
2019-10-12 00:10:08 +04:00
|
|
|
e_assign ~loc name access_path assigns in
|
2019-10-10 04:08:58 +04:00
|
|
|
return_statement @@ expr
|
|
|
|
)
|
2019-05-28 19:36:14 +04:00
|
|
|
| MapRemove r -> (
|
|
|
|
let (v , loc) = r_split r in
|
2019-05-13 00:56:22 +04:00
|
|
|
let key = v.key in
|
2019-10-08 18:41:47 +04:00
|
|
|
let%bind (varname,map,path) = match v.map with
|
2019-12-04 15:40:58 +04:00
|
|
|
| Name v -> ok (v.value , e_variable (Var.of_name v.value) , [])
|
2019-10-08 18:41:47 +04:00
|
|
|
| Path p ->
|
2019-10-08 20:20:32 +04:00
|
|
|
let (name,p') = simpl_path v.map in
|
2019-10-13 22:15:50 +04:00
|
|
|
let%bind accessor = simpl_projection p in
|
2019-10-08 20:20:32 +04:00
|
|
|
ok @@ (name , accessor , p')
|
2019-10-08 18:41:47 +04:00
|
|
|
in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind key' = simpl_expression key in
|
2019-12-04 15:40:58 +04:00
|
|
|
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
|
2019-10-08 18:41:47 +04:00
|
|
|
return_statement @@ e_assign ~loc varname path expr
|
2019-05-28 19:36:14 +04:00
|
|
|
)
|
2019-10-08 08:41:36 +04:00
|
|
|
| SetRemove r -> (
|
|
|
|
let (set_rm, loc) = r_split r in
|
2019-10-15 03:04:48 +04:00
|
|
|
let%bind (varname, set, path) = match set_rm.set with
|
2019-12-04 15:40:58 +04:00
|
|
|
| Name v -> ok (v.value, e_variable (Var.of_name v.value), [])
|
2019-10-15 03:04:48 +04:00
|
|
|
| Path path ->
|
|
|
|
let(name, p') = simpl_path set_rm.set in
|
|
|
|
let%bind accessor = simpl_projection path in
|
|
|
|
ok @@ (name, accessor, p')
|
|
|
|
in
|
2019-10-08 08:41:36 +04:00
|
|
|
let%bind removed' = simpl_expression set_rm.element in
|
2019-12-04 15:40:58 +04:00
|
|
|
let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
|
2019-10-15 03:04:48 +04:00
|
|
|
return_statement @@ e_assign ~loc varname path expr
|
2019-10-08 08:41:36 +04:00
|
|
|
)
|
2019-05-13 00:56:22 +04:00
|
|
|
|
|
|
|
and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->
|
|
|
|
match p with
|
|
|
|
| Raw.Name v -> (v.value , [])
|
|
|
|
| Raw.Path p -> (
|
|
|
|
let p' = p.value in
|
|
|
|
let var = p'.struct_name.value in
|
|
|
|
let path = p'.field_path in
|
|
|
|
let path' =
|
|
|
|
let aux (s:Raw.selection) =
|
|
|
|
match s with
|
|
|
|
| FieldName property -> Access_record property.value
|
|
|
|
| Component index -> Access_tuple (Z.to_int (snd index.value))
|
|
|
|
in
|
|
|
|
List.map aux @@ npseq_to_list path in
|
|
|
|
(var , path')
|
|
|
|
)
|
|
|
|
|
2019-12-04 15:40:58 +04:00
|
|
|
and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result = fun t ->
|
2019-05-13 00:56:22 +04:00
|
|
|
let open Raw in
|
2019-06-05 19:51:06 +04:00
|
|
|
let get_var (t:Raw.pattern) =
|
|
|
|
match t with
|
2019-05-13 00:56:22 +04:00
|
|
|
| PVar v -> ok v.value
|
2019-06-13 18:57:40 +04:00
|
|
|
| p -> fail @@ unsupported_non_var_pattern p in
|
|
|
|
let get_tuple (t: Raw.pattern) =
|
|
|
|
match t with
|
2019-05-13 00:56:22 +04:00
|
|
|
| PTuple v -> npseq_to_list v.value.inside
|
2019-06-13 18:57:40 +04:00
|
|
|
| x -> [ x ] in
|
|
|
|
let get_single (t: Raw.pattern) =
|
2019-05-13 00:56:22 +04:00
|
|
|
let t' = get_tuple t in
|
|
|
|
let%bind () =
|
2019-06-05 19:51:06 +04:00
|
|
|
trace_strong (unsupported_tuple_pattern t) @@
|
2019-05-13 00:56:22 +04:00
|
|
|
Assert.assert_list_size t' 1 in
|
|
|
|
ok (List.hd t') in
|
2019-09-21 13:30:41 +04:00
|
|
|
let get_toplevel (t : Raw.pattern) =
|
|
|
|
match t with
|
2019-11-06 20:23:49 +04:00
|
|
|
| PList PCons x -> (
|
2019-09-21 13:30:41 +04:00
|
|
|
let (x' , lst) = x.value in
|
|
|
|
match lst with
|
|
|
|
| [] -> ok x'
|
|
|
|
| _ -> ok t
|
|
|
|
)
|
2019-10-13 22:15:50 +04:00
|
|
|
| pattern -> ok pattern in
|
2019-06-13 18:57:40 +04:00
|
|
|
let get_constr (t: Raw.pattern) =
|
|
|
|
match t with
|
2019-11-06 20:23:49 +04:00
|
|
|
| PConstr (PConstrApp v) -> (
|
2020-01-03 17:01:13 +04:00
|
|
|
let value = v.value in
|
|
|
|
match value with
|
2020-01-09 20:26:07 +04:00
|
|
|
| constr, None ->
|
|
|
|
ok (constr.value, "unit")
|
|
|
|
| _ ->
|
2019-11-06 20:23:49 +04:00
|
|
|
let const, pat_opt = v.value in
|
2019-06-13 18:57:40 +04:00
|
|
|
let%bind pat =
|
|
|
|
trace_option (unsupported_cst_constr t) @@
|
|
|
|
pat_opt in
|
|
|
|
let%bind single_pat = get_single (PTuple pat) in
|
|
|
|
let%bind var = get_var single_pat in
|
|
|
|
ok (const.value , var)
|
|
|
|
)
|
|
|
|
| _ -> fail @@ only_constructors t in
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind patterns =
|
|
|
|
let aux (x , y) =
|
2019-09-21 13:30:41 +04:00
|
|
|
let%bind x' = get_toplevel x in
|
|
|
|
ok (x' , y)
|
2019-06-13 18:57:40 +04:00
|
|
|
in bind_map_list aux t in
|
2019-05-13 00:56:22 +04:00
|
|
|
match patterns with
|
2019-11-06 20:23:49 +04:00
|
|
|
| [(PConstr PFalse _ , f) ; (PConstr PTrue _ , t)]
|
|
|
|
| [(PConstr PTrue _ , t) ; (PConstr PFalse _ , f)] ->
|
2019-06-05 19:51:06 +04:00
|
|
|
ok @@ Match_bool {match_true = t ; match_false = f}
|
2019-11-06 20:23:49 +04:00
|
|
|
| [(PConstr PSomeApp v , some) ; (PConstr PNone _ , none)]
|
|
|
|
| [(PConstr PNone _ , none) ; (PConstr PSomeApp v , some)] -> (
|
2019-05-13 00:56:22 +04:00
|
|
|
let (_, v) = v.value in
|
|
|
|
let%bind v = match v.value.inside with
|
|
|
|
| PVar v -> ok v.value
|
2019-06-05 19:51:06 +04:00
|
|
|
| p -> fail @@ unsupported_deep_Some_patterns p in
|
2019-12-04 15:40:58 +04:00
|
|
|
ok @@ Match_option {match_none = none ; match_some = (Var.of_name v, some, ()) }
|
2019-05-13 00:56:22 +04:00
|
|
|
)
|
2019-11-06 20:23:49 +04:00
|
|
|
| [(PList PCons c, cons) ; (PList (PNil _), nil)]
|
|
|
|
| [(PList (PNil _), nil) ; (PList PCons c, cons)] ->
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind (a, b) =
|
|
|
|
match c.value with
|
|
|
|
| a, [(_, b)] ->
|
|
|
|
let%bind a = get_var a in
|
|
|
|
let%bind b = get_var b in
|
|
|
|
ok (a, b)
|
2019-06-05 19:51:06 +04:00
|
|
|
| _ -> fail @@ unsupported_deep_list_patterns c
|
2019-12-04 15:40:58 +04:00
|
|
|
|
2019-05-13 00:56:22 +04:00
|
|
|
in
|
2019-12-04 15:40:58 +04:00
|
|
|
ok @@ Match_list {match_cons = (Var.of_name a, Var.of_name b, cons,()) ; match_nil = nil}
|
2019-05-13 00:56:22 +04:00
|
|
|
| lst ->
|
2019-06-05 19:51:06 +04:00
|
|
|
trace (simple_info "currently, only booleans, options, lists and \
|
|
|
|
user-defined constructors are supported in patterns") @@
|
2019-05-13 00:56:22 +04:00
|
|
|
let%bind constrs =
|
|
|
|
let aux (x , y) =
|
|
|
|
let error =
|
|
|
|
let title () = "Pattern" in
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
(** TODO: The labelled arguments should be flowing from the CLI. *)
|
2019-05-13 00:56:22 +04:00
|
|
|
let content () =
|
2019-10-09 18:07:13 +04:00
|
|
|
Printf.sprintf "Pattern : %s"
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
(Parser.Pascaligo.ParserLog.pattern_to_string
|
|
|
|
~offsets:true ~mode:`Point x) in
|
2019-05-13 00:56:22 +04:00
|
|
|
error title content in
|
|
|
|
let%bind x' =
|
|
|
|
trace error @@
|
|
|
|
get_constr x in
|
|
|
|
ok (x' , y) in
|
|
|
|
bind_map_list aux lst in
|
2019-12-04 15:40:58 +04:00
|
|
|
ok @@ ez_match_variant constrs
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-06-05 19:51:06 +04:00
|
|
|
and simpl_instruction : Raw.instruction -> (_ -> expression result) result =
|
|
|
|
fun t ->
|
2019-10-17 20:33:58 +04:00
|
|
|
trace (simplifying_instruction t) @@ simpl_single_instruction t
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-06-05 19:51:06 +04:00
|
|
|
and simpl_statements : Raw.statements -> (_ -> expression result) result =
|
|
|
|
fun ss ->
|
2019-05-13 00:56:22 +04:00
|
|
|
let lst = npseq_to_list ss in
|
2019-05-22 04:46:54 +04:00
|
|
|
let%bind fs = bind_map_list simpl_statement lst in
|
2019-06-05 19:51:06 +04:00
|
|
|
let aux : _ -> (expression option -> expression result) -> _ =
|
|
|
|
fun prec cur ->
|
|
|
|
let%bind res = cur prec in
|
|
|
|
ok @@ Some res in
|
2019-05-22 04:46:54 +04:00
|
|
|
ok @@ fun (expr' : _ option) ->
|
|
|
|
let%bind ret = bind_fold_right_list aux expr' fs in
|
|
|
|
ok @@ Option.unopt_exn ret
|
2019-05-13 00:56:22 +04:00
|
|
|
|
2019-05-23 10:22:58 +04:00
|
|
|
and simpl_block : Raw.block -> (_ -> expression result) result = fun t ->
|
2019-05-13 00:56:22 +04:00
|
|
|
simpl_statements t.statements
|
|
|
|
|
2019-10-11 20:31:04 +04:00
|
|
|
and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
|
|
|
|
(* cond part *)
|
2019-12-04 15:40:58 +04:00
|
|
|
let var = e_variable (Var.of_name fi.assign.value.name.value) in
|
2019-10-11 20:31:04 +04:00
|
|
|
let%bind value = simpl_expression fi.assign.value.expr in
|
|
|
|
let%bind bound = simpl_expression fi.bound in
|
2019-12-04 15:40:58 +04:00
|
|
|
let comp = e_annotation (e_constant C_LE [var ; bound]) t_bool
|
2019-10-11 20:31:04 +04:00
|
|
|
in
|
|
|
|
(* body part *)
|
|
|
|
let%bind body = simpl_block fi.block.value in
|
|
|
|
let%bind body = body None in
|
2019-10-22 14:12:19 +04:00
|
|
|
let step = e_int 1 in
|
|
|
|
let ctrl = e_assign
|
2019-12-04 15:40:58 +04:00
|
|
|
fi.assign.value.name.value [] (e_constant C_ADD [ var ; step ]) in
|
2019-10-11 20:31:04 +04:00
|
|
|
let rec add_to_seq expr = match expr.expression with
|
|
|
|
| E_sequence (_,a) -> add_to_seq a
|
|
|
|
| _ -> e_sequence body ctrl in
|
2019-10-15 15:56:21 +04:00
|
|
|
let body' = add_to_seq body in
|
|
|
|
let loop = e_loop comp body' in
|
2019-12-04 15:40:58 +04:00
|
|
|
return_statement @@ e_let_in (Var.of_name fi.assign.value.name.value, Some t_int) value loop
|
2019-10-11 20:31:04 +04:00
|
|
|
|
2019-10-28 21:40:53 +04:00
|
|
|
(** simpl_for_collect
|
|
|
|
For loops over collections, like
|
|
|
|
|
|
|
|
``` concrete syntax :
|
|
|
|
for x : int in set myset
|
|
|
|
begin
|
|
|
|
myint := myint + x ;
|
|
|
|
myst := myst ^ "to" ;
|
|
|
|
end
|
|
|
|
```
|
|
|
|
|
|
|
|
are implemented using a MAP_FOLD, LIST_FOLD or SET_FOLD:
|
|
|
|
|
|
|
|
``` pseudo Ast_simplified
|
2019-11-06 20:23:49 +04:00
|
|
|
let #COMPILER#folded_record = list_fold( mylist ,
|
2019-10-28 21:40:53 +04:00
|
|
|
record st = st; acc = acc; end;
|
2019-11-06 20:23:49 +04:00
|
|
|
lamby = fun arguments -> (
|
2019-10-28 21:40:53 +04:00
|
|
|
let #COMPILER#acc = arguments.0 in
|
2019-11-18 17:14:54 +04:00
|
|
|
let #COMPILER#elt_x = arguments.1 in
|
|
|
|
#COMPILER#acc.myint := #COMPILER#acc.myint + #COMPILER#elt_x ;
|
2019-10-28 21:40:53 +04:00
|
|
|
#COMPILER#acc.myst := #COMPILER#acc.myst ^ "to" ;
|
|
|
|
#COMPILER#acc
|
|
|
|
)
|
|
|
|
) in
|
|
|
|
{
|
|
|
|
myst := #COMPILER#folded_record.myst ;
|
|
|
|
myint := #COMPILER#folded_record.myint ;
|
|
|
|
}
|
|
|
|
```
|
2019-11-06 20:23:49 +04:00
|
|
|
|
2019-10-28 21:40:53 +04:00
|
|
|
We are performing the following steps:
|
2019-10-29 14:41:59 +04:00
|
|
|
1) Simplifying the for body using ̀simpl_block`
|
2019-10-28 21:40:53 +04:00
|
|
|
|
|
|
|
2) Detect the free variables and build a list of their names
|
|
|
|
(myint and myst in the previous example)
|
2019-11-19 17:25:48 +04:00
|
|
|
Free variables are simply variables being assigned but not defined
|
|
|
|
locally.
|
2019-11-15 21:10:24 +04:00
|
|
|
Note: In the case of a nested loops, assignements to a compiler
|
|
|
|
generated value (#COMPILER#acc) correspond to variables
|
|
|
|
that were already renamed in the inner loop.
|
|
|
|
e.g :
|
|
|
|
```
|
2019-11-18 17:14:54 +04:00
|
|
|
#COMPILER#acc.myint := #COMPILER#acc.myint + #COMPILER#elt_x ;
|
2019-11-15 21:10:24 +04:00
|
|
|
#COMPILER#acc.myst := #COMPILER#acc.myst ^ "to" ;
|
|
|
|
```
|
|
|
|
They must not be considered as free variables
|
2019-10-28 21:40:53 +04:00
|
|
|
|
|
|
|
3) Build the initial record (later passed as 2nd argument of
|
|
|
|
`MAP/SET/LIST_FOLD`) capturing the environment using the
|
|
|
|
free variables list of (2)
|
|
|
|
|
|
|
|
4) In the filtered body of (1), replace occurences:
|
|
|
|
- free variable of name X as rhs ==> accessor `#COMPILER#acc.X`
|
|
|
|
- free variable of name X as lhs ==> accessor `#COMPILER#acc.X`
|
2019-11-15 21:10:24 +04:00
|
|
|
And, in the case of a map:
|
2019-11-18 17:14:54 +04:00
|
|
|
- references to the iterated key ==> variable `#COMPILER#elt_K`
|
|
|
|
- references to the iterated value ==> variable `#COMPILER#elt_V`
|
2019-11-15 21:10:24 +04:00
|
|
|
in the case of a set/list:
|
2019-11-18 17:14:54 +04:00
|
|
|
- references to the iterated value ==> variable `#COMPILER#elt_X`
|
2019-11-15 21:10:24 +04:00
|
|
|
Note: In the case of an inner loop capturing variable from an outer loop
|
|
|
|
the free variable name can be `#COMPILER#acc.Y` and because we do not
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
capture the accumulator record in the inner loop, we don't want to
|
2019-11-15 21:10:24 +04:00
|
|
|
generate `#COMPILER#acc.#COMPILER#acc.Y` but `#COMPILER#acc.Y`
|
2019-10-28 21:40:53 +04:00
|
|
|
|
|
|
|
5) Append the return value to the body
|
|
|
|
|
|
|
|
6) Prepend the declaration of the lambda arguments to the body which
|
|
|
|
is a serie of `let .. in`'s
|
|
|
|
Note that the parameter of the lambda ̀arguments` is a tree of
|
|
|
|
tuple holding:
|
|
|
|
* In the case of `list` or ̀set`:
|
|
|
|
( folding record , current list/set element ) as
|
2019-11-18 17:14:54 +04:00
|
|
|
( #COMPILER#acc , #COMPILER#elt_X )
|
2019-10-28 21:40:53 +04:00
|
|
|
* In the case of `map`:
|
|
|
|
( folding record , current map key , current map value ) as
|
2019-11-18 17:14:54 +04:00
|
|
|
( #COMPILER#acc , #COMPILER#elt_K , #COMPILER#elt_V )
|
|
|
|
Note: X , K and V above have to be replaced with their given name
|
2019-10-28 21:40:53 +04:00
|
|
|
|
|
|
|
7) Build the lambda using the final body of (6)
|
|
|
|
|
2019-11-06 20:23:49 +04:00
|
|
|
8) Build a sequence of assignments for all the captured variables
|
2019-10-28 21:40:53 +04:00
|
|
|
to their new value, namely an access to the folded record
|
|
|
|
(#COMPILER#folded_record)
|
|
|
|
|
2019-11-06 20:23:49 +04:00
|
|
|
9) Attach the sequence of 8 to the ̀let .. in` declaration
|
2019-10-28 21:40:53 +04:00
|
|
|
of #COMPILER#folded_record
|
|
|
|
|
|
|
|
**)
|
2019-10-15 15:14:00 +04:00
|
|
|
and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc ->
|
2019-11-18 17:14:54 +04:00
|
|
|
let elt_name = "#COMPILER#elt_"^fc.var.value in
|
|
|
|
let elt_v_name = match fc.bind_to with
|
2019-11-26 20:49:23 +04:00
|
|
|
| Some v -> "#COMPILER#elt_"^(snd v).value
|
2019-11-18 17:14:54 +04:00
|
|
|
| None -> "#COMPILER#elt_unused" in
|
Refactoring of comments (for [dune build @doc]).
Refactoring of parsing command-line arguments
* The type [options] is now abstract and implemented as an
object type to avoid struggling with scoping and type
inference when record types share some common field names.
Refactoring of ParserLog for PascaLIGO and CameLIGO
* The immediate motivation behind that refactoring was to
remove the use of a couple of global references. A
consequence is that we have a nicer and more compact code, by
threading a state. The files [pascaligo/Tests/pp.ligo] and
[ligodity/Tests/pp.mligo].
* Another consequence is that the choice of making strings from
AST nodes depends on the CLI (offsets? mode?). After this
refactoring, that choice is hardcoded in the simplifiers in a
few places (TODO), waiting for a general solution that would
have all CL options flow through the compiler.
* I removed the use of vendors [x_option.ml], [x_map.ml] and
[x_list.ml] when handling optional values. (Less dependencies
this way.)
Refactoring of the ASTs
* I removed the node [local_decl], which was set to [[]]
already in a previous commit (which removed local
declarations as being redundant, as statements could already
be instructions or declarations).
* I changed [StrLit] to [String] in the AST of CameLIGO and
ReasonLIGO.
* I also changed the type [fun_expr] so now either a block is
present, and therefore followed by the [with] keyword, or it
is not. (Before, the presence of a block was not enforced in
the type with the presence of the keyword.)
Notes
* [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO
are almost identical and differ in the same way (language
name and file extension), which suggests that they should be
in the [shared] folder and instanciated as a functor in the
future (TODO).
* I removed the blank characters at the end of many lines in
the parser of ReasonLIGO.
2019-12-13 15:21:52 +04:00
|
|
|
let element_names = ok @@ match fc.bind_to with
|
2019-12-04 15:40:58 +04:00
|
|
|
| Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value]
|
|
|
|
| None -> [Var.of_name fc.var.value] in
|
2019-10-28 21:40:53 +04:00
|
|
|
(* STEP 1 *)
|
2019-10-29 14:41:59 +04:00
|
|
|
let%bind for_body = simpl_block fc.block.value in
|
|
|
|
let%bind for_body = for_body None in
|
2019-10-28 21:40:53 +04:00
|
|
|
(* STEP 2 *)
|
2019-11-21 04:32:43 +04:00
|
|
|
let%bind local_decl_name_list = bind_concat (detect_local_declarations for_body) element_names in
|
2019-11-19 17:25:48 +04:00
|
|
|
let%bind captured_name_list = detect_free_variables for_body local_decl_name_list in
|
2019-10-28 21:40:53 +04:00
|
|
|
(* STEP 3 *)
|
2019-12-04 15:40:58 +04:00
|
|
|
let add_to_record (prev: expression SMap.t) (captured_name: string) =
|
|
|
|
SMap.add captured_name (e_variable (Var.of_name captured_name)) prev in
|
2019-10-27 16:03:08 +04:00
|
|
|
let init_record = e_record (List.fold_left add_to_record SMap.empty captured_name_list) in
|
2019-10-28 21:40:53 +04:00
|
|
|
(* STEP 4 *)
|
2019-10-27 14:32:03 +04:00
|
|
|
let replace exp =
|
2019-10-26 16:18:06 +04:00
|
|
|
match exp.expression with
|
2019-11-15 21:10:24 +04:00
|
|
|
(* replace references to fold accumulator as lhs *)
|
2019-10-28 21:40:53 +04:00
|
|
|
| E_assign ( name , path , expr ) -> (
|
2019-11-19 17:25:48 +04:00
|
|
|
if (List.mem name local_decl_name_list ) then
|
|
|
|
ok @@ exp
|
|
|
|
else
|
2019-12-04 15:40:58 +04:00
|
|
|
let name = Var.to_name name in
|
2019-11-19 17:25:48 +04:00
|
|
|
let path' = List.filter
|
|
|
|
( fun el ->
|
|
|
|
match el with
|
2019-12-04 15:40:58 +04:00
|
|
|
| Access_record name -> not @@ is_compiler_generated (Var.of_name name)
|
2019-11-19 17:25:48 +04:00
|
|
|
| _ -> true )
|
|
|
|
((Access_record name)::path) in
|
|
|
|
ok @@ e_assign "#COMPILER#acc" path' expr )
|
2019-10-28 21:40:53 +04:00
|
|
|
| E_variable name -> (
|
2019-12-04 15:40:58 +04:00
|
|
|
let name = Var.to_name name in
|
2019-10-29 14:41:59 +04:00
|
|
|
if (List.mem name captured_name_list) then
|
2019-11-15 21:10:24 +04:00
|
|
|
(* replace references to fold accumulator as rhs *)
|
2019-12-04 15:40:58 +04:00
|
|
|
ok @@ e_accessor (e_variable (Var.of_name "#COMPILER#acc")) [Access_record name] (* TODO fresh *)
|
2019-11-06 20:23:49 +04:00
|
|
|
else match fc.collection with
|
2019-10-27 19:42:11 +04:00
|
|
|
(* loop on map *)
|
|
|
|
| Map _ ->
|
2019-12-04 15:40:58 +04:00
|
|
|
let k' = e_variable (Var.of_name elt_name) in
|
2019-10-29 14:41:59 +04:00
|
|
|
if ( name = fc.var.value ) then
|
|
|
|
ok @@ k' (* replace references to the the key *)
|
|
|
|
else (
|
|
|
|
match fc.bind_to with
|
|
|
|
| Some (_,v) ->
|
2019-12-04 15:40:58 +04:00
|
|
|
let v' = e_variable (Var.of_name elt_v_name) in
|
2019-10-29 14:41:59 +04:00
|
|
|
if ( name = v.value ) then
|
|
|
|
ok @@ v' (* replace references to the the value *)
|
|
|
|
else ok @@ exp
|
|
|
|
| None -> ok @@ exp
|
2019-10-27 19:42:11 +04:00
|
|
|
)
|
|
|
|
(* loop on set or list *)
|
|
|
|
| (Set _ | List _) ->
|
|
|
|
if (name = fc.var.value ) then
|
|
|
|
(* replace references to the collection element *)
|
2019-12-04 15:40:58 +04:00
|
|
|
ok @@ (e_variable (Var.of_name elt_name))
|
2019-10-27 19:42:11 +04:00
|
|
|
else ok @@ exp
|
|
|
|
)
|
2019-10-26 16:18:06 +04:00
|
|
|
| _ -> ok @@ exp in
|
2019-10-27 16:03:08 +04:00
|
|
|
let%bind for_body = Self_ast_simplified.map_expression replace for_body in
|
2019-10-28 21:40:53 +04:00
|
|
|
(* STEP 5 *)
|
2019-10-27 16:03:08 +04:00
|
|
|
let rec add_return (expr : expression) = match expr.expression with
|
2019-10-27 00:07:42 +04:00
|
|
|
| E_sequence (a,b) -> e_sequence a (add_return b)
|
2019-12-04 15:40:58 +04:00
|
|
|
| _ -> e_sequence expr (e_variable (Var.of_name "#COMPILER#acc")) in (* TODO fresh *)
|
2019-10-27 16:03:08 +04:00
|
|
|
let for_body = add_return for_body in
|
2019-10-28 21:40:53 +04:00
|
|
|
(* STEP 6 *)
|
2019-10-27 19:42:11 +04:00
|
|
|
let for_body =
|
2019-12-04 15:40:58 +04:00
|
|
|
let ( arg_access: Types.access_path -> expression ) = e_accessor (e_variable (Var.of_name "arguments")) in (* TODO fresh *)
|
2019-11-06 20:23:49 +04:00
|
|
|
( match fc.collection with
|
2019-10-27 19:42:11 +04:00
|
|
|
| Map _ ->
|
2019-11-15 18:49:50 +04:00
|
|
|
let acc = arg_access [Access_tuple 0 ] in
|
2019-10-27 19:42:11 +04:00
|
|
|
let collec_elt_v = arg_access [Access_tuple 1 ; Access_tuple 0] in
|
2019-11-15 18:49:50 +04:00
|
|
|
let collec_elt_k = arg_access [Access_tuple 1 ; Access_tuple 1] in
|
2019-12-04 15:40:58 +04:00
|
|
|
e_let_in (Var.of_name "#COMPILER#acc", None) acc @@ (* TODO fresh *)
|
|
|
|
e_let_in (Var.of_name elt_name, None) collec_elt_v @@
|
|
|
|
e_let_in (Var.of_name elt_v_name, None) collec_elt_k (for_body)
|
2019-10-27 19:42:11 +04:00
|
|
|
| _ ->
|
|
|
|
let acc = arg_access [Access_tuple 0] in
|
|
|
|
let collec_elt = arg_access [Access_tuple 1] in
|
2019-12-04 15:40:58 +04:00
|
|
|
e_let_in (Var.of_name "#COMPILER#acc", None) acc @@ (* TODO fresh *)
|
|
|
|
e_let_in (Var.of_name elt_name, None) collec_elt (for_body)
|
2019-10-27 19:42:11 +04:00
|
|
|
) in
|
2019-10-28 21:40:53 +04:00
|
|
|
(* STEP 7 *)
|
2019-10-26 16:18:06 +04:00
|
|
|
let%bind collect = simpl_expression fc.expr in
|
2019-12-04 15:40:58 +04:00
|
|
|
let lambda = e_lambda (Var.of_name "arguments") None None for_body in
|
2019-10-26 16:27:29 +04:00
|
|
|
let op_name = match fc.collection with
|
2019-12-04 15:40:58 +04:00
|
|
|
| Map _ -> C_MAP_FOLD | Set _ -> C_SET_FOLD | List _ -> C_LIST_FOLD in
|
2019-11-20 16:16:31 +04:00
|
|
|
let fold = e_constant op_name [lambda; collect ; init_record] in
|
2019-10-28 21:40:53 +04:00
|
|
|
(* STEP 8 *)
|
2019-10-27 16:03:08 +04:00
|
|
|
let assign_back (prev : expression option) (captured_varname : string) : expression option =
|
2019-12-04 15:40:58 +04:00
|
|
|
let access = e_accessor (e_variable (Var.of_name "#COMPILER#folded_record")) (* TODO fresh *)
|
2019-10-26 16:18:06 +04:00
|
|
|
[Access_record captured_varname] in
|
|
|
|
let assign = e_assign captured_varname [] access in
|
2019-11-06 20:23:49 +04:00
|
|
|
match prev with
|
|
|
|
| None -> Some assign
|
2019-10-27 14:32:03 +04:00
|
|
|
| Some p -> Some (e_sequence p assign) in
|
2019-10-27 16:03:08 +04:00
|
|
|
let reassign_sequence = List.fold_left assign_back None captured_name_list in
|
2019-10-28 21:40:53 +04:00
|
|
|
(* STEP 9 *)
|
2019-10-27 14:32:03 +04:00
|
|
|
let final_sequence = match reassign_sequence with
|
|
|
|
(* None case means that no variables were captured *)
|
2019-10-28 21:53:40 +04:00
|
|
|
| None -> e_skip ()
|
2019-12-04 15:40:58 +04:00
|
|
|
| Some seq -> e_let_in (Var.of_name "#COMPILER#folded_record", None) fold seq in (* TODO fresh *)
|
2019-10-26 16:18:06 +04:00
|
|
|
return_statement @@ final_sequence
|
|
|
|
|
2019-05-13 00:56:22 +04:00
|
|
|
let simpl_program : Raw.ast -> program result = fun t ->
|
2019-11-06 20:23:49 +04:00
|
|
|
bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl
|