Patch title: Release 93 bulk changes
Abstract:
File: /graphic/browser/server.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/language/parser.pli"
module "/pliant/language/stream.pli"
submodule "/pliant/protocol/common/tcp_server.pli"
submodule "document.pli"


# context pre defined options:
# language = prefered language (an example could be 'fr')
# skill = user skill can be 'low' 'medium' or 'high'
# bps = connection speed
# latency = time to send or receive a packet (in seconds)
# memory = number of bytes of memory available to the browser
# frequency = browser CPU frequency in hz equivalence to i386 architecture
# screen mm_x mm_y size_x size_y = screen size and resolution
# antialiasing = default browser antialiasing


type BrowserConnection
  field Link:Stream stream
  field Link:BrowserDocument document
  field Str event key ; field Int buttons ; field Float x y
  field Str hook_id ; field Float hook_x0 hook_y0 hook_x1 hook_y1
  field Str target_id ; field Float target_x0 target_y0 target_x1 target_y1 ; field Int target_index
  field Str context

export '. stream' '. document'
export '. event' '. key' '. buttons' '. x' '. y'
export '. hook_id' '. hook_x0' '. hook_y0' '. hook_x1' '. hook_y1'
export '. target_id' '. target_x0' '. target_y0' '. target_x1' '. target_y1' '. target_index'


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


type BrowserAttribute
  field Str name
  field Link:Type type

type BrowserTag
  field Str name
  field Dictionary attributes
  field Array:Str required
  field CBool body <- false


method c create tag
  arg_rw BrowserConnection c ; arg Str tag
  c:stream writeline "l "+string:tag

method c create_open tag parent
  arg_rw BrowserConnection c ; arg Str tag ; arg_w Str parent
  c:stream writeline "o "+string:tag

method c create_close parent
  arg_rw BrowserConnection c ; arg Str parent
  c:stream writeline "c"

method c attribute attr value
  arg_rw BrowserConnection c ; arg Str attr value
  c:stream writeline "a "+string:attr+" "+string:value

constant to_index (the_function '. to string' Universal Str -> Str):generic_index

function to_string data options function -> string
  arg Universal data ; arg Str options ; arg Function function ; arg Str string
  indirect

method c attribute attr data fun
  arg_rw BrowserConnection c ; arg Str attr ; arg Universal data ; arg Function fun
  var Str value := to_string data "db" fun
  c:stream writeline "a "+string:attr+" "+string:value

function active_type t access e
  arg BrowserTag t ; arg Int access ; arg_rw Expression e
  if e:size<1+t:required:size+(shunt t:body 1 0)
    return
  if not (e:0 cast BrowserConnection)
    return
  e suckup e:0
  if t:body
    var Link:Argument parent :> argument local Str
    e add (instruction (the_function '. create_open' BrowserConnection Str Str) e:0:result (argument constant Str t:name) parent)
  else
    e add (instruction (the_function '. create' BrowserConnection Str) e:0:result (argument constant Str t:name))
  for (var Int i) 0 t:required:size-1
    var Link:BrowserAttribute a :> (t:attributes first t:required:i) map BrowserAttribute
    if not (e:(i+1) cast a:type)
      return
    e suckup e:(i+1)
    if a:type=Str
      e add (instruction (the_function '. attribute' BrowserConnection Str Str) e:0:result (argument constant Str a:name) e:(i+1):result)
    else
      var Link:Function fun :> a:type get_generic_method to_index
      if addressof:fun=null or addressof:fun=addressof:(the_function '. to string' Universal Str -> Str)
        return
      e add (instruction (the_function '. attribute' BrowserConnection Str Universal Function) e:0:result (argument constant Str a:name) e:(i+1):result (argument mapped_constant Function fun))
  var Int i := 1+t:required:size
  while i<e:size-(shunt t:body 1 0)
    if not e:i:is_pure_ident or i+1>=e:size-(shunt t:body 1 0)
      return
    var Link:Type tt :> null map Type
    each aa t:attributes
      a :> aa map BrowserAttribute
      if a:name=e:i:ident
        tt :> a type
    if not exists:tt
      e:(i+1) compile ?
      tt :> e:(i+1):result:type real_data_type
    if not (e:(i+1) cast tt)
      return
    e suckup e:(i+1)
    if tt=Str
      e add (instruction (the_function '. attribute' BrowserConnection Str Str) e:0:result (argument constant Str e:i:ident) e:(i+1):result)
    else
      var Link:Function fun :> tt get_generic_method to_index
      if addressof:fun=null or addressof:fun=addressof:(the_function '. to string' Universal Str -> Str)
        return
      e add (instruction (the_function '. attribute' BrowserConnection Str Universal Function) e:0:result (argument constant Str e:i:ident) e:(i+1):result (argument mapped_constant Function fun))
    i += 2
  if t:body
    (e e:size-1) compile ?
    e suckup (e e:size-1)
    e add (instruction (the_function '. create_close' BrowserConnection Str) e:0:result parent)
  e set_void_result
  

function the_tag e -> t
  arg Expression e ; arg_C BrowserTag t
  var Pointer:Arrow c :> pliant_general_dictionary first "pliant current browser tag"
  if c<>null and entry_type:c=BrowserTag
    t :> c map BrowserTag
  else
    t :> null map BrowserTag

meta browser_tag_prototype e
  if e:size<2 or not e:0:is_pure_ident
    return
  var Link:BrowserTag t :> new BrowserTag
  t name := e:0 ident
  var Int i := 1
  while i<e:size-1
    if e:i:is_pure_ident
      t required += e:i:ident
      i += 1
    else
      return
  var Address mark := e:module mark
  e:module define "pliant current browser tag" addressof:t
  e:(e:size-1):compile ?
  e:module rewind mark
  e define ". "+t:name addressof:t e:module:actual
  e set_void_result

meta attr e
  var Link:BrowserTag t :> the_tag e
  if not exists:t
    return
  if e:size<>2 or (e:0 constant Type)=null or not e:1:is_pure_ident
    return
  var Link:BrowserAttribute a :> new BrowserAttribute
  a name := e:1 ident 
  a type :> (e:0 constant Type) map Type
  t:attributes insert a:name true addressof:a
  e set_void_result

meta body e
  var Link:BrowserTag t :> the_tag e
  if exists:t and e:size=0
    t body := true
    e set_void_result


export browser_tag_prototype attr body


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


method c window_open w
  arg_rw BrowserConnection c ; arg Str w
  c:stream writeline "push"
  c:stream writeline "i [dq]"+w+"[dq]"
  c:stream writeline "o [dq]root[dq]"

method c window_close w
  arg_rw BrowserConnection c ; arg Str w
  c:stream writeline "c"
  c:stream writeline "pop"
  c:stream writeline "window [dq]"+w+"[dq]"
  c:stream writeline "display [dq]"+w+"[dq]"

meta '. window' e
  if e:size<>3 or not (e:0 cast BrowserConnection) or not e:1:is_pure_ident
    return
  e suckup e:0
  e add (instruction (the_function '. window_open' BrowserConnection Str) e:0:result (argument constant Str e:1:ident))
  (e e:size-1) compile ?
  e suckup (e e:size-1)
  e add (instruction (the_function '. window_close' BrowserConnection Str) e:0:result (argument constant Str e:1:ident))
  e set_void_result


dual_keyword bloc 1 1 event 1 1

method c bloc_open da
  arg_rw BrowserConnection c ; arg DelayedAction da
  var Str id := "event"+generate_id
  c:stream writeline "i [dq]"+id+"[dq]"
  c:stream writeline "o [dq]event[dq]"
  var Link:DelayedAction lda :> new DelayedAction ; lda := da
  c:document:attached insert id true addressof:lda

method c bloc_close
  arg_rw BrowserConnection c
  c:stream writeline "c"

meta '. bloc' e
  if e:size<>4 or not (e:0 cast BrowserConnection) or e:2:ident<>"event"
    return
  e:1 compile ?
  var Link:List expressions :> new List
  expressions append addressof:(e e:size-1)
  var Link:List byaddress :> new List
  byaddress append addressof:(new Ident (cast "connection" Ident))
  var Pointer:Module module :> e module
  var Address mark := module mark
  var List functions ; var Link:Type type
  e freeze expressions byaddress functions type
  module rewind mark
  e add (instruction (the_function '. bloc_open' BrowserConnection DelayedAction) e:0:result (e e:size-1):result)
  e suckup e:1
  e add (instruction (the_function '. bloc_close' BrowserConnection) e:0:result)
  e set_void_result


export '. window' '. bloc'


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


gvar Dictionary pages_dictionary
gvar Sem pages_sem

named_expression browser_page_prototype
  function 'pliant browser page function' connection
    arg_rw BrowserConnection connection
    implicit connection
      body

meta browser_page e
  if e:size=2 and (e:0 constant Str)<>null and e:1:ident="{}"
    var Address mark := e:module mark
    var Link:Expression ee :> expression duplicate browser_page_prototype substitute body e:1 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 page function") map Function
    e:module rewind mark
    if exists:f
      pages_sem request
      pages_dictionary insert ((e:0 constant Str) map Str) true addressof:f
      pages_sem release
      e set_void_result


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


type BrowserServer
  tcp_server_fields "Browser" 4
TcpServer maybe BrowserServer

function browser_type_function connection f
  arg_rw BrowserConnection connection ; arg Function f
  indirect

function execute1 a f
  arg Address a ; arg Function f
  indirect

method server service s
  arg_rw BrowserServer server ; arg_rw Stream s
  var Link:BrowserDocument document :> new BrowserDocument
  var BrowserConnection c
  c stream :> s
  c document :> document
  while not s:atend
    var Str l := s readline
    if (l parse word:"connect" (var Str page))
      pages_sem rd_request
      var Link:Function f :> (pages_dictionary first page) map Function
      pages_sem rd_release
      if exists:f
        console "executing " page eol
        var Str id := generate_id
        s writeline "i [dq]main[dq]"
        s writeline "o [dq]root[dq]"
        browser_type_function c f
        s writeline "c"
        s writeline "window [dq]main[dq]"
        s writeline "display [dq]main[dq]"
        s writeline "once"
      else
        console "no '" page "' page here" eol
      s writeline ""
    eif (l parse word:"event" c:event any)
      c key := l option "key" Str
      c buttons := l option "buttons" Int
      c x := l option "x" Float
      c y := l option "y" Float
      c target_id := l option "target_id" Str
      c target_x0 := l option "target_x0" Float
      c target_y0 := l option "target_y0" Float
      c target_x1 := l option "target_x1" Float
      c target_y1 := l option "target_y1" Float
      c hook_id := l option "hook_id" Str
      c hook_x0 := l option "hook_x0" Float
      c hook_y0 := l option "hook_y0" Float
      c hook_x1 := l option "hook_x1" Float
      c hook_y1 := l option "hook_y1" Float
      c target_index := l option "target_index" Int
      var Link:DelayedAction da :> (document:attached first c:hook_id) map DelayedAction
      if exists:da and (entry_type addressof:da)=DelayedAction
        execute1 da:parameter da:function
      s writeline ""
    eif (l parse word:"context" any:(var Str options))
      c context := options
    else
      console "invalid '" l "' instruction" eol


define_tcp_server BrowserServer browser_server
export browser_server browser_page
export BrowserConnection '. stream' '. document'