AST-12 Implement show : <A>(A -> Text)

src/arrange.ml

@@ -68,6 +68,7 @@ and unop uo = match uo with
   | PosOp -> Atom "PosOp"
   | NegOp -> Atom "NegOp"
   | NotOp -> Atom "NotOp"
+  | ShowOp -> Atom "ShowOp"
 
 and binop bo = match bo with
   | AddOp  -> Atom "AddOp"

src/check_ir.ml

@@ -63,10 +63,12 @@ let with_check_typ check_typ env = { env with check_typ }
 
 (* More error bookkeeping *)
 
+exception CheckFailed of string
+
 let type_error at text : Diag.message = Diag.{ sev = Diag.Error; at; cat = "IR type"; text }
 
 let error env at fmt =
-    Printf.ksprintf (fun s -> failwith (Diag.string_of_message (type_error at s))) fmt
+    Printf.ksprintf (fun s -> raise (CheckFailed (Diag.string_of_message (type_error at s)))) fmt
 
 
 let add_lab c x t = {c with labs = T.Env.add x t c.labs}
@@ -101,7 +103,7 @@ let check env at p =
 let check_sub env at t1 t2 =
   if T.sub t1 t2
   then ()
-  else error env at "subtype violation %s %s" (T.string_of_typ t1) (T.string_of_typ t2)
+  else error env at "subtype violation (%s) (%s)" (T.string_of_typ t1) (T.string_of_typ t2)
 
 let make_mut mut : T.typ -> T.typ =
   match mut.it with
@@ -265,7 +267,9 @@ let rec check_exp env (exp:Ir.exp) : unit =
     check (Operator.has_unop ot op) "unary operator is not defined for operand type";
     check_exp env exp1;
     typ exp1 <: ot;
-    ot <: t;
+    if op = Syntax.ShowOp
+    then T.Prim T.Text <: t
+    else ot <: t
   | BinE (ot, exp1, op, exp2) ->
     check (Operator.has_binop ot op) "binary operator is not defined for operand type";
     check_exp env exp1;
@@ -766,5 +770,9 @@ and gather_dec env scope dec : scope =
 (* Programs *)
 
 let check_prog env prog : unit =
-  check_block env T.unit prog.it prog.at
+  try
+   check_block env T.unit prog.it prog.at
+  with CheckFailed s ->
+    Wasm.Sexpr.print 80 (Arrange_ir.prog prog);
+    failwith s
 

src/lexer.mll

@@ -200,6 +200,7 @@ rule token mode = parse
   | "private" { PRIVATE }
   | "return" { RETURN }
   | "shared" { SHARED }
+  | "show" { SHOW }
   | "switch" { SWITCH }
   | "true" { BOOL true }
   | "type" { TYPE }

src/operator.ml

@@ -22,15 +22,13 @@ let num_unop fint fword8 fword16 fword32 fword64 ffloat = function
   | t -> word_unop fword8 fword16 fword32 fword64 t
 
 let unop t op =
-  match t with
-  | T.Prim p ->
-    (match op with
-    | PosOp -> let id v = v in num_unop id id id id id id p
-    | NegOp -> num_unop Int.neg Word8.neg Word16.neg Word32.neg Word64.neg Float.neg p
-    | NotOp -> word_unop Word8.not Word16.not Word32.not Word64.not p
-    )
-  | T.Non -> impossible
-  | _ -> raise (Invalid_argument "unop")
+  match t, op with
+  | T.Prim p, PosOp -> let id v = v in num_unop id id id id id id p
+  | T.Prim p, NegOp -> num_unop Int.neg Word8.neg Word16.neg Word32.neg Word64.neg Float.neg p
+  | T.Prim p, NotOp -> word_unop Word8.not Word16.not Word32.not Word64.not p
+  | t, ShowOp when Show.can_show t -> fun v -> Text (Show.show_val t v)
+  | T.Non, _ -> impossible
+  | _, _ -> raise (Invalid_argument "unop")
 
 
 (* Binary operators *)

src/parser.mly

@@ -98,6 +98,7 @@ let share_expfield (ef : exp_field) =
 %token FUNC TYPE OBJECT ACTOR CLASS PRIVATE NEW SHARED
 %token SEMICOLON SEMICOLON_EOL COMMA COLON SUB DOT QUEST
 %token AND OR NOT 
+%token SHOW
 %token ASSERT
 %token ADDOP SUBOP MULOP DIVOP MODOP POWOP
 %token ANDOP OROP XOROP SHLOP SHROP ROTLOP ROTROP
@@ -367,6 +368,8 @@ exp_un :
     { assign_op e (fun e' -> UnE(ref Type.Pre, op, e') @? at $sloc) (at $sloc) }
   | NOT e=exp_un
     { NotE e @? at $sloc }
+  | SHOW e=exp_un
+    { UnE (ref Type.Pre, ShowOp, e) @? at $sloc }
 
 exp_bin :
   | e=exp_un

src/pipeline.ml

@@ -136,6 +136,9 @@ let async_lowering =
 let tailcall_optimization =
   transform_ir "Tailcall optimization" Tailcall.transform
 
+let show_translation =
+  transform_ir "Translate show" Show_pass.transform
+
 let check_with parse infer senv name : check_result =
   match parse name with
   | Error e -> Error [e]
@@ -167,7 +170,8 @@ let interpret_prog (senv,denv) name prog : (Value.value * Interpret.scope) optio
       then
         let prog_ir = Desugar.transform senv prog in
         let prog_ir = await_lowering (!Flags.await_lowering) senv prog_ir name in
-        let prog_ir = async_lowering (!Flags.await_lowering && !Flags.async_lowering) senv prog_ir name in 
+        let prog_ir = async_lowering (!Flags.await_lowering && !Flags.async_lowering) senv prog_ir name in
+        let prog_ir = show_translation true senv prog_ir name in
         Interpret_ir.interpret_prog denv prog_ir
       else Interpret.interpret_prog denv prog in
     match vo with
@@ -293,6 +297,7 @@ let compile_with check mode name : compile_result =
     let prog = await_lowering true initial_stat_env prog name in
     let prog = async_lowering true initial_stat_env prog name in
     let prog = tailcall_optimization true initial_stat_env prog name in
+    let prog = show_translation true initial_stat_env prog name in
     phase "Compiling" name;
     let module_ = Compile.compile mode name prelude [prog] in
     Ok module_

src/prelude.ml

@@ -34,6 +34,94 @@ class revrange(x : Nat, y : Nat) {
 func printInt(x : Int) { (prim "printInt" : Int -> ()) x };
 func print(x : Text) { (prim "print" : Text -> ()) x };
 
+// Internal helper functions for the show translation
+
+// The @ in the name ensures that this connot be shadowed by user code, so
+// compiler passes can rely on them being in scope
+// The text_of functions do not need to be exposed; the user can just use
+// the show above.
+
+func @text_of_Nat(x : Nat) : Text {
+  var text = "";
+  var n = x;
+  let base = 10;
+
+  while (n > 0) {
+    let rem = n % base;
+    text := (switch (rem) {
+      case (0) { "0" };
+      case (1) { "1" };
+      case (2) { "2" };
+      case (3) { "3" };
+      case (4) { "4" };
+      case (5) { "5" };
+      case (6) { "6" };
+      case (7) { "7" };
+      case (8) { "8" };
+      case (9) { "9" };
+      case (_) { assert false; "" };
+    }) # text;
+    n := n / base;
+  };
+  return text;
+};
+
+func @text_of_Int(x : Int) : Text {
+  if (x == 0) {
+    return "0";
+  };
+  if (x < 0) {
+    "-" # @text_of_Nat(abs x)
+  } else {
+    @text_of_Nat(abs x)
+  }
+};
+
+func @text_of_Bool(b : Bool) : Text {
+  if (b) "true" else "false"
+};
+
+func @text_of_Text(t : Text) : Text {
+  // TODO: Escape properly
+  "\"" # t # "\"";
+};
+
+func @text_option<T>(f : T -> Text, x : ?T) : Text {
+  switch (x) {
+    case (?y) {"?(" # f y # ")"};
+    case null {"null"};
+  }
+};
+
+func @text_array<T>(f : T -> Text, xs : [T]) : Text {
+  var text = "";
+  for (x in xs.vals()) {
+    if (text == "") {
+      text := text # "[";
+    } else {
+      text := text # ", ";
+    };
+    text := text # f x;
+  };
+  text := text # "]";
+  return text;
+};
+
+func @text_array_mut<T>(f : T -> Text, xs : [var T]) : Text {
+  var text = "";
+  for (x in xs.vals()) {
+    if (text == "") {
+      text := text # "[var ";
+    } else {
+      text := text # ", ";
+    };
+    text := text # f x;
+  };
+  text := text # "]";
+  return text;
+};
+
+// Array utilities
 
 // This would be nicer as a objects, but lets do them as functions
 // until the compiler has a concept of “static objects”

src/show.ml

@@ -0,0 +1,65 @@
+(*
+Specification for `show`: Type predicate and reference implementation
+
+The actual show-lowering pass is in in Show_pass, because Show_pass imports
+check_ir, but check_ir needs can_show
+*)
+
+module T = Type
+
+(* Entry point for type checking: *)
+
+let rec can_show t =
+  let t = T.normalize t in
+  match t with
+  | T.Prim T.Bool
+  | T.Prim T.Nat
+  | T.Prim T.Int
+  | T.Prim T.Text
+  | T.Prim T.Null -> true
+  | T.Tup ts' -> List.for_all can_show ts'
+  | T.Opt t' -> can_show t'
+  | T.Array t' -> can_show (T.as_immut t')
+  | T.Obj (T.Object _, fs) ->
+    List.for_all (fun f -> can_show (T.as_immut f.T.typ)) fs
+  | _ -> false
+
+(* Entry point for the interpreter (reference implementation) *)
+
+let rec show_val t v =
+  let t = T.normalize t in
+  match t, v with
+  | T.Prim T.Bool, Value.Bool b -> if b then "true" else "false"
+  | T.Prim T.Nat, Value.Int i -> Value.Int.to_string i
+  | T.Prim T.Int, Value.Int i -> Value.Int.to_string i
+  | T.Prim T.Text, Value.Text s -> "\"" ^ s ^ "\""
+  | T.Prim T.Null, Value.Null -> "null"
+  | T.Opt _, Value.Null -> "null"
+  | T.Opt t', Value.Opt v -> "?(" ^ show_val t' v ^ ")"
+  | T.Tup ts', Value.Tup vs ->
+    Printf.sprintf "(%s%s)"
+      (String.concat ", " (List.map2 show_val ts' vs))
+      (if List.length vs = 1 then "," else "")
+  | T.Array (T.Mut t'), Value.Array a ->
+    Printf.sprintf "[var %s]"
+      (String.concat ", " (List.map (fun v -> show_val t' !(Value.as_mut v)) (Array.to_list a)))
+  | T.Array t', Value.Array a ->
+    Printf.sprintf "[%s]"
+      (String.concat ", " (List.map (show_val t') (Array.to_list a)))
+  | T.Obj (_, fts), Value.Obj fs ->
+    Printf.sprintf "{%s}" (String.concat "; " (List.map (show_field fs) fts))
+  | _ ->
+    Printf.eprintf "show_val: %s : %s\n" (Value.string_of_val v) (T.string_of_typ t);
+    assert false
+
+and show_field fs ft =
+  let v = Value.Env.find ft.T.name fs in
+  let m, t', v' =
+    match ft.T.typ with
+    | T.Mut t' -> "var ", t', !(Value.as_mut  v)
+    | t' -> "", t', v
+  in
+  (* With types:
+  Printf.sprintf "%s%s : %s = %s" m ft.T.name (T.string_of_typ t') (show_val t' v')
+  *)
+  Printf.sprintf "%s = %s" ft.T.name (show_val t' v')

src/show.mli

@@ -0,0 +1,2 @@
+val can_show : Type.typ -> bool
+val show_val : Type.typ -> Value.value -> string