## object-to-tree-object-g.pkg
## (C) 1999, Albert-Ludwigs-Uni Freiburg
## Author: bu
# Compiled by:
# src/lib/tk/src/toolkit/sources.sublib# ***************************************************************************
# Unified Object Interface
#
# This class macro produces out of an Part_Class-class
# a (standard) Tree_Part_Class-class, i.e. in particular
# also another Part_Class-class. It provides
# standard notions for paths and path-operations on the
# generated TREE_OBJECT's.
#
# These operations require that the application will assure
# uniqueness of object-names and node-info's.
# There are two fundamentally different way's to assure this:
# - update and rename must assure this via postconditions
# - internally in node-infos and names, unique key's are
# generated.
### "No matter how correct a mathematical theorem
### may appear to be, one ought never to be satisfied
### that there was not something imperfect about it
### until it also gives the impression of being beautiful."
###
### -- George Boole
generic package object_to_tree_object_g (package n: Folder_Info # Folder_Info is from src/lib/tk/src/toolkit/tree_object_class.api also
m: Part_Class ;) # Part_Class is from src/lib/tk/src/toolkit/object_class.api: (weak) Ptree_Part_Class # Ptree_Part_Class is from src/lib/tk/src/toolkit/tree_object_class.api# where nodeinfo = N.nodeinfo and basic_object = M.Part_Ilk and
# mlabel = M.label
# We have: obj_to_treeobj (aaa, bbb) : Part_Class
{
include package print;
package basic = m;
Node_Info = n::Node_Info;
Subnode_Info = n::Subnode_Info;
Part_Ilk = CONTENT (basic::Part_Ilk, Subnode_Info)
| FOLDER (n::Node_Info, List( Part_Ilk ));
Cb_Objects = Void -> List( Part_Ilk );
fun cb_objects_abs x = x;
fun cb_objects_rep x = x;
fun is_folder (folder x) => TRUE;
is_folder _ => FALSE; end;
fun get_content (content x) = x;
fun get_folder (folder x) = x;
Path = (List( n::Node_Info ), Null_Or( m::Part_Ilk ));
fun path_rep x = x;
fun path_abs x = x;
Name = Path;
fun name2path x = x;
fun path2name x = x;
fun path_of (p, _) = p;
fun base_of (_, b) = the b;
Part_Type = LEAF_T m::Part_Type
| FOLDER_T;
fun fst (x, _) = x;
fun snd (_, y) = y;
fun lex_ord ord ([],[]) => EQUAL;
lex_ord ord ([], s) => LESS;
lex_ord ord (s,[]) => GREATER;
lex_ord ord (a . s, a' . s') =>
(case (ord (a, a'))
LESS => LESS;
GREATER => GREATER;
EQUAL => lex_ord ord (s, s'); esac);
end;
fun ord (content a, content b) => m::ord (fst a, fst b);
ord (content a, folder b) => LESS;
ord (folder b, content a) => GREATER;
ord (folder (a, s), folder (b, s')) =>
case (n::ord_node (a, b))
LESS => LESS;
GREATER => GREATER;
EQUAL => lex_ord ord (s, s'); esac;
end;
fun name_of (content (a, _)) => ([], THE (a));
name_of (folder (a, s)) => ([a], NULL);
end;
fun rename s (content a) => m::rename s (fst a);
rename s (folder (a, s)) => n::rename_node s a;
end;
fun reset_name (content a) => m::reset_name (fst a);
reset_name (folder (a, s)) => n::reset_name_node a;
end;
separator = "/";
# treatment of printdepth and margin incorrect !!!
fun mgs m
=
\\ (a, b) = separator + (n::string_of_name_node a m) + b;
fun string_of_path p (m as { mode, printdepth, height, width }: print::Format)
=
{ m' = { mode,
printdepth => 0, # Print from scratch.
height => THE 1, # No internal breaking.
width => NULL: Null_Or( Int ) # Unbounded.
};
fun string_of ([], THE l) => m::string_of_name (m::name_of l) m';
string_of (rrr, THE l) => (fold_backward (mgs m') "" rrr) + separator +
(m::string_of_name (m::name_of l) m');
string_of ([], NULL ) => ""; # ???
string_of ([a], NULL ) => (n::string_of_name_node a m')
+ case mode
short => "";
_ => "";
esac;
string_of (a . rrr, NULL) => (fold_backward (mgs m')
(n::string_of_name_node a m')(rrr))
+ case mode
short => ""; # XXX BUGGO FIXME um...???
_ => "";
esac;
end;
fun blk len txt
=
if (size txt > len)
substring (txt, 0, len) .
blk len (substring (txt, len,
size (txt)-len));
else
[txt];
fi;
fun block len txt
=
{ tt = blk len txt;
fold_forward (\\ (a, b) = b + "\n" + a)
(hd tt)(tl tt);
};
fun ht len txt
=
((size txt) div len) + 1;
case (height, width)
(NULL, NULL) => string_of p; # printing unbounded
(THE k, NULL) => string_of p; # unrealistic case
(NULL, THE k) => block k (string_of p);
# printing unbounded height
(THE l, THE k) => if (ht k (string_of p) <= l)
block k (string_of p);
else substring (string_of p, 0, k - 3) + "...";
fi;
esac;
# printing shortened - somewhat panicking
};
string_of_name = string_of_path;
fun part_type (content x) => leaf_t (m::part_type (fst x));
part_type (folder (a, _)) => folder_t; end;
fun is_folder_type folder_t => TRUE;
is_folder_type _ => FALSE; end;
fun get_content_type (leaf_t x) = x;
fun content_type (x) = leaf_t x;
fun folder_icon ()= icons::get_icon
((tk::get_lib_path()) +
"/icons/gengui/",
/* HACK !!! This is not
config-dependent XXX BUGGO FIXME */
"folder.gif");
fun icon (leaf_t x) => m::icon x;
icon (folder_t) => folder_icon(); end;/* INEFFICIENT ! ! ! leads to
reload of the icon whenever
drag on folder dragged... */
string_of_name_node = n::string_of_name_node;
rename_node = n::rename_node;
reset_name_node = n::reset_name_node;
ord_node = n::ord_node;
fun get_path p a b =
(case (ord (a, b))
EQUAL => [(reverse p, if (is_folder b ) NULL;
else THE (fst (get_content b));fi)];
_ => (if (not (is_folder a) ) [];
else { my (n, s) = get_folder a;
fun f a = get_path (n . p) a b;
list::cat (map f s); };fi); esac
);
get_path = get_path [];
fun ord_path ((p, mmm), (p', mmm'))
=
case (lex_ord ord_node (p, p'))
EQUAL => (case mmm
NULL => (case mmm'
NULL => EQUAL;
THE _ => LESS; esac);
THE xxx => (case mmm'
NULL => GREATER;
THE xxx' => m::ord (xxx, xxx'); esac); esac);
xxx => xxx; esac;
fun is_prefix (([], NULL), (p, mmm')) => TRUE;
is_prefix (([], THE xxx), ([], THE (xxx')))=> (m::ord (xxx, xxx') == EQUAL);
is_prefix (([], THE xxx), _) => FALSE;
is_prefix ((a . p, mmm), ([], mmm')) => FALSE;
is_prefix ((a . p, mmm), (a' . p', mmm')) =>
case (ord_node (a, a'))
EQUAL => is_prefix ((p, mmm), (p', mmm'));
xxx => FALSE; esac; end;
fun join_path ((p1, NULL), (p2, rrr)) = (p1@p2, rrr);
exception INCONSIST_PATH;
/* one could imagine a more liberal version (which is
even easier to implement), that yields the *list of objects*
if path-id's are not unique. I chose this more strict
version for efficiency reasons */
fun select_from_path (obj . rrr) ([a], NULL) =>
if (is_folder obj )
case (ord_node (a, fst (get_folder obj)))
EQUAL => obj;
_ => select_from_path rrr ([a], NULL); esac;
else select_from_path rrr ([a], NULL);fi;
select_from_path (obj . rrr) ([], THE a)=>
if (is_folder obj ) select_from_path rrr ([], THE a);
else (case (m::ord (a, fst (get_content obj)))
EQUAL => obj;
_ => select_from_path rrr ([], THE a); esac);fi;
select_from_path (obj . rrr) (a . rrr', r)=>
if (not (is_folder obj) ) select_from_path rrr (a . rrr', r);
else { my (n, s) = get_folder obj;
case (ord_node (a, n))
EQUAL => select_from_path s (rrr', r);
_ => select_from_path rrr (a . rrr', r); esac;
};fi;
select_from_path _ _ => raise exception INCONSIST_PATH;
end;
fun update objs path xxx =
# update is very liberal - it allows none or multiple
# replacements in cases of ambiguities
# potential improvements: other map' (only first replacement)
# working inherently on lists ...
{ fun upd path [] => raise exception INCONSIST_PATH;
upd ([], THE x) (content (bob, h) . rrr) =>
# search for leaf on leaf
(case (m::ord (x, bob))
EQUAL => xxx@rrr;
_ => (content (bob, h) . upd ([], THE x) rrr); esac);
upd ([], THE x) (aaa . rrr) => aaa . upd ([], THE x) rrr;
# search for leaf on folder
upd ([x], NULL) (folder (n, s) . rrr) =>
(case (ord_node (x, n))
EQUAL => xxx@rrr;
_ => (folder (n, s) . upd ([x], NULL) rrr); esac);
upd ([x], NULL) (aaa . rrr) => aaa . upd ([x], NULL) rrr;
upd (x . rrr, hhh) (folder (n, s) . rrr') =>
(case (ord_node (x, n))
EQUAL => folder (n, upd (rrr, hhh) s) . rrr';
_ => folder (n, s) . upd (x . rrr, hhh) rrr'; esac);
upd (x . rrr, hhh) (aaa . rrr') => aaa . upd (x . rrr, hhh) (rrr'); end;
upd path objs; };
fun remove_at_path objs path
=
update objs path [];
fun update_at_path objs path repojb
=
update objs path [repojb];
};
# fields (\\ x = '/') translate ...