PreviousUpNext

15.4.1240  src/lib/tk/src/basic_util.pkg

#  **************************************************************************

#  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)
        =
        fn (y, x) =  f (x, y);

    k0_g =  fn _ =  ();

# ******************************************************************************
#
# 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  (fn 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 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
                (fn (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 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 _ = "";

    };
};










Comments and suggestions to: bugs@mythryl.org

PreviousUpNext