PreviousUpNext

15.4.1338  src/lib/tk/src/toolkit/util_window.pkg

## util_window.pkg
## (C) 1997, 1998, Bremen Institute for Safe Systems, Universitaet Bremen
## Author: cxl

# Compiled by:
#     src/lib/tk/src/toolkit/sources.sublib



# *************************************************************************
#  Windows for errors, warnings, user confirmation and text entry. 
#
#  A better version of util_window.pkg
# *************************************************************************



###                       "It is wrong always, everywhere, and for anyone,
###                        to believe anything upon insufficient evidence."
###
###                                            -- William Kingdon Clifford 



package uw: (weak)  Util_Window         # Util_Window   is from   src/lib/tk/src/toolkit/util_window.api

{

    include package   tk;
    include package   basic_utilities;

    #  -- Configuration section ------------------------------------------- 

    #  Width (in pixels) and font for error, warning and confirmation wins 
                                                                                my
    msg_font      = NORMAL_FONT [];                                              my
    msg_width     = 180;                                                         my
    button_relief = RAISED;                                                      my
    button_width  = 5;                                                           my
    button_font   = SANS_SERIF [];          

    fun error_icon_filenm ()
         =
         winix__premicrothread::path::cat (tk::get_lib_path(),     "images/stop.gif");
    fun warning_icon_filenm ()
         =
         winix__premicrothread::path::cat (tk::get_lib_path(),     "images/warning.gif");

    fun info_icon_filenm ()
         =
         winix__premicrothread::path::cat (tk::get_lib_path(),     "images/info.gif");
                                                                                my
    info_time_out
         =
         10; #  Info windows stay up at least this long 
                                                                                my
    enter_text_font
        =
        TYPEWRITER [LARGE];

     #  -- End of configuration section ------------------------------------ 

     fun errwrnwidgs (iconpath, msg, cc)
         = 
         [   LABEL {
                 widget_id       => make_widget_id (),
                 packing_hints   => [PACK_AT LEFT, FILL ONLY_Y],
                 traits          => [ICON (FILE_IMAGE (iconpath, make_image_id()))], 
                 event_callbacks => []
             },

             FRAME {
                 widget_id       => make_widget_id(),
                 packing_hints   => [PACK_AT TOP, FILL XY], 
                 event_callbacks => [],
                 traits          => [],
                 subwidgets      => PACKED [
                                       MESSAGE {
                                           widget_id     => make_widget_id (),
                                           packing_hints => [   PAD_X 20,
                                                               PAD_Y 20, 
                                                               PACK_AT TOP,
                                                               FILL ONLY_X
                                                           ],
                                           traits => [   TEXT msg,
                                                        WIDTH msg_width, 
                                                        FONT msg_font
                                                    ],
                                           event_callbacks => []
                                       },

                                       BUTTON {
                                           widget_id       => make_widget_id(),
                                           packing_hints   => [PACK_AT RIGHT],
                                           event_callbacks => [],
                                           traits          => [   TEXT "Continue",
                                                                 CALLBACK cc,
                                                                 RELIEF button_relief,
                                                                 WIDTH button_width,
                                                                 FONT button_font
                                                             ]
                                       }
                                   ]
             }
         ];

    fun errwrnwin (title, iconpath, msg, cc)
        =
        {   wid = make_window_id ();

            fun close ()
                =
                {   close_window wid;
                    cc()
                ;};

            make_window {
                window_id    => wid, 
                traits   => [WINDOW_TITLE title, TRANSIENTS_LEADER NULL], 
                subwidgets  => PACKED (errwrnwidgs (iconpath, msg, close)), 
                event_callbacks => [],
                init     => null_callback
            };
        };


    fun error   msg
        =
        open_window (errwrnwin("Error Message",
                                            error_icon_filenm(), msg, k0));
                                  
    fun warning msg = open_window (errwrnwin("Warning Message",
                                            warning_icon_filenm(), msg, k0));

    fun error_cc (msg, cc)   = open_window (errwrnwin("Error Message",
                                            error_icon_filenm(), msg, cc));
                                  
    fun warning_cc (msg, cc) = open_window (errwrnwin("Warning Message",
                                            warning_icon_filenm(), msg, cc));



    #  --- Confirmation [ OK ]  [ Cancel ] -------------------------------- 

                                                                                my
    button_conf
        =
        [   WIDTH  button_width,
            RELIEF button_relief,
            FONT   button_font
        ];

    fun ok_cancel_buttons (window, fate)
        =
        {   fun cc () = { close_window window; fate();};
            fun no () = (close_window window);

            FRAME {
                widget_id        => make_widget_id (), 
                packing_hints   => [PACK_AT BOTTOM, FILL ONLY_X],
                traits          => [],
                event_callbacks => [],
                subwidgets => PACKED [
                                 BUTTON {
                                     widget_id     => make_widget_id(),
                                     packing_hints => [   PAD_X 10,
                                                         PAD_Y 15,
                                                         PACK_AT LEFT
                                                     ],
                                     traits        => [   TEXT "Cancel",
                                                         CALLBACK no]@
                                                         button_conf, 
                                                         event_callbacks => []
                                 },
                                 BUTTON {
                                     widget_id       => make_widget_id (),
                                     packing_hints   => [   PAD_X 10,
                                                           PAD_Y 15,
                                                           PACK_AT RIGHT
                                                       ], 
                                     traits          => [TEXT "OK", CALLBACK cc] @ button_conf, 
                                     event_callbacks => []
                                 }
                             ]
            };
        };


    fun confirm (msg, cc)
        =
        {
            window = make_window_id();

            pic = LABEL {
                      widget_id => make_widget_id(), 
                      packing_hints=> [PACK_AT LEFT, FILL ONLY_Y],
                      traits=> [ICON (FILE_IMAGE (warning_icon_filenm(),
                                                      make_image_id()))], 
                      event_callbacks=> []
                  };

            msg = MESSAGE {
                     widget_id => make_widget_id (),
                     packing_hints => [PACK_AT TOP, FILL XY],
                     traits => [TEXT msg, WIDTH msg_width, FONT msg_font],
                     event_callbacks => []
                  };


            frm = FRAME {
                      widget_id => make_widget_id (),
                            subwidgets=> PACKED [msg, ok_cancel_buttons (window, cc)], 
                            packing_hints=> [PACK_AT TOP, FILL ONLY_X, EXPAND TRUE], 
                            traits=> [], event_callbacks=> [] };

            open_window (make_window { window_id    => window, 
                                traits   =>[WINDOW_TITLE "Please Confirm Or Abort",
                                           TRANSIENTS_LEADER NULL], 
                                subwidgets  => PACKED [pic, frm], 
                                event_callbacks => [],
                                init     => null_callback } );
        };

    #  --- display a text -------------------------------------------------- 


    fun disp_window (winid, title, cc, disp_widg)
        =
        {   fun quit_but window
                =
                FRAME {
                    widget_id=> make_widget_id(),
                    subwidgets => PACKED [
                                     BUTTON { widget_id=> make_widget_id(), 
                                           packing_hints=> [PACK_AT RIGHT, 
                                                      PAD_X 10, PAD_Y 10],
                                           traits=> [TEXT "Close", 
                                            CALLBACK (\\ () = close_window window)]@
                                           (button_conf), 
                                           event_callbacks=> [] } ],
                    packing_hints=> [PACK_AT BOTTOM, FILL ONLY_X], 
                    event_callbacks=> [], traits=> []
                };

            winid
            then 
                open_window (make_window { window_id    => winid, 
                                    traits   => [WINDOW_TITLE title], 
                                    subwidgets  => PACKED [quit_but winid, disp_widg],
                                    event_callbacks => [],
                                    init     => \\ ()=> cc (get_widget_id disp_widg); end  } );
        };


    fun display' { window_id, widget_id, title, width, height, text, cc }
        = 
        #  Add scroll button if text is longer than height 

        # !! This doesn't quite work, since it doesn't take into account
        # line wrapping-- hence disabled  XXX BUGGO FIXME

        {   scb = if (.rows (get_livetext_rows_cols text)
                     >=
                     height
                  )
                       AT_LEFT; 
                  else NOWHERE;fi ;

           ignore (disp_window (window_id, title, cc, 
                            TEXT_WIDGET { widget_id=> widget_id, 
                                    scrollbars=> AT_RIGHT, live_text=> text,
                                    packing_hints=> [PACK_AT TOP, FILL XY, 
                                               EXPAND TRUE], 
                                    traits=> [ACTIVE FALSE, 
                                              BORDER_THICKNESS 1, WIDTH width,
                                              HEIGHT height], 
                                    event_callbacks=> [] } ));
        };

    fun display_id { window_id, widget_id, title, width, height, text }
        = 
        display'{ window_id=> window_id, widget_id=> widget_id, title, width, 
                 height, text, cc=> \\ _ = ()  };

    fun display { title, width, height, text, cc }
        = 
        display' {
            window_id => make_window_id (),
            widget_id => make_widget_id (),
            title, 
            width,
            height,
            text,
            cc=> cc
        };
        

    #  --- informative messages -------------------------------------------- 


    fun infofrm msg
        =
        {   pic =   LABEL { widget_id=> make_widget_id(), 
                            packing_hints=> [PACK_AT LEFT, FILL ONLY_Y, EXPAND TRUE,
                                       PAD_X 10, PAD_Y 10],
                            traits=> [ICON (FILE_IMAGE (info_icon_filenm(),
                                                      make_image_id()))],
                            event_callbacks => []
                          };

            w     = if (string::size msg < 80 ) [WIDTH 100]; else []; fi;

            FRAME { widget_id=> make_widget_id(),
                  subwidgets=> PACKED [pic, 
                                 MESSAGE { widget_id=> make_widget_id(), 
                                         packing_hints=> [PACK_AT TOP, FILL XY, 
                                                    EXPAND TRUE],
                                         traits => w @ [TEXT msg, FONT msg_font],
                                         event_callbacks => [] } ], 
                  traits=> [], event_callbacks=> [], packing_hints=> [] };
        };

    fun info_cc msg
        =
        {   frm = infofrm msg;
            w   = make_window_id ();

            # to make sure the info message stays on
            # for at least timeout seconds: start timer...

            owt =   timer::start_real_timer ();

            open_window (
                make_window {
                    window_id    => w, 
                    traits   => [WINDOW_TITLE "Information"], 
                    subwidgets  => PACKED [frm],
                    event_callbacks => [],
                    init     => null_callback
                }
            );

            \\ ()
                =
                if (is_open w)

                      # Window is still up; check if
                      # it stayed up long enough:
                      # 
                      elapsd  = timer::check_real_timer owt;
                      timeout = time::from_seconds (int::to_large info_time_out);

                      if  (time::(<) (elapsd, timeout))

                          ignore (posix::sleep
                              (time::(-) (timeout, elapsd)));
                      fi;

                      close_window w;

                fi;
        };

    fun info msg
        =
        {
            frm = infofrm msg;

            ignore (
                disp_window (
                    make_window_id (),
                    "Information",
                    \\ _=> (); end ,
                    frm
                )
            );
        };

   #  ---- enter windows ------------------------------------ 
 
   fun buttons (window, twids, fate)
       = 
       # This and OkCancelButtons above are remarkably similar, but
       # I don't know how to implement this in terms of OkCancelButtons:

       {   fun cc ()
               =
               {   txts = map get_tcl_text twids;

                   close_window window;
                   fate txts;
               };

           fun no ()
               =
               close_window window;

           FRAME {
               widget_id => make_widget_id(), 
               subwidgets => PACKED
                          [ BUTTON { widget_id=> make_widget_id(), 
                                  packing_hints=> [PACK_AT LEFT, PAD_X 5, PAD_Y 5], 
                                  traits=> [TEXT "Cancel", CALLBACK no]@button_conf, 
                                  event_callbacks=> [] },
                           BUTTON { widget_id=> make_widget_id(),
                                  packing_hints=> [PACK_AT RIGHT, PAD_X 5, PAD_Y 5], 
                                  traits=> [TEXT "OK", CALLBACK cc]@button_conf,
                                  event_callbacks=> [] } ],
                 packing_hints=> [PACK_AT BOTTOM, FILL ONLY_X], event_callbacks=> [], traits=> [] };
       };
           
   fun enter_text0 {
           title,
           prompt,
           default,
           widgetsbelow,
           width, 
           heights,
           headers,
           cc
       }
       = 
       {   window     = make_window_id ();
           twids   = list::from_fn (length heights, \\ _ => make_widget_id(); end );

           # Make sure there's enough headers:

           hds     = headers @ list::from_fn (length heights,
                                                 \\ _ => ""; end );

           prmpt   = LABEL {
                         widget_id => make_widget_id(),
                         packing_hints => [PACK_AT TOP, FILL ONLY_X, EXPAND TRUE], 
                         traits => [TEXT prompt, WIDTH width],
                         event_callbacks => []
                     };

           fun ewtxt ((w, h), p)
               = 
               {
                  tw = TEXT_WIDGET {
                           widget_id       => w,
                           scrollbars      => AT_RIGHT, 
                           live_text        => string_to_livetext default,
                           packing_hints   => [PACK_AT TOP, EXPAND TRUE],
                           event_callbacks => [],
                           traits => [RELIEF RAISED, BORDER_THICKNESS 2, 
                                             WIDTH width, HEIGHT h,
                                             FONT enter_text_font]
                       };

                   if (p == "")
                       [tw];
                   else
                       [ LABEL { widget_id=> make_widget_id(),
                                    packing_hints=> [PACK_AT TOP, EXPAND TRUE, FILL ONLY_X],
                                    traits=> [TEXT p], event_callbacks=> [] }, tw];
                   fi;
               };

           txwdgs   = list::cat (paired_lists::map ewtxt 
                                       (paired_lists::zip (twids, list::reverse heights), 
                                        hds));

           bws      = FRAME {
                          widget_id => make_widget_id(),
                          subwidgets =>  PACKED (
                                          buttons (window, twids, cc) .
                                          (map (\\ w=> update_widget_packing_hints w 
                                                [PACK_AT TOP]; end ) widgetsbelow)),
                          packing_hints => [PACK_AT BOTTOM, FILL ONLY_X, EXPAND TRUE],
                          traits => [], event_callbacks=> []
                      };

           fun init ()
               =
               ();

           open_window (
               make_window {
                   window_id    => window, 
                   traits   => [WINDOW_TITLE title], 
                   subwidgets  => PACKED ([bws, prmpt]@txwdgs),
                   event_callbacks => [],
                   init
               }
           );
       };

   #  Convert function on singleton lists of strings to function on strings 
   fun list2s cc (t . _)=> cc t; 
      list2s cc _     => cc ""; end;

   fun enter_text { title, prompt, default, height, width, cc }
       =
       enter_text0 { title, prompt, default, 
                  widgetsbelow => [], heights => [height], headers => [""],
                  width, cc => list2s cc
       };


   fun enter_line { title, prompt, default, width, cc }
       =
       {
           window   = make_window_id ();
           twid  = make_widget_id ();

           w_here = size prompt   >   width * 2
                    ?? [PACK_AT LEFT, FILL ONLY_Y, EXPAND TRUE]
                    :: [PACK_AT TOP,  FILL ONLY_X, EXPAND TRUE];

           prmpt = LABEL {
                       widget_id => make_widget_id(),
                       packing_hints => w_here, event_callbacks=> [],
                       traits => [TEXT prompt]
                   };

           entln = TEXT_ENTRY {
                       widget_id     => twid,
                       packing_hints => [PACK_AT LEFT], 

                       traits        => [   RELIEF RIDGE,
                                           WIDTH width, 
                                           BORDER_THICKNESS 2,
                                           FONT enter_text_font
                                       ],

                       event_callbacks => [   EVENT_CALLBACK (
                                                 KEY_PRESS("Return"),
                                                 \\ _ => {   txt= get_tcl_text twid;
                                                             { close_window window; 
                                                              cc txt;};
                                                         }; end 
                                             )
                                         ]
                   };

           open_window (
               make_window {
                   window_id => window,
                   traits => [WINDOW_TITLE title],
                   subwidgets => PACKED [
                                 FRAME {
                                     widget_id => make_widget_id(),
                                     subwidgets => PACKED [prmpt, entln], 
                                     packing_hints => [PACK_AT TOP, FILL ONLY_X],
                                     traits => [],
                                     event_callbacks => []
                                 },
                                 buttons (window, [twid],
                                                        list2s cc)
                             ],
                   event_callbacks =>  [],
                   init            =>  \\ _ = insert_text
                                                   twid default (MARK (1, 0))
               }
           );
       };
};


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext