ocaml: +TagGroup

ocaml/lib/locale.ml

@@ -38,6 +38,8 @@ module Bare : LocaleT = struct
     | XRefOf      -> "ref-of"
     | XSelect     -> "selection"
     | XString     -> "string"
+    | XTagGroup   -> "tag-group"
+    | XTagGroupItem -> "tag-group-item"
     | XIdent      -> "identifier"
 
   let pp_error fmtp (k,file,s) =
@@ -97,6 +99,8 @@ module En : LocaleT = struct
     | XRefOf      -> "ref-of"
     | XSelect     -> "selection"
     | XString     -> "string"
+    | XTagGroup   -> "tag group"
+    | XTagGroupItem -> "tag group item"
     | XIdent      -> "identifier"
 
   let pp_error fmtp (k,file,s) =

ocaml/libsyntax/lex.ml

@@ -93,6 +93,7 @@ let tokens lx () =
           | "layout" -> Layout
           | "let" -> Let
           | "match" -> Match
+          | "tag_group" -> KTagGroup
           | "\u{03BB}" -> Lambda
           | "\u{039B}" -> TyLambda (* a large lambda *)
           | "\u{03BC}" -> Mu

ocaml/libsyntax/literal.ml

@@ -33,6 +33,10 @@ let isz_to_str = function
   | IPow x -> Int.shift_left 1 (Char.code x) |> Int.to_string
   | ISize -> "_size"
 
+let isz_to_pow = function
+  | IPow x -> x
+  | ISize -> '\004' (* should be a fitting default *)
+
 let str_post loc s = String.sub s loc (String.length s - loc)
 
 let of_string = function

ocaml/libsyntax/literal.mli

@@ -14,5 +14,6 @@ type lit =
   | LIntSize of int_size
   | LNatural of int
 
+val isz_to_pow : int_size -> char
 val of_string : string -> lit Option.t
 val to_string : lit -> string

ocaml/libsyntax/tagGroup.ml

@@ -0,0 +1,42 @@
+open Tys
+
+module FieldsReg = Map.Make(String)
+module FinReg = Map.Make(Int)
+
+(* a tag group, which has an underlying type, and a bunch of key-index pairs *)
+type t = loc_span_full * Literal.int_size * (int FieldsReg.t)
+
+let rev_lookup ival ((_, _, frg): t) =
+  FieldsReg.filter (fun _ x -> x == ival) frg |> FieldsReg.choose
+
+(* check if variant conforms to tag group (=> is subset) *)
+let conforms (type u) (vrrcd: u FieldsReg.t) ((_, _, tfrg): t) =
+  let inner k v acc = match (FieldsReg.find_opt k tfrg, acc) with
+    | (_, None) -> None
+    | (None, _) -> None
+    | (Some lhs, Some rhs) -> Some (FinReg.add lhs v rhs)
+  in FieldsReg.fold inner vrrcd (Some FinReg.empty)
+
+let parse_opt ps =
+  let inner ps ((osp, oisz): loc_span_full * Literal.int_size) =
+    let rec inner2 ps frg = match ps.lt with
+      | (DotIdent nam, s)::(LLiteral Literal.LNatural nat, _)::(SemiColon, s3)::lt ->
+          let ps = { ps with lt; offset = loc_span_end s3; } in
+          (if FieldsReg.mem nam frg then
+            Yanais_syntax_err (ERecordDupIdent nam, ps.file, s) |> raise
+          else FieldsReg.add nam nat frg |> inner2 ps)
+      | (Brace Close, s)::lt ->
+          let ps = { ps with lt; offset = loc_span_end s; } in
+          ((osp, oisz, frg), ps)
+      | (k, s)::_ -> Yanais_syntax_err (EUnexpectedToken (XTagGroupItem, k), ps.file, s) |> raise
+      | [] ->
+          let (fl, sp) = osp in
+          Yanais_syntax_err (EUnexpectedEof XTagGroupItem, fl, sp) |> raise
+    in inner2 ps FieldsReg.empty
+  in match ps.lt with
+    | (KTagGroup, s1)::(LLiteral Literal.LIntSize isz, _)::(Brace Open, s3)::lt ->
+        let ps = { ps with lt; offset = loc_span_end s3; } in
+        Some (inner ps ((ps.file, s1), isz))
+    | _ -> None
+
+let parse ps = require XTagGroup parse_opt ps

ocaml/libsyntax/tys.ml

@@ -47,6 +47,7 @@ type token =
   | Layout
   | Let
   | Match
+  | KTagGroup
 
 type token_ann = token * loc_span
 
@@ -76,6 +77,7 @@ let token_to_string = function
   | Layout     -> "layout"
   | Let        -> "let"
   | Match      -> "match"
+  | KTagGroup  -> "tag_group"
 
 type error_ctx =
   | XComment
@@ -90,6 +92,8 @@ type error_ctx =
   | XRefOf
   | XSelect
   | XString
+  | XTagGroup
+  | XTagGroupItem
   | XIdent
 
 let str_of_ectx = function
@@ -105,6 +109,8 @@ let str_of_ectx = function
   | XRefOf      -> "ref-of"
   | XSelect     -> "selection"
   | XString     -> "string"
+  | XTagGroup   -> "tag group"
+  | XTagGroupItem -> "tag group item"
   | XIdent      -> "identifier"
 
 type error_kind =