15.4.1299  src/lib/tk/src/tests+examples/list_box_ex.pkg

# Compiled by:
#     src/lib/tk/src/tests+examples/sources.sublib

package listbox_example

:  api {  go:  Void -> String; }

{
    include package   tk;

    marks = REF (MARK_END, MARK_END);

    main_window_id = make_tagged_window_id "main";

    package warn_window :
    api {
         warn:  String -> Void;
    }
    =
        package {
            warn = make_tagged_window_id "warning";
            nogoon   = make_simple_callback (\\ () => close_window warn; end );
            noaction = make_simple_callback (\\ () => (); end );    

            fun message1 msg yes no
                =
                LABEL {
                    widget_id => make_widget_id(),
                    packing_hints => [FILL ONLY_X, EXPAND TRUE],
                    traits => [TEXT msg, RELIEF FLAT, WIDTH 25],
                    event_callbacks => []
                };
            fun yes_button  msg yes no
                =
                BUTTON {
                    widget_id => make_widget_id(),
                    packing_hints => [PACK_AT LEFT,  FILL ONLY_X, EXPAND TRUE],
                    traits => [TEXT "Ok", CALLBACK yes],
                    event_callbacks => []
                };

            fun yesno   msg yes no
                =
                FRAME {
                    widget_id => make_widget_id(),
                    subwidgets => PACKED [yes_button msg yes no],
                    packing_hints => [],
                    traits => [],
                    event_callbacks => []
                };

            fun tree2   msg yes no
                =
                [message1 msg yes no, yesno msg yes no];

            fun warning_window msg yes no
                =
                make_window {
                    window_id => warn, 
                    traits => [WINDOW_TITLE "Warning"],
                    subwidgets => PACKED (tree2 msg yes no),
                    event_callbacks => [],
                    init=>noaction
                };

            fun warning msg yes no
                =
                open_window (warning_window msg yes no);

            fun warn s
                =
                warning s nogoon noaction;
        };


    do_quit       = make_simple_callback (\\ () = close_window main_window_id);
    do_no_action   = make_simple_callback (\\ () = ());

    list = make_tagged_widget_id "lister";

    fun do_select ()
        = 
        { ms  = get_tcl_selection_range (list);

            cm  = \\ (a, MARK_END) => (a, a);
                        (a, b)       => (a, b); end ;

            sel = \\ [m] => { marks:=m; get_tcl_selected_text (list) (cm (m));};
                        _   => ""; end ;

            se  = sel ms;

           warn_window::warn se;
        }

    also fun lister ()
        =
        LIST_BOX {
            widget_id => list,
            scrollbars => AT_RIGHT_AND_BOTTOM,
            packing_hints => [FILL ONLY_X],
            traits => [RELIEF RIDGE, BORDER_THICKNESS 2],
            event_callbacks => [ EVENT_CALLBACK (
                                    DOUBLE (BUTTON_PRESS (THE 2)),
                                    \\ _=> do_select(); end 
                                )
                              ]
        }

    also fun do_fill ()
        =
        apply (insert_text_end list)
            [   "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
                "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb",
                "cccccccccccccccccccccccccccccccccc"
            ]

    also fun fill_button fill
        =
        BUTTON { widget_id => make_widget_id(),
                 packing_hints => [PACK_AT LEFT, FILL ONLY_X, EXPAND TRUE],
                 traits  => [TEXT "Fill", CALLBACK (make_simple_callback (fill))],
                 event_callbacks => []
        }

    also fun filler ()
        =
        FRAME { widget_id => make_widget_id(),
                subwidgets => PACKED [fill_button do_fill],
                packing_hints => [FILL ONLY_X],
                traits => [RELIEF RIDGE, BORDER_THICKNESS 2],
                event_callbacks => []
        }

    also fun get_button fill
        =
        BUTTON {
            widget_id => make_widget_id(),
            packing_hints => [PACK_AT LEFT, FILL ONLY_X, EXPAND TRUE],
            traits => [TEXT "Select", CALLBACK (make_simple_callback (fill))],
            event_callbacks => []
        }

    also fun selector ()
        =
        FRAME {
            widget_id => make_widget_id(),
            subwidgets  => PACKED [get_button do_select],
            packing_hints => [FILL ONLY_X],
            traits  => [RELIEF RIDGE, BORDER_THICKNESS 2],
            event_callbacks => []
        }


    also fun quit_button quit
        =
        BUTTON {
            widget_id => make_widget_id(),
            packing_hints => [PACK_AT LEFT, FILL ONLY_X, EXPAND TRUE],
            traits  => [TEXT "Quit", CALLBACK (quit)],
            event_callbacks => []
        }

    also fun quitter ()
        =
        FRAME {
            widget_id => make_widget_id(),
            subwidgets => PACKED [quit_button do_quit],
            packing_hints => [FILL ONLY_X],
            traits  => [RELIEF RIDGE, BORDER_THICKNESS 2],
            event_callbacks => []
        };

    initwin
        =
        [   make_window {
               window_id   => main_window_id, 
               traits  => [WINDOW_TITLE "ListBox Example"],
               subwidgets => PACKED [lister(), filler(), selector(), quitter()],
               event_callbacks => [],
               init => do_no_action
            }
        ];

    go
        =
        \\ ()   =>   start_tcl_and_trap_tcl_exceptions initwin; end ;


};