feat: allow access to Self and its public methods from actor initialisers

src/ir_interpreter/interpret_ir.ml

@@ -71,6 +71,15 @@ let find id env =
   with Not_found ->
     trap no_region "unbound identifier %s" id
 
+let lookup_actor env at aid id =
+  match V.Env.find_opt aid !(env.actor_env) with
+  | None -> trap at "Unknown actor \"%s\"" aid
+  | Some actor_value ->
+     let fs = V.as_obj actor_value in
+     match V.Env.find_opt id fs with
+     | None -> trap at "Actor \"%s\" has no method \"%s\"" aid id
+     | Some field_value -> field_value
+
 (* Tracing *)
 
 let trace_depth = ref 0
@@ -307,10 +316,16 @@ and interpret_exp_mut env exp (k : V.value V.cont) =
     )
   | LitE lit ->
     k (interpret_lit env lit)
+  | PrimE (ActorDotPrim n, [{ it = VarE (_, actor); _ }]) when not(Lib.Promise.is_fulfilled (find actor env.vals)) ->
+    (* actor not defined yet, just pair them up *)
+    k V.(Tup [Blob (env.self); Text n])
   | PrimE (p, es) ->
     interpret_exps env es [] (fun vs ->
       match p, vs with
       | CallPrim typs, [v1; v2] ->
+        let v1 = match v1 with
+          | V.(Tup [Blob aid; Text id]) -> lookup_actor env exp.at aid id
+          | _ -> v1 in
         let call_conv, f = V.as_func v1 in
         check_call_conv (List.hd es) call_conv;
         check_call_conv_arg env exp v2 call_conv;
@@ -320,7 +335,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) =
         k (try Operator.unop op ot v1 with Invalid_argument s -> trap exp.at "%s" s)
       | BinPrim (ot, op), [v1; v2] ->
         k (try Operator.binop op ot v1 v2 with _ ->
-          trap exp.at "arithmetic overflow")
+        trap exp.at "arithmetic overflow")
       | RelPrim (ot, op), [v1; v2] ->
         k (Operator.relop op ot v1 v2)
       | TupPrim, exps ->
@@ -335,16 +350,8 @@ and interpret_exp_mut env exp (k : V.value V.cont) =
         let fs = V.as_obj v1 in
         k (try find n fs with _ -> assert false)
       | ActorDotPrim n, [v1] ->
-        let id = V.as_blob v1 in
-        begin match V.Env.find_opt id !(env.actor_env) with
-        (* not quite correct: On the platform, you can invoke and get a reject *)
-        | None -> trap exp.at "Unknown actor \"%s\"" id
-        | Some actor_value ->
-          let fs = V.as_obj actor_value in
-          match V.Env.find_opt n fs with
-          | None -> trap exp.at "Actor \"%s\" has no method \"%s\"" id n
-          | Some field_value -> k field_value
-        end
+        (* delay error handling to the point when the method gets applied *)
+        k V.(Tup [v1; Text n])
       | ArrayPrim (mut, _), vs ->
         let vs' =
           match mut with
@@ -447,6 +454,9 @@ and interpret_exp_mut env exp (k : V.value V.cont) =
         let e = V.Tup [V.Variant ("canister_reject", V.unit); v1] in
         Scheduler.queue (fun () -> reject e)
       | ICCallPrim, [v1; v2; kv; rv; cv] ->
+        let v1 = match v1 with
+          | V.(Tup [Blob aid; Text id]) -> lookup_actor env exp.at aid id
+          | _ -> v1 in
         let call_conv, f = V.as_func v1 in
         check_call_conv (List.hd es) call_conv;
         check_call_conv_arg env exp v2 call_conv;
@@ -463,7 +473,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) =
         in
         k (V.Obj ve)
       | SelfRef _, [] ->
-        k (V.Blob env.self)
+        k (context env)
       | SystemTimePrim, [] ->
         k (V.Nat64 (Numerics.Nat64.of_int 42))
       | SystemCyclesRefundedPrim, [] -> (* faking it *)
@@ -572,7 +582,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) =
 
 and interpret_actor env ds fs k =
     let self = V.fresh_id () in
-    let env0 = {env with self = self} in
+    let env0 = {env with self} in
     let ve = declare_decs ds V.Env.empty in
     let env' = adjoin_vals env0 ve in
     interpret_decs env' ds (fun _ ->

src/lib/lib.mli

@@ -84,7 +84,7 @@ end
 
 module Seq :
 sig
-  val for_all : ('a -> bool) -> 'a Seq.t -> bool
+  val for_all : ('a -> bool) -> 'a Seq.t -> bool (* 4.14 *)
 end
 
 module Option :

src/lowering/desugar.ml

@@ -1145,7 +1145,7 @@ let transform_unit_body (u : S.comp_unit_body) : Ir.comp_unit =
     let actor_expression = build_actor u.at [] 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)
+      I.ActorU (None, ds, fs, u, t)
     | _ -> assert false
     end
 

src/mo_def/arrange.ml

@@ -69,7 +69,13 @@ 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, t, dfs) -> "ObjBlockE" $$ [obj_sort s; match t with None -> Atom "_" | Some t -> typ t] @ List.map dec_field dfs
+    | ObjBlockE (s, nt, dfs) -> "ObjBlockE" $$ [obj_sort s;
+                                                match nt with
+                                                | None, None -> Atom "_"
+                                                | None, Some t -> typ t
+                                                | Some id, Some t -> id.it $$ [Atom ":"; typ t]
+                                                | Some id, None -> Atom id.it
+                                                ] @ List.map dec_field dfs
     | ObjE ([], efs)      -> "ObjE"      $$ List.map exp_field efs
     | ObjE (bases, efs)   -> "ObjE"      $$ exps bases @ [Atom "with"] @ List.map exp_field efs
     | DotE (e, x)         -> "DotE"      $$ [exp e; id x]

src/mo_def/compUnit.ml

@@ -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, fields);
+        it = ObjBlockE ( { it = obj_sort; at; note = () }, (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, fields);
+        { it = ObjBlockE ({ it = obj_sort; at; note = () }, (None, None), fields);
           at; note; },
         None);
       at; note

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 * typ option * dec_field list  (* object block *)
+  | ObjBlockE of obj_sort * (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 *)

src/mo_frontend/definedness.ml

@@ -84,55 +84,55 @@ let rec exp msgs e : f = match e.it with
   (* Or anything that is occurring in a call (as this may call a closure): *)
   | CallE (e1, ts, e2)  -> eagerify (exps msgs [e1; e2])
   (* And break, return, throw can be thought of as calling a continuation: *)
-  | BreakE (i, e)       -> eagerify (exp msgs e)
-  | RetE e              -> eagerify (exp msgs e)
+  | BreakE (_, e)
+  | RetE e
   | ThrowE e            -> eagerify (exp msgs e)
   (* Uses are delayed by function expressions *)
   | FuncE (_, sp, tp, p, t, _, e) ->
-      delayify ((exp msgs e /// pat msgs p) /// shared_pat msgs sp)
+    delayify ((exp msgs e /// pat msgs p) /// shared_pat msgs sp)
+  | ObjBlockE (s, (self_id_opt, _), dfs) ->
+    group msgs ~extern:self_id_opt (dec_fields msgs dfs)
   (* The rest remaining cases just collect the uses of subexpressions: *)
-  | LitE _ | ActorUrlE _
+  | LitE _
   | PrimE _ | ImportE _ -> M.empty
-  | UnE (_, uo, e)      -> exp msgs e
-  | BinE (_, e1, bo, e2)-> exps msgs [e1; e2]
-  | RelE (_, e1, ro, e2)-> exps msgs [e1; e2]
-  | ShowE (_, e)        -> exp msgs e
-  | ToCandidE es        -> exps msgs es
-  | FromCandidE e       -> exp msgs e
-  | TupE es             -> exps msgs es
-  | ProjE (e, i)        -> exp msgs e
-  | ObjBlockE (s, _, dfs) ->
-    (* For actors, this may be too permissive; to be revised when we work on actors again *)
-    group msgs (dec_fields msgs dfs)
   | ObjE (bases, efs)   -> exps msgs bases ++ exp_fields msgs efs
-  | DotE (e, i)         -> exp msgs e
-  | AssignE (e1, e2)    -> exps msgs [e1; e2]
-  | ArrayE (m, es)      -> exps msgs es
-  | IdxE (e1, e2)       -> exps msgs [e1; e2]
+  | TupE es
+  | ArrayE (_, es)
+  | ToCandidE es        -> exps msgs es
   | BlockE ds           -> group msgs (decs msgs ds)
-  | NotE e              -> exp msgs e
-  | AndE (e1, e2)       -> exps msgs [e1; e2]
-  | OrE (e1, e2)        -> exps msgs [e1; e2]
-  | ImpliesE (e1, e2)   -> exps msgs [e1; e2]
-  | OldE e              -> exp msgs e
   | IfE (e1, e2, e3)    -> exps msgs [e1; e2; e3]
-  | SwitchE (e, cs)     -> exp msgs e ++ cases msgs cs
+  | SwitchE (e, cs)
   | TryE (e, cs, None)  -> exp msgs e ++ cases msgs cs
   | TryE (e, cs, Some f)-> exps msgs [e; f] ++ cases msgs cs
-  | WhileE (e1, e2)     -> exps msgs [e1; e2]
   | LoopE (e1, None)    -> exp msgs e1
-  | LoopE (e1, Some e2) -> exps msgs [e1; e2]
+  | LoopE (e1, Some e2)
+  | WhileE (e1, e2)
+  | AssignE (e1, e2)
+  | IdxE (e1, e2)
+  | BinE (_, e1, _, e2)
+  | RelE (_, e1, _, e2)
+  | AndE (e1, e2)
+  | OrE (e1, e2)
+  | ImpliesE (e1, e2)   -> exps msgs [e1; e2]
   | ForE (p, e1, e2)    -> exp msgs e1 ++ (exp msgs e2 /// pat msgs p)
-  | LabelE (i, t, e)    -> exp msgs e
-  | DebugE e            -> exp msgs e
-  | AsyncE (_, _, e)    -> exp msgs e
-  | AwaitE (_, e)       -> exp msgs e
-  | AssertE (_, e)      -> exp msgs e
-  | AnnotE (e, t)       -> exp msgs e
-  | OptE e              -> exp msgs e
-  | DoOptE e            -> exp msgs e
-  | BangE e             -> exp msgs e
-  | TagE (_, e)         -> exp msgs e
+  | UnE (_, _, e)
+  | ShowE (_, e)
+  | FromCandidE e
+  | DotE (e, _)
+  | ProjE (e, _)
+  | NotE e
+  | OldE e
+  | LabelE (_, _, e)
+  | DebugE e
+  | AsyncE (_, _, e)
+  | AwaitE (_, e)
+  | AssertE (_, e)
+  | AnnotE (e, _)
+  | OptE e
+  | DoOptE e
+  | BangE e
+  | TagE (_, e)
+  | ActorUrlE e
   | IgnoreE e           -> exp msgs e
 
 and exps msgs es : f = unions (exp msgs) es
@@ -178,12 +178,15 @@ and dec msgs d = match d.it with
   | 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) ->
+    let extern = if s.it = Type.Actor then Some i' else None in
     (M.empty, S.singleton i.it) +++ delayify (
-      group msgs (dec_fields msgs dfs @ class_self d.at i') /// pat msgs p /// shared_pat msgs csp
+      group msgs ~extern (dec_fields msgs dfs @ class_self d.at i' s.it) /// pat msgs p /// shared_pat msgs csp
     )
 
 (* The class self binding is treated as defined at the very end of the group *)
-and class_self at i : group = [(at, S.singleton i.it, S.empty, S.empty)]
+and class_self at i : Type.obj_sort -> group = function
+  | Type.Actor -> []
+  | _ -> [(at, S.singleton i.it, S.empty, S.empty)]
 
 and decs msgs decs : group =
   (* Annotate the declarations with the analysis results *)
@@ -192,9 +195,13 @@ and decs msgs decs : group =
     (d.at, defs, eager_vars f, delayed_vars f)
   ) decs
 
-and group msgs (grp : group) : f =
+and group msgs ?(extern=None) (grp : group) : f =
   (* Create a map from declared variable to their definition point *)
   let defWhen = M.disjoint_unions (List.mapi (fun i (_, defs, _, _) -> map_of_set i defs) grp) in
+  (* Insert the externally defined binding in front if present, non-shadowing *)
+  let defWhen = match extern with
+    | Some b when M.find_opt b.it defWhen |> Option.is_none -> M.add b.it (-1) defWhen
+    | _ -> defWhen in
   (* Calculate the relation R *)
   let r = NameRel.unions (List.map (fun (_, defs, _, delayed) -> NameRel.cross defs delayed) grp) in
   (* Check for errors *)
@@ -242,4 +249,3 @@ let check_lib lib =
     ignore (group msgs (decs msgs (imp_ds @ ds)));
     Some ()
   )
-

src/mo_frontend/parser.mly

@@ -195,13 +195,13 @@ let share_dec_field (df : dec_field) =
     }
   | _ -> df
 
-and objblock s ty dec_fields =
+and objblock s id ty dec_fields =
   List.iter (fun df ->
     match df.it.vis.it, df.it.dec.it with
     | Public _, ClassD (_, id, _, _, _, _, _, _) when is_anon_id id ->
       syntax_error df.it.dec.at "M0158" "a public class cannot be anonymous, please provide a name"
     | _ -> ()) dec_fields;
-  ObjBlockE(s, ty, dec_fields)
+  ObjBlockE(s, (id, ty), dec_fields)
 
 %}
 
@@ -872,12 +872,13 @@ dec_nonvar :
       let named, x = xf sort $sloc in
       let e =
         if s.it = Type.Actor then
+          let id = if named then Some x else None in
           AwaitE
             (Type.Fut,
              AsyncE(Type.Fut, scope_bind (anon_id "async" (at $sloc)) (at $sloc),
-                    objblock s t (List.map share_dec_field efs) @? at $sloc)
+                    objblock s id t (List.map share_dec_field efs) @? at $sloc)
              @? at $sloc) @? at $sloc
-        else objblock s t efs @? at $sloc
+        else objblock s None t efs @? at $sloc
       in
       let_or_exp named x e.it e.at }
   | sp=shared_pat_opt FUNC xf=id_opt

src/mo_frontend/typing.ml

@@ -1382,7 +1382,7 @@ and infer_exp'' env exp : T.typ =
     in
     let t = infer_obj env' obj_sort.it dec_fields exp.at in
     begin match env.pre, typ_opt with
-      | false, Some typ ->
+      | false, (_, Some typ) ->
         let t' = check_typ env' typ in
         if not (T.sub t t') then
           local_error env exp.at "M0192"