record punning & record patterns

satysfi.opam

@@ -38,6 +38,7 @@ depends: [
   "omd" {< "2.0.0~"}
   "ocamlgraph"
   "alcotest" {with-test & >= "1.4.0"}
+  "ppx_expect" {with-test}
 ]
 synopsis: "A statically-typed, functional typesetting system"
 description: """

src/frontend/bytecomp/compiler.ml

@@ -381,6 +381,19 @@ and compile_patcheck (pat : ir_pattern_tree) (next : instruction list) (cont : i
         in
         aux (ps |> TupleList.to_list) next cont
 
+    | IRPRecord(ps) ->
+        let rec aux ps next cont =
+          match ps with
+          | [] ->
+              return OpPop
+
+          | (label, pat) :: ptl ->
+              let ctl = aux ptl next cont in
+              let chd = compile_patcheck pat (OpPop :: next) ctl in
+              OpCheckStackTopRecord(label, next) :: chd
+        in
+        aux ps next cont
+
     | IRPConstructor(cnm1, psub) ->
         let code = compile_patcheck psub next cont in
         OpCheckStackTopCtor(cnm1, next) :: code

src/frontend/bytecomp/ir.cppo.ml

@@ -241,6 +241,15 @@ and transform_pattern (env : frame) (pat : pattern_tree) : ir_pattern_tree * fra
       in
       (IRPTuple(bs), env)
 
+  | PRecord(field_pats) ->
+      let (bs, env) =
+        field_pats |> List.fold_left (fun (acc, env) (label, pat) ->
+          let (b, env) = transform_pattern env pat in
+          (Alist.extend acc (label, b), env)
+        ) (Alist.empty, env)
+      in
+      (IRPRecord(Alist.to_list bs), env)
+
   | PConstructor(cnm1, psub) ->
       let (bsub, env) = transform_pattern env psub in
       (IRPConstructor(cnm1, bsub), env)

src/frontend/bytecomp/vm.cppo.ml

@@ -439,6 +439,15 @@ and exec_code_pattern_tree (env : vmenv) (irpat : ir_pattern_tree) : vmenv * cod
       in
       (env, CdPTuple(cdpats))
 
+  | IRPRecord(irpats) ->
+      let (env, cdpats) =
+        irpats |> List.fold_left (fun (env, acc) (label, irpat) ->
+          let (env, cdpat) = exec_code_pattern_tree env irpat in
+          (env, Alist.extend acc (label, cdpat))
+        ) (env, Alist.empty)
+      in
+      (env, CdPRecord(cdpats |> Alist.to_list))
+
   | IRPWildCard ->
       (env, CdPWildCard)
 
@@ -985,6 +994,22 @@ and exec_op (op : instruction) (stack : stack) (env : vmenv) (code : instruction
         | _ -> report_bug_vm "invalid argument for OpCheckStackTopTupleCons"
       end
 
+  | OpCheckStackTopRecord(label, next) ->
+      begin
+        match stack with
+        | (v, _) :: stack ->
+            begin
+              match v with
+              | RecordValue(fields) ->
+                let value = LabelMap.find label fields in
+                exec (make_entry value :: make_entry (v) :: stack) env code dump
+              | _                 ->
+                exec stack env next dump
+            end
+
+        | _ -> report_bug_vm "invalid argument for OpCheckStackTopRecord"
+      end
+
   | OpClosure(varloc_labmap, arity, framesize, body) ->
       let entry = make_entry @@ CompiledClosure(varloc_labmap, arity, [], framesize, body, env) in
       exec (entry :: stack) env code dump

src/frontend/evaluator.cppo.ml

@@ -628,6 +628,16 @@ and interpret_1_pattern_tree (env : environment) = function
       in
       (env, CdPTuple(cdpattrs))
 
+  | PRecord(field_pats) ->
+      let (env, cdfields) =
+        field_pats
+        |> List.fold_left (fun (env, lis) (label, pat) ->
+            let (env, cdpat) = interpret_1_pattern_tree env pat in
+            (env, Alist.extend lis (label, cdpat)))
+          (env, Alist.empty)
+      in
+      (env, CdPRecord(cdfields |> Alist.to_list))
+
   | PWildCard ->
       (env, CdPWildCard)
 
@@ -1055,15 +1065,23 @@ and check_pattern_matching (env : environment) (pat : pattern_tree) (value_obj :
   | (PIntegerConstant(pnc), BaseConstant(BCInt(nc))) ->
       if pnc = nc then Some(env) else None
 
+  | (PIntegerConstant _, _) -> None
+
   | (PBooleanConstant(pbc), BaseConstant(BCBool(bc))) ->
       if pbc = bc then Some(env) else None
 
+  | (PBooleanConstant _, _) -> None
+
   | (PStringConstant(psc), BaseConstant(BCString(str2))) ->
       if String.equal psc str2 then Some(env) else None
 
+  | (PStringConstant _, _) -> None
+
   | (PUnitConstant, BaseConstant(BCUnit)) ->
       Some(env)
 
+  | (PUnitConstant, _) -> None
+
   | (PWildCard, _) ->
       Some(env)
 
@@ -1080,11 +1098,15 @@ and check_pattern_matching (env : environment) (pat : pattern_tree) (value_obj :
   | (PEndOfList, List([])) ->
       Some(env)
 
+  | (PEndOfList, _) -> None
+
   | (PListCons(pat_head, pat_tail), List(v_head :: vs_tail)) ->
       let open OptionMonad in
       check_pattern_matching env pat_head v_head >>= fun env ->
       check_pattern_matching env pat_tail (List(vs_tail))
 
+  | (PListCons _, _) -> None
+
   | (PTuple(ps), Tuple(vs)) ->
       let open OptionMonad in
       begin
@@ -1097,14 +1119,26 @@ and check_pattern_matching (env : environment) (pat : pattern_tree) (value_obj :
         | Invalid_argument(_) -> None
       end
 
+  | (PTuple _, _) -> None
+
+  | (PRecord(field_pats), RecordValue(fields)) ->
+       let open OptionMonad in
+       field_pats
+       |> List.fold_left (fun env (label, pat) ->
+           let* env = env in
+           let* v = LabelMap.find_opt label fields in
+           check_pattern_matching env pat v)
+         (Some env)
+
+  | (PRecord _, _) -> None
+
   | (PConstructor(cnm1, psub), Constructor(cnm2, sub)) ->
       if String.equal cnm1 cnm2 then
         check_pattern_matching env psub sub
       else
         None
 
-  | _ ->
-      None
+  | (PConstructor _, _) -> None
 
 
 and add_letrec_bindings_to_environment (env : environment) (recbinds : letrec_binding list) : environment =

src/frontend/parser.mly

@@ -954,6 +954,12 @@ expr_bot_record:
 record_field:
   | rlabel=LOWER; EXACT_EQ; utast=expr
       { (rlabel, utast) }
+  | rlabel=LOWER;
+      {
+        let (rng, _) = rlabel in
+        let expr = (rng, UTContentOf([], rlabel)) in
+        (rlabel, expr)
+      }
 ;
 branch:
   | utpat=pattern; ARROW; utast=expr
@@ -1055,6 +1061,31 @@ pattern_non_var_bot:
         | utpat2 :: utpat_rest ->
             make_standard (Tok tokL) (Tok tokR) (UTPTuple(TupleList.make utpat1 utpat2 utpat_rest))
       }
+  | tokL=L_RECORD; body=pat_record_body; tokR=R_RECORD
+      {
+        let (is_open, fields) = body in
+        make_standard (Tok tokL) (Tok tokR) (UTPRecord(is_open, fields))
+      }
+;
+pat_record_body:
+  | WILDCARD; COMMA?
+    { (true, []) }
+  | field=pat_record_field; COMMA?
+    { (false, [field]) }
+  | field=pat_record_field; COMMA; rest=pat_record_body
+    {
+     let (is_open, fields) = rest in
+     (is_open, field::fields)
+    }
+pat_record_field:
+  | rlabel=LOWER; EXACT_EQ; utpat=pattern
+      { (rlabel, utpat) }
+  | rlabel=LOWER;
+      {
+        let (rng, varnm) = rlabel in
+        let expr = (rng, UTPVariable(varnm)) in
+        (rlabel, expr)
+      }
 ;
 inline:
   | BAR; utasts=list(terminated(inline_single, BAR))

src/frontend/typechecker.ml

@@ -207,6 +207,33 @@ let rec typecheck_pattern (pre : pre) (tyenv : Typeenv.t) ((rng, utpatmain) : un
         in
         return (PTuple(epats), tyres, patvarmap)
 
+    | UTPRecord(is_open, field_pats) ->
+        let rlabels = List.map fst field_pats in
+        let labels = List.map snd rlabels in
+        let utpats = List.map snd field_pats in
+        let* tris = mapM iter utpats in
+        let epats = tris |> List.map (fun (epat, _, _) -> epat) in
+        let typats = tris |> List.map (fun (_, typat, _) -> typat) in
+        let row =
+          if is_open then
+            let frid = fresh_free_row_id pre.level (LabelSet.of_list labels) in
+            let rvuref = ref (MonoRowFree(frid)) in
+            RowVar(UpdatableRow(rvuref))
+          else
+            RowEmpty
+        in
+        let row =
+          List.fold_left2 (fun row label typat -> RowCons(label, typat, row))
+            row rlabels typats
+        in
+        let tyres = (rng, RecordType(row)) in
+        let* patvarmap =
+          tris
+          |> List.map (fun (_, _, patvarmap) -> patvarmap)
+          |> foldM unite_pattern_var_map PatternVarMap.empty
+        in
+        return (PRecord(List.combine labels epats), tyres, patvarmap)
+
     | UTPWildCard ->
         let beta = fresh_type_variable rng pre in
         return (PWildCard, beta, PatternVarMap.empty)

src/frontend/types.cppo.ml

@@ -531,6 +531,7 @@ and untyped_pattern_tree_main =
   | UTPListCons            of untyped_pattern_tree * untyped_pattern_tree
   | UTPEndOfList
   | UTPTuple               of untyped_pattern_tree TupleList.t
+  | UTPRecord              of bool * (label ranged * untyped_pattern_tree) list
   | UTPWildCard
   | UTPVariable            of var_name
   | UTPAsVariable          of var_name * untyped_pattern_tree
@@ -769,6 +770,7 @@ and ir_pattern_tree =
   | IRPListCons             of ir_pattern_tree * ir_pattern_tree
   | IRPEndOfList
   | IRPTuple                of ir_pattern_tree TupleList.t
+  | IRPRecord               of (label * ir_pattern_tree) list
   | IRPWildCard
   | IRPVariable             of varloc
   | IRPAsVariable           of varloc * ir_pattern_tree
@@ -818,6 +820,8 @@ and instruction =
       [@printer (fun fmt _ -> Format.fprintf fmt "OpCheckStackTopStr(...)")]
   | OpCheckStackTopTupleCons of instruction list
       [@printer (fun fmt _ -> Format.fprintf fmt "OpCheckStackTopTupleCons(...)")]
+  | OpCheckStackTopRecord of label * instruction list
+      [@printer (fun fmt _ -> Format.fprintf fmt "OpCheckStackTopRecord(...)")]
   | OpClosure of varloc LabelMap.t * int * int * instruction list
   | OpClosureInlineText of compiled_inline_text_element list
   | OpClosureBlockText of compiled_block_text_element list
@@ -996,6 +1000,7 @@ and pattern_tree =
   | PListCons             of pattern_tree * pattern_tree
   | PEndOfList
   | PTuple                of pattern_tree TupleList.t
+  | PRecord               of (label * pattern_tree) list
   | PWildCard
   | PVariable             of EvalVarID.t
   | PAsVariable           of EvalVarID.t * pattern_tree
@@ -1165,6 +1170,7 @@ and code_pattern_tree =
   | CdPListCons             of code_pattern_tree * code_pattern_tree
   | CdPEndOfList
   | CdPTuple                of code_pattern_tree TupleList.t
+  | CdPRecord               of (label * code_pattern_tree) list
   | CdPWildCard
   | CdPVariable             of CodeSymbol.t
   | CdPAsVariable           of CodeSymbol.t * code_pattern_tree
@@ -1386,6 +1392,7 @@ and unlift_pattern = function
   | CdPListCons(cdpat1, cdpat2) -> PListCons(unlift_pattern cdpat1, unlift_pattern cdpat2)
   | CdPEndOfList                -> PEndOfList
   | CdPTuple(cdpats)            -> PTuple(TupleList.map unlift_pattern cdpats)
+  | CdPRecord(cdpats)           -> PRecord(cdpats |> List.map (fun (label, cd) -> (label, unlift_pattern cd)))
   | CdPWildCard                 -> PWildCard
   | CdPVariable(symb)           -> PVariable(CodeSymbol.unlift symb)
   | CdPAsVariable(symb, cdpat)  -> PAsVariable(CodeSymbol.unlift symb, unlift_pattern cdpat)

src/myUtil.ml

@@ -93,6 +93,8 @@ module OptionMonad = struct
     | Some(v)   -> f v
 
   let return v = Some(v)
+
+  let ( let* ) = ( >>= )
 end
 
 module ResultMonad = struct

src/myUtil.mli

@@ -32,6 +32,7 @@ val pickup : 'a list -> ('a -> bool) -> 'b -> ('a, 'b) result
 module OptionMonad : sig
   val ( >>= ) : 'a option -> ('a -> 'b option) -> 'b option
   val return : 'a -> 'a option
+  val ( let* ) : 'a option -> ('a -> 'b option) -> 'b option
 end
 
 module ResultMonad : sig

test/parsing/dune

@@ -1,26 +1,5 @@
-(rule
- (targets parser.output)
- (deps
-   "nx.saty"
-   "variants.saty"
-   "txprod.saty"
-   "txlist.saty"
-   "txrecord.saty"
-   "pats.saty"
-   "pattuple.saty"
-   "patlist.saty"
-   "sxlist.saty"
-   "mathlist.saty"
-   "toplevel.saty"
- )
- (action
-  (with-stdout-to parser.output (run ./parser_test.exe %{deps}))))
-
-(alias
- (name runtest)
- (action (diff parser.expected parser.output)))
-
-(executable
+(library
  (name parser_test)
+ (inline_tests)
  (libraries main core_kernel)
- (preprocess (pps ppx_deriving.show)))
+ (preprocess (pps ppx_deriving.show ppx_expect)))