experiment: data inspection via fabricated view queries

src/idllib/arrange_idl.ml

@@ -252,6 +252,18 @@ module Make (Cfg : Config) = struct
       kwd ppf ":";
       str ppf x.it;
       pp_close_box ppf ()
+    | Some {it=ClassT(args, {it = ServT ms;_ }); _} ->
+      pp_open_hbox ppf ();
+      kwd ppf "service";
+      kwd ppf ":";
+      pp_args ppf args;
+      str ppf " -> {";
+      pp_open_vbox ppf 2;
+      List.iter (fun m -> pp_print_cut ppf (); pp_meth ppf m; str ppf ";") ms;
+      pp_print_break ppf 0 (-2);
+      str ppf "}";
+      pp_close_box ppf ();
+      pp_close_box ppf ()
     | Some {it=ClassT(args, t); _} ->
       pp_open_hbox ppf ();
       kwd ppf "service";

src/js/astjs.ml

@@ -625,7 +625,7 @@ module Make (Cfg : Config) = struct
     | Some s -> (
         match s.it with
         | Flexible -> js_string "Flexible"
-        | Stable -> js_string "Stable")
+        | Stable _ -> js_string "Stable")
 
   and exp_field_js ef =
     let open Source in

src/lowering/desugar.ml

@@ -529,7 +529,7 @@ and export_footprint self_id expr =
   let size = fresh_var "size" T.nat64 in
   let scope_con1 = Cons.fresh "T1" (Abs ([], scope_bound)) in
   let scope_con2 = Cons.fresh "T2" (Abs ([], Any)) in
-  let bind1  = typ_arg scope_con1 Scope scope_bound in
+  let bind1 = typ_arg scope_con1 Scope scope_bound in
   let bind2 = typ_arg scope_con2 Scope scope_bound in
   let ret_typ = T.(obj Object [("size", nat64)]) in
   let caller = fresh_var "caller" caller in
@@ -558,7 +558,7 @@ and export_runtime_information self_id =
   let v = "$"^lab in
   let scope_con1 = Cons.fresh "T1" (Abs ([], scope_bound)) in
   let scope_con2 = Cons.fresh "T2" (Abs ([], Any)) in
-  let bind1  = typ_arg scope_con1 Scope scope_bound in
+  let bind1 = typ_arg scope_con1 Scope scope_bound in
   let bind2 = typ_arg scope_con2 Scope scope_bound in
   let gc_strategy =
     let open Mo_config in
@@ -613,7 +613,48 @@ and export_runtime_information self_id =
                   ) ret_typ))
               (Con (scope_con1, []))))
   )],
-  [{ it = I.{ name = lab; var = v }; at = no_region; note = typ }])
+   [{ it = I.{ name = lab; var = v }; at = no_region; note = typ }])
+
+and export_view viewer_opt =
+  match viewer_opt with
+  | None -> ([], [], [])
+  | Some {viewer_body; viewer_field} ->
+     let open T in
+     let ts1, ts2, mk_body =
+       match (viewer_body, T.normalize viewer_field.typ) with
+       | DotViewV view_exp, T.Func(Shared Query, _, [_], ts1, ts2) ->
+          (* id.view() available *)
+          ts1, ts2, fun vs -> callE (exp view_exp) [] (tupE (List.map varE vs))
+       | DefaultV view_exp, T.Func(Shared Query, _, [_], [], [t]) ->
+         (* id, t shared *)
+          assert (T.shared t);
+          [], [t], fun _vs -> exp view_exp
+       | _ -> assert false
+     in
+     let vs = fresh_vars "param" ts1 in
+     let args = List.map arg_of_var vs in
+     let lab = viewer_field.lab in
+     let v = fresh_id ("$"^lab) () in
+     let scope_con1 = Cons.fresh "T1" (Abs ([], scope_bound)) in
+     let scope_con2 = Cons.fresh "T2" (Abs ([], Any)) in
+     let bind1 = typ_arg scope_con1 Scope scope_bound in
+     let bind2 = typ_arg scope_con2 Scope scope_bound in
+     let typ = viewer_field.typ in
+     let caller = fresh_var "caller" caller in
+     ([ letD (var v typ) (
+            funcE v (Shared Query) Promises [bind1] args ts2 (
+                (asyncE T.Fut bind2
+                   (blockE [
+                        (* authentication, self or controller only *)
+                        letD caller (primE I.ICCallerPrim []);
+(*                        expD (assertE (orE (primE (I.RelPrim (principal, Operator.EqOp)) [varE caller; selfRefE principal])
+                                           (primE (I.OtherPrim "is_controller") [varE caller]))); *)
+                      ]
+                      (mk_body vs))
+                   (Con (scope_con1, []))))
+      )],
+      [T.{lab;typ; src = empty_src}],
+      [{ it = I.{ name = lab; var = v }; at = no_region; note = typ }])
 
 and build_stabs (df : S.dec_field) : stab option list = match df.it.S.dec.it with
   | S.TypD _ -> []
@@ -631,14 +672,21 @@ and build_stabs (df : S.dec_field) : stab option list = match df.it.S.dec.it wit
     List.concat_map build_stabs decs
   | _ -> [df.it.S.stab]
 
-and build_actor at ts (exp_opt : Ir.exp option) self_id es obj_typ =
-  let candid = build_candid ts obj_typ in
-  let fs = build_fields obj_typ in
+and build_actor at ts (exp_opt : Ir.exp option) self_id es obj_typ0 =
+  let fs0 = build_fields obj_typ0 in
   let stabs = List.concat_map build_stabs es in
   let ds = decs (List.map (fun ef -> ef.it.S.dec) es) in
   let pairs = List.map2 stabilize stabs ds in
   let idss = List.map fst pairs in
   let ids = List.concat idss in
+  let triples = List.map view stabs in
+  let view_ds = List.concat_map (fun (ds, _, _) -> ds) triples in
+  (* let view_fields = List.concat_map (fun (_, flds, _) -> flds) triples in *)
+  let view_fields = [] in
+  let view_fs = List.concat_map (fun (_, _, fs) -> fs) triples in
+  let (sort, tfs0, tfs1) = T.as_obj' obj_typ0 in
+  let obj_typ = T.Obj(sort, List.sort T.compare_field (tfs0@view_fields), tfs1) in
+  let fs = fs0@view_fs in
   let stab_fields = List.sort T.compare_field
     (List.map (fun (i, t) -> T.{lab = i; typ = t; src = empty_src}) ids)
   in
@@ -651,6 +699,7 @@ and build_actor at ts (exp_opt : Ir.exp option) self_id es obj_typ =
   let state = fresh_var "state" (T.Mut (T.Opt mem_ty)) in
   let get_state = fresh_var "getState" (T.Func(T.Local, T.Returns, [], [], [mem_ty])) in
   let ds = List.map (fun mk_d -> mk_d get_state) mk_ds in
+  let candid = build_candid ts obj_typ in
   let sig_, stable_type, migration = match exp_opt with
     | None ->
       T.Single stab_fields,
@@ -768,7 +817,7 @@ and build_actor at ts (exp_opt : Ir.exp option) self_id es obj_typ =
             mem_ty)) in
   let footprint_d, footprint_f = export_footprint self_id (with_stable_vars Fun.id) in
   let runtime_info_d, runtime_info_f = export_runtime_information self_id in
-  I.(ActorE (footprint_d @ runtime_info_d @ ds', footprint_f @ runtime_info_f @ fs,
+  I.(ActorE (footprint_d @ runtime_info_d @ ds' @ view_ds, footprint_f @ runtime_info_f @ fs,
      { meta;
        preupgrade = (primE (I.ICStableWrite mem_ty) []);
        postupgrade =
@@ -805,7 +854,7 @@ and stabilize stab_opt d =
   match s, d.it with
   | (S.Flexible, _) ->
     ([], fun _ -> d)
-  | (S.Stable, I.VarD(i, t, e)) ->
+  | (S.Stable viewer, I.VarD(i, t, e)) ->
     ([(i, T.Mut t)],
      fun get_state ->
      let v = fresh_var i t in
@@ -814,8 +863,8 @@ and stabilize stab_opt d =
          e
          (varP v) (varE v)
          t))
-  | (S.Stable, I.RefD _) -> assert false (* RefD cannot come from user code *)
-  | (S.Stable, I.LetD({it = I.VarP i; _} as p, e)) ->
+  | (S.Stable viewer, I.RefD _) -> assert false (* RefD cannot come from user code *)
+  | (S.Stable viewer, I.LetD({it = I.VarP i; _} as p, e)) ->
     let t = p.note in
     ([(i, t)],
      fun get_state ->
@@ -825,8 +874,17 @@ and stabilize stab_opt d =
          e
          (varP v) (varE v)
          t))
-  | (S.Stable, I.LetD _) ->
-    assert false
+  | (S.Stable viewer, I.LetD _) ->
+     assert false
+
+and view stab_opt =
+  match stab_opt with
+  | None -> ([], [], [])
+  | Some stab ->
+    match stab.it with
+    | S.Flexible -> ([], [], [])
+    | S.Stable viewer ->
+      export_view (!viewer)
 
 and build_obj at s self_id dfs obj_typ =
   let fs = build_fields obj_typ in

src/mo_def/arrange.ml

@@ -231,7 +231,7 @@ module Make (Cfg : Config) = struct
     | Some s ->
       (match s.it with
       | Flexible -> Atom "Flexible"
-      | Stable -> Atom "Stable")
+      | Stable _ -> Atom "Stable")
 
   and typ_field (tf : typ_field) = source tf.at (match tf.it with
     | ValF (lab, t, m) -> "ValF" $$ [id lab; typ t; mut m]

src/mo_def/syntax.ml

@@ -145,8 +145,6 @@ and vis' =
 let is_public vis = match vis.Source.it with Public _ -> true | _ -> false
 let is_private vis = match vis.Source.it with Private -> true | _ -> false
 
-type stab = stab' Source.phrase
-and stab' = Stable | Flexible
 
 type op_typ = Type.typ ref (* For overloaded resolution; initially Type.Pre. *)
 
@@ -180,6 +178,10 @@ let break_label kind (id_opt : id option) =
 
 
 type id_ref = (string, mut' * exp option) Source.annotated_phrase
+and viewer_body = DotViewV of exp | DefaultV of exp
+and viewer = {viewer_body : viewer_body; viewer_field : Type.field}
+and stab = stab' Source.phrase
+and stab' = Stable of viewer option ref | Flexible
 and hole_sort = Named of string | Anon of int
 and exp = (exp', typ_note) Source.annotated_phrase
 and exp' =

src/mo_frontend/parser.mly

@@ -168,7 +168,7 @@ let share_stab default_stab stab_opt dec =
   | None ->
     (match dec.it with
      | VarD _
-     | LetD _ -> Some default_stab
+     | LetD _ -> Some (default_stab ())
      | _ -> None)
   | _ -> stab_opt
 
@@ -184,7 +184,7 @@ let share_dec_field default_stab (df : dec_field) =
   | Public _ ->
     {df with it = {df.it with
       dec = share_dec df.it.dec;
-      stab = share_stab (Flexible @@ df.it.dec.at) df.it.stab df.it.dec}}
+      stab = share_stab (fun () -> Flexible @@ df.it.dec.at) df.it.stab df.it.dec}}
   | System -> ensure_system_cap df
   | _ when is_sugared_func_or_module (df.it.dec) ->
     {df with it =
@@ -203,7 +203,7 @@ let share_dec_field default_stab (df : dec_field) =
              | TypD _
              | MixinD _
              | ClassD _ -> None
-             | _ -> Some default_stab)
+             | _ -> Some (default_stab()))
           | some -> some}
     }
 
@@ -880,7 +880,7 @@ vis :
 stab :
   | (* empty *) { None }
   | FLEXIBLE { Some (Flexible @@ at $sloc) }
-  | STABLE { Some (Stable @@ at $sloc) }
+  | STABLE { Some ((Stable (ref None)) @@ at $sloc) }
   | TRANSIENT { Some (Flexible @@ at $sloc) }
 
 %inline persistent :
@@ -974,7 +974,7 @@ dec_nonvar :
       let_or_exp named x (func_exp x.it sp tps p t is_sugar e) (at $sloc) }
   | eo=parenthetical_opt mk_d=obj_or_class_dec  { mk_d eo }
   | MIXIN p=pat_plain dfs=obj_body {
-     let dfs = List.map (share_dec_field (Stable @@ no_region)) dfs in
+     let dfs = List.map (share_dec_field (fun () -> Stable (ref None) @@ no_region)) dfs in
      MixinD(p, dfs) @? at $sloc
   }
   | INCLUDE x=id e=exp(ob) { IncludeD(x, e, ref None) @? at $sloc }
@@ -989,7 +989,7 @@ obj_or_class_dec :
       let named, x = xf sort $sloc in
       let e =
         if s.it = Type.Actor then
-          let default_stab = (if persistent.it then Stable else Flexible) @@ no_region in
+          let default_stab () = (if persistent.it then (Stable (ref None)) else Flexible) @@ no_region in
           let id = if named then Some x else None in
           AwaitE
             (Type.AwaitFut false,
@@ -1009,7 +1009,7 @@ obj_or_class_dec :
       let x, dfs = cb in
       let dfs', tps', t' =
        if s.it = Type.Actor then
-          let default_stab = (if persistent.it then Stable else Flexible) @@ no_region in
+         let default_stab () = (if persistent.it then Stable (ref None) else Flexible) @@ no_region in
           (List.map (share_dec_field default_stab) dfs,
            ensure_scope_bind "" tps,
            (* Not declared async: insert AsyncT but deprecate in typing *)

src/mo_frontend/typing.ml

@@ -3772,7 +3772,7 @@ and infer_obj env obj_sort exp_opt dec_fields at : T.typ =
   let _, scope = infer_block env decs at false in
   let t = object_of_scope env s dec_fields scope at in
   leave_scope env (private_identifiers scope.Scope.val_env) initial_usage;
-  let (_, fs) = T.as_obj t in
+  let (_, fs, _) = T.as_obj' t in
   if not env.pre then begin
     if s = T.Actor || s = T.Mixin then begin
       List.iter (fun T.{lab; typ; _} ->
@@ -3878,6 +3878,14 @@ and stable_pat pat =
   | AnnotP (pat', _) -> stable_pat pat'
   | _ -> false
 
+and stable_id pat =
+  match pat.it with
+  | VarP id -> id
+  | ParP pat'
+  | AnnotP (pat', _) -> stable_id pat'
+  | _ -> assert false
+
+
 and infer_migration env obj_sort exp_opt =
   Option.map
     (fun exp ->
@@ -4023,7 +4031,7 @@ and check_stable_defaults env sort dec_fields =
         warn env sort.note.at "M0217" "with flag --default-persistent-actors, the `persistent` keyword is redundant and can be removed";
       List.iter (fun dec_field ->
         match dec_field.it.stab, dec_field.it.dec.it with
-        | Some {it = Stable; at; _}, (LetD _ | VarD _) ->
+        | Some {it = Stable _; at; _}, (LetD _ | VarD _) ->
           if at <> Source.no_region then
             warn env at "M0218" "redundant `stable` keyword, this declaration is implicitly stable"
         | _ -> ())
@@ -4066,12 +4074,14 @@ and check_stab env sort scope dec_fields =
         "misplaced stability declaration on field of non-actor";
       []
     | (T.Actor | T.Mixin), _ , IncludeD _ -> []
-    | (T.Actor | T.Mixin), Some {it = Stable; _}, VarD (id, _) ->
+    | (T.Actor | T.Mixin), Some {it = Stable view; _}, VarD (id, _) ->
       check_stable id.it id.at;
+      infer_viewer env scope Var id view;
       [id]
-    | (T.Actor | T.Mixin), Some {it = Stable; _}, LetD (pat, _, _) when stable_pat pat ->
+    | (T.Actor | T.Mixin), Some {it = Stable view; _}, LetD (pat, _, _) when stable_pat pat ->
       let ids = T.Env.keys (gather_pat env Scope.empty pat).Scope.val_env in
       List.iter (fun id -> check_stable id pat.at) ids;
+      infer_viewer env scope Const (stable_id pat) view;
       List.map (fun id -> {it = id; at = pat.at; note = ()}) ids;
     | (T.Actor | T.Mixin), Some {it = Flexible; _} , (VarD _ | LetD _) -> []
     | (T.Actor | T.Mixin), Some stab, _ ->
@@ -4093,6 +4103,60 @@ and check_stab env sort scope dec_fields =
              src = {depr = None; track_region = id.at; region = id.at}})
       ids)
 
+and infer_viewer env scope mut id viewer =
+  assert (!viewer = None);
+  match Diag.with_message_store (recover_opt (fun msgs ->
+    let env = {env with msgs} in (* don't record errors in outer env *) 
+    let env = adjoin env scope in
+    let note() = empty_typ_note in
+    let at = id.at in
+    let dot_exp =
+      { it = DotE
+               ( {it = VarE {it = id.it; at ; note = (mut, None)};
+                  at;
+                  note = note()},
+                 {it = "view"; note = (); at},
+                 ref None);
+        at;
+        note = note()}
+    in
+    let arg_exp = (false, ref {it = TupE []; at; note = note()}) in
+    let inst = {it = None; at; note = []} in
+    let exp = {it = CallE(None, dot_exp, inst, arg_exp); at; note = note()} in
+    let viewer_typ = infer_exp env exp in
+    (match T.normalize viewer_typ with
+     | T.Func(T.Local, T.Returns, [], ts1, ts2) ->
+        if List.for_all T.shared ts1 && List.for_all T.shared ts2
+        then { viewer_body = DotViewV exp;
+               viewer_field =
+               T.{ lab = id.it;
+                   typ = Func (Shared Query, Promises, [scope_bind], ts1, ts2);
+                   src = empty_src };
+             }
+        else error env id.at "M0XXX" "viewer '%s.view()' has non-shared type" id.it
+     | _ -> error env id.at "M0XXX" "viewer '%s.view()' is not a function" id.it)))
+  with
+  | Error _ ->
+     (* info env id.at "viewer not found for %s" id.it; *)
+     (match T.Env.find_opt id.it scope.Scope.val_env with
+     | Some (typ, _, _)  ->
+        let typ = T.as_immut typ in
+        if T.shared typ then
+          viewer := Some { viewer_body = DefaultV
+                             {it = VarE {it = id.it; at = id.at ; note = (mut, None)};
+                              at = id.at;
+                              note = { empty_typ_note with note_typ = typ }};
+                            viewer_field =
+                             T.{ lab = id.it;
+                                 typ = Func (Shared Query, Promises, [scope_bind], [], [typ]);
+                                 src = empty_src } }
+     | None -> assert false)
+  | Ok (exp_typ, _) ->
+     (* info env id.at "viewer found for %s" id.it; *)
+     viewer := Some exp_typ;
+     ()
+
+
 (* Blocks and Declarations *)
 
 and infer_block env decs at check_unused : T.typ * Scope.scope =