attach optional migration expression to actor (class) as actor [exp]?

doc/md/examples/grammar.txt

@@ -14,7 +14,7 @@
 
 <obj_sort> ::= 
     'object'
-    'persistent'? 'actor'
+    'persistent'? 'actor' ('[' <exp> ']')?
     'module'
 
 <query> ::= 

src/docs/extract.ml

@@ -140,7 +140,7 @@ struct
           _;
         } -> (
         match rhs with
-        | Source.{ it = Syntax.ObjBlockE (sort, _, fields); _ } ->
+        | Source.{ it = Syntax.ObjBlockE (sort, _, _, fields); _ } ->
             let mk_field_xref xref = mk_xref (Xref.XClass (name, xref)) in
             Some
               ( mk_xref (Xref.XType name),
@@ -155,7 +155,7 @@ struct
         )
     | Source.{ it = Syntax.VarD ({ it = name; _ }, rhs); _ } -> (
         match rhs with
-        | Source.{ it = Syntax.ObjBlockE (sort, _, fields); _ } ->
+        | Source.{ it = Syntax.ObjBlockE (sort, _, _, fields); _ } ->
             let mk_field_xref xref = mk_xref (Xref.XClass (name, xref)) in
             Some
               ( mk_xref (Xref.XType name),
@@ -184,7 +184,7 @@ struct
         {
           it =
             Syntax.ClassD
-              (shared_pat, name, type_args, ctor, _, obj_sort, _, fields);
+              (shared_pat, exp_opt, name, type_args, ctor, _, obj_sort, _, fields);
           _;
         } ->
         let mk_field_xref xref = mk_xref (Xref.XClass (name.it, xref)) in

src/docs/namespace.ml

@@ -32,7 +32,7 @@ let from_module =
         | Syntax.ExpD _ -> acc
         | Syntax.LetD
             ( { it = Syntax.VarP id; _ },
-              { it = Syntax.ObjBlockE (_, _, decs); _ },
+              { it = Syntax.ObjBlockE (_, _, _, decs); _ },
               _ ) ->
             let mk_nested x = mk_xref (Xref.XNested (id.it, x)) in
             {
@@ -69,7 +69,7 @@ let from_module =
                   (mk_xref (Xref.XValue id.it), None)
                   acc.values;
             }
-        | Syntax.ClassD (_, id, _, _, _, _, _, _) ->
+        | Syntax.ClassD (_, _, id, _, _, _, _, _, _) ->
             {
               acc with
               types = StringMap.add id.it (mk_xref (Xref.XType id.it)) acc.types;

src/languageServer/declaration_index.ml

@@ -251,7 +251,7 @@ let populate_definitions (project_root : string) (libs : Syntax.lib list)
   let is_type_def dec_field =
     match dec_field.it.Syntax.dec.it with
     | Syntax.TypD (typ_id, _, _) -> Some typ_id
-    | Syntax.ClassD (_, typ_id, _, _, _, _, _, _) -> Some typ_id
+    | Syntax.ClassD (_, _, typ_id, _, _, _, _, _, _) -> Some typ_id
     | _ -> None
   in
   let extract_binders env (pat : Syntax.pat) = gather_pat env pat in

src/lowering/desugar.ml

@@ -90,8 +90,8 @@ and exp' at note = function
       (breakE "!" (nullE()))
       (* case ? v : *)
       (varP v) (varE v) ty).it
-  | S.ObjBlockE (s, (self_id_opt, _), dfs) ->
-    obj_block at s self_id_opt dfs note.Note.typ
+  | S.ObjBlockE (s, exp_opt, (self_id_opt, _), dfs) ->
+    obj_block at s exp_opt self_id_opt dfs note.Note.typ
   | S.ObjE (bs, efs) ->
     obj note.Note.typ efs bs
   | S.TagE (c, e) -> (tagE c.it (exp e)).it
@@ -326,12 +326,12 @@ and mut m = match m.it with
   | S.Const -> Ir.Const
   | S.Var -> Ir.Var
 
-and obj_block at s self_id dfs obj_typ =
+and obj_block at s exp_opt self_id dfs obj_typ =
   match s.it with
   | T.Object | T.Module ->
     build_obj at s.it self_id dfs obj_typ
   | T.Actor ->
-    build_actor at [] self_id dfs obj_typ
+    build_actor at [] exp_opt self_id dfs obj_typ
   | T.Memory -> assert false
 
 and build_field {T.lab; T.typ;_} =
@@ -532,7 +532,7 @@ and export_runtime_information self_id =
   )],
   [{ it = I.{ name = lab; var = v }; at = no_region; note = typ }])
 
-and build_actor at ts self_id es obj_typ =
+and build_actor at ts exp_opt self_id es obj_typ =
   let candid = build_candid ts obj_typ in
   let fs = build_fields obj_typ in
   let es = List.filter (fun ef -> is_not_typD ef.it.S.dec) es in
@@ -812,7 +812,8 @@ and dec' at n = function
     end
   | S.VarD (i, e) -> I.VarD (i.it, e.note.S.note_typ, exp e)
   | S.TypD _ -> assert false
-  | S.ClassD (sp, id, tbs, p, _t_opt, s, self_id, dfs) ->
+  | S.ClassD (sp, exp_opt, id, tbs, p, _t_opt, s, self_id, dfs) ->
+     (* TODO exp_opt *)
     let id' = {id with note = ()} in
     let sort, _, _, _, _ = Type.as_func n.S.note_typ in
     let op = match sp.it with
@@ -839,13 +840,13 @@ and dec' at n = function
         let (_, _, obj_typ) = T.as_async rng_typ in
         let c = Cons.fresh T.default_scope_var (T.Abs ([], T.scope_bound)) in
         asyncE T.Fut (typ_arg c T.Scope T.scope_bound) (* TBR *)
-          (wrap { it = obj_block at s (Some self_id) dfs (T.promote obj_typ);
+          (wrap { it = obj_block at  s exp_opt (Some self_id) dfs (T.promote obj_typ);
             at = at;
             note = Note.{def with typ = obj_typ } })
           (List.hd inst)
       else
        wrap
-        { it = obj_block at s (Some self_id) dfs rng_typ;
+        { it = obj_block at s exp_opt (Some self_id) dfs rng_typ;
           at = at;
           note = Note.{ def with typ = rng_typ } }
     in
@@ -1023,7 +1024,7 @@ let import_compiled_class (lib : S.comp_unit) wasm : import_declaration =
   let f = lib.note.filename in
   let { body; _ } = lib.it in
   let id = match body.it with
-    | S.ActorClassU (_, id, _, _, _, _, _) -> id.it
+    | S.ActorClassU (_, _, id, _, _, _, _, _) -> id.it
     | _ -> assert false
   in
   let fun_typ = T.normalize body.note.S.note_typ in
@@ -1118,7 +1119,8 @@ let transform_unit_body (u : S.comp_unit_body) : Ir.comp_unit =
     I.LibU ([], {
       it = build_obj u.at T.Module self_id fields u.note.S.note_typ;
       at = u.at; note = typ_note u.note})
-  | S.ActorClassU (sp, typ_id, _tbs, p, _, self_id, fields) ->
+  | S.ActorClassU (sp, exp_opt, typ_id, _tbs, p, _, self_id, fields) ->
+    (* TODO exp_opt *)
     let fun_typ = u.note.S.note_typ in
     let op = match sp.it with
       | T.Local -> None
@@ -1134,7 +1136,7 @@ let transform_unit_body (u : S.comp_unit_body) : Ir.comp_unit =
         T.promote rng
       | _ -> assert false
     in
-    let actor_expression = build_actor u.at ts (Some self_id) fields obj_typ in
+    let actor_expression = build_actor u.at ts exp_opt (Some self_id) fields obj_typ in
     let e = wrap {
        it = actor_expression;
        at = no_region;
@@ -1145,8 +1147,8 @@ let transform_unit_body (u : S.comp_unit_body) : Ir.comp_unit =
       I.ActorU (Some args, ds, fs, u, t)
     | _ -> assert false
     end
-  | S.ActorU (self_id, fields) ->
-    let actor_expression = build_actor u.at [] self_id fields u.note.S.note_typ in
+  | S.ActorU (exp_opt, self_id, fields) ->
+    let actor_expression = build_actor u.at [] exp_opt self_id fields u.note.S.note_typ in
     begin match actor_expression with
     | I.ActorE (ds, fs, u, t) ->
       I.ActorU (None, ds, fs, u, t)
@@ -1182,7 +1184,7 @@ let import_unit (u : S.comp_unit) : import_declaration =
     raise (Invalid_argument "Desugar: Cannot import actor")
   | I.ActorU (Some as_, ds, fs, up, actor_t) ->
     let id = match body.it with
-      | S.ActorClassU (_, id, _, _, _, _, _) -> id.it
+      | S.ActorClassU (_, _, id, _, _, _, _, _) -> id.it
       | _ -> assert false
     in
     let s, cntrl, tbs, ts1, ts2 = T.as_func t in

src/mo_def/arrange.ml

@@ -69,7 +69,10 @@ module Make (Cfg : Config) = struct
     | FromCandidE e       -> "FromCandidE" $$ [exp e]
     | TupE es             -> "TupE"      $$ exps es
     | ProjE (e, i)        -> "ProjE"     $$ [exp e; Atom (string_of_int i)]
-    | ObjBlockE (s, nt, dfs) -> "ObjBlockE" $$ [obj_sort s;
+    | ObjBlockE (s, po, nt, dfs) -> "ObjBlockE" $$ [obj_sort s;
+                                                (match po with
+                                                |  None -> Atom "_"
+                                                |  Some e -> exp e);
                                                 match nt with
                                                 | None, None -> Atom "_"
                                                 | None, Some t -> typ t
@@ -267,8 +270,9 @@ module Make (Cfg : Config) = struct
     | VarD (x, e) -> "VarD" $$ [id x; exp e]
     | TypD (x, tp, t) ->
       "TypD" $$ [id x] @ List.map typ_bind tp @ [typ t]
-    | ClassD (sp, x, tp, p, rt, s, i', dfs) ->
-      "ClassD" $$ shared_pat sp :: id x :: List.map typ_bind tp @ [
+    | ClassD (sp, po, x, tp, p, rt, s, i', dfs) ->
+       "ClassD" $$ shared_pat sp :: id x :: List.map typ_bind tp @ [
+        (match po with None -> Atom "_" | Some e -> exp e);
         pat p;
         (match rt with None -> Atom "_" | Some t -> typ t);
         obj_sort s; id i'

src/mo_def/compUnit.ml

@@ -9,20 +9,20 @@ let (@~) it at = Source.annotate Const it at
 let is_actor_def e =
   let open Source in
   match e.it with
-  | AwaitE (Type.Fut, { it = AsyncE (Type.Fut, _, {it = ObjBlockE ({ it = Type.Actor; _}, _t, _fields); _ }) ; _  }) -> true
+  | AwaitE (Type.Fut, { it = AsyncE (Type.Fut, _, {it = ObjBlockE ({ it = Type.Actor; _}, _po, _t, _fields); _ }) ; _  }) -> true
   | _ -> false
 
 let as_actor_def e =
   let open Source in
   match e.it with
-  | AwaitE (Type.Fut, { it = AsyncE (Type.Fut, _, {it = ObjBlockE ({ it = Type.Actor; _}, _t, fields); note; at }) ; _  }) ->
-    fields, note, at
+  | AwaitE (Type.Fut, { it = AsyncE (Type.Fut, _, {it = ObjBlockE ({ it = Type.Actor;_}, po,  _t, fields); note; at }) ; _  }) ->
+    po, fields, note, at
   | _ -> assert false
 
 let is_module_def e =
   let open Source in
   match e.it with
-  | ObjBlockE ({ it = Type.Module; _}, _, _) -> true
+  | ObjBlockE ({ it = Type.Module; _}, _, _, _) -> true
   | _ -> false
 
 (* Happens after parsing, before type checking *)
@@ -42,20 +42,20 @@ let comp_unit_of_prog as_lib (prog : prog) : comp_unit =
       go (i :: imports) ds'
 
     (* terminal expressions *)
-    | [{it = ExpD ({it = ObjBlockE ({it = Type.Module; _}, _t, fields); _} as e); _}] when as_lib ->
+    | [{it = ExpD ({it = ObjBlockE ({it = Type.Module; _}, po, _t, fields); _} as e); _}] when as_lib ->
       finish imports { it = ModuleU (None, fields); note = e.note; at = e.at }
     | [{it = ExpD e; _} ] when is_actor_def e ->
-      let fields, note, at = as_actor_def e in
-      finish imports { it = ActorU (None, fields); note; at }
-    | [{it = ClassD (sp, tid, tbs, p, typ_ann, {it = Type.Actor;_}, self_id, fields); _} as d] ->
-      assert (List.length tbs > 0);
-      finish imports { it = ActorClassU (sp, tid, tbs, p, typ_ann, self_id, fields); note = d.note; at = d.at }
+      let po, fields, note, at = as_actor_def e in
+      finish imports { it = ActorU (po, None, fields); note; at }
+    | [{it = ClassD (sp, po, tid, tbs, p, typ_ann, {it = Type.Actor;_}, self_id, fields); _} as d] ->
+      assert (List.length tbs > 0); (* TODO: record _po *)
+      finish imports { it = ActorClassU (sp, po, tid, tbs, p, typ_ann, self_id, fields); note = d.note; at = d.at }
     (* let-bound terminal expressions *)
-    | [{it = LetD ({it = VarP i1; _}, ({it = ObjBlockE ({it = Type.Module; _}, _t, fields); _} as e), _); _}] when as_lib ->
+    | [{it = LetD ({it = VarP i1; _}, ({it = ObjBlockE ({it = Type.Module; _}, _po, _t, fields); _} as e), _); _}] when as_lib ->
       finish imports { it = ModuleU (Some i1, fields); note = e.note; at = e.at }
     | [{it = LetD ({it = VarP i1; _}, e, _); _}] when is_actor_def e ->
-      let fields, note, at = as_actor_def e in
-      finish imports { it = ActorU (Some i1, fields); note; at }
+      let po, fields, note, at = as_actor_def e in (* TODO: record _po *)
+      finish imports { it = ActorU (po, Some i1, fields); note; at }
 
     (* Everything else is a program *)
     | ds' ->
@@ -80,14 +80,14 @@ let obj_decs obj_sort at note id_opt fields =
   match id_opt with
   | None -> [
     { it = ExpD {
-        it = ObjBlockE ( { it = obj_sort; at; note = () }, (None, None), fields);
+        it = ObjBlockE ( { it = obj_sort; at; note = () }, None, (None, None), fields);
         at;
         note };
       at; note }]
   | Some id -> [
     { it = LetD (
         { it = VarP id; at; note = note.note_typ },
-        { it = ObjBlockE ({ it = obj_sort; at; note = () }, (None, None), fields);
+        { it = ObjBlockE ({ it = obj_sort; at; note = () }, None, (None, None), fields);
           at; note; },
         None);
       at; note
@@ -116,8 +116,8 @@ let decs_of_lib (cu : comp_unit) =
   match cub.it with
   | ModuleU (id_opt, fields) ->
     obj_decs Type.Module cub.at cub.note id_opt fields
-  | ActorClassU (csp, i, tbs, p, t, i', efs) ->
-    [{ it = ClassD (csp, i, tbs, p, t, { it = Type.Actor; at = no_region; note = ()}, i', efs);
+  | ActorClassU (csp, po, i, tbs, p, t, i', efs) -> (* TODO : restor po *)
+    [{ it = ClassD (csp, po, i, tbs, p, t,{ it = Type.Actor; at = no_region; note = ()}, i', efs);
        at = cub.at;
        note = cub.note;}];
   | ProgU _

src/mo_def/syntax.ml

@@ -165,7 +165,7 @@ and exp' =
   | OptE of exp                                (* option injection *)
   | DoOptE of exp                              (* option monad *)
   | BangE of exp                               (* scoped option projection *)
-  | ObjBlockE of obj_sort * (id option * typ option) * dec_field list  (* object block *)
+  | ObjBlockE of obj_sort * exp option * (id option * typ option) * dec_field list  (* object block *)
   | ObjE of exp list * exp_field list          (* record literal/extension *)
   | TagE of id * exp                           (* variant *)
   | DotE of exp * id                           (* object projection *)
@@ -223,7 +223,7 @@ and dec' =
   | VarD of id * exp                           (* mutable *)
   | TypD of typ_id * typ_bind list * typ       (* type *)
   | ClassD of                                  (* class *)
-      sort_pat * typ_id * typ_bind list * pat * typ option * obj_sort * id * dec_field list
+      sort_pat * exp option * typ_id * typ_bind list * pat * typ option * obj_sort * id * dec_field list
 
 
 (* Program (pre unit detection) *)
@@ -245,10 +245,10 @@ and import' = pat * string * resolved_import ref
 type comp_unit_body = (comp_unit_body', typ_note) Source.annotated_phrase
 and comp_unit_body' =
  | ProgU of dec list                         (* main programs *)
- | ActorU of id option * dec_field list      (* main IC actor *)
+ | ActorU of exp option * id option * dec_field list      (* main IC actor *)
  | ModuleU of id option * dec_field list     (* module library *)
  | ActorClassU of                            (* IC actor class, main or library *)
-     sort_pat * typ_id * typ_bind list * pat * typ option * id * dec_field list
+     sort_pat * exp option * typ_id * typ_bind list * pat * typ option * id * dec_field list
 
 type comp_unit = (comp_unit', prog_note) Source.annotated_phrase
 and comp_unit' = {

src/mo_frontend/definedness.ml

@@ -90,7 +90,8 @@ let rec exp msgs e : f = match e.it with
   (* Uses are delayed by function expressions *)
   | FuncE (_, sp, tp, p, t, _, e) ->
     delayify ((exp msgs e /// pat msgs p) /// shared_pat msgs sp)
-  | ObjBlockE (s, (self_id_opt, _), dfs) ->
+  | ObjBlockE (s, eo, (self_id_opt, _), dfs) ->
+    (* TODO eo *)
     group msgs (add_self self_id_opt s (dec_fields msgs dfs))
   (* The rest remaining cases just collect the uses of subexpressions: *)
   | LitE _
@@ -177,7 +178,8 @@ and dec msgs d = match d.it with
   | LetD (p, e, Some f) -> pat msgs p +++ exp msgs e +++ exp msgs f
   | VarD (i, e) -> (M.empty, S.singleton i.it) +++ exp msgs e
   | TypD (i, tp, t) -> (M.empty, S.empty)
-  | ClassD (csp, i, tp, p, t, s, i', dfs) ->
+  | ClassD (csp, eo, i, tp, p, t, s, i', dfs) ->
+    (* TODO eo *)
     (M.empty, S.singleton i.it) +++ delayify (
       group msgs (add_self (Some i')  s (dec_fields msgs dfs)) /// pat msgs p /// shared_pat msgs csp
     )

src/mo_frontend/effect.ml

@@ -99,7 +99,8 @@ let rec infer_effect_exp (exp:Syntax.exp) : T.eff =
     map_max_effs effect_exp exps
   | BlockE decs ->
     map_max_effs effect_dec decs
-  | ObjBlockE (sort, _, dfs) ->
+  | ObjBlockE (sort, _, _, dfs) ->
+    (* TODO *)
     infer_effect_dec_fields dfs
   | ObjE (bases, efs) ->
     let bases = map_max_effs effect_exp bases in