tmp

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
 

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"
+

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

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
 

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