Patch title: Release 94 bulk changes
Abstract:
File: /pliant/graphic/browser/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/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 BrowserRedraw
    field Int x0 y0 x1 y1

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

  type BrowserWindowHistory
    field Str name
    field Int scroll_x scroll_y

  type BrowserHistory
    field Str url ; field Dictionary context
    field List:BrowserWindowHistory windows

  type BrowserWindow
    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:BrowserRedraw 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 BrowserFocusHistory
    field Pointer:BrowserWindow window
    field Link:LayoutPrototype target
    field Int index

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

  type BrowserSession
    field Dictionary namespace
    # windows
    field Address console_address
    field List:BrowserWindow windows
    field Int position <- 4
    # control
    field Str url ; field Dictionary context
    field Link:Stream connection
    field (List Link:Stream) extra_connections
    field List:BrowserHistory history
    # focus
    field Pointer:BrowserWindow 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:BrowserFocusHistory focus_history
    field Pointer:BrowserWindow 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 BrowserLogin
    field Str user password ; field CBool secured <- false

  type BrowserConsole
    field Link:ConsolePrototype console
    field (Array BrowserSession 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:BrowserSpace spaces
    field Sem sem
    field Int hurry_count <- 0
    field CBool cancelable <- false
    field DateTime last_full_cycle
    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 BrowserLogin) login
    field Str clipboard_text
    field Link:LayoutPrototype clipboard_target
    field Int clipboard_index <- undefined

  method w session -> s
    arg BrowserWindow w ; arg_C BrowserSession s
    s :> w:session_address map BrowserSession

  method s console -> c
    arg BrowserSession s ; arg_C BrowserConsole c
    c :> s:console_address map BrowserConsole

  
function build c
  arg_w BrowserConsole c
  for (var Int i) 0 11
    var Pointer:BrowserSession s :> c:session i
    s console_address := addressof c
    var BrowserWindow 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 BrowserSession s ; arg Str name ; arg_C BrowserWindow w
  each ww s:windows
    if ww:name=name
      w :> ww
      return
  w :> null map BrowserWindow

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

method c canceled -> canceled
  arg BrowserConsole 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:BrowserWindow w
  w :>> (addressof dc:window_address) map Pointer:BrowserWindow

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:BrowserWindow w
  w :>> (addressof ec:window_address) map Pointer:BrowserWindow


method c request_sem
  arg_rw BrowserConsole 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 BrowserWindow w
  w:session:console last_full_cycle := undefined


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


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


public

  type BrowserClientContext
    field Link:Stream connection
    field Pointer:BrowserSession 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 BrowserClientContext c
  c chain :>> null map Link:LayoutPrototype
  c parent :> null map LayoutPrototype
  c current :> null map LayoutPrototype


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


gvar Dictionary browser_client_instructions

named_expression browser_client_instruction_prototype
  function 'pliant browser client instruction function' context
    arg_rw BrowserClientContext context
    implicit context
      body

meta browser_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 browser_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 browser client instruction function") map Function
    e:module rewind mark
    if exists:f
      browser_client_instructions insert e:0:ident true addressof:f
      e set_void_result

export browser_client_instruction browser_client_instructions


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


constant trace true
constant trace2 false

function browser_client_instruction_prototype context fun
  arg_rw BrowserClientContext context ; arg Function fun
  indirect

method c lazy_display fun
  arg_rw BrowserConsole c ; arg Function fun
  indirect

gvar Link:Function real_lazy_display_function

method c process_instruction lock
  arg_rw BrowserClientContext c ; arg CBool lock
  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 :> browser_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
  browser_client_instruction_prototype c (pfun map Function)
  # console "end " (cast instruction Str) eol
  if lock
    var Pointer:BrowserConsole bc :> c:session console
    thread
      bc lazy_display real_lazy_display_function
      bc:sem release
  if trace and c:connection=failure
    console "corrupted instruction '" (cast instruction Str) "'" eol


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


method s history_push
  arg_rw BrowserSession s
  var BrowserHistory h
  h url := s url
  h context := s context
  each w s:windows
    var BrowserWindowHistory 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 BrowserSession s
  var Pointer:BrowserHistory h :> s:history last
  if not exists:h
    return
  s url := h url
  s context := h context
  each wh h:windows
    var Pointer:BrowserWindow 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_lazy_display_function