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

Refactored the AST and fixed the symlinks.

Browse Source
This commit is contained in:
Christian Rinderknecht 2019-05-20 21:42:11 +02:00
parent e48a5fde28
commit 331b11dcca
No known key found for this signature in database
GPG Key ID: 9446816CFD267040
11 changed files with 219 additions and 224 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/parser/dune
View File

@ -6,7 +6,7 @@
tezos-utils
parser_pascaligo
parser_camligo
;; parser_ligodity
parser_ligodity
)
(preprocess
(pps simple-utils.ppx_let_generalized)

10
src/parser/ligodity/.links
View File

@ -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

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

@ -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,17 +318,27 @@ 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;
test : expr;
kwd_then : kwd_then;
ifso : expr;
kwd_else : kwd_else;
ifnot : expr
kwd_if : kwd_if;
test : expr;
kwd_then : kwd_then;
ifso : expr;
kwd_else : kwd_else;
ifnot : expr
}
(* Projecting regions of the input source code *)
@ -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

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

@ -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

1
src/parser/ligodity/Lexer.mll
View File

@ -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) *)

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

@ -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 {
@ -255,13 +300,13 @@ sub_irrefutable:
ident { PVar $1 }
| wild { PWild $1 }
| unit { PUnit $1 }
| par(closed_irrefutable) { PPar $1 }
| par(closed_irrefutable) { PPar $1 }
closed_irrefutable:
reg(tuple(sub_irrefutable)) { PTuple $1 }
| sub_irrefutable { $1 }
| reg(constr_pattern) { PConstr $1 }
| reg(typed_pattern) { PTyped $1 }
reg(tuple(sub_irrefutable)) { PTuple $1 }
| sub_irrefutable { $1 }
| reg(constr_pattern) { PConstr $1 }
| reg(typed_pattern) { PTyped $1 }
typed_pattern:
irrefutable colon type_expr { {pattern=$1; colon=$2; type_expr=$3} }
@ -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)) }

4
src/parser/ligodity/ParserMain.ml
View File

@ -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

0
src/parser/ligodity/Stubs/Tezos_utils.ml → src/parser/ligodity/Stubs/Simple_utils.ml
View File

2
src/parser/parser.ml
View File

@ -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

2
src/simplify/dune
View File

@ -7,7 +7,7 @@
parser
ast_simplified
operators)
(modules pascaligo camligo simplify)
(modules ligodity pascaligo camligo simplify)
(preprocess
(pps
simple-utils.ppx_let_generalized

53
src/simplify/ligodity.ml
View File

@ -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