Patch title: Release 96 bulk changes
Abstract:
File: /pliant/graphic/ui/server/api.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"
module "/pliant/language/parser.pli"
module "/pliant/language/stream/blob.pli"
module "/pliant/util/pml/io.pli"
submodule "context.pli"
module "/pliant/language/data/id.pli"
module "/pliant/storage/database.pli"
submodule "/pliant/graphic/color/rgb888.pli"
module "/pliant/util/encoding/utf8.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/language/data/id.pli"
module "/pliant/util/crypto/random.pli"
module "/pliant/util/encoding/base64.pli"

constant check_style false
constant lazy_clipboard true


if check_style
  module "/pliant/graphic/layout/style.pli"


function encode c -> e
  arg Str c e
  if default_charset_is_utf8
    e := c
  else
    e := utf8_encode c


method c para_in
  arg_rw UIServerContext c
  if c:inside_para=0
    c:connection oraw open (cast "para" Ident) (cast "stick" Ident) body
    c inside_para := 1
 
method c para_out
  arg_rw UIServerContext c
  if c:inside_para=1
    c:connection oraw close
    c inside_para := 0
 

method c tag_open0 tag
  arg_rw UIServerContext c ; arg Ident tag
  c:connection oraw tag open

method c tag_open tag
  arg_rw UIServerContext c ; arg Ident tag
  c:connection oraw open tag

method c tag_open1 path
  arg_rw UIServerContext c ; arg Str path
  c para_in
  c:connection oraw open (cast "style" Ident) (cast "set" Ident) path true body

method c tag_open2 tag
  arg_rw UIServerContext c ; arg Ident tag
  c para_out
  c:connection oraw open tag

method c tag_ident ident
  arg_rw UIServerContext c ; arg Ident ident
  c:connection oraw ident

method c tag_value value
  arg_rw UIServerContext c ; arg CBool value
  c:connection oraw value

method c tag_value value
  arg_rw UIServerContext c ; arg Int value
  c:connection oraw value

method c tag_value value
  arg_rw UIServerContext c ; arg Str value
  c:connection oraw value

method c tag_value value
  arg_rw UIServerContext c ; arg Float value
  c:connection oraw value

method c tag_value value
  arg_rw UIServerContext c ; arg ColorRGB888 value
  c:connection oraw open (cast "rgb" Ident) (cast value:r Int) (cast value:g Int) (cast value:b Int) close


method c tag_body
  arg_rw UIServerContext c
  c:connection oraw body

method c tag_close
  arg_rw UIServerContext c
  c:connection oraw close

method c tag_close2
  arg_rw UIServerContext c
  c para_out
  c:connection oraw close


method c text txt
  arg_rw UIServerContext c ; arg Str txt
  c para_in
  c:connection otag "text" encode:txt

method c eol
  arg_rw UIServerContext c
  c para_in
  c:connection otag "text" (cast "[lf]" Str)


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


function attribute_tag e tag
  arg_rw Expression e ; arg Str tag
  if e:size<>2 or not (e:0 cast UIServerContext) or e:(e:size-1):ident<>"{}"
    return
  e:(e:size-1) compile ?
  e suckup e:0
  e add (instruction (the_function '. tag_open1' UIServerContext Str) e:0:result (argument constant Str "standard/text/"+tag))
  e suckup e:(e:size-1)
  e add (instruction (the_function '. tag_close' UIServerContext) e:0:result)
  e set_void_result

meta '. bold' e
  attribute_tag e "bold"

meta '. italic' e
  attribute_tag e "italic"

meta '. fixed' e
  attribute_tag e "fixed"


method c para_open flags
  arg_rw UIServerContext c ; arg Int flags
  c para_out
  c:connection oraw open (cast (shunt (flags .and. 20h)<>0 "title" (flags .and. 10h)<>0 "header" "para") Ident)
  if (flags .and. 3)=0
    c:connection oraw (cast "stick" Ident)
  if (flags .and. 4)<>0
    c:connection oraw (cast "cursor" Ident)
  if (flags .and. 8)<>0
    c:connection oraw (cast "edit" Ident)
  c:connection oraw body
  c inside_para := 2

method c para_close
  arg_rw UIServerContext c
  c:connection oraw close
  c inside_para := 0

function para_tag e base
  arg_rw Expression e ; arg Int base
  if e:size<2 or not (e:0 cast UIServerContext) or e:(e:size-1):ident<>"{}"
    return
  var Int flags := base
  var Int i := 1
  while i<e:size-1
    if e:i:is_pure_ident and e:i:ident="stick"
      flags := flags .and. .not. (cast 3 Int)
      i += 1
    eif e:i:is_pure_ident and e:i:ident="cursor"
      flags := flags .or. 4
      i += 1
    eif e:i:is_pure_ident and e:i:ident="edit"
      flags := flags .or. 8
      i += 1
    else
      return
  e:(e:size-1) compile ?
  e suckup e:0
  e add (instruction (the_function '. para_open' UIServerContext Int) e:0:result (argument constant Int flags))
  e suckup e:(e:size-1)
  e add (instruction (the_function '. para_close' UIServerContext) e:0:result)
  e set_void_result

meta '. para' e
  para_tag e 3

method c header txt
  arg_rw UIServerContext c ; arg Str txt
  c para_out
  c:connection oraw open (cast "header" Ident) body open (cast "text" Ident) txt close close

meta '. header' e
  para_tag e 13h

method c title txt
  arg_rw UIServerContext c ; arg Str txt
  c para_out
  c:connection oraw open (cast "title" Ident) body open (cast "text" Ident) encode:txt close close

meta '. title' e
  para_tag e 23h


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


meta '. table' e
  if e:size<2 or not (e:0 cast UIServerContext) or e:(e:size-1):ident<>"{}"
    return
  e:(e:size-1) compile ?
  e suckup e:0
  e add (instruction (the_function '. tag_open2' UIServerContext Ident) e:0:result (argument constant Ident (cast "table" Ident)))
  var Int i := 1
  while i<e:size-1
    return
  e add (instruction (the_function '. tag_body' UIServerContext) e:0:result)
  e suckup e:(e:size-1)
  e add (instruction (the_function '. tag_close' UIServerContext) e:0:result)
  e set_void_result

meta '. row' e
  if e:size<2 or not (e:0 cast UIServerContext) or e:(e:size-1):ident<>"{}"
    return
  e:(e:size-1) compile ?
  e suckup e:0
  e add (instruction (the_function '. tag_open' UIServerContext Ident) e:0:result (argument constant Ident (cast "row" Ident)))
  var Int i := 1
  while i<e:size-1
    return
  e add (instruction (the_function '. tag_body' UIServerContext) e:0:result)
  e suckup e:(e:size-1)
  e add (instruction (the_function '. tag_close' UIServerContext) e:0:result)
  e set_void_result


meta '. cell' e
  if e:size<2 or not (e:0 cast UIServerContext) or e:(e:size-1):ident<>"{}"
    return
  e:(e:size-1) compile ?
  e suckup e:0
  e add (instruction (the_function '. tag_open' UIServerContext Ident) e:0:result (argument constant Ident (cast "cell" Ident)))
  var Int i := 1
  while i<e:size-1
    if (e:i is_pure_ident) and e:i:ident="header"
      e add (instruction (the_function '. tag_ident' UIServerContext Ident) e:0:result (argument constant Ident (cast "header" Ident)))
      i += 1
    else
      return
  e add (instruction (the_function '. tag_body' UIServerContext) e:0:result)
  e suckup e:(e:size-1)
  e add (instruction (the_function '. tag_close2' UIServerContext) e:0:result)
  e set_void_result

export '. text' '. eol'
export '. bold' '. italic' '. fixed'
export '. para' '. header' '. title'
export '. table' '. row' '. cell'


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


function ovar_init v t
  arg_rw Arrow v ; arg Type t
  if v=null
    v := entry_new t

meta ovar e
  var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
  if c=null or entry_type:c<>Function
    return
  var Link:Function current_function :> c map Function
  if e:size<2
    return
  var Pointer:Type t :> (e:0 constant Type) map Type
  if not exists:t
    return
  for (var Int i) 1 e:size-1
    if not e:i:is_pure_ident
      return
  for (var Int i) 1 e:size-1
    var Link:Argument v :> e local_variable e:i:ident linkto:t
    e add (instruction (the_function ovar_init Arrow Type) v (argument mapped_constant Type t))
  e set_result v access_read+access_write


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 input_data_tag label flags focus help d
  arg_rw UIServerContext c ; arg Str label ; arg Int flags ; arg CBool focus ; arg Str help ; arg Data_ d
  c para_in
  var Str var_id := generate_id
  c:connection otag "input" (string c:current_section)+" "+string:var_id
  if (d:interface get d addressof:(var Str value) Str)=failure
    value := ""
  if value<>""
    c:connection oattr "value" encode:value
  if label<>""
    c:connection oattr "label" encode:label
  if (flags .and. 2)<>0
    c:connection oattr "password"
  if (flags .and. 4)<>0
    c:connection oattr "multiline"
  if focus
    c:connection oattr "focus"
  if help<>""
    c:connection oattr "help" encode:help
  c:env_sem request
  var Link:UIServerSection section :> (c:env first "section "+c:current_section) map UIServerSection
  if not exists:section or (entry_type addressof:section)<>UIServerSection
    section :> new UIServerSection
    c:env insert "section "+c:current_section true addressof:section
  var Link:UIServerVariable va :> new UIServerVariable
  va data_path := d path
  section:env insert var_id true addressof:va
  c:env_sem release
  
method c input_var_tag label flags focus help v
  arg_rw UIServerContext c ; arg Str label ; arg Int flags ; arg CBool focus ; arg Str help ; arg Universal v
  c para_in
  var Str var_id := generate_id
  c:connection otag "input" (string c:current_section)+" "+string:var_id
  var Pointer:Function f :> (entry_type addressof:v) get_generic_method to_index
  var Str value := to_string v "db" f
  if value<>""
    c:connection oattr "value" encode:value
  if label<>""
    c:connection oattr "label" encode:label
  if (flags .and. 2)<>0
    c:connection oattr "password"
  if (flags .and. 4)<>0
    c:connection oattr "multiline"
  if focus
    c:connection oattr "focus"
  if help<>""
    c:connection oattr "help" encode:help
  c:env_sem request
  var Link:UIServerSection section :> (c:env first "section "+c:current_section) map UIServerSection
  if not exists:section or (entry_type addressof:section)<>UIServerSection
    section :> new UIServerSection
    c:env insert "section "+c:current_section true addressof:section
  var Link:UIServerVariable va :> new UIServerVariable
  va variable := addressof v
  section:env insert var_id true addressof:va
  c:env_sem release

meta '. input' e
  if e:size<3 or not (e:0 cast UIServerContext) or not (e:1 cast Str)
    return
  e:2 compile ?
  var CBool data := e:2 is_data
  if not data
    var Link:Type type :> e:2:result:type:real_data_type
    if not (e:2 cast type)
      return
    var Pointer:Function function :> type get_generic_method to_index
    if addressof:function=null or addressof:function=addressof:(the_function '. to string' Universal Str -> Str)
      return
  var Int flags := 0
  var Link:Argument focus :> argument constant CBool false
  var Link:Argument help :> argument constant Str ""
  var Int i := 3
  while i<e:size
    if e:i:ident="password"
      flags := flags .or. 2
      i += 1
    eif e:i:ident="multiline"
      flags := flags .or. 4
      i += 1
    eif e:i:ident="focus" and i+1<e:size and ((e i+1) cast CBool)
      e suckup (e i+1)
      focus :> (e i+1) result
      i += 2
    eif e:i:ident="help" and i+1<e:size and ((e i+1) cast Str)
      e suckup (e i+1)
      help :> (e i+1) result
      i += 2
    else
      return
  e suckup e:0 ; e suckup e:1 ; e suckup e:2
  if data
    e add (instruction (the_function '. input_data_tag' UIServerContext Str Int CBool Str Data_) e:0:result e:1:result (argument constant Int flags) focus help e:2:result)
  else
    e add (instruction (the_function '. input_var_tag' UIServerContext Str Int CBool Str Universal) e:0:result e:1:result (argument constant Int flags) focus help e:2:result)
  e set_void_result


method c select_data_open label flags focus help d
  arg_rw UIServerContext c ; arg Str label ; arg Int flags ; arg CBool focus ; arg Str help ; arg Data_ d
  c para_in
  var Str var_id := generate_id
  c:connection oraw open (cast "select" Ident) (string c:current_section)+" "+string:var_id
  if (d:interface get d addressof:(var Str value) Str)=failure
    value := ""
  if value<>""
    c:connection oraw (cast "value" Ident) value
  if label<>""
    c:connection oraw (cast "label" Ident) label
  if focus
    c:connection oraw (cast "focus" Ident)
  if help<>""
    c:connection oattr "help" encode:help
  c:connection oraw body
  c:env_sem request
  var Link:UIServerSection section :> (c:env first "section "+c:current_section) map UIServerSection
  if not exists:section or (entry_type addressof:section)<>UIServerSection
    section :> new UIServerSection
    c:env insert "section "+c:current_section true addressof:section
  var Link:UIServerVariable va :> new UIServerVariable
  va data_path := d path
  section:env insert var_id true addressof:va
  c:env_sem release

method c select_var_open label flags focus help v
  arg_rw UIServerContext c ; arg Str label ; arg Int flags ; arg CBool focus ; arg Str help ; arg Universal v
  c para_in
  var Str var_id := generate_id
  c:connection oraw open (cast "select" Ident) (string c:current_section)+" "+string:var_id
  var Pointer:Function f :> (entry_type addressof:v) get_generic_method to_index
  var Str value := to_string v "db" f
  if value<>""
    c:connection oraw (cast "value" Ident) value
  if label<>""
    c:connection oraw (cast "label" Ident) label
  if focus
    c:connection oraw (cast "focus" Ident)
  if help<>""
    c:connection oraw (cast "help" Ident) encode:help
  c:connection oraw body
  c:env_sem request
  var Link:UIServerSection section :> (c:env first "section "+c:current_section) map UIServerSection
  if not exists:section or (entry_type addressof:section)<>UIServerSection
    section :> new UIServerSection
    c:env insert "section "+c:current_section true addressof:section
  var Link:UIServerVariable va :> new UIServerVariable
  va variable := addressof v
  section:env insert var_id true addressof:va
  c:env_sem release

method c select_close
  arg_rw UIServerContext c
  c:connection oraw close
  
meta '. select' e
  if e:size<4 or not (e:0 cast UIServerContext) or not (e:1 cast Str)
    return
  e:2 compile ?
  var CBool data := e:2 is_data
  if not data
    var Link:Type type :> e:2:result:type:real_data_type
    if not (e:2 cast type)
      return
    var Pointer:Function function :> type get_generic_method to_index
    if addressof:function=null or addressof:function=addressof:(the_function '. to string' Universal Str -> Str)
      return
  var Int flags := 0
  var Link:Argument focus :> argument constant CBool false
  var Link:Argument help :> argument constant Str ""
  var Int i := 3
  while i<e:size-1
    if e:i:ident="focus" and i+1<e:size and ((e i+1) cast CBool)
      e suckup (e i+1)
      focus :> (e i+1) result
      i += 2
    eif e:i:ident="help" and i+1<e:size and ((e i+1) cast Str)
      e suckup (e i+1)
      help :> (e i+1) result
      i += 2
    else
      return
  (e e:size-1) compile ?
  e suckup e:0 ; e suckup e:1 ; e suckup e:2
  if data
    e add (instruction (the_function '. select_data_open' UIServerContext Str Int CBool Str Data_) e:0:result e:1:result (argument constant Int flags) focus help e:2:result)
  else
    e add (instruction (the_function '. select_var_open' UIServerContext Str Int CBool Str Universal) e:0:result e:1:result (argument constant Int flags) focus help e:2:result)
  e suckup (e e:size-1)
  e add (instruction (the_function '. select_close' UIServerContext) e:0:result)
  e set_void_result


method c option label value
  arg_rw UIServerContext c ; arg Str label value
  c:connection otag "option" encode:label value


method c button_tag label key da help flags active selected
  arg_rw UIServerContext c ; arg Str label ; arg Str key ; arg DelayedAction da ; arg Str help ; arg Int flags ; arg CBool active selected
  c para_in
  var Str button_id := generate_id
  c:connection otag "button" (shunt active (string c:current_section)+" "+string:button_id "")
  if label<>""
    c:connection oattr "label" encode:label
  if key<>""
    c:connection oattr "key" key
  if (flags .and. 2)<>0
    c:connection oattr "stretch"
  if selected
    c:connection oattr "selected"
  if help<>""
    c:connection oattr "help" encode:help
  if active
    c:env_sem request
    var Link:UIServerSection section :> (c:env first "section "+c:current_section) map UIServerSection
    if not exists:section or (entry_type addressof:section)<>UIServerSection
      section :> new UIServerSection
      c:env insert "section "+c:current_section true addressof:section
    var Link:DelayedAction lda :> new DelayedAction ; lda := da
    section:env insert button_id true addressof:lda
    c:env_sem release

meta '. button' e
  if e:size<3 or not (e:0 cast UIServerContext) or not (e:1 cast Str)
    return
  var Int flags := 0
  var Link:Argument key :> argument constant Str ""
  var Link:Argument help :> argument constant Str ""
  var Link:Argument active :> argument constant CBool true
  var Link:Argument selected :> argument constant CBool false
  var Int i := 2
  while i<e:size-1
    if not e:i:is_pure_ident or e:i:ident<>"stretch" and i+1>=e:size-1
      return
    eif e:i:ident="key" and ((e i+1) cast Str)
      e suckup (e i+1)
      key :> (e i+1) result
      i += 2
    eif e:i:ident="help" and ((e i+1) cast Str)
      e suckup (e i+1)
      help :> (e i+1) result
      i += 2
    eif e:i:ident="stretch"
      flags := flags .or. 2
      i += 1
    eif e:i:ident="active" and ((e i+1) cast CBool)
      e suckup (e i+1)
      active :> (e i+1) result
      i += 2
    eif e:i:ident="selected" and ((e i+1) cast CBool)
      e suckup (e i+1)
      selected :> (e i+1) result
      i += 2
    else
      return
  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 "context" 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 suckup e:0
  e suckup e:1
  e add (instruction (the_function '. button_tag' UIServerContext Str Str DelayedAction Str Int CBool CBool) e:0:result e:1:result key (e e:size-1):result help (argument constant Int flags) active selected)
  e set_void_result


method c link_tag label da help
  arg_rw UIServerContext c ; arg Str label ; arg DelayedAction da ; arg Str help
  var Str button_id := generate_id
  c para_in
  c:connection otag "link" encode:label (string c:current_section)+" "+string:button_id
  if help<>""
    c:connection oattr "help" encode:help
  c:env_sem request
  var Link:UIServerSection section :> (c:env first "section "+c:current_section) map UIServerSection
  if not exists:section or (entry_type addressof:section)<>UIServerSection
    section :> new UIServerSection
    c:env insert "section "+c:current_section true addressof:section
  var Link:DelayedAction lda :> new DelayedAction ; lda := da
  section:env insert button_id true addressof:lda
  c:env_sem release

meta '. link' e
  if e:size<3 or not (e:0 cast UIServerContext) or not (e:1 cast Str)
    return
  var Link:Argument help :> argument constant Str ""
  var Int i := 2
  while i<e:size-1
    if e:i:ident="help" and i+1<e:size-1 and ((e i+1) cast Str)
      e suckup (e i+1)
      help :> (e i+1) result
      i += 2
    else
      return
  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 "context" 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 suckup e:0
  e suckup e:1
  e add (instruction (the_function '. link_tag' UIServerContext Str DelayedAction Str) e:0:result e:1:result (e e:size-1):result help)
  e set_void_result


export ovar '. input' '. select' '. option'
export '. button' '. link'


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


dual_keyword hook 1 100 clic 1 1
dual_keyword hook 1 100 event 1 1
dual_keyword hook 1 100 change 1 1
dual_keyword hook 1 100 focus 1 1
dual_keyword hook 1 100 over 1 1
dual_keyword hook 1 100 move 1 1

method c hook_open flags -> id
  arg_rw UIServerContext c ; arg Int flags ; arg Str id
  id := (string c:current_section)+" "+string:generate_id
  c:connection oraw open (cast "hook" Ident) id flags
  c:connection oraw body

method c hook_record id cat da
  arg_rw UIServerContext c ; arg Str id cat ; arg DelayedAction da
  id parse (var Str sid) (var Str bid)
  c:env_sem request
  var Link:UIServerSection section :> (c:env first "section "+sid) map UIServerSection
  if not exists:section or (entry_type addressof:section)<>UIServerSection
    section :> new UIServerSection
    c:env insert "section "+sid true addressof:section
  section:env insert bid+" "+cat true addressof:(new DelayedAction da)
  c:env_sem release

meta '. hook' e
  if e:size<4 or not (e:0 cast UIServerContext)
    return
  var Int flags := 0
  var Int body := undefined
  var Int i := 1
  while i<e:size
    if e:i:ident="ssr"
      flags := flags .or. 2^24
      i += 1
    eif e:i:ident="{}" and body=undefined
      body := i
      i += 1
    else
      var Str cat := shunt e:i:is_pure_ident e:i:ident ""
      var Int flag := shunt cat="clic" 1 cat="event" 2 cat="change" 4 cat="focus" 8 cat="over" 16 cat="move" 32 (cast undefined Int)
      if flag=undefined or i+1>=e:size or (flags .and. flag)<>0
        return
      flags := flags .or. flag
      i += 2
  if body=undefined
    return
  e suckup e:0
  var Link:Argument vid :> argument local Str
  e add (instruction (the_function '. hook_open' UIServerContext Int -> Str) e:0:result (argument constant Int flags) vid)
  e:body compile ?
  e suckup e:body
  var Int i := 1
  while i<e:size
    if e:i:ident="ssr"
      i += 1
    eif e:i:ident="{}"
      i += 1
    else
      var Link:List expressions :> new List
      expressions append addressof:(e i+1)
      var Link:List byaddress :> new List
      byaddress append addressof:(new Ident (cast "context" 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 '. hook_record' UIServerContext Str Str DelayedAction) e:0:result vid (argument constant Str e:i:ident) e:(i+1):result)
      i += 2
  e add (instruction (the_function '. tag_close' UIServerContext) e:0:result)
  e set_void_result


method c focus_set section index
  arg_rw UIServerContext c ; arg Str section ; arg Int index
  c:connection otag "focus_set" section index


method c focus_save
  arg_rw UIServerContext c
  c:connection otag "focus_save"


method c focus_restore
  arg_rw UIServerContext c
  c:connection otag "focus_restore"


export '. hook' '. focus_set' '. focus_save' '. focus_restore'


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


method c style_copy src dest
  arg_rw UIServerContext c ; arg Str src dest
  c:connection otag "style_copy" src dest


method c style_set_bool style path value
  arg_rw UIServerContext c ; arg Str style path ; arg CBool value
  c:connection otag "style_set" style path value

method c style_set_int style path value
  arg_rw UIServerContext c ; arg Str style path ; arg Int value
  c:connection otag "style_set" style path value

method c style_set_float style path value
  arg_rw UIServerContext c ; arg Str style path ; arg Float value
  c:connection otag "style_set" style path value

method c style_set_str style path value
  arg_rw UIServerContext c ; arg Str style path value
  c:connection otag "style_set" style path value

method c style_set_color style path value
  arg_rw UIServerContext c ; arg Str style path ; arg ColorRGB888 value
  c:connection otag "style_set" style path open (cast "rgb" Ident) (cast value:r Int) (cast value:g Int) (cast value:b Int) close

meta '. style_set' e
  if e:size<>4 or not (e:0 cast UIServerContext) or not (e:1 cast Str) or not (e:2 cast Str)
    return
  e suckup e:0
  e suckup e:1
  e suckup e:2
  if (e:3 cast CBool)
    e suckup e:3
    e add (instruction (the_function '. style_set_bool' UIServerContext Str Str CBool) e:0:result e:1:result e:2:result e:3:result)
  eif (e:3 cast Int)
    e suckup e:3
    e add (instruction (the_function '. style_set_int' UIServerContext Str Str Int) e:0:result e:1:result e:2:result e:3:result)
  eif (e:3 cast Float)
    e suckup e:3
    e add (instruction (the_function '. style_set_float' UIServerContext Str Str Float) e:0:result e:1:result e:2:result e:3:result)
  eif (e:3 cast Str)
    e suckup e:3
    e add (instruction (the_function '. style_set_str' UIServerContext Str Str Str) e:0:result e:1:result e:2:result e:3:result)
  eif (e:3 cast ColorRGB888)
    e suckup e:3
    e add (instruction (the_function '. style_set_color' UIServerContext Str Str ColorRGB888) e:0:result e:1:result e:2:result e:3:result)
  else
    return
  e set_void_result


meta '. style' e
  if e:size<2 or not (e:0 cast UIServerContext) or e:(e:size-1):ident<>"{}"
    return
  e:(e:size-1) compile ?
  e suckup e:0
  e add (instruction (the_function '. tag_open' UIServerContext Ident) e:0:result (argument constant Ident (cast "style" Ident)))
  var Int i := 1
  while i<e:size-1
    if e:i:is_pure_ident and e:i:ident="use" and i+1<e:size-1 and ((e i+1) cast Str)
      e add (instruction (the_function '. tag_ident' UIServerContext Ident) e:0:result (argument constant Ident (cast "use" Ident)))
      e suckup (e i+1)
      e add (instruction (the_function '. tag_value' UIServerContext Str) e:0:result (e i+1):result)
      i += 2
    eif e:i:is_pure_ident and e:i:ident="set" and i+2<e:size and ((e i+1) cast Str)
      e add (instruction (the_function '. tag_ident' UIServerContext Ident) e:0:result (argument constant Ident (cast "set" Ident)))
      e suckup (e i+1)
      e add (instruction (the_function '. tag_value' UIServerContext Str) e:0:result (e i+1):result)
      var Link:Function f
      if ((e i+2) cast CBool)
        f :> the_function '. tag_value' UIServerContext CBool
      eif ((e i+2) cast Int)
        f :> the_function '. tag_value' UIServerContext Int
      eif ((e i+2) cast Float)
        f :> the_function '. tag_value' UIServerContext Float
      eif ((e i+2) cast Str)
        f :> the_function '. tag_value' UIServerContext Str
      eif ((e i+2) cast ColorRGB888)
        f :> the_function '. tag_value' UIServerContext ColorRGB888
      else
        return
      e suckup (e i+2)
      e add (instruction f e:0:result (e i+2):result)
      i += 3
    else
      return
  e add (instruction (the_function '. tag_body' UIServerContext) e:0:result)
  e suckup (e e:size-1)
  e add (instruction (the_function '. tag_close' UIServerContext) e:0:result)
  e set_void_result


export '. style_copy' '. style_set' '. style'


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


meta '. window' e
  if e:size<>3 or not (e:0 cast UIServerContext) or not e:1:is_pure_ident or e:2:ident<>"{}"
    return
  e:2 compile ?
  e suckup e:0
  e add (instruction (the_function '. tag_open' UIServerContext Ident) e:0:result (argument constant Ident (cast "window" Ident)))
  e add (instruction (the_function '. tag_value' UIServerContext Str) e:0:result (argument constant Str e:1:ident))
  e add (instruction (the_function '. tag_body' UIServerContext) e:0:result)
  e suckup e:2
  e add (instruction (the_function '. tag_close2' UIServerContext) e:0:result)
  e set_void_result


method c section_open id inside memo
  arg_rw UIServerContext c ; arg Str id ; arg CBool inside ; arg_w Str memo
  memo := c current_section ; c current_section := id
  if inside
    c para_in
  else
    c para_out
  c:env_sem request
  var Link:UIServerSection section :> (c:env first "section "+id) map UIServerSection
  if not exists:section or (entry_type addressof:section)<>UIServerSection
    section :> new UIServerSection
    c:env insert "section "+id true addressof:section
  section inside := inside
  section env := var Dictionary empty_env
  c:env_sem release
  c:connection oraw open (cast "section" Ident) id body

method c section_close inside memo
  arg_rw UIServerContext c ; arg CBool inside ; arg Str memo
  if not inside
    c para_out
  c:connection oraw close
  c current_section := memo

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

method c section_play id inside da
  arg_rw UIServerContext c ; arg Str id ; arg CBool inside ; arg DelayedAction da
  var Str memo := c current_section ; c current_section := id
  if inside
    c para_in
  else
    c para_out
  c:env_sem request
  var Link:UIServerSection section :> (c:env first "section "+id) map UIServerSection
  if not exists:section or (entry_type addressof:section)<>UIServerSection
    section :> new UIServerSection
    c:env insert "section "+id true addressof:section
  section inside := inside
  section env := var Dictionary empty_env
  section refresh := da
  c:env_sem release
  c:connection oraw open (cast "section" Ident) id body
  var Pointer:Type t :> entry_type da:parameter
  for (var Int i) 0 t:nb_fields-1
    if (t field i):name="context"
      (da:parameter translate Byte (t field i):offset) map Address := addressof c
  execute1 da:parameter da:function
  if not inside
    c para_out
  c:connection oraw close
  c current_section := memo

meta '. section' e
  if e:size<3 or not (e:0 cast UIServerContext) or not (e:1 cast Str)
    return
  var CBool dynamic := false
  var CBool inside := false
  var Int i := 2
  while i<e:size-1
    if e:i:ident="dynamic"
      dynamic := true
      i += 1
    eif e:i:ident="inside"
      inside := true
      i += 1
    else
      return
  if dynamic
    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 "context" 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 suckup e:0
    e suckup e:1
    e add (instruction (the_function '. section_play' UIServerContext Str CBool DelayedAction) e:0:result e:1:result (argument constant CBool inside) (e e:size-1):result)
  else
    (e e:size-1) compile ?
    e suckup e:0 ; e suckup e:1
    var Link:Argument memo :> argument local Str
    e add (instruction (the_function '. section_open' UIServerContext Str CBool Str) e:0:result e:1:result (argument constant CBool inside) memo)
    e suckup (e e:size-1)
    e add (instruction (the_function '. section_close' UIServerContext CBool Str) e:0:result (argument constant CBool inside) memo)
  e set_void_result


method c section_replay id
  arg_rw UIServerContext c ; arg Str id
  c:env_sem request
  var Link:UIServerSection section :> (c:env first "section "+id) map UIServerSection
  if exists:section and (entry_type addressof:section)=UIServerSection and (exists section:refresh:function)
    section env := var Dictionary empty_env
    var DelayedAction da := section refresh
    c:env_sem release
    var Str memo_section := c current_section ; c current_section := id
    var Int memo_inside_para := c inside_para ; c inside_para := shunt section:inside 2 0
    c:connection oraw open (cast "section_overwrite" Ident) id body
    var Pointer:Type t :> entry_type da:parameter
    for (var Int i) 0 t:nb_fields-1
      if (t field i):name="context"
        (da:parameter translate Byte (t field i):offset) map Address := addressof c
    execute1 da:parameter da:function
    c para_out
    c:connection oraw close
    c current_section := memo_section
    c inside_para := memo_inside_para
  else
    c:env_sem release


method c section_reopen tag id memo1 memo2
  arg_rw UIServerContext c ; arg Str tag id ; arg_w Str memo1 ; arg_w Int memo2
  c:env_sem request
  var Link:UIServerSection section :> (c:env first "section "+id) map UIServerSection
  if exists:section and (entry_type addressof:section)=UIServerSection
    if tag="section_overwrite"
      section env := var Dictionary empty_env
    c:env_sem release
    memo1 := c current_section ; c current_section := id
    memo2 := c:inside_para ; c inside_para := shunt section:inside 2 0
    c:connection oraw open (cast tag Ident) id body
  else
    c:env_sem release
    memo2 := undefined

method c section_reclose memo1 memo2
  arg_rw UIServerContext c ; arg Str memo1 ; arg Int memo2
  if memo2<>undefined
    c para_out
    c:connection oraw close
    c current_section := memo1
    c inside_para := memo2

meta '. section_overwrite' e
  if e:size<>3 or not (e:0 cast UIServerContext) or not (e:1 cast Str) or e:2:ident<>"{}"
    return
  e:2 compile ?
  e suckup e:0 ; e suckup e:1
  var Link:Argument memo1 :> argument local Str
  var Link:Argument memo2 :> argument local Int
  e add (instruction (the_function '. section_reopen' UIServerContext Str Str Str Int) e:0:result (argument constant Str "section_overwrite") e:1:result memo1 memo2)
  e suckup e:2
  e add (instruction (the_function '. section_reclose' UIServerContext Str Int) e:0:result memo1 memo2)
  e set_void_result


meta '. section_head' e
  if e:size<>3 or not (e:0 cast UIServerContext) or not (e:1 cast Str) or e:2:ident<>"{}"
    return
  e:2 compile ?
  e suckup e:0 ; e suckup e:1
  var Link:Argument memo1 :> argument local Str
  var Link:Argument memo2 :> argument local Int
  e add (instruction (the_function '. section_reopen' UIServerContext Str Str Str Int) e:0:result (argument constant Str "section_head") e:1:result memo1 memo2)
  e suckup e:2
  e add (instruction (the_function '. section_reclose' UIServerContext Str Int) e:0:result memo1 memo2)
  e set_void_result


meta '. section_tail' e
  if e:size<>3 or not (e:0 cast UIServerContext) or not (e:1 cast Str) or e:2:ident<>"{}"
    return
  e:2 compile ?
  e suckup e:0 ; e suckup e:1
  var Link:Argument memo1 :> argument local Str
  var Link:Argument memo2 :> argument local Int
  e add (instruction (the_function '. section_reopen' UIServerContext Str Str Str Int) e:0:result (argument constant Str "section_tail") e:1:result memo1 memo2)
  e suckup e:2
  e add (instruction (the_function '. section_reclose' UIServerContext Str Int) e:0:result memo1 memo2)
  e set_void_result


meta '. section_before' e
  if e:size<>3 or not (e:0 cast UIServerContext) or not (e:1 cast Str) or e:2:ident<>"{}"
    return
  e:2 compile ?
  e suckup e:0 ; e suckup e:1
  var Link:Argument memo1 :> argument local Str
  var Link:Argument memo2 :> argument local Int
  e add (instruction (the_function '. section_reopen' UIServerContext Str Str Str Int) e:0:result (argument constant Str "section_before") e:1:result memo1 memo2)
  e suckup e:2
  e add (instruction (the_function '. section_reclose' UIServerContext Str Int) e:0:result memo1 memo2)
  e set_void_result


meta '. section_after' e
  if e:size<>3 or not (e:0 cast UIServerContext) or not (e:1 cast Str) or e:2:ident<>"{}"
    return
  e:2 compile ?
  e suckup e:0 ; e suckup e:1
  var Link:Argument memo1 :> argument local Str
  var Link:Argument memo2 :> argument local Int
  e add (instruction (the_function '. section_reopen' UIServerContext Str Str Str Int) e:0:result (argument constant Str "section_after") e:1:result memo1 memo2)
  e suckup e:2
  e add (instruction (the_function '. section_reclose' UIServerContext Str Int) e:0:result memo1 memo2)
  e set_void_result


method c section_delete name
  arg_rw UIServerContext c ; arg Str name
  c:connection otag "section_delete" name
  c:connection flush anytime


method c help txt
  arg_rw UIServerContext c ; arg Str txt
  c section_overwrite "help"
    c para
      c text txt


method c allowed name -> a
  arg_rw UIServerContext c ; arg Str name ; arg CBool a
  a := c:user_is_admin or (c:user_rights first name)<>null and name<>""


method c url_call url
  arg_rw UIServerContext c ; arg Str url
  c:connection otag "url_call" url
  c:connection flush anytime
  
method c url_return
  arg_rw UIServerContext c
  c:connection otag "url_return"
  c:connection flush anytime
  

method c ui_thread_start da
  arg_rw UIServerContext c ; arg DelayedAction da
  var Str id := generate_id+(random_string 128\8)
  var UIPendingThread p
  p action := da
  p env_sem :> c env_sem
  p env :> c env
  ui_thread_sem request
  ui_thread_dict insert id p
  ui_thread_sem release
  c:connection otag "thread_create" id
  
meta '. ui_thread' e
  if e:size<>2 or not (e:0 cast UIServerContext)
    return
  var Link:List expressions :> new List
  expressions append (addressof e:1)
  var Link:List byaddress :> new List
  byaddress append addressof:(new Ident (cast "context" 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 suckup e:0
  e add (instruction (the_function '. ui_thread_start' UIServerContext DelayedAction) e:0:result e:1:result)
  e set_void_result


method c cb_write_begin
  arg_rw UIServerContext c
  if lazy_clipboard
    c clipboard :> new Stream
    c:clipboard open c:clipboard_content out
  else
    c:connection oraw open (cast "clipboard_write" Ident) body
    c clipboard :> c connection
  
method c cb_write_end
  arg_rw UIServerContext c
  if lazy_clipboard
    c:clipboard close
    c:connection otag "clipboard_declare"
  else
    c:connection oraw close
  c clipboard :> null map Stream
  
meta '. clipboard_write' e
  if e:size<>2 or not (e:0 cast UIServerContext)
    return
  e:1 compile ?
  e suckup e:0
  e add (instruction (the_function '. cb_write_begin' UIServerContext) e:0:result)
  e suckup e:1
  e add (instruction (the_function '. cb_write_end' UIServerContext) e:0:result)
  e set_void_result


method c cb_read da
  arg_rw UIServerContext c ; arg DelayedAction da
  c clipboard_handler := da
  c:connection otag "clipboard_read"
  c:connection flush anytime

meta '. clipboard_read' e
  if e:size<>2 or not (e:0 cast UIServerContext)
    return
  var Link:List expressions :> new List
  expressions append (addressof e:1)
  var Link:List byaddress :> new List
  byaddress append addressof:(new Ident (cast "context" 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 suckup e:0
  e add (instruction (the_function '. cb_read' UIServerContext DelayedAction) e:0:result e:1:result)
  e set_void_result


method c flush
  arg_rw UIServerContext c
  c:connection otag "flush"
  c:connection flush anytime


export '. window'
export '. section' '. section_replay' '. section_overwrite'
export '. section_head' '. section_tail' '. section_before' '. section_after'
export '. section_delete'
export '. help'
export '. allowed'
export '. url_call' '. url_return'
export '. ui_thread'
export '. clipboard_write' '. clipboard_read'
export '. flush'

export '. para_in' '. para_out'