working with loose ends

src/ir_def/check_ir.ml

@@ -241,7 +241,7 @@ let rec check_typ env typ : unit =
     if not (Lib.List.is_strictly_ordered T.compare_field fields) then
       error env no_region "variant type's fields are not distinct and sorted %s" (T.string_of_typ typ)
   | T.Mut typ ->
-    error env no_region "unexpected T.Mut"
+    error env no_region "unexpected T.Mut %s" (T.string_of_typ typ)
   | T.Typ c ->
     error env no_region "unexpected T.Typ"
 

src/ir_def/construct.ml

@@ -790,8 +790,42 @@ let objE sort typ_flds flds =
   in
   go [] [] [] flds
 
+
 let recordE flds = objE T.Object [] flds
 
+let objectE sort flds (tfs : T.field list) =
+  let rec go ds fields = function
+    | [] ->
+      blockE
+        (List.rev ds)
+        (newObjE sort fields
+          (T.Obj (sort, List.sort T.compare_field tfs)))
+    | (lab, exp)::flds ->
+       let v, typ, ds =
+         match T.lookup_val_field_opt lab tfs with
+         | None -> assert false
+         | Some typ ->
+           if T.is_mut typ
+           then
+             let v = fresh_var lab typ in
+             v, typ, varD v exp :: ds
+           else
+             match exp.it with
+             | VarE (Const, v) ->
+                var v typ, typ, ds
+             | _ ->
+                let v = fresh_var lab typ in
+                v, typ, letD v exp :: ds
+       in
+       let field = {
+         it = {name = lab; var = id_of_var v};
+         at = no_region;
+         note = typ
+       } in
+      go ds (field::fields) flds
+  in
+  go [] [] flds
+
 let check_call_perform_status success mk_failure =
   ifE
     (callE

src/ir_def/construct.mli

@@ -147,6 +147,8 @@ val (-*-) : exp -> exp -> exp (* application *)
 
 val objE : obj_sort -> (lab * con) list -> (lab * exp) list -> exp
 
+val objectE : obj_sort -> (lab * exp) list -> field list -> exp
+
 (* Records *)
 
 val recordE : (lab * exp) list -> exp

src/lowering/desugar.ml

@@ -561,12 +561,17 @@ and build_actor at ts exp_opt self_id es obj_typ =
                primE (I.OtherPrim "rts_stable_memory_size") [];
                natE Numerics.Nat.zero])
         (primE (I.ICStableRead ty) [])
-        (let fields' = List.map (fun (i,t) ->
-           let t' = match T.lookup_val_field_opt i dom_fields with
-             | None -> t
-             | Some t -> t
-           in
-           T.{lab = i; typ = T.Opt (T.as_immut t'); src = T.empty_src}) ids in
+        (let fields' =
+           List.map
+             (fun (i,t) ->
+                T.{lab = i; typ = T.Opt (T.as_immut t); src = T.empty_src})
+             ((List.map (fun T.{lab;typ;_} -> (lab,typ)) dom_fields) @
+                (List.filter_map
+                   (fun (i,t) ->
+                     match T.lookup_val_field_opt i dom_fields with
+                     | Some t -> None (* ignore overriden *)
+                     | None -> Some (i, t) (* retain others *))
+                   ids)) in
          let ty' = T.Obj (T.Memory, List.sort T.compare_field fields') in
          let v = fresh_var "v" ty' in
 (*         let fields'' = List.map (fun (i,t) ->
@@ -581,28 +586,28 @@ and build_actor at ts exp_opt self_id es obj_typ =
          (*         let v_res = fresh_var "v_res" ty in *)
          letE v (primE (I.ICStableRead ty') [])
            (letE v_dom
-              (objE T.Object []
-                (List.map (fun T.{lab=i;typ=t;_} ->
-                  let vi = fresh_var ("v_"^i) t in
-                  (i, switch_optE (dotE (varE v) i (T.Opt t))
+              (objectE T.Object
+                 (List.map (fun T.{lab=i;typ=t;_} ->
+                  let vi = fresh_var ("v_"^i) (T.as_immut t) in
+                  (i, switch_optE (dotE (varE v) i (T.Opt (T.as_immut t)))
                        (primE (Ir.OtherPrim "trap")
-                         [textE ("stable variable "^i^"required but no found")])
+                         [textE ("stable variable " ^ i ^ " expected but not found")])
                        (varP vi) (varE vi)
-                       t)) dom_fields))
-              (letE v_rng (callE e [] (varE v))
-                 (objE T.Memory []
+                       (T.as_immut t))) dom_fields) dom_fields)
+              (letE v_rng (callE e [] (varE v_dom))
+                 (objectE T.Memory
                     (List.map (fun T.{lab=i;typ=t;_} ->
                      i,
                      match T.lookup_val_field_opt i rng_fields with
                        (* produced by migration *)
-                     | Some t -> optE (dotE (varE v_rng) i t) (* wrap in ? _*)
-                       | None ->
+                     | Some t -> optE (dotE (varE v_rng) i (T.as_immut t)) (* wrap in ?_*)
+                     | None ->
                          (* not produced by migration *)
                          match T.lookup_val_field_opt i dom_fields with
                          | Some t -> nullE() (* consumed by migration (not produced) *)
                             (*TBR: could also reuse if compatible *)
-                         | None -> dotE (varE v) i (T.Opt t))
-                       fields)))))
+                         | None -> dotE (varE v) i t)
+                       fields) fields))))
   in
   let ds =
     varD state (optE migration)

src/mo_frontend/typing.ml

@@ -1368,7 +1368,8 @@ and infer_exp'' env exp : T.typ =
          error_in [Flags.ICMode; Flags.RefMode] env exp.at "M0069"
            "non-toplevel actor; an actor can only be declared at the toplevel of a program"
       | _ -> ()
-    end;
+      end;
+    let _t_opt = Option.map (infer_exp env) exp_opt in
     let env' =
       if obj_sort.it = T.Actor then
         { env with
@@ -2687,6 +2688,7 @@ and infer_dec env dec : T.typ =
      (*TODO exp_opt *)
     let (t, _, _, _) = T.Env.find id.it env.vals in
     if not env.pre then begin
+      let _t_opt = Option.map (infer_exp env) exp_opt in
       let c = T.Env.find id.it env.typs in
       let ve0 = check_class_shared_pat env shared_pat obj_sort in
       let cs, tbs, te, ce = check_typ_binds env typ_binds in

test/run-drun/upgrade-migration/Migration2.mo

@@ -1,10 +1,14 @@
+import Prim "mo:prim";
 module {
 
-  public func run( o : { var three : [var (Nat,Nat)] } ) :
+  public func run( pre : { var three : [var (Nat,Nat)] } ) :
      { var four : [var (Nat,Nat)] } {
+    let post =
     {
-      var four = o.three;
-    }
+      var four = pre.three;
+    };
+    Prim.debugPrint(debug_show{pre;post});
+    post
   }
 
 }

test/run-drun/upgrade-migration/version1.mo

@@ -1,7 +1,7 @@
 import Prim "mo:prim";
 import Migration "Migration1";
 
-actor {
+actor [Migration.run] {
 
    Prim.debugPrint("Version 1");