# **************************************************************************
#
# Some utility functions needed for tk.
#
# Originally, this was based on the gofer prelude, but most of the
# functions there are in the new standard basis library.
#
# $Date: 2001/03/30 13:39:01 $
# $Revision: 3.0 $
# Author: bu/cxl (Last modification by $Author: 2cxl $)
#
# (C) 1998, Bremen Institute for Safe Systems, Universitaet Bremen
#
# **************************************************************************
# Compiled by:
# src/lib/tk/src/tk.sublib#DO set_control "compiler::trap_int_overflow" "TRUE";
package basic_utilities
: (weak) Basic_Utilities # Basic_Utilities is from src/lib/tk/src/basic_util.api{
# ******************************************************************************
#
# Part 1: General functions.
#
# Mainly these are fst and snd (why are they not in the basis anyway?), and
# some functionals to schoenfinkel and unschoenfinkel functions, and twiddle
# their arguments.
fun fst (a, _) = a;
fun snd (_, b) = b;
fun pair (f, g) z = (f z, g z);
fun eq a b = a == b;
fun upto (i, j)
=
if ( (i: Int) <= j ) i . (upto (i+1, j));
else []; fi;
fun inc x
=
{ x := *x + 1;
*x;
};
fun curry f x y = f (x, y);
fun uncurry f (x, y) = f x y;
fun twist (f: (X, Y) -> Z)
=
\\ (y, x) = f (x, y);
k0_g = \\ _ = ();
# ******************************************************************************
#
# Part 2: List utility functions
#
# Most of these are needed because of the Gopheresque programming style
# in parts of tk.
package list_util {
fun getx p [] ex => raise exception ex;
getx p (x . xs) ex => if (p x ) x; else getx p xs ex;fi;
end;
fun update_val p y
=
map (\\ x = if (p x ) y; else x; fi);
fun drop_while p [] => [];
drop_while p (xs as (x . xs2)) => if (p x ) drop_while p xs2;
else xs; fi;
end;
# Note this is not the same as list::partition, which runs through
# the whole of the list-- span stops as soon as p x is FALSE.
fun span p []
=>
([], []);
span p (x . xs)
=>
if (p x)
my (ys, zs)
=
span p xs;
(x . ys, zs);
else
([], x . xs);
fi;
end;
fun break p
=
span (not o p);
fun sort (less: (X, X) -> Bool)
=
sort1
where
fun insert (x, [])
=>
[x];
insert (x, y . ys)
=>
if (less (y, x))
y . insert (x, ys);
else
x . y . ys;
fi;
end;
fun sort1 [] => [];
sort1 (x . xs) => insert (x, sort1 xs);
end;
end;
fun prefix [] ys => TRUE;
prefix (x . xs) [] => FALSE;
prefix (x . xs) (y . ys)
=>
(x==y and prefix xs ys);
end;
fun join s [] => [];
join s [t] => t;
join s (t . l)
=>
t @ s @ (join s l);
end;
};
# ******************************************************************************
#
# Part 3: String utility functions.
#
# The "is_*" functions are needed here because SML/NJ 0.93
# doesn't like the literal character syntax.
#
# The other ones are here because they're dead handy.
package string_util {
fun is_dot c = '.' == c;
fun is_comma c = ',' == c;
fun is_linefeed c = '\n' == c;
fun is_open_paren c = '(' == c;
fun is_close_paren c = ')' == c;
fun join s [] => "";
join s [t] => t;
join s (t . l) => t + s + (join s l);
end;
words = string::tokens char::is_space;
# a utility function which splits up a string at the first dot
# from the left, returning the two substrings dropping the dot-- e.g.
# breakAtDot("12.345 bollocks) = ("12", "345 bollocks")
# (Needed quite often because dots are a bit special in Tcl.)
stipulate
include package substring;
herein
fun break_at_dot s
=
{ my (hd, tl)
=
split_off_prefix (not o is_dot) (full s);
(string hd, string (drop_first 1 tl));
};
end;
# Convert string to int, but return 0 if conversion fails
fun to_int s
=
null_or::the_else (int::from_string s, 0)
except
OVERFLOW
=
{ # file__premicrothread::write (file::stderr, "WARNING: caught int conversion overflow\n");
0;
};
# Convert int to string as readable by Tcl-- need - instead of ~
# XXX BUGGO FIXME this should be unneeded once we complete phasing out tilda-as-negation.
fun from_int s
=
if (s < 0 ) ("-" + (int::to_string (int::abs s)));
else int::to_string s; fi;
fun all p str
=
substring::fold_forward
(\\ (c, r)=> (p c) and r; end )
TRUE
(substring::from_string str);
# Adaptstring converts double quotes and other special characters
# into properly escaped sequences, to ensure the string is to
# Tcl's liking:
fun adapt_string s
=
string::translate escape s
where
fun escape c
=
if (char::contains "\"\\$[]{}" c)
"\\" + (str c);
else
if (c == '\n' ) "\\n";
else str c; fi;
fi;
end;
};
# *****************************************************************************
#
# Part 4: File utility functions.
#
# Now that the basis library offers a standardized interface to the OS and
# the file system, we can put these here.
package file_util {
# spawn__premicrothread is from src/lib/std/src/posix/spawn--premicrothread.pkg spawn = spawn__premicrothread::streams_of o spawn__premicrothread::spawn;
exec = sys_dep::exec;
stipulate
include package posix;
herein
fun who_am_i ()
=
process_environment::getlogin () # This doesn't seem to work all the time, e.g. if running inside an emacs.
except
winix__premicrothread::RUNTIME_EXCEPTION _
=
# Do it the hard way :-}
#
system_db::passwd::name (system_db::getpwuid (process_environment::getuid()))
except
winix__premicrothread::RUNTIME_EXCEPTION _ = "???";
end;
fun what_time_is_it ()
=
{ dt= date::from_time_local (time::now ());
(date::to_string dt) + (date::fmt " %Z" dt);
}
except
winix__premicrothread::RUNTIME_EXCEPTION _ = "";
};
};