AST-53: Pattern-matching objects

src/arrange.ml

@@ -56,6 +56,7 @@ and pat p = match p.it with
   | WildP           -> Atom "WildP"
   | VarP x          -> "VarP"       $$ [id x]
   | TupP ps         -> "TupP"       $$ List.map pat ps
+  | ObjP ps         -> "ObjP"       $$ List.map pat_field ps
   | AnnotP (p, t)   -> "AnnotP"     $$ [pat p; typ t]
   | LitP l          -> "LitP"       $$ [lit !l]
   | SignP (uo, l)   -> "SignP"      $$ [unop uo ; lit !l]
@@ -110,6 +111,8 @@ and relop ro = match ro with
 
 and case c = "case" $$ [pat c.it.pat; exp c.it.exp]
 
+and pat_field pf = pf.it.id.it $$ [pat pf.it.pat]
+
 and prim p = Atom (Type.string_of_prim p)
 
 and sharing sh = match sh with

src/arrange_ir.ml

@@ -42,7 +42,7 @@ let rec exp e = match e.it with
   | ActorE (i, ds, fs, t) -> "ActorE"  $$ [id i] @ List.map dec ds @ fields fs @ [typ t]
   | NewObjE (s, fs, t)  -> "NewObjE" $$ (Arrange.obj_sort' s :: fields fs @ [typ t])
 
-and fields fs = List.fold_left (fun flds f -> (name f.it.name $$ [ id f.it.var ]):: flds) [] fs
+and fields fs = List.fold_left (fun flds (f : field) -> (name f.it.name $$ [ id f.it.var ]):: flds) [] fs
 
 and args = function
  | [] -> []
@@ -54,11 +54,14 @@ and pat p = match p.it with
   | WildP           -> Atom "WildP"
   | VarP i          -> "VarP"       $$ [ id i ]
   | TupP ps         -> "TupP"       $$ List.map pat ps
+  | ObjP pfs        -> "ObjP"       $$ List.map pat_field pfs
   | LitP l          -> "LitP"       $$ [ Arrange.lit l ]
   | OptP p          -> "OptP"       $$ [ pat p ]
   | VariantP (i, p) -> "VariantP"   $$ [ id i; pat p ]
   | AltP (p1,p2)    -> "AltP"       $$ [ pat p1; pat p2 ]
 
+and pat_field pf = name pf.it.name $$ [pat pf.it.pat]
+
 and case c = "case" $$ [pat c.it.pat; exp c.it.exp]
 
 and name n = match n.it with

src/async.ml

@@ -380,6 +380,8 @@ module Transform() = struct
       pat
     | TupP pats ->
       TupP (List.map t_pat pats)
+    | ObjP pfs ->
+      ObjP (map_obj_pat t_pat pfs)
     | OptP pat1 ->
       OptP (t_pat pat1)
     | VariantP (i, pat1) ->

src/await.ml

@@ -405,6 +405,7 @@ and declare_pat pat exp : exp =
   | WildP | LitP  _ ->  exp
   | VarP id -> declare_id id pat.note exp
   | TupP pats -> declare_pats pats exp
+  | ObjP pfs -> declare_pats (pats_of_obj_pat pfs) exp
   | OptP pat1
   | VariantP (_, pat1) -> declare_pat pat1 exp
   | AltP (pat1, pat2) -> declare_pat pat1 exp
@@ -430,6 +431,10 @@ and rename_pat' pat =
   | TupP pats ->
     let (patenv,pats') = rename_pats pats in
     (patenv,TupP pats')
+  | ObjP pfs ->
+    let (patenv, pats') = rename_pats (pats_of_obj_pat pfs) in
+    let pfs' = replace_obj_pat pfs pats' in
+    (patenv, ObjP pfs')
   | OptP pat1 ->
     let (patenv,pat1) = rename_pat pat1 in
     (patenv, OptP pat1)
@@ -457,6 +462,7 @@ and define_pat patenv pat : dec list =
   | VarP id ->
     [ expD (define_idE id constM (PatEnv.find id.it patenv)) ]
   | TupP pats -> define_pats patenv pats
+  | ObjP pfs -> define_pats patenv (pats_of_obj_pat pfs)
   | OptP pat1
   | VariantP (_, pat1) -> define_pat patenv pat1
   | AltP (pat1, pat2) ->

src/check_ir.ml

@@ -8,7 +8,7 @@ module E = Effect
 (* TODO: make note immutable, perhaps just using type abstraction *)
 
 (* TODO:
-   dereferencing is still implicit in the IR (see immut_typ below) - consider making it explicit as   part of desugaring.
+   dereferencing is still implicit in the IR (see immut_typ below) - consider making it explicit as part of desugaring.
  *)
 
 (* TODO: enforce second-class nature of T.Mut? in check_typ *)
@@ -575,6 +575,8 @@ and gather_pat env ve0 pat : val_env =
       T.Env.add id.it pat.note ve (*TBR*)
     | TupP pats ->
       List.fold_left go ve pats
+    | ObjP pfs ->
+      List.fold_left go ve (pats_of_obj_pat pfs)
     | AltP (pat1, pat2) ->
       ve
     | OptP pat1
@@ -601,7 +603,11 @@ and check_pat env pat : val_env =
   | TupP pats ->
     let ve = check_pats pat.at env pats T.Env.empty in
     let ts = List.map (fun pat -> pat.note) pats in
-    T.Tup ts <: t;
+    t <: T.Tup ts;
+    ve
+  | ObjP pfs ->
+    let ve = check_pats pat.at env (pats_of_obj_pat pfs) T.Env.empty in
+    check_pat_fields env t pfs;
     ve
   | OptP pat1 ->
     let ve = check_pat env pat1 in
@@ -628,6 +634,17 @@ and check_pats at env pats ve : val_env =
     let ve' = disjoint_union env at "duplicate binding for %s in pattern" ve ve1 in
     check_pats at env pats' ve'
 
+and check_pat_fields env t = List.iter (check_pat_field env t)
+
+and check_pat_field env t (pf : pat_field) =
+  let Name lab = pf.it.name.it in
+  let tf = T.{lab; typ=pf.it.pat.note} in
+  let s, tfs = T.as_obj_sub lab t in
+  let (<:) = check_sub env pf.it.pat.at in
+  t <: T.Obj (s, [tf]);
+  if T.is_mut (T.lookup_field lab tfs)
+  then error env pf.it.pat.at "cannot match mutable field %s" lab
+
 (* Objects *)
 
 and type_obj env s fs : T.typ =

src/compile.ml

@@ -4091,6 +4091,16 @@ let compile_relop env t op =
      compile_comparison env t1 op1
   | _ -> todo_trap env "compile_relop" (Arrange.relop op)
 
+(* compile_load_field performs a tag check if the projection's domain
+   is ambiguous, then calls the appropriate accessor *)
+let compile_load_field env typ ({it=(Name n); _} as name) =
+  let selective tag = function
+    | None -> [] | Some code -> [ tag, code ] in
+  Tagged.branch_with env (ValBlockType (Some I32Type))
+    (List.concat [ [Tagged.Object, Object.load_idx env typ name]
+                 ; selective Tagged.Array (Array.fake_object_idx env n)
+                 ; selective Tagged.Text (Text.fake_object_idx env n)])
+
 (* compile_lexp is used for expressions on the left of an
 assignment operator, produces some code (with side effect), and some pure code *)
 let rec compile_lexp (env : E.t) exp =
@@ -4122,15 +4132,10 @@ and compile_exp (env : E.t) exp =
     G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^
     Array.idx env ^^
     load_ptr
-  | DotE (e, ({it = Name n;_} as name)) ->
+  | DotE (e, name) ->
     SR.Vanilla,
     compile_exp_vanilla env e ^^
-      let selective tag = function
-        | None -> [] | Some code -> [ tag, code ]
-      in Tagged.branch_with env (ValBlockType (Some I32Type))
-           (List.concat [ [Tagged.Object, Object.load_idx env e.note.note_typ name]
-                        ; selective Tagged.Array (Array.fake_object_idx env n)
-                        ; selective Tagged.Text (Text.fake_object_idx env n)])
+    compile_load_field env e.note.note_typ name
   | ActorDotE (e, ({it = Name n;_} as name)) ->
     SR.UnboxedReference,
     if E.mode env <> DfinityMode then G.i Unreachable else
@@ -4412,9 +4417,7 @@ and compile_exp (env : E.t) exp =
 
     let rec go env cs = match cs with
       | [] -> CanFail (fun k -> k)
-      | (c::cs) ->
-          let pat = c.it.pat in
-          let e = c.it.exp in
+      | {it={pat; exp=e}; _}::cs ->
           let (env1, code) = compile_pat_local env pat in
           orElse ( CannotFail get_i ^^^ code ^^^
                    CannotFail (compile_exp_vanilla env1 e) ^^^ CannotFail set_j)
@@ -4574,15 +4577,23 @@ and fill_pat env pat : patternCode =
       CannotFail (Var.set_val env name.it)
   | TupP ps ->
       let (set_i, get_i) = new_local env "tup_scrut" in
-      let rec go i ps env = match ps with
+      let rec go i = function
         | [] -> CannotFail G.nop
-        | (p::ps) ->
+        | p::ps ->
           let code1 = fill_pat env p in
-          let code2 = go (i+1) ps env in
-          ( CannotFail (get_i ^^ Tuple.load_n (Int32.of_int i)) ^^^
-            code1 ^^^
-            code2 ) in
-      CannotFail set_i ^^^ go 0 ps env
+          let code2 = go (Int32.add i 1l) ps in
+          CannotFail (get_i ^^ Tuple.load_n i) ^^^ code1 ^^^ code2 in
+      CannotFail set_i ^^^ go 0l ps
+  | ObjP pfs ->
+      let project = compile_load_field env pat.note in
+      let (set_i, get_i) = new_local env "obj_scrut" in
+      let rec go = function
+        | [] -> CannotFail G.nop
+        | {it={name; pat}; _}::pfs' ->
+          let code1 = fill_pat env pat in
+          let code2 = go pfs' in
+          CannotFail (get_i ^^ project name) ^^^ code1 ^^^ code2 in
+      CannotFail set_i ^^^ go pfs
   | AltP (p1, p2) ->
       let code1 = fill_pat env p1 in
       let code2 = fill_pat env p2 in

src/coverage.ml

@@ -12,6 +12,7 @@ type desc =
   | Val of V.value
   | NotVal of ValSet.t
   | Tup of desc list
+  | Object of desc list
   | Opt of desc
   | Tag of desc * id
   | NotTag of TagSet.t
@@ -20,6 +21,7 @@ type ctxt =
   | InOpt of ctxt
   | InTag of ctxt * id
   | InTup of ctxt * desc list * desc list * pat list * Type.typ list
+  | InObject of ctxt * desc list * desc list * pat_field list * Type.field list
   | InAlt1 of ctxt * Source.region * pat * Type.typ
   | InAlt2 of ctxt * Source.region
   | InCase of Source.region * case list * Type.typ
@@ -77,6 +79,20 @@ let rec match_pat ctxt desc pat t sets =
       | Any -> List.map (fun _ -> Any) pats
       | _ -> assert false
     in match_tup ctxt [] descs pats ts sets
+  | ObjP pfs ->
+    let t' = Type.promote t in
+    let sensible (pf : pat_field) =
+      List.exists (fun {Type.lab; _} -> pf.it.id.it = lab) (snd (Type.as_obj_sub pf.it.id.it t')) in
+    let pfs' = List.filter sensible pfs in
+    let tf_of_pf (pf : pat_field) =
+      List.find (fun {Type.lab; _} -> pf.it.id.it = lab) (snd (Type.as_obj_sub pf.it.id.it t')) in
+    let tfs' = List.map tf_of_pf pfs' in
+    let descs =
+      match desc with
+      | Object descs -> descs
+      | Any -> List.map (fun _ -> Any) pfs'
+      | _ -> assert false
+    in match_object ctxt [] descs pfs' tfs' sets
   | OptP pat1 ->
     let t' = Type.as_opt (Type.promote t) in
     (match desc with
@@ -152,6 +168,14 @@ and match_tup ctxt descs_r descs pats ts sets =
   | _ ->
     assert false
 
+and match_object ctxt descs_r descs (pfs : pat_field list) tfs sets =
+  match descs, pfs, tfs with
+  | [], [], [] ->
+    succeed ctxt (Object (List.rev descs_r)) sets
+  | desc::descs', pf::pfs', Type.{lab; typ}::tfs' ->
+    match_pat (InObject (ctxt, descs_r, descs', pfs', tfs')) desc pf.it.pat typ sets
+  | _ ->
+    assert false
 
 and succeed ctxt desc sets : bool =
   match ctxt with
@@ -161,6 +185,8 @@ and succeed ctxt desc sets : bool =
     succeed ctxt' (Tag (desc, t)) sets
   | InTup (ctxt', descs_r, descs, pats, ts) ->
     match_tup ctxt' (desc::descs_r) descs pats ts sets
+  | InObject (ctxt', descs_r, descs, pfs, tfs) ->
+    match_object ctxt' (desc::descs_r) descs pfs tfs sets
   | InAlt1 (ctxt', at1, _pat2, _t) ->
     sets.reached_alts <- AtSet.add at1 sets.reached_alts;
     succeed ctxt' desc sets
@@ -187,6 +213,8 @@ and fail ctxt desc sets : bool =
     fail ctxt' (Tag (desc, id)) sets
   | InTup (ctxt', descs', descs, pats, _ts) ->
     fail ctxt' (Tup (List.rev descs' @ [desc] @ descs)) sets
+  | InObject (ctxt', descs', descs, pats, _ts) ->
+    fail ctxt' (Object (List.rev descs' @ [desc] @ descs)) sets
   | InAlt1 (ctxt', at1, pat2, t) ->
     match_pat (InAlt2 (ctxt', pat2.at)) desc pat2 t sets
   | InAlt2 (ctxt', at2) ->

src/definedness.ml

@@ -45,15 +45,15 @@ type fd = f * defs
 (* Operations: *)
 
 (* This adds a set of free variables to a combined set *)
-let (+++) ((f,d) : fd)  x = ((++) f x, d)
+let (+++) ((f, d) : fd) x = ((++) f x, d)
 (* This takes the union of two combined sets *)
-let (++++) (f1, d1) (f2,d2) = ((++) f1 f2, S.union d1 d2)
+let (++++) (f1, d1) (f2, d2) = ((++) f1 f2, S.union d1 d2)
 let union_binders f xs = List.fold_left (++++) (M.empty, S.empty) (List.map f xs)
 
 let diff f d = M.filter (fun k _ -> not (S.mem k d)) f
 
 (* The bound variables from the second argument scope over the first *)
-let (///) (x : f) ((f,d) : fd) = f ++ diff x d
+let (///) (x : f) ((f, d) : fd) = f ++ diff x d
 
 (* Usage tracking. We distinguish between eager and delayed variable use.
    Eager variables become delayed
@@ -126,6 +126,7 @@ and pat msgs p : fd = match p.it with
   | WildP         -> (M.empty, S.empty)
   | VarP i        -> (M.empty, S.singleton i.it)
   | TupP ps       -> pats msgs ps
+  | ObjP pfs      -> pat_fields msgs pfs
   | AnnotP (p, _)
   | ParP p        -> pat msgs p
   | LitP l        -> (M.empty, S.empty)
@@ -136,6 +137,8 @@ and pat msgs p : fd = match p.it with
 
 and pats msgs ps : fd = union_binders (pat msgs) ps
 
+and pat_fields msgs pfs = union_binders (fun (pf : pat_field) -> pat msgs pf.it.pat) pfs
+
 and case msgs (c : case) = exp msgs c.it.exp /// pat msgs c.it.pat
 
 and cases msgs cs : f = unions (case msgs) cs

src/desugar.ml

@@ -4,7 +4,7 @@ module I = Ir
 module T = Type
 open Construct
 
-(* Combinators used in the desguaring *)
+(* Combinators used in the desugaring *)
 
 let trueE : Ir.exp = boolE true
 let falseE : Ir.exp = boolE false
@@ -218,12 +218,18 @@ and pat' = function
   | S.LitP l -> I.LitP !l
   | S.SignP (o, l) -> I.LitP (apply_sign o !l)
   | S.TupP ps -> I.TupP (pats ps)
+  | S.ObjP pfs ->
+    I.ObjP (pat_fields pfs)
   | S.OptP p -> I.OptP (pat p)
   | S.VariantP (i, p) -> I.VariantP (i, pat p)
   | S.AltP (p1, p2) -> I.AltP (pat p1, pat p2)
   | S.AnnotP (p, _)
   | S.ParP p -> pat' p.it
 
+and pat_fields pfs = List.map pat_field pfs
+
+and pat_field pf = phrase (fun S.{id; pat=p} -> I.{name=phrase (fun s -> Name s) id; pat=pat p}) pf
+
 and to_arg p : (Ir.arg * (Ir.exp -> Ir.exp)) =
   match p.it with
   | S.AnnotP (p, _) -> to_arg p

src/freevars.ml

@@ -103,6 +103,7 @@ and pat p : fd = match p.it with
   | WildP           -> (M.empty, S.empty)
   | VarP i          -> (M.empty, S.singleton i.it)
   | TupP ps         -> pats ps
+  | ObjP pfs        -> pats (pats_of_obj_pat pfs)
   | LitP l          -> (M.empty, S.empty)
   | OptP p          -> pat p
   | VariantP (i, p) -> pat p