PreviousUpNext

15.4.1320  src/lib/x-kit/style/style.pkg

## 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.pkg

package 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 


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext