1structure FlagDB :> FlagDB =
2struct
3
4open Portable
5type t = (UniversalType.t * string) Symtab.table
6
7type 'a tag =
8     ('a -> UniversalType.t) * (UniversalType.t -> 'a option) * string
9fun tagProject (_, Out,_) t = Out t
10fun tagInject (In,_, _) v = In v
11fun tagDesc (_, _, d) = d
12
13val empty = Symtab.empty
14
15fun update nm (tag, v:'a) t =
16    let
17      val u = tagInject tag v
18    in
19      Symtab.map_entry nm (apfst (K u)) t
20    end
21
22  fun update_new {desc,name} (tag, v) t =
23      let
24        val u = tagInject tag v
25      in
26        Symtab.update (name, (u, desc ^ " (" ^ tagDesc tag ^ ")")) t
27      end
28
29  fun peek t tag nm =
30      case Symtab.lookup t nm of
31          NONE => NONE
32        | SOME (u,d) => Option.map (fn v => (v, d)) (tagProject tag u)
33
34  fun mkTag s = let val (In,Out) = UniversalType.embed ()
35                in
36                  (In,Out,s)
37                end
38
39  fun keys t =
40      Symtab.fold_rev (fn (k,(_,d)) => fn A => {key = k,desc = d} :: A) t []
41
42  val string : string tag = mkTag "string"
43  val int : int tag = mkTag "int"
44  val bool : bool tag = mkTag "bool"
45  val stringopt : string option tag = mkTag "string-option"
46
47end
48