package typegist

  1. Overview
  2. Docs

Source file typegist__meta.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
(*---------------------------------------------------------------------------
   Copyright (c) 2026 The typegist programmers. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

(* Abstracting type constructors with two parameter.
   See Yallop and White Lightweight Higher-Kinded Polymorphism
   https://doi.org/10.1007/978-3-319-07151-0_8 *)
module Higher = struct
  (*  Snippet from https://github.com/yallop/higher
      Copyright (c) 2013 Leo White and Jeremy Yallop
      SPDX-License-Identifier: MIT *)
  type ('a, 'f) app
  module Newtype2 (T : sig type ('a, 'b) t end) = struct
    type ('a, 'b) s = ('a, 'b) T.t
    type t
    external inj : 'a -> 'b = "%identity"
    external prj : 'a -> 'b = "%identity"
  end
end

module M = Map.Make (Int)
type 't mkey = 't Type.Id.t
type ('a, 'b, 't) value = ('a, ('b, 't) Higher.app) Higher.app
type ('a, 'b) binding = B : 't mkey * ('a, 'b, 't) value -> ('a, 'b) binding
type ('a, 'b) t2 = ('a, 'b) binding M.t
type 'a t = ('a, 'a) binding M.t

module type VALUE = sig type ('a, 'b) t end
module type KEY = sig
  type ('a, 'b) meta := ('a, 'b) t2
  type ('a, 'b) value
  val mem : ('a, 'b) meta -> bool
  val add : ('a, 'b) value -> ('a, 'b) meta -> ('a, 'b) meta
  val find : ('a, 'b) meta -> ('a, 'b) value option
  val remove : ('a, 'b) meta -> ('a, 'b) meta
end


let empty = M.empty
let is_empty = M.is_empty
let mem (module K : KEY) m = K.mem m
let add (module K : KEY) v m = K.add v m
let find (module K : KEY) m = K.find m
let remove (module K : KEY) m = K.remove m

module Key (V : VALUE) = struct
  type ('a, 'b) meta = ('a, 'b) t2
  module H = Higher.Newtype2 (V)
  type ('a, 'b) value = ('a, 'b) H.s
  type t = H.t
  let key = Type.Id.make ()
  let mem m = M.mem (Type.Id.uid key) m
  let add v m = M.add (Type.Id.uid key) (B (key, H.inj v)) m
  let remove m = M.remove (Type.Id.uid key) m
  let find m =
    let find : type v a b. v mkey -> (a, b) meta -> (a, b) value option =
    fun key m -> match M.find_opt (Type.Id.uid key) m with
    | None -> None
    | Some B (k', v) ->
        match Type.Id.provably_equal key k' with
        | Some Equal -> Some (H.prj v) | None -> assert false
    in
    find key m
end

type key = (module KEY)

module Default = Key (struct type ('a, 'b) t = 'b end)
let default = (module Default : KEY)

module Deprecated = Key (struct type ('a, 'b) t = string end)
module Ignore = Key (struct type ('a, 'b) t = bool end)
module Immediate = Key (struct type ('a, 'b) t = bool end)
module Immediate64 = Key (struct type ('a, 'b) t = bool end)
module Min = Key (struct type ('a, 'b) t = 'b end)
module Max = Key (struct type ('a, 'b) t = 'b end)
module Unboxed = Key (struct type ('a, 'b) t = bool end)