diff --git a/src/ligo/ast_simplified.ml b/src/ligo/ast_simplified.ml index 587a0ed3c..62da3bfc8 100644 --- a/src/ligo/ast_simplified.ml +++ b/src/ligo/ast_simplified.ml @@ -96,12 +96,76 @@ and matching = match_none : b ; match_some : name * b ; } - | Match_tuple of (name * b) list + | Match_tuple of name list * b let ae expression = {expression ; type_annotation = None} open Ligo_helpers.Trace +module PP = struct + open Ligo_helpers.PP + open Format + + let rec type_expression ppf (te:type_expression) = match te with + | Type_tuple lst -> fprintf ppf "tuple[%a]" (list_sep type_expression) lst + | Type_sum m -> fprintf ppf "sum[%a]" (smap_sep type_expression) m + | Type_record m -> fprintf ppf "record[%a]" (smap_sep type_expression) m + | Type_function (p, r) -> fprintf ppf "%a -> %a" type_expression p type_expression r + | Type_variable name -> fprintf ppf "%s" name + | Type_constant (name, lst) -> fprintf ppf "%s(%a)" name (list_sep type_expression) lst + + let literal ppf (l:literal) = match l with + | Unit -> fprintf ppf "Unit" + | Bool b -> fprintf ppf "%b" b + | Number n -> fprintf ppf "%d" n + | String s -> fprintf ppf "%S" s + | Bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b + + let rec expression ppf (e:expression) = match e with + | Literal l -> literal ppf l + | Variable name -> fprintf ppf "%s" name + | Application (f, arg) -> fprintf ppf "(%a) (%a)" annotated_expression f annotated_expression arg + | Constructor (name, ae) -> fprintf ppf "%s(%a)" name annotated_expression ae + | Constant (name, lst) -> fprintf ppf "%s(%a)" name (list_sep annotated_expression) lst + | Tuple lst -> fprintf ppf "tuple[%a]" (list_sep annotated_expression) lst + | Tuple_accessor (ae, i) -> fprintf ppf "%a.%d" annotated_expression ae i + | Record m -> fprintf ppf "record[%a]" (smap_sep annotated_expression) m + | Record_accessor (ae, s) -> fprintf ppf "%a.%s" annotated_expression ae s + | Lambda {binder;input_type;output_type;result;body} -> + fprintf ppf "lambda (%s:%a) : %a {%a} return %a" + binder type_expression input_type type_expression output_type + block body annotated_expression result + + and annotated_expression ppf (ae:annotated_expression) = match ae.type_annotation with + | None -> fprintf ppf "%a" expression ae.expression + | Some t -> fprintf ppf "(%a) : %a" expression ae.expression type_expression t + + and block ppf (b:block) = (list_sep instruction) ppf b + + and single_record_patch ppf ((s, ae) : string * ae) = + fprintf ppf "%s <- %a" s annotated_expression ae + + and matching ppf (m:matching) = match m with + | Match_tuple (lst, b) -> + fprintf ppf "let (%a) = %a" (list_sep (fun ppf -> fprintf ppf "%s")) lst block b + | Match_bool {match_true ; match_false} -> + fprintf ppf "| True -> %a @.| False -> %a" block match_true block match_false + | Match_list {match_nil ; match_cons = (hd, tl, match_cons)} -> + fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" block match_nil hd tl block match_cons + | Match_option {match_none ; match_some = (some, match_some)} -> + fprintf ppf "| None -> %a @.| Some %s -> %a" block match_none some block match_some + + and instruction ppf (i:instruction) = match i with + | Skip -> fprintf ppf "skip" + | Fail ae -> fprintf ppf "fail with (%a)" annotated_expression ae + | Record_patch (ae, lst) -> fprintf ppf "%a.[%a]" annotated_expression ae (list_sep single_record_patch) lst + | Loop (cond, b) -> fprintf ppf "while (%a) { %a }" annotated_expression cond block b + | Assignment {name;annotated_expression = ae} -> + fprintf ppf "%s := %a" name annotated_expression ae + | Matching (ae, m) -> + fprintf ppf "match %a with %a" annotated_expression ae matching m +end + module Simplify = struct module Raw = Ligo_parser.AST diff --git a/src/ligo/ast_typed.ml b/src/ligo/ast_typed.ml index 84dd88845..5c303e1e7 100644 --- a/src/ligo/ast_typed.ml +++ b/src/ligo/ast_typed.ml @@ -194,6 +194,18 @@ let t_unit : type_value = Type_constant ("unit", []) let get_annotation (x:annotated_expression) = x.type_annotation +let get_t_bool : type_value -> unit result = function + | Type_constant ("bool", []) -> ok () + | _ -> simple_fail "not a bool" + +let get_t_option : type_value -> type_value result = function + | Type_constant ("option", [o]) -> ok o + | _ -> simple_fail "not a option" + +let get_t_list : type_value -> type_value result = function + | Type_constant ("list", [o]) -> ok o + | _ -> simple_fail "not a list" + let get_t_tuple : type_value -> type_value list result = function | Type_tuple lst -> ok lst | _ -> simple_fail "not a tuple" @@ -205,3 +217,4 @@ let get_t_sum : type_value -> type_value SMap.t result = function let get_t_record : type_value -> type_value SMap.t result = function | Type_record m -> ok m | _ -> simple_fail "not a record" + diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml index 91186eac6..a1c376676 100644 --- a/src/ligo/ligo.ml +++ b/src/ligo/ligo.ml @@ -47,9 +47,40 @@ let parse (s:string) : AST_Raw.t result = ) @@ (fun () -> Parser.contract read lexbuf) >>? fun program_cst -> ok program_cst +let parse_expression (s:string) : AST_Raw.expr result = + let lexbuf = Lexing.from_string s in + let Lexer.{read ; _} = + Lexer.open_token_stream None in + specific_try (function + | Parser.Error -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in + simple_error str + ) + | _ -> simple_error "unrecognized parse_ error" + ) @@ (fun () -> Parser.interactive_expr read lexbuf) >>? fun expr -> + ok expr let simplify (p:AST_Raw.t) : Ast_simplified.program result = AST_Simplified.Simplify.simpl_program p +let simplify_expr (e:AST_Raw.expr) : Ast_simplified.annotated_expression result = AST_Simplified.Simplify.simpl_expression e +let unparse_simplified_expr (e:AST_Simplified.annotated_expression) : string result = + ok @@ Format.asprintf "%a" AST_Simplified.PP.annotated_expression e let type_ (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p +let type_expression ?(env:Typer.Environment.t = Typer.Environment.empty) + (e:AST_Simplified.annotated_expression) : AST_Typed.annotated_expression result = + Typer.type_annotated_expression env e +let untype_expression (e:AST_Typed.annotated_expression) : AST_Simplified.annotated_expression = Typer.untype_annotated_expression e let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p +let transpile_expression ?(env:Mini_c.Environment.t = Mini_c.Environment.empty) + (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression env e +let transpile_value ?(env:Mini_c.Environment.t = Mini_c.Environment.empty) + (e:AST_Typed.annotated_expression) : Mini_c.expression result = + let%bind e = Transpiler.translate_annotated_expression env e in + Mini_c.expression_to_value e diff --git a/src/ligo/mini_c.ml b/src/ligo/mini_c.ml index 5c0c1b449..691f70170 100644 --- a/src/ligo/mini_c.ml +++ b/src/ligo/mini_c.ml @@ -99,6 +99,11 @@ and block = block' * environment (* Environment at the beginning of the block *) and program = toplevel_statement list +let expression_to_value ((e, _, _):expression) : value result = + match e with + | Literal v -> ok v + | _ -> simple_fail "not a value" + module PP = struct open Format diff --git a/src/ligo/typer.ml b/src/ligo/typer.ml index af3700759..a1b1be6d9 100644 --- a/src/ligo/typer.ml +++ b/src/ligo/typer.ml @@ -125,27 +125,42 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc ok (e', O.Assignment {name;annotated_expression}) ) | Matching (ex, m) -> - let%bind m' = type_match e m in let%bind ex' = type_annotated_expression e ex in + let%bind m' = type_match e ex'.type_annotation m in ok (e, O.Matching (ex', m')) | Record_patch _ -> simple_fail "no record_patch yet" -and type_match (e:environment) : I.matching -> O.matching result = function +and type_match (e:environment) (t:O.type_value) : I.matching -> O.matching result = function | Match_bool {match_true ; match_false} -> + let%bind _ = + trace_strong (simple_error "Matching bool on not-a-bool") + @@ O.get_t_bool t in let%bind match_true = type_block e match_true in let%bind match_false = type_block e match_false in ok (O.Match_bool {match_true ; match_false}) | Match_option {match_none ; match_some} -> + let%bind t_opt = + trace_strong (simple_error "Matching option on not-an-option") + @@ O.get_t_option t in let%bind match_none = type_block e match_none in let (n, b) = match_some in - let%bind b' = type_block e b in + let e' = Environment.add e n t_opt in + let%bind b' = type_block e' b in ok (O.Match_option {match_none ; match_some = (n, b')}) | Match_list {match_nil ; match_cons} -> + let%bind t_list = + trace_strong (simple_error "Matching list on not-an-list") + @@ O.get_t_list t in let%bind match_nil = type_block e match_nil in - let (n, m, b) = match_cons in - let%bind b' = type_block e b in - ok (O.Match_list {match_nil ; match_cons = (n, m, b')}) - | Match_tuple lst -> + let (hd, tl, b) = match_cons in + let e' = Environment.add e hd t_list in + let e' = Environment.add e' tl t in + let%bind b' = type_block e' b in + ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')}) + | Match_tuple (lst, b) -> + let%bind lst = + trace_strong (simple_error "Matching tuple on not-a-tuple") + get_tuple let aux (x, y) = let%bind y = type_block e y in ok (x, y) in