ocaml: +TagGroup
This commit is contained in:
parent
d4fddeb596
commit
892ac5f097
|
@ -38,6 +38,8 @@ module Bare : LocaleT = struct
|
||||||
| XRefOf -> "ref-of"
|
| XRefOf -> "ref-of"
|
||||||
| XSelect -> "selection"
|
| XSelect -> "selection"
|
||||||
| XString -> "string"
|
| XString -> "string"
|
||||||
|
| XTagGroup -> "tag-group"
|
||||||
|
| XTagGroupItem -> "tag-group-item"
|
||||||
| XIdent -> "identifier"
|
| XIdent -> "identifier"
|
||||||
|
|
||||||
let pp_error fmtp (k,file,s) =
|
let pp_error fmtp (k,file,s) =
|
||||||
|
@ -97,6 +99,8 @@ module En : LocaleT = struct
|
||||||
| XRefOf -> "ref-of"
|
| XRefOf -> "ref-of"
|
||||||
| XSelect -> "selection"
|
| XSelect -> "selection"
|
||||||
| XString -> "string"
|
| XString -> "string"
|
||||||
|
| XTagGroup -> "tag group"
|
||||||
|
| XTagGroupItem -> "tag group item"
|
||||||
| XIdent -> "identifier"
|
| XIdent -> "identifier"
|
||||||
|
|
||||||
let pp_error fmtp (k,file,s) =
|
let pp_error fmtp (k,file,s) =
|
||||||
|
|
|
@ -93,6 +93,7 @@ let tokens lx () =
|
||||||
| "layout" -> Layout
|
| "layout" -> Layout
|
||||||
| "let" -> Let
|
| "let" -> Let
|
||||||
| "match" -> Match
|
| "match" -> Match
|
||||||
|
| "tag_group" -> KTagGroup
|
||||||
| "\u{03BB}" -> Lambda
|
| "\u{03BB}" -> Lambda
|
||||||
| "\u{039B}" -> TyLambda (* a large lambda *)
|
| "\u{039B}" -> TyLambda (* a large lambda *)
|
||||||
| "\u{03BC}" -> Mu
|
| "\u{03BC}" -> Mu
|
||||||
|
|
|
@ -33,6 +33,10 @@ let isz_to_str = function
|
||||||
| IPow x -> Int.shift_left 1 (Char.code x) |> Int.to_string
|
| IPow x -> Int.shift_left 1 (Char.code x) |> Int.to_string
|
||||||
| ISize -> "_size"
|
| 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 str_post loc s = String.sub s loc (String.length s - loc)
|
||||||
|
|
||||||
let of_string = function
|
let of_string = function
|
||||||
|
|
|
@ -14,5 +14,6 @@ type lit =
|
||||||
| LIntSize of int_size
|
| LIntSize of int_size
|
||||||
| LNatural of int
|
| LNatural of int
|
||||||
|
|
||||||
|
val isz_to_pow : int_size -> char
|
||||||
val of_string : string -> lit Option.t
|
val of_string : string -> lit Option.t
|
||||||
val to_string : lit -> string
|
val to_string : lit -> string
|
||||||
|
|
42
ocaml/libsyntax/tagGroup.ml
Normal file
42
ocaml/libsyntax/tagGroup.ml
Normal file
|
@ -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
|
|
@ -47,6 +47,7 @@ type token =
|
||||||
| Layout
|
| Layout
|
||||||
| Let
|
| Let
|
||||||
| Match
|
| Match
|
||||||
|
| KTagGroup
|
||||||
|
|
||||||
type token_ann = token * loc_span
|
type token_ann = token * loc_span
|
||||||
|
|
||||||
|
@ -76,6 +77,7 @@ let token_to_string = function
|
||||||
| Layout -> "layout"
|
| Layout -> "layout"
|
||||||
| Let -> "let"
|
| Let -> "let"
|
||||||
| Match -> "match"
|
| Match -> "match"
|
||||||
|
| KTagGroup -> "tag_group"
|
||||||
|
|
||||||
type error_ctx =
|
type error_ctx =
|
||||||
| XComment
|
| XComment
|
||||||
|
@ -90,6 +92,8 @@ type error_ctx =
|
||||||
| XRefOf
|
| XRefOf
|
||||||
| XSelect
|
| XSelect
|
||||||
| XString
|
| XString
|
||||||
|
| XTagGroup
|
||||||
|
| XTagGroupItem
|
||||||
| XIdent
|
| XIdent
|
||||||
|
|
||||||
let str_of_ectx = function
|
let str_of_ectx = function
|
||||||
|
@ -105,6 +109,8 @@ let str_of_ectx = function
|
||||||
| XRefOf -> "ref-of"
|
| XRefOf -> "ref-of"
|
||||||
| XSelect -> "selection"
|
| XSelect -> "selection"
|
||||||
| XString -> "string"
|
| XString -> "string"
|
||||||
|
| XTagGroup -> "tag group"
|
||||||
|
| XTagGroupItem -> "tag group item"
|
||||||
| XIdent -> "identifier"
|
| XIdent -> "identifier"
|
||||||
|
|
||||||
type error_kind =
|
type error_kind =
|
||||||
|
|
Loading…
Reference in a new issue