feat: use static type information for pretty-printing values (#4471)

* Modifies `pp_val` and related functions to receive type information (using `Type.Non` for the original behavior).
* Displays a text representation for actor IDs. For example: `` `ys6dh-5cjiq-5dc` : actor {...}``

Resolves #776.
Resolves #4470.

src/ir_interpreter/interpret_ir.ml

@@ -80,8 +80,8 @@ let trace fmt =
     Printf.printf "%s%s\n%!" (String.make (2 * !trace_depth) ' ') s
   ) fmt
 
-let string_of_val env = V.string_of_val env.flags.print_depth
-let string_of_def flags = V.string_of_def flags.print_depth
+let string_of_val env = V.string_of_val env.flags.print_depth T.Non
+let string_of_def flags = V.string_of_def flags.print_depth T.Non
 let string_of_arg env = function
   | V.Tup _ as v -> string_of_val env v
   | v -> "(" ^ string_of_val env v ^ ")"
@@ -643,7 +643,7 @@ and match_args at args v : val_env =
   | _ ->
     let vs = V.as_tup v in
     if (List.length vs <> List.length args) then
-      failwith (Printf.sprintf "%s %s" (Source.string_of_region at) (V.string_of_val 0 v));
+      failwith (Printf.sprintf "%s %s" (Source.string_of_region at) (V.string_of_val 0 T.Non v));
     List.fold_left V.Env.adjoin V.Env.empty (List.map2 match_arg args vs)
 
 (* Patterns *)

src/mo_frontend/coverage.ml

@@ -126,7 +126,7 @@ let rec expand_nottag tfs n ls : desc list =
 (* TODO: pretty print *)
 let rec string_of_desc t = function
   | Any -> "_"
-  | Val v -> V.string_of_val 100 v
+  | Val v -> V.string_of_val 100 t v
   | NotVal vs -> string_of_descs t (expand_notval (T.promote t) 0 vs)
   | Tup descs ->
     let ts = T.as_tup_sub (List.length descs) t in

src/mo_interpreter/interpret.ml

@@ -92,8 +92,8 @@ let trace fmt =
     Printf.printf "%s%s\n%!" (String.make (2 * !trace_depth) ' ') s
   ) fmt
 
-let string_of_val env = V.string_of_val env.flags.print_depth
-let string_of_def flags = V.string_of_def flags.print_depth
+let string_of_val env = V.string_of_val env.flags.print_depth T.Non
+let string_of_def flags = V.string_of_def flags.print_depth T.Non
 let string_of_arg env = function
   | V.Tup _ as v -> string_of_val env v
   | v -> "(" ^ string_of_val env v ^ ")"

src/mo_values/show.ml

@@ -83,7 +83,7 @@ let rec show_val t v =
     end
   | _ ->
     Format.eprintf "@[show_val: %a : %a@.@]"
-      (Value.pp_val 2) v
+      (Value.pp_val 2) (t, v)
       T.pp_typ t;
     assert false
 

src/mo_values/value.ml

@@ -1,4 +1,5 @@
 open Numerics
+module T = Mo_types.Type
 
 (* Environments *)
 
@@ -180,75 +181,113 @@ let comma ppf () = fprintf ppf ",@ "
 
 let semi ppf () = fprintf ppf ";@ "
 
-let rec pp_val_nullary d ppf = function
-  | Null -> pr ppf "null"
-  | Bool b -> pr ppf (if b then "true" else "false")
-  | Int n when Int.(ge n zero) -> pr ppf (Int.to_pretty_string n)
-  | Int8 n when Int_8.(n = zero) -> pr ppf (Int_8.to_pretty_string n)
-  | Int16 n when Int_16.(n = zero) -> pr ppf (Int_16.to_pretty_string n)
-  | Int32 n when Int_32.(n = zero) -> pr ppf (Int_32.to_pretty_string n)
-  | Int64 n when Int_64.(n = zero) -> pr ppf (Int_64.to_pretty_string n)
-  | Nat8 n -> pr ppf (Nat8.to_pretty_string n)
-  | Nat16 n -> pr ppf (Nat16.to_pretty_string n)
-  | Nat32 n -> pr ppf (Nat32.to_pretty_string n)
-  | Nat64 n -> pr ppf (Nat64.to_pretty_string n)
-  | Float f -> pr ppf (Float.to_pretty_string f)
-  | Char c ->  pr ppf (string_of_string '\'' [c] '\'')
-  | Text t -> pr ppf (string_of_string '\"' (Lib.Utf8.decode t) '\"')
-  | Blob b -> pr ppf ("\"" ^ Blob.escape b ^ "\"")
-  | Tup vs ->
-    fprintf ppf "@[<1>(%a%s)@]"
-      (pp_print_list ~pp_sep:comma (pp_val d)) vs
-      (if List.length vs = 1 then "," else "")
-  | Obj ve ->
-    if d = 0 then pr ppf "{...}" else
-    fprintf ppf "@[<hv 2>{@;<0 0>%a@;<0 -2>}@]"
-      (pp_print_list ~pp_sep:semi (pp_field d)) (Env.bindings ve)
-  | Array a ->
-    fprintf ppf "@[<1>[%a]@]"
-      (pp_print_list ~pp_sep:comma (pp_val d)) (Array.to_list a)
-  | Func (_, _) -> pr ppf "func"
-  | Comp _ -> pr ppf "async*"
-  | v ->
-    (* "(" ^ string_of_val d v ^ ")" *)
-    fprintf ppf "@[<1>(%a)@]" (pp_val d) v
-
-and pp_field d ppf (lab, v) =
-    fprintf ppf "@[<2>%s =@ %a@]" lab (pp_val d) v
-
-and pp_val d ppf = function
-  | Int i -> pr ppf (Int.to_pretty_string i)
-  | Int8 i -> pr ppf (Int_8.(pos_sign (gt i zero) ^ to_pretty_string i))
-  | Int16 i -> pr ppf (Int_16.(pos_sign (gt i zero) ^ to_pretty_string i))
-  | Int32 i -> pr ppf (Int_32.(pos_sign (gt i zero) ^ to_pretty_string i))
-  | Int64 i -> pr ppf (Int_64.(pos_sign (gt i zero) ^ to_pretty_string i))
-  | Opt v -> fprintf ppf "@[<1>?%a@]" (pp_val_nullary d) v
-  | Variant (l, Tup []) -> fprintf ppf "#%s" l
-  | Variant (l, Tup vs) -> fprintf ppf "@[#%s@;<0 1>%a@]" l (pp_val d) (Tup vs)
-  | Variant (l, v) -> fprintf ppf "@[#%s@;<0 1>(%a)@]" l (pp_val d) v
-  | Async {result; waiters = []} ->
-    fprintf ppf "@[<2>async@ %a@]" (pp_res d) result
-  | Async {result; waiters} ->
-    fprintf ppf "@[<2>async[%d]@ %a@]"
-      (List.length waiters) (pp_res d) result
-  | Mut r -> pp_val d ppf !r
-  | v -> pp_val_nullary d ppf v
-
-and pp_res d ppf result =
+let rec pp_val_nullary d ppf (t, v : T.typ * value) =
+  match T.normalize t with
+  | T.Any -> pr ppf "<any>"
+  | t ->
+    match v with
+    | Null -> pr ppf "null"
+    | Bool b -> pr ppf (if b then "true" else "false")
+    | Int n when Int.(ge n zero) -> pr ppf (Int.to_pretty_string n)
+    | Int8 n when Int_8.(n = zero) -> pr ppf (Int_8.to_pretty_string n)
+    | Int16 n when Int_16.(n = zero) -> pr ppf (Int_16.to_pretty_string n)
+    | Int32 n when Int_32.(n = zero) -> pr ppf (Int_32.to_pretty_string n)
+    | Int64 n when Int_64.(n = zero) -> pr ppf (Int_64.to_pretty_string n)
+    | Nat8 n -> pr ppf (Nat8.to_pretty_string n)
+    | Nat16 n -> pr ppf (Nat16.to_pretty_string n)
+    | Nat32 n -> pr ppf (Nat32.to_pretty_string n)
+    | Nat64 n -> pr ppf (Nat64.to_pretty_string n)
+    | Float f -> pr ppf (Float.to_pretty_string f)
+    | Char c ->  pr ppf (string_of_string '\'' [c] '\'')
+    | Text t -> pr ppf (string_of_string '\"' (Lib.Utf8.decode t) '\"')
+    | Blob b ->
+      (match t with
+         T.Obj (T.Actor, _) ->
+         pr ppf (string_of_string '`' (Lib.Utf8.decode (Ic.Url.encode_principal b)) '`')
+       | _ -> pr ppf ("\"" ^ Blob.escape b ^ "\""))
+    | Tup vs ->
+      let list = match t with
+      | T.Tup ts -> List.combine ts vs
+      | _ -> List.map (fun v -> (T.Non, v)) vs in
+      fprintf ppf "@[<1>(%a%s)@]"
+        (pp_print_list ~pp_sep:comma (pp_val d)) list
+        (if List.length vs = 1 then "," else "")
+    | Obj ve ->
+      if d = 0 then pr ppf "{...}" else
+      let sort, lookup = match t with
+        | T.Obj (s, fs) ->
+          T.string_of_obj_sort s,
+          fun lab -> T.lookup_val_field_opt lab fs
+        | _ ->
+          "", fun lab -> Some T.Non
+      in
+      fprintf ppf "@[<hv 2>%a{@;<0 0>%a@;<0 -2>}@]"
+        pr sort
+        (pp_print_list ~pp_sep:semi (pp_field d)) (List.filter_map (fun (lab, v) ->
+            match lookup lab with
+            | Some t -> Some (lab, t, v)
+            | None -> None)
+          (Env.bindings ve))
+    | Array vs ->
+      let t' = match t with T.Array t' -> t' | _ -> T.Non in
+      fprintf ppf "@[<1>[%a%a]@]"
+        pr (match t' with T.Mut t -> "var " | _ -> "")
+        (pp_print_list ~pp_sep:comma (pp_val d)) (List.map (fun v -> (t', v)) (Array.to_list vs))
+
+    | Func (_, _) -> pr ppf "<func>"
+    | Comp _ -> pr ppf "<async*>"
+    | v ->
+      fprintf ppf "@[<1>(%a)@]" (pp_val d) (t, v)
+
+and pp_field d ppf (lab, t, v) =
+  fprintf ppf "@[<2>%s =@ %a@]" lab (pp_val d) (t, v)
+
+and pp_val d ppf (t, v) =
+  match T.normalize t with
+  | T.Any -> pr ppf "<any>"
+  | t ->
+    match v with
+    | Int i -> pr ppf (Int.to_pretty_string i)
+    | Int8 i -> pr ppf (Int_8.(pos_sign (gt i zero) ^ to_pretty_string i))
+    | Int16 i -> pr ppf (Int_16.(pos_sign (gt i zero) ^ to_pretty_string i))
+    | Int32 i -> pr ppf (Int_32.(pos_sign (gt i zero) ^ to_pretty_string i))
+    | Int64 i -> pr ppf (Int_64.(pos_sign (gt i zero) ^ to_pretty_string i))
+    | Opt v ->
+      let t' = match t with T.Opt t' -> t' | _ -> T.Non in
+      fprintf ppf "@[<1>?%a@]" (pp_val_nullary d) (t', v)
+    | Variant (l, Tup []) -> fprintf ppf "#%s" l
+    | Variant (l, v) ->
+      let t' = match t with T.Variant fs -> T.lookup_val_field l fs | _ -> T.Non in
+      (match v with
+      | Tup vs -> fprintf ppf "@[#%s@;<0 1>%a@]" l (pp_val d) (t', Tup vs)
+      | _ -> fprintf ppf "@[#%s@;<0 1>(%a)@]" l (pp_val d) (t', v))
+    | Async {result; waiters = []} ->
+      let t' = match t with T.Async (_, _, t') -> t' | _ -> T.Non in
+      fprintf ppf "@[<2>async@ %a@]" (pp_res d) (t', result)
+    | Async {result; waiters} ->
+      let t' = match t with T.Async (_, _, t') -> t' | _ -> T.Non in
+      fprintf ppf "@[<2>async[%d]@ %a@]"
+        (List.length waiters) (pp_res d) (t', result)
+    | Mut r ->
+      let t' = match t with T.Mut t' -> t' | _ -> T.Non in
+      pp_val d ppf (t', !r)
+    | v -> pp_val_nullary d ppf (t, v)
+
+and pp_res d ppf (t, result) =
   match Lib.Promise.value_opt result with
-  | Some (Error v)-> fprintf ppf "@[Error@ %a@]" (pp_val_nullary d) v
-  | Some (Ok v) -> pp_val_nullary d ppf v
+  | Some (Error v) -> fprintf ppf "@[Error@ %a@]" (pp_val_nullary d) (t, v)
+  | Some (Ok v) -> pp_val_nullary d ppf (t, v)
   | None -> pr ppf "_"
 
-and pp_def d ppf def =
+and pp_def d ppf (t, def) =
   match Lib.Promise.value_opt def with
-  | Some v -> pp_val d ppf v
+  | Some v -> pp_val d ppf (t, v)
   | None -> pr ppf "_"
 
-let string_of_val d v : string =
+and string_of_val d t v : string =
   Lib.Format.with_str_formatter (fun ppf ->
-    pp_val d ppf) v
+    pp_val d ppf) (t, v)
 
-let string_of_def d def : string =
+let string_of_def d t def : string =
   Lib.Format.with_str_formatter (fun ppf ->
-    pp_def d ppf) def
+    pp_def d ppf) (t, def)

src/mo_values/value.mli

@@ -113,8 +113,10 @@ val compare : value -> value -> int
 
 (* Pretty Printing *)
 
-val pp_val : int -> Format.formatter -> value -> unit
-val pp_def : int -> Format.formatter -> def -> unit
+(* NB: Pass Type.Non to print value at full dynamic, not static, type. *)
+val pp_val : int -> Format.formatter -> (Type.typ * value) -> unit
+val pp_def : int -> Format.formatter -> (Type.typ * def) -> unit
 
-val string_of_val : int -> value -> string
-val string_of_def : int -> def -> string
+(* NB: Pass Type.Non to print value at full dynamic, not static, type. *)
+val string_of_val : int -> Type.typ -> value -> string
+val string_of_def : int -> Type.typ -> def -> string

src/pipeline/pipeline.ml

@@ -53,16 +53,16 @@ let print_dyn_ve scope =
       Format.printf "@[<hv 2>%s %s :@ %a =@ %a@]@."
         (if t == t' then "let" else "var") x
         Type.pp_typ t'
-        (Value.pp_def !Flags.print_depth) d
+        (Value.pp_def !Flags.print_depth) (t', d)
   )
 
 let print_scope senv scope dve =
   print_ce scope.Scope.con_env;
   print_dyn_ve senv dve
 
-let print_val _senv v t =
+let print_val _senv t v =
   Format.printf "@[<hv 2>%a :@ %a@]@."
-    (Value.pp_val !Flags.print_depth) v
+    (Value.pp_val !Flags.print_depth) (t, v)
     Type.pp_typ t
 
 
@@ -559,7 +559,7 @@ let is_exp dec = match dec.Source.it with Syntax.ExpD _ -> true | _ -> false
 
 let output_scope (senv, _) t v sscope dscope =
   print_scope senv sscope dscope.Interpret.val_env;
-  if v <> Value.unit then print_val senv v t
+  if v <> Value.unit then print_val senv t v
 
 let run_stdin lexer (senv, denv) : env option =
   match Diag.flush_messages (load_decl (parse_lexer lexer) senv) with
@@ -593,9 +593,7 @@ let run_stdin_from_file files file : Value.value option =
     Diag.flush_messages (load_decl (parse_file Source.no_region file) senv) in
   let denv' = interpret_libs denv libs in
   let* (v, dscope) = interpret_prog denv' prog in
-  Format.printf "@[<hv 2>%a :@ %a@]@."
-    (Value.pp_val 10) v
-    Type.pp_typ t;
+  print_val senv t v;
   Some v
 
 let run_files_and_stdin files =

src/profiler/counters.ml

@@ -10,6 +10,7 @@ such as search, sorting, etc.
 
 open Source
 module Value = Mo_values.Value
+module T = Mo_types.Type
 
 type t = {
     label  : ((region * string), int) Hashtbl.t ;
@@ -60,7 +61,7 @@ let dump (c:t) (ve: Value.value Value.Env.t) =
       Printf.printf "{\n" ;
       Value.Env.iter (fun fn fv ->
           Printf.printf " %s = %s;\n"
-            fn (Value.string_of_val 0 fv)
+            fn (Value.string_of_val 0 T.Non fv)
         )
         ve ;
       Printf.printf "}\n"
@@ -112,7 +113,7 @@ let dump (c:t) (ve: Value.value Value.Env.t) =
         (fun var (line, flds) ->
           match Value.Env.find_opt var ve with
             None   -> (Printf.sprintf "%s, #err" line, (var :: flds))
-          | Some v -> (Printf.sprintf "%s, %s" line (Value.string_of_val 0 v), var :: flds)
+          | Some v -> (Printf.sprintf "%s, %s" line (Value.string_of_val 0 T.Non v), var :: flds)
         ) !ProfilerFlags.profile_field_names ("", [])
     in
     Printf.fprintf file "# column: source region\n" ;