PreviousUpNext

15.4.1369  src/lib/x-kit/widget/fancy/graphviz/text/ml-source-code-viewer.pkg

# ml-source-code-viewer.pkg
#
# This is a ML source code viewer, which is a test application for
# the new text widget.

# Compiled by:
#     src/lib/x-kit/widget/xkit-widget.sublib

stipulate
    include threadkit;                                                  # threadkit             is from   src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg
    #
    package xg =  xgeometry;                                            # xgeometry             is from   src/lib/std/2d/xgeometry.pkg
    #
    package xc =  xclient;                                              # xclient               is from   src/lib/x-kit/xclient/xclient.pkg
    #
    package wg =  widget;                                               # widget                is from   src/lib/x-kit/widget/basic/widget.pkg
    #
    package vb =  view_buffer;                                          # view_buffer           is from   src/lib/x-kit/widget/fancy/graphviz/text/view-buffer.pkg
    package td =  text_display;                                         # text_display          is from   src/lib/x-kit/widget/fancy/graphviz/text/text-display.pkg
    package tc =  text_canvas;                                          # text_canvas           is from   src/lib/x-kit/widget/fancy/graphviz/text/text-canvas.pkg
herein

    package ml_source_code_viewer:  Ml_Source_Code_Viewer {             # Ml_Source_Code_Viewer is from   src/lib/x-kit/widget/fancy/graphviz/text/ml-source-code-viewer.api

        Plea_Mail
          #
          = SCROLL_MSG Int
          #
          | VIEW_MSG
                Oneshot_Maildrop
                  { view_start:  Int,
                    view_ht:     Int,
                    nlines:      Int
                  };


        Viewer
            =
            VIEWER
              { widget:        wg::Widget,
                text_display:  Oneshot_Maildrop( td::Text_Display ),
                plea_slot:     Mailslot( Plea_Mail )
              };

        Face = FACE { font:   Null_Or( xc::Font ),
                      color:  Null_Or( xc::Color_Spec )
                    };

        fun make_viewer
            root_window
            {
              src,
              font,
              comm_face,
              kw_face,
              sym_face,
              id_face,
              background
            }
            =
            VIEWER {
                text_display =>  oneshot,
                plea_slot =>  plea_slot,

                widget
                    =>
                    wg::make_widget
                      {
                        args         =>  (fn ()  = {   background => NULL }),   # Added 2009-12-28 CrT just to get it to compile
                        root_window,
                        realize,

                        size_preference_thunk_of
                            =>
                            fn () = { col_preference =>  wg::INT_PREFERENCE { start_at=>0, step_by=>1, min_steps=>10, ideal_steps=>80*char_width,  max_steps=>NULL },
                                      row_preference =>  wg::INT_PREFERENCE { start_at=>0, step_by=>1, min_steps=>20, ideal_steps=>24*line_high,   max_steps=>NULL }
                                    }
                      }
            }
            where
                oneshot = make_oneshot_maildrop ();

                plea_slot = make_mailslot ();

                (xc::font_high  font)
                    ->
                    { ascent, descent };

                line_high  =  ascent + descent;

                char_width =  xc::text_width  font  "m";

                fun realize { kidplug, window, window_size as xg::SIZE { high, ... }}
                    =
                    {   put_in_oneshot  (oneshot, text_display);

    #               x_debug::make_thread  "viewer::server"  server;

                        ();
                    }
                    where

                        canvas
                            =
                            tc::make_text_canvas
                              {
                                window,
                                size => window_size,
                                font,
                                foreground => NULL,
                                background => (THE background)
                              };

                        fun make_tb (FACE { font, color } )
                            =
                            {   fun mk traits
                                    =
                                    tc::make_typeball (canvas, traits);

                                case (font, color)
                                    #
                                    (NULL,  NULL ) =>  mk [];
                                    (THE f, NULL ) =>  mk [tc::TBV_FONT f];
                                    (NULL,  THE c) =>  mk [tc::TBV_FOREGROUND c];
                                    (THE f, THE c) =>  mk [tc::TBV_FONT f, tc::TBV_FOREGROUND c];
                                esac;
                            };

                        pool = vb::make_view_buffer
                                 {
                                   src,
                                   nrows => high % line_high,
                                   font,
                                   char_width,
                                   ascent,
                                   descent,
                                   line_high,
                                   #
                                   fill_tb    => tc::make_typeball (canvas, [tc::TBV_FOREGROUND background]),
                                   #
                                   comment_tb =>  make_tb  comm_face,
                                   keyword_tb =>  make_tb  kw_face,
                                   symbol_tb  =>  make_tb  sym_face,
                                   ident_tb   =>  make_tb  id_face
                                 };

                        text_display
                            =
                            td::make_text_display { canvas, text => pool, size => window_size };

                        redraw =  td::redraw  text_display;

                        scroll_up   =  td::scroll_up   text_display;
                        scroll_down =  td::scroll_down text_display;

                        # Clear and fill in the region
                        # vacated by a scroll operation: 
                        #
                        fun fill_in { vacated, damage }
                            =
                            {   td::clear_box  text_display  vacated;
                                #
                                redraw  (vacated  !  (block_until_mailop_fires  damage));
                            };


                        my xc::KIDPLUG { from_other', ... }
                            =
                            xc::ignore_mouse_and_keyboard  kidplug;


                        fun do_mom  envelope
                            =
                            case (xc::envelope_contents  envelope)
                                #
                                xc::ETC_REDRAW  damage
                                    =>
                                    redraw damage;

                                xc::ETC_RESIZE (xg::BOX { wide, high, ... } )
                                    =>
                                    td::resize (text_display, xg::SIZE { wide, high } );

                                xc::ETC_OWN_DEATH
                                    =>
                                    {   # v_debug::pr ["viewer::die\n"];
                                        shut_down_thread_scheduler  winix__premicrothread::process::success;
                                    };

                                _   => ();
                            esac;


                        fun do_plea (VIEW_MSG reply_oneshot)
                                =>
                                put_in_oneshot  (reply_oneshot, vb::get_view pool);

                            do_plea (SCROLL_MSG new_top)
                                =>
                                {   (vb::get_view  pool)
                                        ->
                                        { view_start, view_ht, nlines };

                                    vb::set_view_top (pool, new_top);

                                    (vb::get_view  pool)
                                        ->
                                        { view_start => new_top, ... };

                                    if (new_top != view_start)

                                        # Scroll needed:

                                        delta = new_top - view_start;


                                        my xg::SIZE { wide, high }
                                            =
                                            td::size_of  text_display;


                                        if (abs delta >= view_ht)

                                            tc::clear canvas;

                                            redraw [xg::BOX { col=>0, row=>0, wide, high } ];

                                        elif (delta < 0)

                                           fill_in (scroll_down -delta);

                                        else

                                           fill_in (scroll_up    delta);
                                        fi;
                                    fi;
                              };
                        end;


                        fun server ()
                            =
                            for (;;) {
                                #
                                do_one_mailop [
                                    #
                                    from_other'
                                        ==>
                                        do_mom,

                                    take_from_mailslot'  plea_slot
                                        ==>
                                        do_plea
                                ];
                            };
                      end;
            end;                                        # fun make_viewer


        fun as_widget (VIEWER { widget, ... } )
            =
            widget;


        fun view_of (VIEWER { plea_slot, ... } )
            =
            {   oneshot =  make_oneshot_maildrop ();
                #
                put_in_mailslot (plea_slot, VIEW_MSG oneshot);

                take_from_oneshot  oneshot;
            };

        fun scroll_view (VIEWER { plea_slot, ... }, new_top)
            =
            put_in_mailslot (plea_slot, SCROLL_MSG new_top);

    };                          # package viewer 

end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext