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