Refactored the AST and fixed the symlinks.
This commit is contained in:
Christian Rinderknecht
parent
e48a5fde28
commit
331b11dcca
@ -6,7 +6,7 @@
|
||||
tezos-utils
|
||||
parser_pascaligo
|
||||
parser_camligo
|
||||
;; parser_ligodity
|
||||
parser_ligodity
|
||||
)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized)
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
$HOME/git/OCaml-build/Makefile
|
||||
$HOME/git/OCaml-build/Makefile.cfg
|
||||
$HOME/git/tezos/src/lib_utils/pos.mli
|
||||
$HOME/git/tezos/src/lib_utils/pos.ml
|
||||
$HOME/git/tezos/src/lib_utils/region.mli
|
||||
$HOME/git/tezos/src/lib_utils/region.ml
|
||||
Stubs/Tezos_utils.ml
|
||||
$HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.mli
|
||||
$HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.ml
|
||||
$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli
|
||||
$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml
|
||||
Stubs/Simple_utils.ml
|
||||
|
||||
@ -207,7 +207,7 @@ and expr =
|
||||
| ETuple of (expr, comma) Utils.nsepseq reg
|
||||
| EPar of expr par reg
|
||||
| ELetIn of let_in reg
|
||||
| EFun of fun_expr
|
||||
| EFun of fun_expr reg
|
||||
| ECond of conditional reg
|
||||
| ESeq of sequence
|
||||
|
||||
@ -318,9 +318,19 @@ and 'a case_clause = {
|
||||
rhs : 'a
|
||||
}
|
||||
|
||||
and let_in = kwd_let * let_binding * kwd_in * expr
|
||||
and let_in = {
|
||||
kwd_let : kwd_let;
|
||||
binding : let_binding;
|
||||
kwd_in : kwd_in;
|
||||
body : expr
|
||||
}
|
||||
|
||||
and fun_expr = (kwd_fun * variable * arrow * expr) reg
|
||||
and fun_expr = {
|
||||
kwd_fun : kwd_fun;
|
||||
param : variable;
|
||||
arrow : arrow;
|
||||
body : expr
|
||||
}
|
||||
|
||||
and conditional = {
|
||||
kwd_if : kwd_if;
|
||||
@ -385,71 +395,6 @@ let region_of_expr = function
|
||||
| ESeq {region; _} | ERecord {region; _}
|
||||
| EConstr {region; _} -> region
|
||||
|
||||
(* Rewriting let-expressions and fun-expressions, with some optimisations *)
|
||||
|
||||
type sep = Region.t
|
||||
|
||||
let ghost_fun, ghost_arrow, ghost_let, ghost_eq, ghost_in =
|
||||
let ghost = Region.ghost in ghost, ghost, ghost, ghost, ghost
|
||||
|
||||
let norm_fun region kwd_fun pattern eq expr =
|
||||
let value =
|
||||
match pattern with
|
||||
PVar v -> kwd_fun, v, eq, expr
|
||||
| _ -> let value = Utils.gen_sym () in
|
||||
let fresh = Region.{region=Region.ghost; value} in
|
||||
let binding = {pattern; eq;
|
||||
lhs_type=None; let_rhs = EVar fresh} in
|
||||
let let_in = ghost_let, binding, ghost_in, expr in
|
||||
let expr = ELetIn {value=let_in; region=Region.ghost}
|
||||
in kwd_fun, fresh, ghost_arrow, expr
|
||||
in Region.{region; value}
|
||||
|
||||
let norm ?reg (pattern, patterns) sep expr =
|
||||
let reg, fun_reg =
|
||||
match reg with
|
||||
None -> Region.ghost, ghost_fun
|
||||
| Some p -> p in
|
||||
let apply pattern (sep, expr) =
|
||||
ghost_eq, EFun (norm_fun Region.ghost ghost_fun pattern sep expr) in
|
||||
let sep, expr = List.fold_right apply patterns (sep, expr)
|
||||
in norm_fun reg fun_reg pattern sep expr
|
||||
|
||||
(* Unparsing expressions *)
|
||||
|
||||
type unparsed = [
|
||||
`Fun of (kwd_fun * (pattern Utils.nseq * arrow * expr))
|
||||
| `Let of (pattern Utils.nseq * equal * expr)
|
||||
| `Idem of expr
|
||||
]
|
||||
|
||||
(* The function [unparse'] returns a triple [patterns,
|
||||
separator_region, expression], and the context (handled by
|
||||
[unparse]) decides if [separator_region] is the region of a "="
|
||||
sign or "->". *)
|
||||
|
||||
let rec unparse' = function
|
||||
EFun {value=_,var,arrow,expr; _} ->
|
||||
if var.region#is_ghost then
|
||||
match expr with
|
||||
ELetIn {value = _,{pattern;eq;_},_,expr; _} ->
|
||||
if eq#is_ghost then
|
||||
let patterns, sep, e = unparse' expr
|
||||
in Utils.nseq_cons pattern patterns, sep, e
|
||||
else (pattern,[]), eq, expr
|
||||
| _ -> assert false
|
||||
else if arrow#is_ghost then
|
||||
let patterns, sep, e = unparse' expr
|
||||
in Utils.nseq_cons (PVar var) patterns, sep, e
|
||||
else (PVar var, []), arrow, expr
|
||||
| _ -> assert false
|
||||
|
||||
let unparse = function
|
||||
EFun {value=kwd_fun,_,_,_; _} as e ->
|
||||
let binding = unparse' e in
|
||||
if kwd_fun#is_ghost then `Let binding else `Fun (kwd_fun, binding)
|
||||
| e -> `Idem e
|
||||
|
||||
(* Printing the tokens with their source locations *)
|
||||
|
||||
let print_nsepseq sep print (head,tail) =
|
||||
@ -480,16 +425,16 @@ let print_bytes Region.{region; value=lexeme, abstract} =
|
||||
Printf.printf "%s: Bytes (\"%s\", \"0x%s\")\n"
|
||||
(region#compact `Byte) lexeme (Hex.to_string abstract)
|
||||
|
||||
let rec print_tokens ?(undo=false) {decl;eof} =
|
||||
Utils.nseq_iter (print_statement undo) decl; print_token eof "EOF"
|
||||
let rec print_tokens {decl;eof} =
|
||||
Utils.nseq_iter print_statement decl; print_token eof "EOF"
|
||||
|
||||
and print_statement undo = function
|
||||
and print_statement = function
|
||||
Let {value=kwd_let, let_binding; _} ->
|
||||
print_token kwd_let "let";
|
||||
print_let_binding undo let_binding
|
||||
print_let_binding let_binding
|
||||
| LetEntry {value=kwd_let_entry, let_binding; _} ->
|
||||
print_token kwd_let_entry "let%entry";
|
||||
print_let_binding undo let_binding
|
||||
print_let_binding let_binding
|
||||
| TypeDecl {value={kwd_type; name; eq; type_expr}; _} ->
|
||||
print_token kwd_type "type";
|
||||
print_var name;
|
||||
@ -587,28 +532,14 @@ and print_terminator = function
|
||||
Some semi -> print_token semi ";"
|
||||
| None -> ()
|
||||
|
||||
and print_let_binding undo {pattern; lhs_type; eq; let_rhs} =
|
||||
and print_let_binding {pattern; lhs_type; eq; let_rhs} =
|
||||
print_pattern pattern;
|
||||
(match lhs_type with
|
||||
None -> ()
|
||||
| Some (colon, type_expr) ->
|
||||
print_token colon ":";
|
||||
print_type_expr type_expr);
|
||||
if undo then
|
||||
match unparse let_rhs with
|
||||
`Let (patterns, eq, e) ->
|
||||
Utils.nseq_iter print_pattern patterns;
|
||||
print_token eq "=";
|
||||
print_expr undo e
|
||||
| `Fun (kwd_fun, (patterns, arrow, e)) ->
|
||||
print_token eq "=";
|
||||
print_token kwd_fun "fun";
|
||||
Utils.nseq_iter print_pattern patterns;
|
||||
print_token arrow "->";
|
||||
print_expr undo e
|
||||
| `Idem _ ->
|
||||
print_token eq "="; print_expr undo let_rhs
|
||||
else (print_token eq "="; print_expr undo let_rhs)
|
||||
(print_token eq "="; print_expr let_rhs)
|
||||
|
||||
and print_pattern = function
|
||||
PTuple {value=patterns;_} -> print_csv print_pattern patterns
|
||||
@ -657,69 +588,62 @@ and print_constr_pattern {value=constr, p_opt; _} =
|
||||
None -> ()
|
||||
| Some pattern -> print_pattern pattern
|
||||
|
||||
and print_expr undo = function
|
||||
ELetIn {value;_} -> print_let_in undo value
|
||||
| ECond cond -> print_conditional undo cond
|
||||
| ETuple {value;_} -> print_csv (print_expr undo) value
|
||||
| ECase {value;_} -> print_match_expr undo value
|
||||
| EFun {value=(kwd_fun,_,_,_) as f; _} as e ->
|
||||
if undo then
|
||||
let patterns, arrow, expr = unparse' e in
|
||||
print_token kwd_fun "fun";
|
||||
Utils.nseq_iter print_pattern patterns;
|
||||
print_token arrow "->";
|
||||
print_expr undo expr
|
||||
else print_fun_expr undo f
|
||||
and print_expr = function
|
||||
ELetIn {value;_} -> print_let_in value
|
||||
| ECond cond -> print_conditional cond
|
||||
| ETuple {value;_} -> print_csv print_expr value
|
||||
| ECase {value;_} -> print_match_expr value
|
||||
| EFun e -> print_fun_expr e
|
||||
|
||||
| EAnnot e -> print_annot_expr undo e
|
||||
| ELogic e -> print_logic_expr undo e
|
||||
| EArith e -> print_arith_expr undo e
|
||||
| EString e -> print_string_expr undo e
|
||||
| EAnnot e -> print_annot_expr e
|
||||
| ELogic e -> print_logic_expr e
|
||||
| EArith e -> print_arith_expr e
|
||||
| EString e -> print_string_expr e
|
||||
|
||||
| ECall {value=f,l; _} ->
|
||||
print_expr undo f; Utils.nseq_iter (print_expr undo) l
|
||||
print_expr f; Utils.nseq_iter print_expr l
|
||||
| EVar v -> print_var v
|
||||
| EProj p -> print_projection p
|
||||
| EUnit {value=lpar,rpar; _} ->
|
||||
print_token lpar "("; print_token rpar ")"
|
||||
| EBytes b -> print_bytes b
|
||||
| EPar {value={lpar;inside=e;rpar}; _} ->
|
||||
print_token lpar "("; print_expr undo e; print_token rpar ")"
|
||||
| EList e -> print_list_expr undo e
|
||||
| ESeq seq -> print_sequence undo seq
|
||||
| ERecord e -> print_record_expr undo e
|
||||
print_token lpar "("; print_expr e; print_token rpar ")"
|
||||
| EList e -> print_list_expr e
|
||||
| ESeq seq -> print_sequence seq
|
||||
| ERecord e -> print_record_expr e
|
||||
| EConstr {value=constr,None; _} -> print_uident constr
|
||||
| EConstr {value=(constr, Some arg); _} ->
|
||||
print_uident constr; print_expr undo arg
|
||||
print_uident constr; print_expr arg
|
||||
|
||||
and print_annot_expr undo {value=e,t; _} =
|
||||
print_expr undo e;
|
||||
and print_annot_expr {value=e,t; _} =
|
||||
print_expr e;
|
||||
print_token Region.ghost ":";
|
||||
print_type_expr t
|
||||
|
||||
and print_list_expr undo = function
|
||||
and print_list_expr = function
|
||||
Cons {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1;
|
||||
print_expr arg1;
|
||||
print_token op "::";
|
||||
print_expr undo arg2
|
||||
| List e -> print_injection (print_expr undo) e
|
||||
print_expr arg2
|
||||
| List e -> print_injection print_expr e
|
||||
(*| Append {value=e1,append,e2; _} ->
|
||||
print_expr undo e1;
|
||||
print_expr e1;
|
||||
print_token append "@";
|
||||
print_expr undo e2 *)
|
||||
print_expr e2 *)
|
||||
|
||||
and print_arith_expr undo = function
|
||||
and print_arith_expr = function
|
||||
Add {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op "+"; print_expr undo arg2
|
||||
print_expr arg1; print_token op "+"; print_expr arg2
|
||||
| Sub {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op "-"; print_expr undo arg2
|
||||
print_expr arg1; print_token op "-"; print_expr arg2
|
||||
| Mult {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op "*"; print_expr undo arg2
|
||||
print_expr arg1; print_token op "*"; print_expr arg2
|
||||
| Div {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op "/"; print_expr undo arg2
|
||||
print_expr arg1; print_token op "/"; print_expr arg2
|
||||
| Mod {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op "mod"; print_expr undo arg2
|
||||
| Neg {value={op;arg}; _} -> print_token op "-"; print_expr undo arg
|
||||
print_expr arg1; print_token op "mod"; print_expr arg2
|
||||
| Neg {value={op;arg}; _} -> print_token op "-"; print_expr arg
|
||||
| Int {region; value=lex,z} ->
|
||||
print_token region (sprintf "Int %s (%s)" lex (Z.to_string z))
|
||||
| Mtz {region; value=lex,z} ->
|
||||
@ -727,94 +651,95 @@ and print_arith_expr undo = function
|
||||
| Nat {region; value=lex,z} ->
|
||||
print_token region (sprintf "Nat %s (%s)" lex (Z.to_string z))
|
||||
|
||||
and print_string_expr undo = function
|
||||
and print_string_expr = function
|
||||
Cat {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op "^"; print_expr undo arg2
|
||||
print_expr arg1; print_token op "^"; print_expr arg2
|
||||
| String s -> print_str s
|
||||
|
||||
and print_logic_expr undo = function
|
||||
BoolExpr e -> print_bool_expr undo e
|
||||
| CompExpr e -> print_comp_expr undo e
|
||||
and print_logic_expr = function
|
||||
BoolExpr e -> print_bool_expr e
|
||||
| CompExpr e -> print_comp_expr e
|
||||
|
||||
and print_bool_expr undo = function
|
||||
and print_bool_expr = function
|
||||
Or {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op "||"; print_expr undo arg2
|
||||
print_expr arg1; print_token op "||"; print_expr arg2
|
||||
| And {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op "&&"; print_expr undo arg2
|
||||
| Not {value={op;arg}; _} -> print_token op "not"; print_expr undo arg
|
||||
print_expr arg1; print_token op "&&"; print_expr arg2
|
||||
| Not {value={op;arg}; _} -> print_token op "not"; print_expr arg
|
||||
| True kwd_true -> print_token kwd_true "true"
|
||||
| False kwd_false -> print_token kwd_false "false"
|
||||
|
||||
and print_comp_expr undo = function
|
||||
and print_comp_expr = function
|
||||
Lt {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op "<"; print_expr undo arg2
|
||||
print_expr arg1; print_token op "<"; print_expr arg2
|
||||
| Leq {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op "<="; print_expr undo arg2
|
||||
print_expr arg1; print_token op "<="; print_expr arg2
|
||||
| Gt {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op ">"; print_expr undo arg2
|
||||
print_expr arg1; print_token op ">"; print_expr arg2
|
||||
| Geq {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op ">="; print_expr undo arg2
|
||||
print_expr arg1; print_token op ">="; print_expr arg2
|
||||
| Neq {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op "<>"; print_expr undo arg2
|
||||
print_expr arg1; print_token op "<>"; print_expr arg2
|
||||
| Equal {value={arg1;op;arg2}; _} ->
|
||||
print_expr undo arg1; print_token op "="; print_expr undo arg2
|
||||
print_expr arg1; print_token op "="; print_expr arg2
|
||||
|
||||
and print_record_expr undo e =
|
||||
print_injection (print_field_assign undo) e
|
||||
and print_record_expr e =
|
||||
print_injection print_field_assign e
|
||||
|
||||
and print_field_assign undo {value; _} =
|
||||
and print_field_assign {value; _} =
|
||||
let {field_name; assignment; field_expr} = value in
|
||||
print_var field_name;
|
||||
print_token assignment "=";
|
||||
print_expr undo field_expr
|
||||
print_expr field_expr
|
||||
|
||||
and print_sequence undo seq = print_injection (print_expr undo) seq
|
||||
and print_sequence seq = print_injection print_expr seq
|
||||
|
||||
and print_match_expr undo expr =
|
||||
and print_match_expr expr =
|
||||
let {kwd_match; expr; opening;
|
||||
lead_vbar; cases; closing} = expr in
|
||||
print_token kwd_match "match";
|
||||
print_expr undo expr;
|
||||
print_expr expr;
|
||||
print_opening opening;
|
||||
print_token_opt lead_vbar "|";
|
||||
print_cases undo cases;
|
||||
print_cases cases;
|
||||
print_closing closing
|
||||
|
||||
and print_token_opt = function
|
||||
None -> fun _ -> ()
|
||||
| Some region -> print_token region
|
||||
|
||||
and print_cases undo {value; _} =
|
||||
print_nsepseq "|" (print_case_clause undo) value
|
||||
and print_cases {value; _} =
|
||||
print_nsepseq "|" print_case_clause value
|
||||
|
||||
and print_case_clause undo {value; _} =
|
||||
and print_case_clause {value; _} =
|
||||
let {pattern; arrow; rhs} = value in
|
||||
print_pattern pattern;
|
||||
print_token arrow "->";
|
||||
print_expr undo rhs
|
||||
print_expr rhs
|
||||
|
||||
and print_let_in undo (kwd_let, let_binding, kwd_in, expr) =
|
||||
and print_let_in {kwd_let; binding; kwd_in; body} =
|
||||
print_token kwd_let "let";
|
||||
print_let_binding undo let_binding;
|
||||
print_let_binding binding;
|
||||
print_token kwd_in "in";
|
||||
print_expr undo expr
|
||||
print_expr body
|
||||
|
||||
and print_fun_expr undo (kwd_fun, rvar, arrow, expr) =
|
||||
and print_fun_expr {value; _} =
|
||||
let {kwd_fun; param; arrow; body} = value in
|
||||
print_token kwd_fun "fun";
|
||||
print_var rvar;
|
||||
print_var param;
|
||||
print_token arrow "->";
|
||||
print_expr undo expr
|
||||
print_expr body
|
||||
|
||||
and print_conditional undo {value; _} =
|
||||
and print_conditional {value; _} =
|
||||
let open Region in
|
||||
let {kwd_if; test; kwd_then; ifso; kwd_else; ifnot} = value
|
||||
in print_token ghost "(";
|
||||
print_token kwd_if "if";
|
||||
print_expr undo test;
|
||||
print_expr test;
|
||||
print_token kwd_then "then";
|
||||
print_expr undo ifso;
|
||||
print_expr ifso;
|
||||
print_token kwd_else "else";
|
||||
print_expr undo ifnot;
|
||||
print_expr ifnot;
|
||||
print_token ghost ")"
|
||||
|
||||
let rec unpar = function
|
||||
|
||||
@ -216,7 +216,7 @@ and expr =
|
||||
| ETuple of (expr, comma) Utils.nsepseq reg (* e1, e2, ... *)
|
||||
| EPar of expr par reg (* (e) *)
|
||||
| ELetIn of let_in reg (* let p1 = e1 and p2 = e2 and ... in e *)
|
||||
| EFun of fun_expr (* fun x -> e *)
|
||||
| EFun of fun_expr reg (* fun x -> e *)
|
||||
| ECond of conditional reg (* if e1 then e2 else e3 *)
|
||||
| ESeq of sequence (* begin e1; e2; ... ; en end *)
|
||||
|
||||
@ -327,9 +327,19 @@ and 'a case_clause = {
|
||||
rhs : 'a
|
||||
}
|
||||
|
||||
and let_in = kwd_let * let_binding * kwd_in * expr
|
||||
and let_in = {
|
||||
kwd_let : kwd_let;
|
||||
binding : let_binding;
|
||||
kwd_in : kwd_in;
|
||||
body : expr
|
||||
}
|
||||
|
||||
and fun_expr = (kwd_fun * variable * arrow * expr) reg
|
||||
and fun_expr = {
|
||||
kwd_fun : kwd_fun;
|
||||
param : variable;
|
||||
arrow : arrow;
|
||||
body : expr
|
||||
}
|
||||
|
||||
and conditional = {
|
||||
kwd_if : kwd_if;
|
||||
@ -389,11 +399,11 @@ and conditional = {
|
||||
keep the region of the original), and the region of the original
|
||||
"fun" keyword.
|
||||
*)
|
||||
|
||||
(*
|
||||
type sep = Region.t
|
||||
|
||||
val norm : ?reg:(Region.t * kwd_fun) -> pattern Utils.nseq -> sep -> expr -> fun_expr
|
||||
|
||||
*)
|
||||
(* Undoing the above rewritings (for debugging by comparison with the
|
||||
lexer, and to feed the source-to-source transformations with only
|
||||
tokens that originated from the original input.
|
||||
@ -446,21 +456,6 @@ val norm : ?reg:(Region.t * kwd_fun) -> pattern Utils.nseq -> sep -> expr -> fun
|
||||
let f l = let n = l in n
|
||||
*)
|
||||
|
||||
type unparsed = [
|
||||
`Fun of (kwd_fun * (pattern Utils.nseq * arrow * expr))
|
||||
| `Let of (pattern Utils.nseq * equal * expr)
|
||||
| `Idem of expr
|
||||
]
|
||||
|
||||
val unparse : expr -> unparsed
|
||||
|
||||
(* Conversions to type [string] *)
|
||||
|
||||
(*
|
||||
val to_string : t -> string
|
||||
val pattern_to_string : pattern -> string
|
||||
*)
|
||||
|
||||
(* Printing the tokens reconstructed from the AST. This is very useful
|
||||
for debugging, as the output of [print_token ast] can be textually
|
||||
compared to that of [Lexer.trace] (see module [LexerMain]). The
|
||||
@ -468,7 +463,7 @@ val pattern_to_string : pattern -> string
|
||||
the AST to be unparsed before printing (those nodes that have been
|
||||
normalised with function [norm_let] and [norm_fun]). *)
|
||||
|
||||
val print_tokens : ?undo:bool -> ast -> unit
|
||||
val print_tokens : (*?undo:bool ->*) ast -> unit
|
||||
|
||||
|
||||
(* Projecting regions from sundry nodes of the AST. See the first
|
||||
|
||||
@ -10,7 +10,6 @@ let sprintf = Printf.sprintf
|
||||
module Region = Simple_utils.Region
|
||||
module Pos = Simple_utils.Pos
|
||||
module SMap = Utils.String.Map
|
||||
module SSet = Utils.String.Set
|
||||
|
||||
(* Making a natural from its decimal notation (for Tez) *)
|
||||
|
||||
|
||||
@ -3,6 +3,51 @@
|
||||
|
||||
open AST
|
||||
|
||||
(* We rewrite "fun p -> e" into "fun x -> match x with p -> e" *)
|
||||
|
||||
let norm_fun_expr patterns expr =
|
||||
let ghost_of value = Region.{region=ghost; value} in
|
||||
let ghost = Region.ghost in
|
||||
let apply pattern expr =
|
||||
match pattern with
|
||||
PVar var ->
|
||||
let fun_expr = {
|
||||
kwd_fun = ghost;
|
||||
param = var;
|
||||
arrow = ghost;
|
||||
body = expr} in
|
||||
EFun (ghost_of fun_expr)
|
||||
| _ -> let fresh = Utils.gen_sym () |> ghost_of in
|
||||
let clause = {pattern; arrow=ghost; rhs=expr} in
|
||||
let clause = ghost_of clause in
|
||||
let cases = ghost_of (clause, []) in
|
||||
let case = {
|
||||
kwd_match = ghost;
|
||||
expr = EVar fresh;
|
||||
opening = With ghost;
|
||||
lead_vbar = None;
|
||||
cases;
|
||||
closing = End ghost} in
|
||||
let case = ECase (ghost_of case) in
|
||||
let fun_expr = {
|
||||
kwd_fun = ghost;
|
||||
param = fresh;
|
||||
arrow = ghost;
|
||||
body = case}
|
||||
in EFun (ghost_of fun_expr)
|
||||
in Utils.nseq_foldr apply patterns expr
|
||||
|
||||
(*
|
||||
let norm_fun_expr patterns expr =
|
||||
let apply pattern expr =
|
||||
let fun_expr = {
|
||||
kwd_fun = Region.ghost;
|
||||
param = pattern;
|
||||
arrow = Region.ghost;
|
||||
body = expr} in
|
||||
EFun {region=Region.ghost; value=fun_expr}
|
||||
in Utils.nseq_foldr apply patterns expr
|
||||
*)
|
||||
(* END HEADER *)
|
||||
%}
|
||||
|
||||
@ -236,7 +281,7 @@ field_decl:
|
||||
|
||||
let_binding:
|
||||
ident nseq(sub_irrefutable) type_annotation? eq expr {
|
||||
let let_rhs = EFun (norm $2 $4 $5) in
|
||||
let let_rhs = norm_fun_expr $2 $5 in
|
||||
{pattern = PVar $1; lhs_type=$3; eq = Region.ghost; let_rhs}
|
||||
}
|
||||
| irrefutable type_annotation? eq expr {
|
||||
@ -387,12 +432,12 @@ case_clause(right_expr):
|
||||
|
||||
let_expr(right_expr):
|
||||
reg(kwd(Let) let_binding kwd(In) right_expr {$1,$2,$3,$4}) {
|
||||
ELetIn $1 }
|
||||
let Region.{region; value = kwd_let, binding, kwd_in, body} = $1 in
|
||||
let let_in = {kwd_let; binding; kwd_in; body}
|
||||
in ELetIn {region; value=let_in} }
|
||||
|
||||
fun_expr(right_expr):
|
||||
reg(kwd(Fun) nseq(irrefutable) arrow right_expr {$1,$2,$3,$4}) {
|
||||
let Region.{region; value = kwd_fun, patterns, arrow, expr} = $1
|
||||
in EFun (norm ~reg:(region, kwd_fun) patterns arrow expr) }
|
||||
kwd(Fun) nseq(irrefutable) arrow right_expr { norm_fun_expr $2 $4 }
|
||||
|
||||
disj_expr_level:
|
||||
reg(disj_expr) { ELogic (BoolExpr (Or $1)) }
|
||||
|
||||
@ -38,9 +38,7 @@ let tokeniser =
|
||||
let () =
|
||||
try
|
||||
let ast = Parser.program tokeniser buffer in
|
||||
if Utils.String.Set.mem "unparsing" options.verbose then
|
||||
AST.print_tokens ~undo:true ast
|
||||
else () (* AST.print_tokens ast *)
|
||||
AST.print_tokens ast
|
||||
with
|
||||
Lexer.Error diag ->
|
||||
close_in cin; Lexer.prerr ~kind:"Lexical" diag
|
||||
|
||||
@ -2,7 +2,7 @@ open Trace
|
||||
|
||||
module Pascaligo = Parser_pascaligo
|
||||
module Camligo = Parser_camligo
|
||||
(*module Ligodity = Parser_ligodity*)
|
||||
module Ligodity = Parser_ligodity
|
||||
|
||||
open Parser_pascaligo
|
||||
module AST_Raw = Parser_pascaligo.AST
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
parser
|
||||
ast_simplified
|
||||
operators)
|
||||
(modules pascaligo camligo simplify)
|
||||
(modules ligodity pascaligo camligo simplify)
|
||||
(preprocess
|
||||
(pps
|
||||
simple-utils.ppx_let_generalized
|
||||
|
||||
@ -1,8 +1,11 @@
|
||||
[@@@warning "-45"]
|
||||
|
||||
open Trace
|
||||
open Ast_simplified
|
||||
|
||||
module Raw = Parser.Ligodity.AST
|
||||
module SMap = Map.String
|
||||
module Option = Simple_utils.Option
|
||||
|
||||
open Combinators
|
||||
|
||||
@ -17,8 +20,8 @@ let get_value : 'a Raw.reg -> 'a = fun x -> x.value
|
||||
let type_constants = Operators.Simplify.type_constants
|
||||
let constants = Operators.Simplify.constants
|
||||
|
||||
let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
|
||||
match t with
|
||||
let rec simpl_type_expression : Raw.type_expr -> type_expression result =
|
||||
function
|
||||
| TPar x -> simpl_type_expression x.value.inside
|
||||
| TAlias v -> (
|
||||
match List.assoc_opt v.value type_constants with
|
||||
@ -82,7 +85,7 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result
|
||||
ok @@ T_tuple lst
|
||||
|
||||
let rec simpl_expression :
|
||||
?te_annot:_ -> Raw.expr -> ae result = fun ?te_annot t ->
|
||||
?te_annot:type_expression -> Raw.expr -> ae result = fun ?te_annot t ->
|
||||
let return x = ok @@ make_e_a ?type_annotation:te_annot x in
|
||||
let simpl_projection = fun (p:Raw.projection) ->
|
||||
let var =
|
||||
@ -100,8 +103,23 @@ let rec simpl_expression :
|
||||
List.map aux @@ npseq_to_list path in
|
||||
return @@ E_accessor (var, path')
|
||||
in
|
||||
let open Raw in
|
||||
let mk_let_in binder rhs result =
|
||||
E_let_in {binder; rhs; result} in
|
||||
|
||||
match t with
|
||||
| Raw.ELetIn e -> (
|
||||
let Raw.{binding; body; _} = e.value in
|
||||
let Raw.{pattern; lhs_type; let_rhs; _} = binding in
|
||||
let%bind type_annotation = bind_map_option
|
||||
(fun (_,type_expr) -> simpl_type_expression type_expr)
|
||||
lhs_type in
|
||||
let%bind rhs = simpl_expression ?te_annot:type_annotation let_rhs in
|
||||
let%bind body = simpl_expression body in
|
||||
match pattern with
|
||||
Raw.PVar v -> return (mk_let_in v.value rhs body)
|
||||
| _ -> let%bind case = simpl_cases [(pattern, body)]
|
||||
in return (E_matching (rhs, case))
|
||||
)
|
||||
| Raw.EAnnot a -> (
|
||||
let (expr , type_expr) = a.value in
|
||||
match te_annot with
|
||||
@ -207,7 +225,7 @@ let rec simpl_expression :
|
||||
@@ npseq_to_list c.value.cases.value in
|
||||
let%bind cases = simpl_cases lst in
|
||||
return @@ E_matching (e, cases)
|
||||
| _ -> failwith "TOTO"
|
||||
| _ -> failwith "XXX" (* TODO *)
|
||||
|
||||
and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : annotated_expression result =
|
||||
let return x = ok @@ make_e_a ?type_annotation:te_annot x in
|
||||
@ -330,7 +348,8 @@ and simpl_fun_declaration : Raw.fun_decl -> named_expression result = fun x ->
|
||||
let%bind result = simpl_expression return in
|
||||
let%bind output_type = simpl_type_expression ret_type in
|
||||
let body = local_declarations @ instructions in
|
||||
let expression = E_lambda {binder ; input_type ; output_type ; result ; body } in
|
||||
let expression = E_lambda {binder ; input_type = Some input_type;
|
||||
output_type = Some input_type; result ; body } in
|
||||
let type_annotation = Some (T_function (input_type, output_type)) in
|
||||
ok {name;annotated_expression = {expression;type_annotation}}
|
||||
)
|
||||
@ -369,7 +388,8 @@ and simpl_fun_declaration : Raw.fun_decl -> named_expression result = fun x ->
|
||||
|
||||
let body = tpl_declarations @ local_declarations @ instructions in
|
||||
let%bind result = simpl_expression return in
|
||||
let expression = E_lambda {binder ; input_type ; output_type ; result ; body } in
|
||||
let expression = E_lambda {binder ; input_type = Some input_type;
|
||||
output_type = Some output_type; result ; body } in
|
||||
let type_annotation = Some (T_function (input_type, output_type)) in
|
||||
ok {name = name.value;annotated_expression = {expression;type_annotation}}
|
||||
)
|
||||
@ -383,9 +403,22 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu
|
||||
let%bind type_expression = simpl_type_expression type_expr in
|
||||
ok @@ loc x @@ Declaration_type {type_name=name.value;type_expression}
|
||||
| LetEntry _ -> simple_fail "no entry point yet"
|
||||
(* | Let x ->
|
||||
let _, binding = x.value in*)
|
||||
| Let x ->
|
||||
let _, binding = x.value in
|
||||
let {pattern; lhs_type; let_rhs} = binding in
|
||||
let%bind type_annotation = bind_map_option
|
||||
(fun (_,type_expr) -> simpl_type_expression type_expr)
|
||||
lhs_type in
|
||||
let%bind rhs = simpl_expression ?te_annot:type_annotation let_rhs in
|
||||
match pattern with
|
||||
Raw.PVar v ->
|
||||
let name = v.value in
|
||||
let named_expr = {name; annotated_expression=rhs}
|
||||
in return (Declaration_constant named_expr)
|
||||
| _ -> let%bind case = simpl_cases [(pattern, rhs)]
|
||||
in return (Declaration_constant (E_matching (rhs, case)))
|
||||
|
||||
(*
|
||||
| ConstDecl x ->
|
||||
let simpl_const_decl = fun {name;const_type;init} ->
|
||||
let%bind expression = simpl_expression init in
|
||||
@ -400,7 +433,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu
|
||||
ok @@ Declaration_constant x' in
|
||||
bind_map_location (aux simpl_fun_declaration) (Location.lift_region x)
|
||||
| LambdaDecl (ProcDecl _) -> simple_fail "no proc declaration yet"
|
||||
|
||||
*)
|
||||
|
||||
and simpl_statement : Raw.statement -> instruction result = fun s ->
|
||||
match s with
|
||||
|
||||
Loading…
Reference in New Issue
Block a user