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