## styles.pkg
# This package is presumably obsoleted by
# src/lib/x-kit/widget/lib/widget-style.pkg# + src/lib/x-kit/style/widget-style-g.pkgpackage styles {
package q = Quark
package av = attribute_value
package prs = parse_resource_specs
exception BAD_STYLE_NAME
exception BadStyleSpec of String * Int
# A style_name is a key for searching a style database
#
type style_name = {
name: List( quark::quark ),
hash: Int
}
no_vals = av::no_vals;
fun extHash (hash, comp) =
Bits::bitwise_and (Bits::lshift (hash, 1), 0xffffff) + q::hash comp
fun styleName sl
=
{ fun chkName ([], comps, hash)
=
{ name = reverse comps, hash };
| chkName (s . r, comps, hash)
=
{ comp = prs::checkCompName s;
chkName (r, comp . comps, extHash (hash, comp));
};
(chkName (sl, [], 0))
except
_ => raise exception BAD_STYLE_NAME;
}
# Compare two style names for equality
fun sameStyleName ( { name=n1, hash=h1 } : style_name, { name=n2, hash=h2 } )
=
{ fun compare ([], [])
=
TRUE;
| compare (q1 . r1, q2 . r2)
=
quark::same (q1, q2) and compare (r1, r2);
| compare _
=
FALSE;
(h1 = h2) and compare (n1, n2);
}
# A style_view is a search key for finding attributes in a style.
# It consists of a name and an ordered list of aliases.
enum style_view = SV of {
name: style_name,
aliases: List( style_name )
}
# make a style_view from a name and list of aliases; the order of the
# list defines the search order.
mkView = SV
# Return the name part of the view
fun nameOfView (SV { name, ... } ) = name
# Return the list of aliases that defines the view.
fun aliasesOfView (SV { aliases, ... } )
=
aliases
# Extend each of the names in the view by the component
fun extendView (SV { name, aliases }, comp)
=
{ compQ = prs::checkCompName comp;
fun ext { name, hash }
=
{ name = name @ [compQ],
hash = extHash (hash, compQ)
};
SV { name = ext name,
aliases = map ext aliases
};
}
# Concatenate two views; the first view has priority over the second.
fun meld_views (SV { name=n1, aliases=a1 }, SV { name=n2, aliases=a2 } )
=
SV { name = n1, aliases = a1 @ (n2 . a2) }
# Add a alias to the back or front of a view
fun appendAlias (SV { name, aliases }, alias)
=
SV { name, aliases = aliases@[alias] }
fun prependAlias (SV { name, aliases }, alias) =
SV { name, aliases = alias . aliases }
# attributes in the database
enum attribute = ATTRIBUTE of {
rawValue: String,
cache: Ref( av::attribute_value )
}
fun make_attribute rawValue = ATTRIBUTE {
rawValue,
cache = REF av::no_val
}
# extract the value from an attribute chunk, performing
# the conversion, if necessary, and caching the result.
fun getAttrValue screen
=
{ cvtValue = av::cvtAttrValue screen;
fun get (ATTRIBUTE { rawValue, cache }, attrType)
=
{ cacheVal = *cache;
case (cacheVal, attrType)
of (av::AV_Str _, av::AT_Str) => cacheVal
| (av::AV_Int _, av::AT_Int) => cacheVal
| (av::AV_Real _, av::AT_Real) => cacheVal
| (av::AV_Bool _, av::AT_Bool) => cacheVal
| (av::AV_Font _, av::AT_Font) => cacheVal
| (av::AV_Color _, av::AT_Color) => cacheVal
| _ => ( { cvtVal = cvtValue (rawValue, attrType);
cache := cvtVal;
cvtVal;
}
except
_ => av::no_val
);
# end case
};
get;
}
# ** The resource database tables **
package quark_table = hashtable (package {
type Hash_Key = q::quark
hash_value = q::hash
same_key = q::same
})
# Maps on quarks
type qmap(X)
=
quark_table::Hashtable(X)
fun findQuark (table, q)
=
quark_table::peek table q;
fun insQuark (table, q, v)
=
quark_table::set table (q, v)
fun empty table
=
quark_table::vals_count table == 0
type naming = prs::naming
enum db_table
=
DBTABLE of {
tight: qmap( db_table ),
loose: qmap( db_table ), # entries of the form "*path.attribute:"
attributes: qmap (attribute * naming) # entries of the form "[*]attribute:"
}
fun newDBTable ()
=
DBTABLE {
tight = quark_table::make_hashtable (8, FAIL "db_table.tight"),
loose = quark_table::make_hashtable (8, FAIL "db_table.loose"),
attributes = quark_table::make_hashtable (8, FAIL "db_table.attributes")
}
# Given a database and a component name path,
# find the list of attribute naming tables keyed by the path.
fun findAttrTables (DBTABLE { tight, loose, attributes }, path)
=
{ fun findLooseAttr attrTable attrQ
=
(case findQuark (attrTable, attrQ)
of (THE (attribute, LOOSE)) => (THE attribute)
| _ => NULL
); # end case
fun findAttr attrTable attrQ
=
(case findQuark (attrTable, attrQ)
of (THE (attribute, LOOSE)) => (THE attribute)
| _ => NULL
); # end case
fun find (tight, loose, attributes, [], tables)
=
if (empty attributes) then tables
else (findAttr attributes) . tables;
| find (tight, loose, attributes, comp . r, tables)
=
{ tables'
=
( case (findQuark (tight, comp))
of NULL => tables
| (THE (DBTABLE { tight, loose, attributes } ))
=>
find (tight, loose, attributes, r, tables)
); # end case
fun findLoose ([], tables)
=
tables
| findLoose (comp . r, tables)
=
( case findQuark (loose, comp)
of NULL => findLoose (r, tables)
| (THE (DBTABLE { tight, loose, attributes } ))
=>
findLoose (r, find (tight, loose, attributes, r, tables))
); # end case
tables'' = if empty loose
then tables'
else findLoose (r, tables');
if empty attributes)
then tables''
else findLooseAttr attributes) . tables'';
}
tables
=
reverse (find (tight, loose, attributes, path, []));
# NOTE: we may want to just return a list of tables, instead of a composite
# function, since views consist of a name plus aliases.
fun search attribute
=
{ fun search' []
=
NULL
| search' (table . r)
=
( case (table attribute)
of NULL => search' r
| someVal => someVal
); # end case
search' tables;
}
search;
} # findAttrTables
# Insert an attribute naming into the database
fun insertAttr (db, isLoose, path, name, attribute) = let
fun find (table, comp) = (case findQuark (table, comp)
of (THE db) => db
| NULL => let db = newDBTable()
in
insQuark (table, comp, db); db
end
) # end case
fun insert (DBTABLE { tight, loose, attributes }, bind, path) = (
case (bind, path)
of (prs::TIGHT, (prs::Name comp, bind) . r) =>
insert (find (tight, comp), bind, r)
| (prs::LOOSE, (prs::Name comp, bind) . r) =>
insert (find (loose, comp), bind, r)
| (_, (prs::Wild, _) . _) =>
raise exception FAIL "wildcard components not implemented"
| (_, []) => insQuark (attributes, name, (attribute, bind))
) # end case
in
insert (db, if isLoose then prs::LOOSE else prs::TIGHT, path)
end # insertRsrcSpec
# ** The database with view cache **
enum db = DB of {
db: db_table,
cache: Ref( List( weak::weak( style_name * (prs::attribute_name -> Null_Or( attribute ) ) ) ) )
}
fun mkDB () = DB {
db = newDBTable(),
cache = REF []
}
# this is a temporary function for building resource data bases by hand
fun insertRsrcSpec (DB { db, cache }, { loose, path, attribute, value } ) = (
insertAttr (db, loose, path, attribute, make_attribute value);
cache := [])
# given a database and a style view (name + aliases) construct the lookup
# function for the view.
fun constructView (DB { db, cache }, SV { name, aliases } ) = let
/* probe the cache for a naming for name; remove any stale
* cache entries that are encountered.
*/
fun probeCache name = let
fun probe ([], l) = (reverse l, NULL)
| probe (w . r, l) = (case (weak::strong w)
of NULL => probe (r, l)
| (THE (name', naming)) =>
if (sameStyleName (name, name'))
then (w . ((reverse l) @ r), THE naming)
else probe (r, w . l)
) # end case
my (cache', result) = probe (*cache, [])
in
cache := cache'; result
end
# Add a naming to the cache
fun addToCache item = cache := (weak::weak item) . *cache
# find the attribute tables for a name
fun findTables (name: style_name) = (case (probeCache name)
of NULL => let
tables = findAttrTables (db, name.name)
in
addToCache (name, tables);
tables
end
| (THE tables) => tables
) # end case
# search for an attribute in this view
fun findAttr attrName = let
fun search [] = NULL
| search (name . r) = (case (findTables name attrName)
of NULL => search r
| attribute => attribute
) # end case
in
search (name . aliases)
end
in
findAttr
end
# ** styles **
enum req_msg
= FindAttrs of {
key: style_view,
targets: List( prs::attribute_name * av::type ),
reply: threadkit::cond_var( List (prs::attribute_name * av::attribute_value ) )
}
enum style = STY of {
screen: xclient::screen,
plea_slot: threadkit::chan( req_msg )
}
# spawn a style imp for the given screen and database
#
fun mkStyleImp (screen, db) = let
ch = threadkit::make_mailslot()
getAttrValue = getAttrValue screen
fun findAttr key = let
find = constructView (db, key)
in
fn (attrName, attrType) => (case (find attrName)
of NULL => (attrName, av::No_Val)
| (THE attribute) => (attrName, getAttrValue (attribute, attrType))
) # end case
end
fun imp () = (
case (threadkit::accept ch)
of (FindAttrs { key, targets, reply } ) => let
results = map (findAttr key) targets
in
threadkit::writeVariable (reply, results)
end
; # end case
imp ())
in
threadkit::make_thread "style imp" imp;
STY {
plea_slot = ch, screen
}
end # mkStyleImp
# Create an empty style
fun emptyStyle screen = mkStyleImp (screen, mkDB ())
# create a style, initializing it from a list of strings. This
# is for testing purposes.
fun styleFromStrings (screen, sl) = let
db = mkDB()
fun parse str = let
my (prs::RsrcSpec { loose, path, attribute, value, ... } ) =
prs::parseRsrcSpec str
in
insertRsrcSpec (db, {
loose, path, attribute, value
} )
end except prs::BAD_SPECIFICATION i => raise exception BadStyleSpec (str, i)
in
apply parse sl;
mkStyleImp (screen, db)
end
# Applicative maps from attribute names to attribute values
package quark_map = BinaryDict (package {
type Key = q::quark
cmpKey = q::compare
})
#
fun findAttrs (STY { plea_slot, screen, ... } ) (name, queries) = let
cvtValue = av::cvtAttrValue screen
fun unzip ([], attrReqs, defaults) = (attrReqs, defaults)
| unzip ((attrName, attrType, default) . r, attrReqs, defaults) =
unzip (r, (attrName, attrType) . attrReqs, (default, attrType) . defaults)
fun zip ([], [], attrMap) = attrMap
| zip ((attrName, attrVal) . r1, (default, attrType) . r2, attrMap) = (
case (attrVal, default)
of (av::no_val, NULL) => zip (r1, r2, attrMap)
| (av::no_val, THE v) =>
zip (r1, r2,
quark_map::set (attrMap, attrName, cvtValue (v, attrType))
) # end case
| _ => zip (r1, r2, quark_map::set (attrMap, attrName, attrVal))
) # end case
my (attrReqs, defaults) = unzip (queries, [], [])
replyV = threadkit::condVariable()
threadkit::put_mail (plea_slot, FindAttrs {
key=name, targets=attrReqs, reply=replyV
} )
map = zip (threadkit::readVariable replyV, defaults, quark_map::mkDict())
fun find attribute = (case (quark_map::peek (map, attribute))
of NULL => av::no_val
| (THE v) => v
) # end case
in
find
end # findAttrs
# my style: style -> style
### Create a style that is the logical child of another style
#
### NOTE: we may want to distinguish between "dynamic" and "static" attributes
#
# type attribute_spec = { attribute: String, value: String }
#
# my addResourceSpecs: style -> List (String * String) -> Void
# # Add a list of resource specifications to the style
#
# my addAttrs: style -> (style_name * List( attribute_spec ) ) -> Void
# # add a list of (attribute, value) pairs to a style; this will propagate
# # to any listeners.
#
#
# my deleteAttr: style -> (style_name * String) -> Void
# # Delete an attribute value from a style
#
# my mkStyle: style -> (style_name * List( attribute_spec ) ) -> style
# # create a new style from an existing style and a list of attribute
# # value definitions.
#
#
# my findAttr: style -> style_view -> Null_Or( String )
# # lookup the given attribute in the given style
#
# enum attribute_change
# = ADD_ATTRIBUTE of String
# | CHANGE_ATTRIBUTE of String
# | DELETE_ATTRIBUTE
#
# my listen: style -> style_view -> threadkit::event( attribute_change )
# # express an interest in changes to an attribute in a style. This
# # event will be enabled once for each change to the style that occurs
# # after the event is created.
}; # styles