package frama-c

  1. Overview
  2. Docs
package frama-c
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file data.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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
(**************************************************************************)
(*                                                                        *)
(*  This file is part of Frama-C.                                         *)
(*                                                                        *)
(*  Copyright (C) 2007-2024                                               *)
(*    CEA (Commissariat à l'énergie atomique et aux énergies              *)
(*         alternatives)                                                  *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, version 2.1.                                              *)
(*                                                                        *)
(*  It is distributed in the hope that it will be useful,                 *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  See the GNU Lesser General Public License version 2.1                 *)
(*  for more details (enclosed in the file licenses/LGPLv2.1).            *)
(*                                                                        *)
(**************************************************************************)

open Package
module Js = Yojson.Basic
module Ju = Yojson.Basic.Util

(* -------------------------------------------------------------------------- *)
(* --- Data Encoding                                                      --- *)
(* -------------------------------------------------------------------------- *)

type json = Js.t
let pretty = Js.pretty_print ~std:false

module type S =
sig
  type t
  val jtype : jtype
  val of_json : json -> t
  val to_json : t -> json
end

exception InputError of string

let failure ?json msg =
  let add_json msg =
    let msg = match json with
      | None -> msg
      | Some json ->
        Format.asprintf "@[%s:@ %s@]" msg (Js.pretty_to_string json)
    in
    raise(InputError(msg))
  in
  Pretty_utils.ksfprintf add_json msg

let failure_from_type_error msg json =
  failure ~json "%s" msg

let package = Package.package ~name:"data" ~title:"Informations" ()

(* -------------------------------------------------------------------------- *)
(* --- Declared Type                                                      --- *)
(* -------------------------------------------------------------------------- *)

let derived ~package ~id jtype =
  let module Md = Markdown in
  begin
    declare ~package ~name:(Derived.decode id).name
      ~descr:(Md.plain "Decoder for" @ Md.code id.name)
      (D_decoder(id,jtype)) ;
    declare ~package ~name:(Derived.order id).name
      ~descr:(Md.plain "Natural order for" @ Md.code id.name)
      (D_order(id,jtype)) ;
    declare ~package ~name:(Derived.default id).name
      ~descr:(Md.plain "Default value for" @ Md.code id.name)
      (D_default(id,jtype)) ;
    Jdata(id,jtype)
  end

let declare ~package ~name ?descr jtype =
  let id = declare_id ~package ~name ?descr (D_type jtype) in
  derived ~package ~id jtype

(* -------------------------------------------------------------------------- *)
(* --- Option                                                             --- *)
(* -------------------------------------------------------------------------- *)

module Joption(A : S) : S with type t = A.t option =
struct
  type t = A.t option

  let nullable = try ignore (A.of_json `Null) ; true with _ -> false
  let jtype = Joption (if not nullable then A.jtype else Jtuple [A.jtype])

  let to_json = function
    | None -> `Null
    | Some v -> if nullable then `List [A.to_json v] else A.to_json v

  let of_json = function
    | `Null -> None
    | `List [js] when nullable -> Some (A.of_json js)
    | js -> Some (A.of_json js)

end

(* -------------------------------------------------------------------------- *)
(* --- Tuples                                                             --- *)
(* -------------------------------------------------------------------------- *)

module Jpair(A : S)(B : S) : S with type t = A.t * B.t =
struct
  type t = A.t * B.t
  let jtype = Jtuple [A.jtype;B.jtype]
  let to_json (x,y) = `List [ A.to_json x ; B.to_json y ]
  let of_json = function
    | `List [ ja ; jb ] -> A.of_json ja , B.of_json jb
    | js -> failure ~json:js "Expected list with 2 elements"
end

module Jtriple(A : S)(B : S)(C : S) : S with type t = A.t * B.t * C.t =
struct
  type t = A.t * B.t * C.t
  let jtype = Jtuple [A.jtype;B.jtype;C.jtype]
  let to_json (x,y,z) = `List [ A.to_json x ; B.to_json y ; C.to_json z ]
  let of_json = function
    | `List [ ja ; jb ; jc ] -> A.of_json ja , B.of_json jb , C.of_json jc
    | js -> failure ~json:js "Expected list with 3 elements"
end

(* -------------------------------------------------------------------------- *)
(* --- Lists                                                              --- *)
(* -------------------------------------------------------------------------- *)

module Jlist(A : S) : S with type t = A.t list =
struct
  type t = A.t list
  let jtype = Jarray A.jtype
  let to_json xs = `List (List.map A.to_json xs)
  let of_json js = List.map A.of_json (Ju.to_list js)
end

(* -------------------------------------------------------------------------- *)
(* --- Arrays                                                             --- *)
(* -------------------------------------------------------------------------- *)

module Jarray(A : S) : S with type t = A.t array =
struct
  type t = A.t array
  let jtype = Jarray A.jtype
  let to_json xs = `List (List.map A.to_json (Array.to_list xs))
  let of_json js = Array.of_list @@ List.map A.of_json (Ju.to_list js)
end

(* -------------------------------------------------------------------------- *)
(* --- Atomic Types                                                       --- *)
(* -------------------------------------------------------------------------- *)

module Junit : S with type t = unit =
struct
  type t = unit
  let jtype = Jnull
  let of_json _js = ()
  let to_json () = `Null
end

module Jany : S with type t = json =
struct
  type t = json
  let jtype = Jany
  let of_json js = js
  let to_json js = js
end

module Jbool : S with type t = bool =
struct
  type t = bool
  let jtype = Jboolean
  let of_json = Ju.to_bool
  let to_json b = `Bool b
end

module Jint : S with type t = int =
struct
  type t = int
  let jtype = Jnumber
  let of_json = Ju.to_int
  let to_json n = `Int n
end

module Jfloat : S with type t = float =
struct
  type t = float
  let jtype = Jnumber
  let of_json = Ju.to_number
  let to_json v = `Float v
end

module Jstring : S with type t = string =
struct
  type t = string
  let jtype = Jstring
  let of_json = Ju.to_string
  let to_json s = `String s
end

module Jalpha : S with type t = string =
struct
  type t = string
  let jtype = Jalpha
  let of_json = Ju.to_string
  let to_json s = `String s
end

module Jfile : S with type t = Filepath.Normalized.t =
struct
  type t = Filepath.Normalized.t
  let jtype = Jstring
  let of_json js = Ju.to_string js |> Filepath.Normalized.of_string
  let to_json (file:t) = `String (file :> string)
end

(* -------------------------------------------------------------------------- *)
(* --- Text Datatypes                                                     --- *)
(* -------------------------------------------------------------------------- *)

module Jmarkdown : S with type t = Markdown.text =
struct
  type t = Markdown.text
  let jtype =
    let descr = Markdown.plain "Markdown (inlined) text." in
    declare ~package ~name:"markdown" ~descr Jstring
  let of_json js = Markdown.plain (Ju.to_string js)
  let to_json txt = `String (Pretty_utils.to_string Markdown.pp_text txt)
end

module Jtext =
struct
  include Jany
  let jtype =
    let descr = Markdown.plain
        "Rich text format uses `[tag; …text ]` to apply \
         the tag `tag` to the enclosed text. \
         Empty tag `\"\"` can also used to simply group text together." in
    let jdef = Junion [ Jnull; Jstring; Jarray Jself ] in
    declare ~package ~name:"text" ~descr jdef
end

let jpretty = Jbuffer.to_json
let jtext s = `String s

(* -------------------------------------------------------------------------- *)
(* --- Functional API                                                     --- *)
(* -------------------------------------------------------------------------- *)

type 'a data = (module S with type t = 'a)

let data_of_json (type a) (d : a data) (js : json) : a =
  let module M : S with type t = a = (val d) in M.of_json js

let data_to_json (type a) (d : a data) (v : a) : json =
  let module M : S with type t = a = (val d) in M.to_json v

let junit : unit data = (module Junit)
let jany : json data = (module Jany)
let jbool : bool data = (module Jbool)
let jint : int data = (module Jint)
let jfloat : float data = (module Jfloat)
let jstring : string data = (module Jstring)
let jalpha : string data = (module Jalpha)

let jkey ~kind =
  let module JkeyKind =
  struct
    include Jstring
    let jtype = Jkey kind
  end in
  (module JkeyKind : S with type t = string)

let jindex ~kind =
  let module JindexKind =
  struct
    include Jint
    let jtype = Jindex kind
  end in
  (module JindexKind : S with type t = int)

let joption (type a) (d : a data) : a option data =
  let module A = Joption(val d) in
  (module A : S with type t = a option)

let jlist (type a) (d : a data) : a list data =
  let module A = Jlist(val d) in
  (module A : S with type t = a list)

let jalist (type a) (d : a data) : a list data =
  let module A = Jlist(val d) in
  (module A : S with type t = a list)

let jarray (type a) (d : a data) : a array data =
  let module A = Jarray(val d) in
  (module A : S with type t = a array)

(* -------------------------------------------------------------------------- *)
(* --- Records                                                            --- *)
(* -------------------------------------------------------------------------- *)

module Fmap = Map.Make(String)

module Record =
struct

  type 'a record = json Fmap.t

  type ('r,'a) field = {
    member : 'r record -> bool ;
    getter : 'r record -> 'a ;
    setter : 'r record -> 'a -> 'r record ;
  }

  type 'a signature = {
    mutable fields : fieldInfo list ;
    mutable default : 'a record ;
    mutable published : bool ;
  }

  module type S =
  sig
    type r
    include S with type t = r record
    val default : t
    val has : (r,'a) field -> t -> bool
    val get : (r,'a) field -> t -> 'a
    val set : (r,'a) field -> 'a -> t -> t
  end

  let signature () = {
    published = false ;
    fields = [] ;
    default = Fmap.empty ;
  }

  let not_published s =
    if s.published then
      raise (Invalid_argument "Server.Data.Record: already published")

  let check_field_name s name =
    begin
      if List.exists (fun f -> f.Package.fd_name = name) s.fields then
        (let msg = Printf.sprintf "Server.Data.Record: duplicate field %S" name
         in raise (Invalid_argument msg));
      if not (Str.string_match (Str.regexp "[a-zA-Z0-9 _-]+$") name 0) then
        (let msg = Printf.sprintf
             "Server.Data.Record: invalid characters for field %S" name in
         raise (Invalid_argument msg));
    end

  let field (type a r) (s : r signature)
      ~name ~descr ?default (d : a data) : (r,a) field =
    not_published s ;
    check_field_name s name ;
    let module D = (val d) in
    begin match default with
      | None -> ()
      | Some v -> s.default <- Fmap.add name (D.to_json v) s.default
    end ;
    let field = Package.{
        fd_name = name ;
        fd_type = D.jtype ;
        fd_descr = descr ;
      } in
    s.fields <- field :: s.fields ;
    let member r = Fmap.mem name r in
    let getter r = D.of_json (Fmap.find name r) in
    let setter r v = Fmap.add name (D.to_json v) r in
    { member ; getter ; setter }

  let option (type a r) (s : r signature)
      ~name ~descr (d : a data) : (r,a option) field =
    not_published s ;
    check_field_name s name ;
    let module D = (val d) in
    let field = Package.{
        fd_name = name ;
        fd_type = Joption D.jtype ;
        fd_descr = descr ;
      } in
    s.fields <- field :: s.fields ;
    let member r = Fmap.mem name r in
    let getter r =
      try Some (D.of_json (Fmap.find name r)) with Not_found -> None in
    let setter r = function
      | None -> Fmap.remove name r
      | Some v -> Fmap.add name (D.to_json v) r in
    { member ; getter ; setter }

  let publish (type r) ~package ~name ?(descr=[]) (s : r signature) =
    not_published s ;
    let module M =
    struct
      type nonrec r = r
      type t = r record
      let jtype =
        let fields = List.rev s.fields in
        let id = Package.declare_id ~package ~name ~descr (D_record fields) in
        derived ~package ~id (Jrecord (List.map Package.field fields))
      let default = s.default
      let has fd r = fd.member r
      let get fd r = fd.getter r
      let set fd v r = fd.setter r v
      let of_json js =
        List.fold_left
          (fun r (fd,js) -> Fmap.add fd js r)
          default (Ju.to_assoc js)
      let to_json r : json =
        `Assoc (Fmap.fold (fun fd js fds -> (fd,js) :: fds) r [])
    end in
    begin
      s.default <- Fmap.empty ;
      s.fields <- [] ;
      s.published <- true ;
      (module M : S with type r = r)
    end

end

(* -------------------------------------------------------------------------- *)
(* --- Enums                                                              --- *)
(* -------------------------------------------------------------------------- *)

module Tag =
struct
  type t = Package.tagInfo

  let jtype = declare ~package ~name:"tag"
      ~descr:(Markdown.plain "Enum Tag Description")
      (Jrecord [
          "name",Jalpha ;
          "label",Jmarkdown.jtype ;
          "descr",Jmarkdown.jtype ;
        ])

  let to_json tg = `Assoc Package.[
      "name", `String tg.tg_name ;
      "label", Jmarkdown.to_json tg.tg_label ;
      "descr" , Jmarkdown.to_json tg.tg_descr ;
    ]

  let of_json js = Package.{
      tg_name = Ju.member "name" js |> Ju.to_string ;
      tg_label = Ju.member "label" js |> Jmarkdown.of_json ;
      tg_descr = Ju.member "descr" js |> Jmarkdown.of_json ;
    }

end

module Enum =
struct

  type 'a dictionary = {
    values : (string,'a option) Hashtbl.t ;
    vindex : ('a,string) Hashtbl.t ;
    mutable published : (package * string) option ;
    mutable tags : tagInfo list ;
    mutable prefix : tagInfo list ;
    mutable lookup : ('a -> string) option ;
  }

  type 'a tag = string
  type 'a prefix = 'a dictionary * string

  let tag_name tg = tg
  let tag_label a = function
    | None -> Markdown.plain (String.(capitalize_ascii (lowercase_ascii a)))
    | Some lbl -> lbl

  let dictionary () = {
    published = None ;
    values = Hashtbl.create 0 ;
    vindex = Hashtbl.create 0 ;
    prefix = [] ;
    tags = [] ;
    lookup = None ;
  }

  let tag ~name ?label ~descr ?value (d : 'a dictionary) : 'a tag =
    if Hashtbl.mem d.values name then
      ( let msg = Printf.sprintf "Server.Data.Enum: duplicate tag %S" name in
        raise (Invalid_argument msg) );
    let tg = Package.{
        tg_name = name ;
        tg_label = tag_label name label ;
        tg_descr = descr ;
      } in
    d.tags <- tg :: d.tags ;
    Hashtbl.add d.values name value ;
    begin match value with
      | None -> ()
      | Some v -> Hashtbl.add d.vindex v name
    end ; name

  let add ~name ?label ~descr ?value (d : 'a dictionary) : unit =
    ignore (tag ~name ?label ~descr ?value d)

  let find (d : 'a dictionary) (tg : 'a tag) : 'a =
    match Hashtbl.find d.values tg with
    | Some v -> v
    | None -> raise Not_found

  let find_tag (d : 'a dictionary) name : 'a tag =
    if Hashtbl.mem d.values name then name else
      raise Not_found

  let lookup_index lookup vindex v =
    match lookup with
    | None -> Hashtbl.find vindex v
    | Some f -> try f v with Not_found -> Hashtbl.find vindex v

  let lookup (d : 'a dictionary) (v: 'a) :  'a tag =
    lookup_index d.lookup d.vindex v

  let set_lookup (d : 'a dictionary) (tag : 'a -> 'a tag) =
    d.lookup <- Some tag

  let instance_name = Printf.sprintf "%s_%s"

  let instance (_,prefix) = instance_name prefix

  let prefix ~name ?(var="*") ?label ~descr (d : 'a dictionary) =
    let tg = Package.{
        tg_name = instance_name name var ;
        tg_label = tag_label (name ^ ".") label ;
        tg_descr = descr ;
      } in
    d.prefix <- tg :: d.prefix ; d , name

  let extends ~name ?label ~descr ?value ((d,prefix) : 'a prefix) : 'a tag =
    let name = tag ~name:(instance_name prefix name) ?label ~descr ?value d in
    ( match d.published with
      | None -> ()
      | Some (package,name) ->
        Package.update ~package ~name (D_enum (List.rev d.tags))
    ) ; name

  let to_json name lookup vindex v =
    `String begin
      try lookup_index lookup vindex v
      with Not_found ->
        failure "[%s] Value not found" name
    end

  let of_json name values js =
    let tag = Ju.to_string js in
    match Hashtbl.find values tag with
    | Some v -> v
    | None ->
      failure "[%s] No registered value for tag '%s" name tag
    | exception Not_found ->
      failure "[%s] Not registered tag '%s" name tag

  let tags d = List.rev d.tags

  let publish (type a) ~package ~name ~descr (d : a dictionary) =
    ( match d.published with
      | None -> ()
      | Some _ ->
        let msg = "Server.Data.Enums: already published" in
        raise (Invalid_argument msg) );
    let module M =
    struct
      type t = a
      let jtype =
        let tags = List.rev d.tags in
        let tagNames = List.map (fun { tg_name } -> tg_name) tags in
        let id = Package.declare_id ~package ~name ~descr (D_enum tags) in
        derived ~package ~id (Jenum(id,tagNames))
      let of_json = of_json name d.values
      let to_json = to_json name d.lookup d.vindex
    end in
    begin
      d.published <- Some (package,name) ;
      (module M : S with type t = a)
    end

end

(* -------------------------------------------------------------------------- *)
(* --- Index                                                              --- *)
(* -------------------------------------------------------------------------- *)

module type Info =
sig
  val package: package
  val name: string
  val descr: Markdown.text
end

(** Simplified [Map.S] *)
module type Map =
sig
  type 'a t
  type key
  val empty : 'a t
  val add : key -> 'a -> 'a t -> 'a t
  val find : key -> 'a t -> 'a
  val remove : key -> 'a t -> 'a t
end

module type Index =
sig
  include S
  type tag
  val get : t -> tag
  val find : tag -> t
  val remove : t -> unit
  val clear : unit -> unit
end

module INDEXER(M : Map)(I : Info) :
sig
  type index
  val create : unit -> index
  val clear : index -> unit
  val get : index -> M.key -> int
  val find : index -> int -> M.key
  val remove : index -> M.key -> unit
  val to_json : index -> M.key -> json
  val of_json : index -> json -> M.key
end =
struct

  type index = {
    mutable kid : int ;
    mutable index : int M.t ;
    lookup : (int,M.key) Hashtbl.t ;
  }

  let create () = {
    kid = 0 ;
    index = M.empty ;
    lookup = Hashtbl.create 0 ;
  }

  let clear m =
    begin
      m.kid <- 0 ;
      m.index <- M.empty ;
      Hashtbl.clear m.lookup ;
    end

  let get m a =
    try M.find a m.index
    with Not_found ->
      let id = succ m.kid in
      m.kid <- id ;
      m.index <- M.add a id m.index ;
      Hashtbl.add m.lookup id a ; id

  let remove m a =
    try
      let id = M.find a m.index in
      Hashtbl.remove m.lookup id ;
      m.index <- M.remove a m.index ;
    with Not_found -> ()

  let find m id = Hashtbl.find m.lookup id

  let to_json m a = `Int (get m a)
  let of_json m js =
    let id = Ju.to_int js in
    try find m id
    with Not_found ->
      failure "[%s] No registered id #%d" I.name id

end

module Static(M : Map)(I : Info)
  : Index with type t = M.key and type tag := int =
struct
  module INDEX = INDEXER(M)(I)
  let index = INDEX.create ()
  let clear () = INDEX.clear index
  let get = INDEX.get index
  let find = INDEX.find index
  let remove = INDEX.remove index
  include
    (struct
      type t = M.key
      let jtype =
        declare ~package:I.package ~name:I.name ~descr:I.descr (Jindex I.name)
      let of_json = INDEX.of_json index
      let to_json = INDEX.to_json index
    end)
end

module Index(M : Map)(I : Info)
  : Index with type t = M.key and type tag := int =
struct
  module INDEX = INDEXER(M)(I)
  module TYPE : Datatype.S with type t = INDEX.index =
    Datatype.Make
      (struct
        type t = INDEX.index
        include Datatype.Undefined
        let reprs = [INDEX.create()]
        let name = "Server.Data.Index.Type." ^ I.name
        let mem_project = Datatype.never_any_project
      end)
  module STATE = State_builder.Ref(TYPE)
      (struct
        let name = "Server.Data.Index.State." ^ I.name
        let dependencies = []
        let default = INDEX.create
      end)

  let index () = STATE.get ()
  let clear () = INDEX.clear (index())
  let remove a = INDEX.remove (index()) a

  let get a = INDEX.get (index()) a
  let find id = INDEX.find (index()) id

  include
    (struct
      type t = M.key
      let jtype =
        declare ~package:I.package ~name:I.name ~descr:I.descr (Jindex I.name)
      let of_json js = INDEX.of_json (index()) js
      let to_json v = INDEX.to_json (index()) v
    end)

end

(* -------------------------------------------------------------------------- *)
(* --- Identified & Tagged Indexers                                       --- *)
(* -------------------------------------------------------------------------- *)

module type HASH =
sig
  type t
  type tag
  val id : t -> tag
end

module type TAG =
sig
  type tag
  val jtype : string -> jtype
  val to_json : tag -> Json.t
  val of_json : Json.t -> tag
end

module HASHED(T : TAG)(A : HASH with type tag := T.tag)(I : Info) :
  Index with type t = A.t and type tag := T.tag =
struct

  type index = (T.tag,A.t) Hashtbl.t

  module TYPE : Datatype.S with type t = index =
    Datatype.Make
      (struct
        type t = index
        include Datatype.Undefined
        let reprs = [Hashtbl.create 0]
        let name = "Server.Data.Identified.Type." ^ I.name
        let mem_project = Datatype.never_any_project
      end)

  module STATE = State_builder.Ref(TYPE)
      (struct
        let name = "Server.Data.Identified.State." ^ I.name
        let dependencies = []
        let default () = Hashtbl.create 0
      end)

  let lookup () = STATE.get ()
  let clear () = Hashtbl.clear (lookup())

  let find id = Hashtbl.find (lookup()) id

  let get x =
    let tag = A.id x in
    let hash = lookup () in
    if not (Hashtbl.mem hash tag) then Hashtbl.add hash tag x ; tag

  let remove x =
    let tag = A.id x in
    let hash = lookup () in
    Hashtbl.remove hash tag

  include
    (struct
      type t = A.t
      let jtype =
        declare ~package:I.package ~descr:I.descr ~name:I.name (T.jtype I.name)
      let to_json a = T.to_json (get a)
      let of_json js =
        let k = T.of_json js in
        try find k
        with Not_found ->
          failure "[%s] Not registered tag (%a)" I.name Json.pp js
    end)

end

module type IdentifiedType =
sig
  type t
  val id : t -> int
end

module Identified(A : IdentifiedType)(I : Info)
  : Index with type t = A.t and type tag := int =
  HASHED
    (struct
      include Jint
      type tag = int
      let jtype a = Jindex a
    end)(A)(I)

module type TaggedType =
sig
  type t
  val id : t -> string
end

module Tagged(A : TaggedType)(I : Info)
  : Index with type t = A.t and type tag := string
  = HASHED
    (struct
      include Jstring
      type tag = string
      let jtype a = Jkey a
    end)(A)(I)

(* -------------------------------------------------------------------------- *)