1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
2 * Jagannathan, and Stephen Weeks.
4 * MLton is released under a BSD-style license.
5 * See the file MLton-LICENSE for details.
8 functor Property (Plist: PROPERTY_LIST):> PROPERTY where type Plist.t = Plist.t =
11 structure Plist = Plist
13 datatype ('sym, 'val) init =
15 | Fun of 'sym * ('sym -> 'val) -> 'val
19 fun initConst c = Const c
21 fun initFun f = initRec (fn (s, _) => f s)
23 fun initRaise (name, layout) =
28 in toString (seq [layout s, str " has no ", str name, str " property"])
31 fun ('sym, 'val) nondestructable (plist: 'sym -> Plist.t,
32 init: ('sym, 'val) init) =
34 val {add, peek, remove, ...} = Plist.newProperty ()
43 let val v = f (s, get)
48 fun set (s: 'sym, none: unit -> 'val, some: 'val -> unit): unit =
51 NONE => add (p, none ())
54 in {get = get, rem = remove o plist, remove = remove, set = set}
57 fun ('sym, 'val) destructable (plist, init) =
60 fun add s = List.push (plists, plist s)
61 val {get, remove, set, ...} =
62 nondestructable (plist,
65 | Fun f => Fun (fn z as (s, _) => (add s; f z)))
66 val set: 'sym * (unit -> 'val) * ('val -> unit) -> unit =
67 fn (s, none, some) => set (s, fn () => (add s; none ()), some)
69 (List.foreach (!plists, remove)
71 in {destroy = destroy, get = get, set = set}
74 fun setToSetOnce set (s, v) =
75 set (s, fn _ => v, fn _ => Error.bug "Property.setOnce: set used twice")
77 fun destGetSetOnce z =
78 let val {destroy, get, set} = destructable z
79 in {destroy = destroy, get = get, set = setToSetOnce set}
83 let val {destroy, get, ...} = destGetSetOnce z
84 in {destroy = destroy, get = get}
89 val {get, rem, set, ...} = nondestructable z
90 in {get = get, rem = rem, set = setToSetOnce set}
94 let val {get, rem, ...} = getSetOnce z
95 in {get = get, rem = rem}
98 fun setInit (plist, init) =
101 Const c => Fun (fn _ => ref c)
102 | Fun f => Fun (fn (s, get) => ref (f (s, ! o get))))
106 val {destroy, get, set} = destructable (setInit z)
107 val set = fn (s, v) => set (s, fn () => ref v, fn r => r := v)
109 {destroy = destroy, get = ! o get, set = set}
113 let val {get, rem, set, ...} = nondestructable (setInit z)
114 val set = fn (s, v) => set (s, fn () => ref v, fn r => r := v)
115 in {get = ! o get, rem = rem, set = set}
120 structure HetContainer = ExnHetContainer ()
121 structure PropertyList = PropertyList (ExnHetContainer ())
122 structure Property = Property (PropertyList)