Patch title: Release 96 bulk changes
Abstract:
File: /pliant/graphic/ui/client/context.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"
module "/pliant/language/stream.pli"
module "/pliant/util/pml/io.pli"
module "/pliant/language/type/misc/blob.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/color/rgb888.pli"
module "/pliant/graphic/image/prototype.pli"
module "/pliant/graphic/layout/prototype.pli"
module "/pliant/graphic/layout/text1.pli"
module "/pliant/graphic/console/prototype.pli"


public

  type UIRedraw
    field Int x0 y0 x1 y1

  type UISpace
    field Int x0 y0 x1 y1 ; field LayoutColor color

  type UIWindowHistory
    field Str name
    field Int scroll_x scroll_y

  type UIHistory
    field Str url ; field Dictionary context
    field List:UIWindowHistory windows

  type UIWindow
    field Str name
    field Address session_address
    field Link:LayoutPrototype root overlay
    field LayoutArea bbox
    field Int scroll_x scroll_y <- 0
    field Int x0 y0 x1 y1 <- undefined # visible area in the window or on the screen
    field CBool refresh
    field CBool orefresh
    field List:UIRedraw redraw
    # styling
    field Int antialiasing <- 4
    field Float fraction <- 0.25
    field Int padding_size <- 5
    field LayoutColor padding_color <- (color rgb 255 255 255)
  
  type UIFocusHistory
    field Pointer:UIWindow window
    field Link:LayoutPrototype target
    field Int index

  type UIEvent
    field Str id event key ; field Int buttons ; field Float x y ; field Str options ; field Pointer:UIWindow window

  type UISession
    field Dictionary namespace
    # windows
    field Address console_address
    field List:UIWindow windows
    field Int position <- 4
    # control
    field Str url ; field Dictionary context
    field Link:Stream connection
    field (List Link:Stream) extra_connections
    field List:UIHistory history
    field CBool rejected <- false
    field CBool unknown <- false
    # focus
    field Pointer:UIWindow focus_window
    field Link:LayoutPrototype focus_target
    field Int focus_index
    field Str focus_value
    field Int focus_scroll_stage
    field Int focus_scroll_x focus_scroll_y
    field List:UIFocusHistory focus_history
    field Pointer:UIWindow over_window
    field Link:LayoutPrototype over_target
    # shortcuts
    field (Dictionary Str Link:LayoutPrototype) keys
    # styling
    field Int border_size <- 1
    field LayoutColor border_color <- (color rgb 192 192 192)
    field LayoutColor border_active_color <- (color rgb 128 128 128)

  type UILogin
    field Str user password ; field CBool secured <- false

  type UIConsole
    field Link:ConsolePrototype console
    field (Array UISession 12) session
    field Array:Int zorder
    field Int size_x size_y # screen or OS window size
    field Float unit_x unit_y # pixel size is mm
    field Float middle_x middle_y <- 0.5
    field Link:ColorGamut gamut
    field CBool brefresh <- true
    field List:UISpace spaces
    field Sem sem
    field Int hurry_count <- 0
    field CBool cancelable <- false
    field DateTime last_successfull_redraw
    field Float force_after <- 15 # seconds
    field Link:LayoutStyle default_style
    field Dictionary fonts
    field Str font_server
    field Link:Stream font_stream
    field (Dictionary Str UILogin) login
    field Link:Stream clipboard_connection
    field Sem clipboard_sem
    field Blob clipboard_content
    field Link:LayoutPrototype clipboard_target
    field Int clipboard_index
    field CBool lazy_display_flag <- false
    field CBool ack_flag <- false

  method w session -> s
    arg UIWindow w ; arg_C UISession s
    s :> w:session_address map UISession

  method s console -> c
    arg UISession s ; arg_C UIConsole c
    c :> s:console_address map UIConsole

  
function build c
  arg_w UIConsole c
  for (var Int i) 0 11
    var Pointer:UISession s :> c:session i
    s console_address := addressof c
    var UIWindow w ; w session_address := addressof s
    w name := "main" ; w padding_color := color rgb 248 248 248 ; s windows += w
    w name := "top" ; w padding_color := color rgb 240 240 240 ; s windows += w
    w name := "bottom" ; w padding_color := color rgb 240 240 240 ; s windows += w
    w name := "left" ; w padding_color := color rgb 240 240 240 ; s windows += w
    w name := "right" ; w padding_color := color rgb 224 224 224 ; s windows += w
    c zorder += i


method s window name -> w
  arg UISession s ; arg Str name ; arg_C UIWindow w
  each ww s:windows
    if ww:name=name
      w :> ww
      return
  w :> null map UIWindow

method pc window -> w
  arg LayoutPC pc ; arg_C Pointer:UIWindow w
  w :>> (addressof pc:window_address) map Pointer:UIWindow

method c canceled -> canceled
  arg UIConsole c ; arg CBool canceled
  canceled := c:hurry_count>0 and c:cancelable

method pc canceled -> c
  arg LayoutPC pc ; arg CBool c
  c := pc:window:session:console canceled

method dc window -> w
  arg LayoutDC dc ; arg_C Pointer:UIWindow w
  w :>> (addressof dc:window_address) map Pointer:UIWindow

method dc canceled -> c
  arg LayoutDC dc ; arg CBool c
  c := dc:window:session:console canceled

method ec window -> w
  arg LayoutEC ec ; arg_C Pointer:UIWindow w
  w :>> (addressof ec:window_address) map Pointer:UIWindow


method c request_sem
  arg_rw UIConsole c
  var CBool cancel := true # c:last_full_cycle=defined and datetime:seconds-c:last_full_cycle:seconds<c:force_after
  if cancel
    atomic_add c:hurry_count 1
  c:sem request
  if cancel
    atomic_add c:hurry_count -1
   

method w redraw_hurry
  arg_rw UIWindow w
  w:session:console last_successfull_redraw := undefined


export '. window' '. canceled' '. request_sem' '. redraw_hurry'


#-------------------------------------------------------------------------------


public

  type UIClientContext
    field Link:Stream connection
    field Pointer:UISession session
    field CBool eos
    field CBool extra_thread <- false
    #
    field Pointer:LayoutPrototype parent
    field (Pointer Link:LayoutPrototype) chain
    field Pointer:LayoutPrototype current

function build c
  arg_w UIClientContext c
  c chain :>> null map Link:LayoutPrototype
  c parent :> null map LayoutPrototype
  c current :> null map LayoutPrototype


#-------------------------------------------------------------------------------


gvar Dictionary ui_client_instructions

named_expression ui_client_instruction_prototype
  function 'pliant ui client instruction function' context
    arg_rw UIClientContext context
    implicit context
      body

meta ui_client_instruction e
  if e:size>=2 and e:0:is_pure_ident and (e e:size-1):ident="{}"
    var Address mark := e:module mark
    var Link:Expression ee :> expression duplicate ui_client_instruction_prototype substitute parameters (e 1 e:size-2) substitute body (e e:size-1) substitute instruction (expression constant e:0:ident near e:0) near e
    error_push_record (var ErrorRecord er) error_filter_all
    ee compile
    if er:id<>error_id_noerror
      console er:message eol
      er id := error_id_noerror
      e suckup_error ee
    error_pull_record er
    var Link:Function f :> (pliant_general_dictionary first "pliant ui client instruction function") map Function
    e:module rewind mark
    if exists:f
      ui_client_instructions insert e:0:ident true addressof:f
      e set_void_result

export ui_client_instruction ui_client_instructions


#-------------------------------------------------------------------------------


constant trace true
constant trace2 false

function ui_client_instruction_prototype context fun
  arg_rw UIClientContext context ; arg Function fun
  indirect

method c attempt_redraw_now fun
  arg_rw UIConsole c ; arg Function fun
  indirect

gvar Link:Function real_attempt_redraw_now_function

method c process_instruction lock
  arg_rw UIClientContext c ; arg CBool lock
  has_side_effects
  if not (c:connection ipick open (var Ident instruction))
    if trace and not c:extra_thread
      console "broken connection" eol
    c:connection error "corrupted connection"
    return
  var Pointer:Arrow pfun :> ui_client_instructions first (cast instruction Str)
  if pfun=null
    if trace
      console "unsupported instruction '" (cast instruction Str) "'" eol
    c:connection error "unsupported instruction '"+(cast instruction Str)+"'"
    return
  if trace2
    console "process instruction " (cast instruction Str) eol
  if lock
    c:session:console request_sem
  # console "begin " (cast instruction Str) eol
  ui_client_instruction_prototype c (pfun map Function)
  # console "end " (cast instruction Str) eol
  if lock
    if c:eos
      c:session:console:sem release
    else
      var Pointer:UIConsole bc :> c:session console
      thread
        bc attempt_redraw_now real_attempt_redraw_now_function
        bc:sem release
  if trace and c:connection=failure
    console "corrupted instruction '" (cast instruction Str) "'" eol


method c ierror msg
  arg_rw UIClientContext c ; arg Str msg
  if c:connection=success
    if trace
      console msg eol
    c:connection error msg


method s history_push
  arg_rw UISession s
  var UIHistory h
  h url := s url
  h context := s context
  each w s:windows
    var UIWindowHistory wh
    wh name := w name
    wh scroll_x := w scroll_x
    wh scroll_y := w scroll_y
    h windows += wh
  s history += h

method s history_pull
  arg_rw UISession s
  var Pointer:UIHistory h :> s:history last
  if not exists:h
    return
  s url := h url
  s context := h context
  each wh h:windows
    var Pointer:UIWindow w :> s window wh:name
    w scroll_x := wh scroll_x
    w scroll_y := wh scroll_y
  s:history remove h


export '. process_instruction'
export '. ierror'
export '. history_push' '. history_pull'

export real_attempt_redraw_now_function