PreviousUpNext

15.4.1355  src/lib/x-kit/style/widget-style-g.pkg

## widget-style-g.pkg

# Compiled by:
#     src/lib/x-kit/style/xkit-style.sublib



###                   "I notice that you use plain, simple language,
###                    short words and brief sentences. That is the
###                    way to write English -- it is the modern way
###                    and the best way. Stick to it; don't let fluff
###                    and flowers and verbosity creep in.
###
###                   "When you catch an adjective, kill it.
###                    No, I don't mean utterly, but kill most
###                    of them -- then the rest will be valuable.
###                    They weaken when they are close together.
###                    They give strength when they are wide apart.
###
###                   "An adjective habit, or a wordy, diffuse,
###                    flowery habit, once fastened upon a person,
###                    is as hard to get rid of as any other vice."
###
###                                          -- Mark Twain,
###                                             Letter to D. W. Bowser,
###                                             3/20/1880



# We use this to select just the
# parts we want from:
#
#     src/lib/x-kit/widget/old/lib/widget-attribute-old.pkg

api Pruned_Widget_Attribute {

    Type;
    Value;
    Context;

    exception NO_CONVERSION;
    exception BAD_ATTRIBUTE_VALUE;

    no_val:     Value;
    same_value:     (Value, Value) -> Bool;
    same_type:      (Value, Type ) -> Bool;

    convert_string:           Context -> (String, Type) -> Value;
    convert_attribute_value:  Context -> (Value,  Type) -> Value;
};


stipulate
    package wkr =  weak_reference;                                      # weak_reference        is from   src/lib/std/src/nj/weak-reference.pkg
herein

    # This generic is compile-time invoked from:
    #
    #     src/lib/x-kit/widget/old/lib/widget-style-old.pkg
    #
    generic package   widget_style_g  (
        #             ==============
        #
        wa:  Pruned_Widget_Attribute                                    # widget_attribute_old  is from   src/lib/x-kit/widget/old/lib/widget-attribute-old.pkg
    )
    #  : Widget_Style                                                   # Widget_Style          is from(?)   src/lib/x-kit/style/widget-style-ancient.api
    {
        include package   threadkit;                                    # threadkit             is from   src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg


        package q   = quark;                                            # quark                 is from   src/lib/x-kit/style/quark.pkg
        package prs = parse_resource_specs;                             # parse_resource_specs  is from   src/lib/x-kit/style/parse-resource-specs.pkg


        exception BAD_STYLE_NAME;


        Style_Name                                                      # A style_name is a key for searching a style database.
            =
            { name:  List( quark::Quark ),
              hash:  Unt
            };

        fun ext_hash (hash, comp)
            =
            unt::bitwise_and (unt::(<<) (hash, 0u1), 0uxffffff) + q::hash comp;

        fun style_name sl
            =
            {   (check_name (sl, [], 0u0))
                except
                    _ = raise exception BAD_STYLE_NAME;
            }
            where
                fun check_name ([], comps, hash)
                        =>
                        { name => reverse comps, hash };

                    check_name (s ! r, comps, hash)
                        =>
                        {   comp =   prs::check_comp_name s;

                            check_name (r, comp ! comps, ext_hash (hash, comp));
                        };
                end;
            end;


        #  Compare two style names for equality 
        #
        fun same_style_name ( { name=>n1, hash=>h1 } : Style_Name, { name=>n2, hash=>h2 } )
            =
            (h1 == h2) and compare (n1, n2)
            where
                fun compare ([], []) => TRUE;
                    compare (q1 ! r1, q2 ! r2) =>   quark::same (q1, q2) and compare (r1, r2);
                    compare _ => FALSE;
                end;
            end;

        # Extend a style name with a component 
        #
        fun extend_style_name ( { name, hash } : Style_Name, comp) : Style_Name
            =
            {   comp_q =   quark::quark comp;
                #
                { name =>  name @ [comp_q],
                  hash =>  ext_hash (hash, comp_q)
                };
            };

        # A style_view is a search key for finding attributes in a style.
        # It consists of a name and an ordered list of aliases.
        #
        Style_View
            =
            STYLE_VIEW
              { 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.
        #
        make_view = STYLE_VIEW;


        # Return the name part of the view 
        #
        fun name_of_view (STYLE_VIEW { name, ... } )
            =
            name;


        # Return the list of aliases that defines the view. 
        #
        fun aliases_of_view (STYLE_VIEW { aliases, ... } )
            =
            aliases;


        # Extend each of the names in the view by the component 
        #
        fun extend_view (STYLE_VIEW { name, aliases }, comp)
            =
            {   comp_q =   prs::check_comp_name comp;
                #
                fun ext { name, hash }
                    =
                    {   name => name @ [comp_q],
                        hash => ext_hash (hash, comp_q)
                    };

                STYLE_VIEW { name => ext name, aliases => map ext aliases };
            };


        # Concatenate two views; the first view has priority over the second. 
        #
        fun meld_views (STYLE_VIEW { name=>n1, aliases=>a1 }, STYLE_VIEW { name=>n2, aliases=>a2 } )
            =
            STYLE_VIEW { name => n1, aliases => a1 @ (n2 ! a2) };


        # Add a alias to the back or front of a view 
        #
        fun append_alias (STYLE_VIEW { name, aliases }, alias)
            =
            STYLE_VIEW { name, aliases => aliases @ [alias] };

        fun prepend_alias (STYLE_VIEW { name, aliases }, alias)
            =
            STYLE_VIEW { name, aliases => alias ! aliases };


        # ** attributes in the database **
        #
        Attribute
            =
            ATTRIBUTE  {
                raw_value:  String,
                cache:  Ref( wa::Value )
            };

        fun make_attribute raw_value
            =
            ATTRIBUTE {
                raw_value,
                cache => REF wa::no_val
            };


        # Extract the value from an attribute chunk, performing
        # the conversion, if necessary, and caching the result.
        #
        fun get_attribute_value context
            =
            get
            where
                cvt_value =   wa::convert_string context;
                #
                fun get (ATTRIBUTE { raw_value, cache }, type)
                    =
                    {   cache_val =   *cache;

                        if   (wa::same_type (cache_val, type))
                             cache_val;
                        else {   cvt_val =   cvt_value (raw_value, type);
                                 cache := cvt_val;
                                 cvt_val;
                             }
                             except
                                 _ = wa::no_val;
                        fi;
                    };
            end;


        # The resource database tables:

        package qht
            =
            typelocked_hashtable_g (
                Hash_Key = q::Quark;
                hash_value = q::hash;
                same_key = q::same;
            );

        #  maps on quarks 

        Qmap(X) =   qht::Hashtable(X);

        fun find_quark (table, q)
            =
            qht::find table q;

        fun ins_quark (table, q, v)
            =
            qht::set table (q, v);

        fun empty table
            =
            (qht::vals_count table == 0);


        Naming = prs::Naming;

        Db_Table
            =
            DBTABLE  {
                tight:  Qmap( Db_Table ),
                loose:  Qmap( Db_Table ),        #  entries of the form "*path.attribute:" 
                attributes:  Qmap( (Attribute, Naming) )   #  entries of the form "[*]attribute:" 
            };

        fun new_dbtable ()
            =
            DBTABLE
              {
                tight      =>  qht::make_hashtable  { size_hint => 8,  not_found_exception => DIE "db_table.tight"      },
                loose      =>  qht::make_hashtable  { size_hint => 8,  not_found_exception => DIE "db_table.loose"      },
                attributes =>  qht::make_hashtable  { size_hint => 8,  not_found_exception => DIE "db_table.attributes" }
              };

        # Given a database and a component name path, find the list of
        # attribute naming tables keyed by the path.
        #
        fun find_attribute_tables (DBTABLE { tight, loose, attributes }, path)
            = 
            {   fun find_loose_attribute attribute_table attribute_q
                    =
                    case (find_quark (attribute_table, attribute_q))

                         THE (attribute, loose) =>  THE attribute;
                         _                 =>  NULL;
                    esac;


                fun find_attribute attribute_table attribute_q
                    =
                    case (find_quark (attribute_table, attribute_q))

                         THE (attribute, loose) =>  THE attribute;
                         _                 =>  NULL;
                    esac;


                fun find (tight, loose, attributes, [], tables)
                        =>
                        if (empty attributes)
                               tables;
                        else   (find_attribute attributes) ! tables;
                        fi;

                   find (tight, loose, attributes, comp ! r, tables)
                        =>
                        {   tables' =   case (find_quark (tight, comp))
                                            #
                                            NULL => tables;

                                            THE (DBTABLE { tight, loose, attributes } )
                                                =>
                                                find (tight, loose, attributes, r, tables);
                                        esac;


                            fun find_loose ([], tables)
                                    =>
                                    tables;

                               find_loose (comp ! r, tables)
                                    =>
                                    case (find_quark (loose, comp))
                                        #
                                        NULL => find_loose (r, tables);

                                        THE (DBTABLE { tight, loose, attributes } )
                                           =>
                                           find_loose (r, find (tight, loose, attributes, r, tables));
                                    esac;
                            end;

                            tables'' =  if (empty loose)    tables';
                                        else                find_loose (r, tables');
                                        fi;

                            if (empty attributes)   tables'';
                            else                    (find_loose_attribute attributes) ! tables'';
                            fi;
                        };
                end;

                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
                    =
                    search' tables
                    where
                        fun search' []
                                =>
                                NULL;

                            search' (table ! r)
                                =>
                                case (table attribute)

                                     NULL     =>  search' r;
                                     some_val =>  some_val;
                                esac;
                        end;
                    end;

                search;

            };  # fun find_attribute_tables 

        # Insert an attribute naming into the database: 
        #
        fun insert_attribute (db, is_loose, path, name, attribute)
            =
            {   fun find (table, comp)
                    =
                    case (find_quark (table, comp))
                        #                 
                        THE db =>   db;

                        NULL =>
                            {   db =   new_dbtable ();

                                ins_quark (table, comp, db);

                                db;
                            };
                    esac;


                fun insert (DBTABLE { tight, loose, attributes }, bind, path)
                    =
                    case (bind, path)
                        #                 
                        (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 DIE "wildcard components not implemented";

                        (_, [])
                            =>
                            ins_quark (attributes, name, (attribute, bind));
                    esac;


                insert
                    ( db,
                      is_loose  ??  prs::LOOSE  ::  prs::TIGHT,
                      path
                    );
            };


        # The database with view cache:
        #
        Db = DB { db:      Db_Table,
                  cache:   Ref( List( wkr::Weak_Reference( (Style_Name, (prs::Name -> Null_Or( Attribute ))))))
                };

        fun make_db ()
            =
            DB {   db => new_dbtable(),
                   cache => REF []
            };

        # This is a temporary function for
        # building resource data bases by hand 
        #
        fun insert_rsrc_spec (DB { db, cache }, { loose, path, attribute, value } )
            =
            {   insert_attribute (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 construct_view (DB { db, cache }, STYLE_VIEW { name, aliases } )
            =
            find_attribute
            where
                # Probe the cache for a naming for name.
                # Remove any stale cache entries encountered:
                #
                fun probe_cache name
                    =
                    {   fun probe ([], l)
                                =>
                                (reverse l, NULL);

                           probe (weakref ! r, l)
                                =>
                                case (wkr::get_normal_reference_from_weak_reference  weakref)
                                    #
                                    NULL =>   probe (r, l);
                                    #
                                    THE (name', naming)
                                        =>
                                        if (same_style_name (name, name'))   (weakref ! ((reverse l) @ r), THE naming);
                                        else                                 probe (r, weakref ! l);
                                        fi;
                                esac;
                        end;

                        (probe (*cache, []))
                            ->
                            (cache', result);

                        cache := cache';

                        result;
                    };

                # Add a naming to the cache 
                #
                fun add_to_cache item
                    =
                    cache :=   (wkr::make_weak_reference  item) ! *cache;



                # Find the attribute tables for a name 
                #
                fun find_tables (name:  Style_Name)
                    =
                    case (probe_cache name)
                        #
                        THE tables =>   tables;

                        NULL =>     {   tables = find_attribute_tables (db, name.name);
                                        add_to_cache (name, tables);
                                        tables;
                                    };
                    esac;


                # Search for an attribute in this view; 
                #
                fun find_attribute attribute_name
                    =
                    search (name ! aliases)
                    where
                        fun search [] => NULL;
                            #
                            search (name ! r)
                                =>
                                case (find_tables  name  attribute_name)
                                    #
                                    NULL =>  search r;
                                    attribute =>  attribute;
                                esac;
                        end;
                    end;
            end;                                # fun construct_view


        # ** styles **

        Plea_Mail = PLEA_MAIL
                      {
                        key:          Style_View,
                        targets:      List( (prs::Name, wa::Type) ),
                        reply_1shot:  Oneshot_Maildrop( List( (prs::Name, wa::Value) ) )
                      }

          | GET_DB  Oneshot_Maildrop( Db );

        Widget_Style
            =
            WIDGET_STYLE
              { context:    wa::Context,
                plea_slot:  Mailslot( Plea_Mail )
              };


        fun context_of (WIDGET_STYLE { context, ... } )
            =
            context;


        # Spawn a style imp for the
        # given context and database:
        #
        fun make_style_imp (context, db)
            = 
            {   plea_slot =  make_mailslot ();
                #
                get_attribute_value
                    =
                    get_attribute_value  context;


                fun find_attribute key
                    =
                    {   find = construct_view (db, key);
                        #
                        \\ (attribute_name, type)
                            =
                            case (find  attribute_name)
                                #
                                THE attribute =>  (attribute_name, get_attribute_value (attribute, type));
                                NULL          =>  (attribute_name, wa::no_val);
                            esac;
                    };


                fun imp_loop ()
                    =
                    for (;;) {
                        #
                        case (take_from_mailslot  plea_slot)
                            #                 
                            PLEA_MAIL { key, targets, reply_1shot }
                                =>
                                {   results = map (find_attribute key)
                                                  targets;

                                    put_in_oneshot (reply_1shot, results);
                                };

                            GET_DB reply_1shot
                                =>
                                put_in_oneshot (reply_1shot, db);
                        esac;
                    };

                make_thread "style_imp" imp_loop;

                WIDGET_STYLE { plea_slot, context };
              };                                                        # fun make_style_imp

        # Create an empty style:
        #
        fun empty_style  context
            =
            make_style_imp (context, make_db ());



        # Create a style, initializing
        # it from a list of strings.
        # This is for testing purposes.
        #
        fun style_from_strings (context, sl)            # "sl" might be "string list".
            =
            make_style_imp (context, db)
            where
                db =  make_db ();
                #
                apply parse sl
                where
                    fun parse str                               # "str" might be "string".
                        =
                        insert_rsrc_spec (db, lpav)             # "lpav" == "loose, path, attribute, value".
                        where
                            lpav =  case (prs::parse_rsrc_spec str)   (prs::RSRC_SPEC { loose, path, attribute, value, ... } ) =>  { loose, path, attribute, value };
                                        /* */                      _                                                       =>  raise exception DIE "Bug: Unsupported case in style_from_strings/parse.";
                                    esac;
                        end;
                end;
            end;

        # Applicative maps from attribute names to attribute values 
        #
        package quark_map
            =
            binary_map_g (
                #
                Key     =  q::Quark;
                compare =  q::cmp;
            );

        #  
        fun find_attributes (WIDGET_STYLE { plea_slot, context, ... } )  (name, queries)
            =
            {   cvt_value = wa::convert_attribute_value context;
                #
                fun unzip ([], attribute_reqs, defaults)
                        =>
                        (attribute_reqs, defaults);

                    unzip ((attribute_name, type, default) ! r, attribute_reqs, defaults)
                        =>
                        unzip (r, (attribute_name, type) ! attribute_reqs, (default, type) ! defaults);
                end;


                fun zip ( (attribute_name, attribute_val)  ! r1,
                          (default, type)                  ! r2,
                           attribute_map
                        )
                        =>
                        if (wa::same_value (attribute_val, wa::no_val))
                            #
                            if (wa::same_value (default, wa::no_val))
                                 #
                                 zip (r1, r2, attribute_map);
                            else zip (r1, r2, quark_map::set (attribute_map, attribute_name, cvt_value (default, type)));
                            fi;
                        else
                            zip (r1, r2, quark_map::set (attribute_map, attribute_name, attribute_val));
                        fi;

                    zip ([], [], attribute_map)
                        =>
                        attribute_map;

                    zip _ =>   raise exception DIE "Bug: Unsupported case in find_attributes/zip.";
                end;

                (unzip (queries, [], []))
                    ->
                    (attribute_reqs, defaults);


                reply_1shot =  make_oneshot_maildrop ();


                put_in_mailslot
                  (  plea_slot,
                     PLEA_MAIL { key=>name, targets=>attribute_reqs, reply_1shot }
                  );

                map =  zip  (get_from_oneshot reply_1shot,  defaults,  quark_map::empty);

                fun find attribute
                    =
                    case (quark_map::get (map, attribute))
                        THE v => v;
                        NULL  => wa::no_val;
                    esac;


                  find;
            };

    #    ######################################################################
    #        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 )
    #        # Look up the given attribute in the given style 
    #    
    #        Attribute_Change
    #          = ADD_ATTRIBUTE  String
    #          | CHANGE_ATTRIBUTE String
    #          | DELETE_ATTRIBUTE
    #    
    #        my listen:  style -> style_view -> 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.
    #    


        # Additions by ddeboer, May 2004. 
        # Dusty deBoer, KSU CIS 705, Spring 2004.

        # utility function: list the resource specs from a db. 
        # a resource spec is roughly:
        # PRS::RsrcSpec { loose: Bool, path: List( PRS::component * PRS::naming ), attribute: PRS::attribute_name, value: String, ext:(FALSE) }
        #
        fun list_rsrc_specs (DB { db, cache } )
            =
            {
                fun lst_spcs (DBTABLE { tight, loose, attributes }, pth)
                    =
                    #  list specs from attributes; that is the easy part. 
                    {
                        my (qab_lst:  List ((quark::Quark, ((Attribute, Naming))))) = qht::keyvals_list attributes;

                        my (rsc_sp_l: List( prs::Resource_Spec )) = 
                            list::map 
                                (\\ (qu, (ATTRIBUTE { raw_value, ... }, bind)) => 
                                    prs::RSRC_SPEC { loose=>(case bind    prs::LOOSE=>TRUE;  prs::TIGHT=>FALSE; esac),
                                        path=>pth, attribute=>qu, value=>raw_value, ext=>FALSE }; end  ) 
                                qab_lst;

                        my (loosqt_lst:  List( (quark::Quark, Db_Table) ) ) = 
                                qht::keyvals_list loose;

                        my (loostp_lst:  List( (Db_Table,  List( (prs::Component, prs::Naming) )) )) =
                                list::map (\\ (q, t) = (t, pth @ [(prs::NAME q, prs::LOOSE)])) loosqt_lst;

                        my (loos_rsc_sp_l: List( prs::Resource_Spec )) = 
                                list::cat (list::map lst_spcs loostp_lst);

                        my (tghtqt_lst: List( (quark::Quark, Db_Table)) ) = 
                                qht::keyvals_list tight;

                        my (tghttp_lst:  List( (Db_Table,  List( (prs::Component, prs::Naming) )) ) ) =
                                list::map (\\ (q, t) = (t, pth @ [(prs::NAME q, prs::TIGHT)])) tghtqt_lst;

                        my (tght_rsc_sp_l: List( prs::Resource_Spec ))
                            = 
                            list::cat (list::map lst_spcs tghttp_lst);    

                         (rsc_sp_l@loos_rsc_sp_l@tght_rsc_sp_l);
                     };

                 lst_spcs (db,[]);
            };

        # Another utility function:
        # Get the resource specs from a style,
        # then convert them to strings.
        #
        # This could be used to write a style
        # back to a database, as in
        #     XrmPutFileDatabase ().
        #
        fun strings_from_style (WIDGET_STYLE { plea_slot, context } )
            =
            {   reply_1shot = make_oneshot_maildrop ();
                #
                put_in_mailslot  (plea_slot,  GET_DB reply_1shot);

                db =  get_from_oneshot  reply_1shot;

                list::map f (list_rsrc_specs db)
                where
                    fun g (prs::NAME cn, b)
                            =>
                            case b
                                #
                                prs::LOOSE =>  "*";
                                prs::TIGHT =>  ".";
                            esac
                            +
                            (quark::string_of cn);

                        g _ =>   raise exception DIE "Bug: Unsupported case in strings_from_style/g.";
                    end;

                    fun f (prs::RSRC_SPEC { loose, path, attribute, value, ... })
                            #
                            => (string::cat (list::map g path))
                            +  (loose ?? "*" :: ".")
                            +  (quark::string_of attribute)
                            +  ":"
                            +  value;

                        f _ =>   raise exception DIE "Bug: Unsupported case in strings_from_style/f.";
                    end;
                end;


            };

        # merge_styles (sourceStyle: style, targetStyle: style) -> mergedStyle: style
        # 
        # mergedStyle should consist of the same resource specifications that would
        # exist in targetStyle if all resource specifications of sourceStyle were
        # inserted into targetStyle. That is, in particular, a tight naming of a
        # particular resource specification in targetStyle would not be overwritten
        # by a loose naming of the same specification in sourceStyle.
        #
        # The behavior of this should be similar to XrmMergeDatabases (db1, db2) of Xlib;
        # in particular, resources specified in db1 should override those in db2.
        #
        fun merge_styles
            ( WIDGET_STYLE { plea_slot=>plea_slot_1, context=>ctxt1 },
              WIDGET_STYLE { plea_slot=>plea_slot_2, context=>ctxt2 }
            )
            =
            {   reply_1shot_1 =  make_oneshot_maildrop ();
                reply_1shot_2 =  make_oneshot_maildrop ();

                put_in_mailslot  (plea_slot_1,  GET_DB reply_1shot_1);
                put_in_mailslot  (plea_slot_2,  GET_DB reply_1shot_2);

                db1 =  (get_from_oneshot  reply_1shot_1): Db;
                db2 =  (get_from_oneshot  reply_1shot_2): Db;

                rsrcsp1 = list_rsrc_specs db1;

                ins_rsrc_spcs  rsrcsp1
                where
                    fun ins_rsrc_spcs (prs::RSRC_SPEC { loose, path, attribute, value, ... } ! rs)
                            =>
                            {   insert_rsrc_spec (db2,{ loose, path, attribute, value } );
                                ins_rsrc_spcs rs;
                            };

                        ins_rsrc_spcs [] =>   ();

                        ins_rsrc_spcs _  =>   raise exception DIE "Bug: Unsupported case in ins_rsrc_spcs";
                    end;
                end;

                make_style_imp (ctxt2, db2);
            };


    #    fun mergeStyles (WIDGET_STYLE { plea_slot=plea_slot_1, context=ctxt1 }, WIDGET_STYLE { plea_slot=plea_slot_2, context=ctxt2 } )
    #        =
    #        let
    #        reply_1shot_1 = make_oneshot_maildrop ()
    #        reply_1shot_2 = make_oneshot_maildrop ()
    #
    #        put_mail (plea_slot_1, GET_DB (reply_1shot_1))
    #        put_mail (plea_slot_2, GET_DB (reply_1shot_2))
    #
    #        my (db1: db) = get_mail reply_1shot_1
    #        my (db2: db) = get_mail reply_1shot_2
    #
    #        * insert every entry in quarktable1 into quarktable2 *
    #
    #        fun qtMerge (ht1, ht2) =
    #            (list::apply (\\ (k, v) => (qht::set ht2 (k, v))) (qht::keyvals_list ht1))
    #        * merge: insert all attribute values from db1 into db2 *
    #        fun dbMerge (DBTABLE { tight=tght1, loose=loos1, attributes=attr1 },
    #                     DBTABLE { tight=tght2, loose=loos2, attributes=attr2 } ) =
    #                        (qtMerge (attr1, attr2);dbMerge (tght1, tght2);dbMerge (loos1, loos2))
    #        in (dbMerge (db1, db2); mkStyleServer (ctxt2, db2)) end



        # Parsing of command line arguments:
        # ----------------------------------

        # options specified on the command line may be of two types:
        # - a "named" option, such as "x" and "y" in "add -x 1 -y 3" where "x" and "y" are simple
        #   arguments to the "add" program that adds them together, and where the "add" program
        #   simply wishes to determine the value of "x" and "y", or
        # - a "resource spec" option, such as "foreground" in "xapp -foreground black" where the
        #   "xapp" wishes to obtain a resource specification like "*foreground: black" from these
        #   command line arguments.

        # Named options should be typically useful in obtaining input for 
        # processing by an application, as opposed to X resource specification
        # values. For example, "-filename foo" will probably be used by an
        # application in some process, while "-background bar" is an X resource
        # to be used in some graphical display.
        # For further details see src/lib/x-kit/style/widget-style-g.pkg.

         Opt_Name 
            = OPT_NAMED  String   #  Custom options: retrieve by name 
            | OPT_RESSPEC  String; #  resource options: convert to a style 

         Arg_Name = String; #  option spec string in argv 
         Opt_Kind
            = OPT_NOARG  String #  As XrmoptionNoArg. optname will assume this value if argName is specified in argv 
            | OPT_ISARG     #  As XrmoptionIsArg:     value is option string itself 
            | OPT_STICKYARG #  As XrmoptionStickyArg: value is chars immediately following option 
            | OPT_SEPARG    #  As XrmoptionSepArg:    value is next argument in argv 
            | OPT_RESARG    #  As XrmoptionResArg:    resource and value in next argument in argv 
            | OPT_SKIPARG   #  As XrmSkipArg:         ignore this option and next argument in argv 
            | OPT_SKIPLINE;  #  As XrmSkipLine:        ignore this option and the rest of argv 
         Opt_Val
            = OPT_ATTRVAL  ((String, wa::Type))
            | OPT_STRING  String;
        #  option specification table: name for searching, name in argv, kind of option, and type of option 
         Opt_Spec = List( (Opt_Name, Arg_Name, Opt_Kind, wa::Type) ); 
        #  Command line argument strings, with optSpec, will be converted into a optDb 
         Opt_Db = List( (Opt_Name, Opt_Val) ); 

        # parseCommand: optSpec -> (String List) -> (optDb * String List) 
        # parseCommand proceeds through the string list of command line arguments,
        # adding any recognizable options from optSpec to the optDb. Any unrecognized
        # arguments (that is, arguments not recognized as unique prefixes of an option
        # in optSpec) are returned as a string list, along with the optDb produced.
        # Future improvement: figure out a way for these unrecognized arguments to be
        # somehow marked as to their position in the original argument list, in case
        # position is important.


        fun parse_command (os: Opt_Spec)  []
                =>
                ([],[]);
            parse_command (os: Opt_Spec)  (s ! sl)
                =>
                {   fun make_opt_rec (opt_nam, opt_val: String, type: wa::Type)
                        =
                        case opt_nam   
                            #
                            OPT_NAMED  n
                                =>
                                (opt_nam, OPT_ATTRVAL (opt_val, type));

                            OPT_RESSPEC  n
                                =>
                                (opt_nam, OPT_STRING (opt_val));
                        esac;

                    case ((list::filter 
                            (\\ (_, an, _, _) => ((string::is_prefix s an) or (string::is_prefix an s)); end ) 
                            os):  List ((Opt_Name, Arg_Name, Opt_Kind, wa::Type)))   

                        ([]:Opt_Spec)
                            => 
                            {   my (od, ua) = (parse_command (os) sl);
                                (od, s ! ua);
                            };

                        ([(on, an, OPT_NOARG (av), at)]:Opt_Spec)
                            =>
                            {   my (od, ua) = (parse_command (os) sl);
                                ((make_opt_rec (on, av, at)) ! od, ua);
                            };

                        ([(on, an, OPT_ISARG, at)]:Opt_Spec)
                            =>
                            {   my (od, ua) = (parse_command (os) sl);
                                ((make_opt_rec (on, an, at)) ! od, ua);
                            };

                        ([(on, an, OPT_STICKYARG, at)]:Opt_Spec)
                            =>
                            {   la = string::length_in_bytes s;
                                lo = string::length_in_bytes an;
                                sv = (if (la>lo ) string::substring (s, (lo), (la-lo)); else "";fi);
                                my (od, ua) = (parse_command (os) sl);
                                ((make_opt_rec (on, sv, at)) ! od, ua);
                            };

                        ([(on, an, OPT_SEPARG, at)]:Opt_Spec)
                            =>
                            case sl   
                                #
                                sv ! svs
                                    =>
                                    {   my (od, ua) = (parse_command (os) svs);
                                        ((make_opt_rec (on, sv, at)) ! od, ua);
                                    };

                                [] =>
                                    {   my (od, ua) = (parse_command (os) sl);
                                        (od, s ! ua);
                                    };
                            esac;

                        ([(on, an, OPT_RESARG, at)]:Opt_Spec)
                            =>
                            case sl   
                                #
                                sv ! svs
                                    =>
                                    {   my  (acol, bcol)
                                            =
                                            case (string::tokens   (\\ c = (c == (':')))   sv)   (bcol ! (acol ! _)) =>  (acol, bcol);
                                                /* */                                        _                   =>  raise exception DIE "Bug: Unsupported case in parse_command.";     
                                            esac;

                                        (parse_command (os) svs)
                                            ->
                                            (od, ua);

                                        ( (make_opt_rec (on, sv, at)) ! (OPT_RESSPEC (bcol), OPT_STRING (acol)) ! od,
                                          ua
                                        );
                                    };

                                [] =>
                                    {   my (od, ua) = (parse_command (os) sl);
                                        (od, s ! ua);
                                    };
                            esac;

                        ([(on, an, OPT_SKIPARG, at)]:Opt_Spec)
                            =>
                            case sl   
                                #
                                sv ! svs
                                    =>
                                    {   my (od, ua) = (parse_command (os) svs);
                                        (od, ua);
                                    };

                                [] =>
                                    {   my (od, ua) = (parse_command (os) sl);
                                        (od, s ! ua);
                                    };
                            esac;

                        ([(on, an, OPT_SKIPLINE, at)]:Opt_Spec)
                            =>
                            ([],[]);

                        # Ambiguous argument s:
                        #       
                        (_: Opt_Spec)
                            =>
                            {   my (od, ua) = (parse_command (os) sl);
                                (od, s ! ua);
                            };
                    esac; 
                };
        end;

        # findNamedOpt: optDb -> optName -> wa::attribute_value List 
        # find the attribute values of the "named" command line arguments.
        # this will return a list of _all_ arguments with the given name, with
        # the last argument value given on the command line as the head of the
        # list.
        # this allows an application to process named arguments in several ways -
        # it may wish that later arguments take precedence over earlier arguments,
        # in which case it may use only the head of the value list (if it exists).
        # otherwise, if the application wishes to obtain all of the argument values,
        # it may do this also (by working with the whole list).
        # 
        # OPT_ATTRVAL (wa::cvtString context (optVal, attrType))
        #
        fun find_named_opt od (OPT_NAMED (on)) context
                =>
                {   fun filt (OPT_NAMED (n), v) =>   n == on;
                        filt (_, _)             =>   FALSE;
                    end;

                    (list::reverse 
                        (list::map (\\ (n, v) => 
                            (case v    OPT_ATTRVAL (v, t) => 
                                (wa::convert_string context (v, t));  _ => wa::no_val; esac); end )
                        (list::filter filt od)));
                };

            find_named_opt od (OPT_RESSPEC (on)) context
                =>
                [];
        end;

        fun find_named_opt_strings od (OPT_NAMED (on))
                =>
                {
                    fun filt (OPT_NAMED (n), v)   =>   (n == on);
                        filt (_, _) => FALSE;
                    end;

                    (list::reverse 
                        (list::map
                            (\\ (n, v)
                                = 
                                case v   
                                    OPT_ATTRVAL (v, t) =>  v;
                                    _                  =>  "";
                                esac
                            )
                            (list::filter filt od)));
                };

            find_named_opt_strings od (OPT_RESSPEC (on))
                =>
                [];
        end;

        # styleFromOptDb: create a style from resource specifications in optDb.

        fun style_from_opt_db (context, od)
            =
            {   fun filt (OPT_RESSPEC (n), v) =>  TRUE;
                    filt (_, _)               =>  FALSE;
                end;

                fun rov_to_string (OPT_RESSPEC (n), OPT_STRING (v)) =>  (n + ":" + v);
                    rov_to_string(_, _)                             =>  "";
                end;

                str_lst = list::map (rov_to_string) (list::filter filt od);

                style_from_strings (context, str_lst);
            };

        # A utility function that returns
        # a string outlining the valid command
        # line arguments in optSpec.
        #
        fun help_string_from_opt_spec (os: Opt_Spec)
            =
            {   arg_lst =   list::map
                                (\\ (_, ar, _, _) =  ar: String)
                                os;

                hlp_string = ("[" + (string::join "|" arg_lst) + "]");

                "Valid options:\n" + hlp_string + "\n";
            };

        #  end additions by ddeboer. 

        no_val =   wa::no_val;
    };                                                                          # generic package   widget_style_g
end;

## COPYRIGHT (c) 1994 AT&T Bell Laboratories.
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.





Comments and suggestions to: bugs@mythryl.org

PreviousUpNext