diff --git a/src/parser/dune b/src/parser/dune index e08c2915a..eb7dca130 100644 --- a/src/parser/dune +++ b/src/parser/dune @@ -6,7 +6,7 @@ tezos-utils parser_pascaligo parser_camligo -;; parser_ligodity + parser_ligodity ) (preprocess (pps simple-utils.ppx_let_generalized) diff --git a/src/parser/ligodity/.links b/src/parser/ligodity/.links index 34a1424ad..8af33d655 100644 --- a/src/parser/ligodity/.links +++ b/src/parser/ligodity/.links @@ -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 diff --git a/src/parser/ligodity/AST.ml b/src/parser/ligodity/AST.ml index 9e24fc74b..dad6d82c7 100644 --- a/src/parser/ligodity/AST.ml +++ b/src/parser/ligodity/AST.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,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 diff --git a/src/parser/ligodity/AST.mli b/src/parser/ligodity/AST.mli index b2fe8024c..74ab48e91 100644 --- a/src/parser/ligodity/AST.mli +++ b/src/parser/ligodity/AST.mli @@ -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 diff --git a/src/parser/ligodity/Lexer.mll b/src/parser/ligodity/Lexer.mll index d3f92a382..a36b64833 100644 --- a/src/parser/ligodity/Lexer.mll +++ b/src/parser/ligodity/Lexer.mll @@ -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) *) diff --git a/src/parser/ligodity/Parser.mly b/src/parser/ligodity/Parser.mly index 052edc526..bae729da0 100644 --- a/src/parser/ligodity/Parser.mly +++ b/src/parser/ligodity/Parser.mly @@ -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)) } diff --git a/src/parser/ligodity/ParserMain.ml b/src/parser/ligodity/ParserMain.ml index cfa5c19d0..fbfd4789c 100644 --- a/src/parser/ligodity/ParserMain.ml +++ b/src/parser/ligodity/ParserMain.ml @@ -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 diff --git a/src/parser/ligodity/Stubs/Tezos_utils.ml b/src/parser/ligodity/Stubs/Simple_utils.ml similarity index 100% rename from src/parser/ligodity/Stubs/Tezos_utils.ml rename to src/parser/ligodity/Stubs/Simple_utils.ml diff --git a/src/parser/parser.ml b/src/parser/parser.ml index b4df5be84..1a259af0f 100644 --- a/src/parser/parser.ml +++ b/src/parser/parser.ml @@ -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 diff --git a/src/simplify/dune b/src/simplify/dune index 5402076af..7035f2eef 100644 --- a/src/simplify/dune +++ b/src/simplify/dune @@ -7,7 +7,7 @@ parser ast_simplified operators) - (modules pascaligo camligo simplify) + (modules ligodity pascaligo camligo simplify) (preprocess (pps simple-utils.ppx_let_generalized diff --git a/src/simplify/ligodity.ml b/src/simplify/ligodity.ml index ecd7a55e2..b2e6d1fd5 100644 --- a/src/simplify/ligodity.ml +++ b/src/simplify/ligodity.ml @@ -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