Patch title: Release 96 bulk changes
Abstract:
File: /pliant/graphic/ui/sample/document.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/data/id.pli"
module "/pliant/graphic/ui/server/context.pli"
module "/pliant/graphic/ui/server/api.pli"
module "/pliant/storage/document/document.pli"
module "/pliant/storage/document/document2.pli"
module "/pliant/storage/ground/control.pli"
module "/pliant/storage/ground/object.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/util/encoding/utf8.pli"
module "/pliant/util/pml/io.pli"


ui_type DocumentEditorContext
  field Pointer:UIServerContext context
  field Link:StorageDocument d
  field Str menu
  field Str action <- "navigate"
  field Str aid ; field Int aindex
  field Str bid ; field Int bindex
  field Str cid ; field Int cindex
  field Str32 pending


#-------------------------------------------------------------------------
#  Send display version of the XML tree to the ui


gvar Dictionary send_methods

method n send_prototype s section f
  arg StorageNode n ; arg Stream s ; arg CBool section ; arg Function f
  indirect

method n send s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  var Pointer:Function f :> (send_methods first n:tag) map Function
  if exists:f
    n send_prototype s section f

method n send_body s
  arg StorageNode n ; arg Stream s
  var Pointer:StorageNode n2 :> n first
  while exists:n2
    n2 send s true
    n2 :> n2 next


method n send_document s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  n send_body s
send_methods insert "document" true addressof:(the_function '. send_document' StorageNode Stream CBool)


method n send_para s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  if section
    s oraw open (cast "section" Ident) n:id body
  s oraw open (cast "para" Ident) (cast "cursor" Ident) (cast "edit" Ident) body
  n send_body s
  s oraw close
  if section
    s oraw close
send_methods insert "para" true addressof:(the_function '. send_para' StorageNode Stream CBool)

method n send_text s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  s oraw open (cast "text" Ident) (n attr "") close
send_methods insert "text" true addressof:(the_function '. send_text' StorageNode Stream CBool)

method n send_link s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  s oraw open (cast "style" Ident) (cast "use" Ident) "link" body
  n send_body s
  s oraw close
send_methods insert "link" true addressof:(the_function '. send_link' StorageNode Stream CBool)


method n send_header s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  if section
    s oraw open (cast "section" Ident) n:id body
  s oraw open (cast "header" Ident) (cast "cursor" Ident) (cast "edit" Ident) body
  n send_body s
  s oraw close
  if section
    s oraw close
send_methods insert "header" true addressof:(the_function '. send_header' StorageNode Stream CBool)

method n send_title s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  if section
    s oraw open (cast "section" Ident) n:id body
  s oraw open (cast "title" Ident) (cast "cursor" Ident) (cast "edit" Ident) body
  n send_body s
  s oraw close
  if section
    s oraw close
send_methods insert "title" true addressof:(the_function '. send_title' StorageNode Stream CBool)


#-------------------------------------------------------------------------
#  A fiew utility functions


method n is_bloc -> c
  arg StorageNode n ; arg CBool c
  var Str t := n tag
  c := t="para" or t="header" or t="title"

method n has_style -> c
  arg StorageNode n ; arg CBool c
  var Str t := n tag
  c := false


function locate_rec n node index -> found
  arg StorageNode n ; arg_rw Pointer:StorageNode node ; arg_rw Int index ; arg CBool found
  if n:tag="text"
    var Int l := utf8_decode:(n attr "") len
    if index<=l
      node :> n ; found := true
    else
      index -= l+1 ; found := false
  else
    var Pointer:StorageNode n2 :> n first
    while exists:n2
      if (locate_rec n2 node index)
        return true
      n2 :> n2 next
    found := false
  
method d locate id i node index -> found
  arg StorageDocument d ; arg Str id ; arg Int i ; arg_rw Pointer:StorageNode node ; arg_rw Int index ; arg CBool found
  var Pointer:StorageNode n :> d search_node id
  index := i
  found := exists:n and n:is_bloc and (locate_rec n node index)


function count_rec n -> nb
  arg StorageNode n ; arg Int nb
  if n:tag="text"
    nb := utf8_decode:(n attr ""):len+1
  else
    nb := 0
    var Pointer:StorageNode n2 :> n first
    while exists:n2
      nb += count_rec n2
      n2 :> n2 next
  
method d count id -> nb
  arg StorageDocument d ; arg Str id ; arg Int nb
  var Pointer:StorageNode n :> d search_node id
  nb := shunt exists:n count_rec:n 0


method e pending_flush
  arg_rw DocumentEditorContext e
  implicit e
    if pending:len>0
      if (e:d locate cid cindex (var Pointer:StorageNode node) (var Int index))
        var Str32 t := utf8_decode (node attr "")
        e:d set_attr node "" (utf8_encode (t 0 index)+pending+(t index t:len))
      cindex += pending len
      pending := ""


method e focus id index
  arg_rw DocumentEditorContext e ; arg Str id ; arg Int index
  implicit context e
    cid := id ; cindex := index
    var Pointer:StorageNode n :> d search_node id
    if exists:n and index<>undefined
      context focus_set (shunt n:has_style "f " "")+id index


method e bloc_overwrite id
  arg_rw DocumentEditorContext e ; arg Str id
  implicit e
    var Pointer:StorageNode n :> d search_node id
    if exists:n
      context:connection oraw open (cast "section_overwrite" Ident) id body
      n send context:connection false
      context:connection oraw close


method e bloc_create_after id tag -> id2
  arg_rw DocumentEditorContext e ; arg Str id tag id2
  implicit e
    id2 := generate_id
    var Pointer:StorageNode n :> d search_node id
    if exists:n
      var Pointer:StorageNode bloc :> d create_node id2 tag
      d stick bloc stick_after n
      var Pointer:StorageNode txt :> d create_node generate_id "text"
      d set_attr txt "" ""
      d stick txt stick_tail bloc
      context:connection oraw open (cast "section_after" Ident) n:id body
      bloc send context:connection true
      context:connection oraw close


method e bloc_delete id
  arg_rw DocumentEditorContext e ; arg Str id
  implicit e
    var Pointer:StorageNode n :> d search_node id
    if exists:n
      context section_delete id
      d delete_node n


method e bloc_cut
  arg_rw DocumentEditorContext e
  implicit e
    var Pointer:StorageNode n :> d search_node cid
    if exists:n and (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
      var Str32 t := utf8_decode (node attr "")
      if index<t:len
        var Str id2 := bloc_create_after cid n:tag
        if (d locate id2 0 (var Pointer:StorageNode node2) (var Int index2))
          d set_attr node2 "" utf8_encode:(t index t:len)
          bloc_overwrite id2
          d set_attr node "" utf8_encode:(t 0 index)
          bloc_overwrite cid
      

method e text_cut
  arg_rw DocumentEditorContext e
  implicit e
    var Pointer:StorageNode n :> d search_node cid
    if exists:n and (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
      var Str32 t := utf8_decode (node attr "")
      if index<t:len
        var Pointer:StorageNode node2 :> d create_node generate_id "text"
        d stick node2 stick_after node
        d set_attr node2 "" utf8_encode:(t index t:len)
        d set_attr node "" utf8_encode:(t 0 index)


method d bloc_stick_rec n -> modified
  arg_rw StorageDocument d ; arg_rw StorageNode n ; arg CBool modified
  modified := false
  var Pointer:StorageNode n2 :> n first
  while exists:n2
    while n2:tag="text" and (exists n2:next) and n2:next:tag="text" and { var Str32 t := utf8_decode (n2 attr "") ; t:len=0 or (t t:len-1)<>"[lf]" }
      d set_attr n2 "" (n2 attr "")+(n2:next attr "")
      d delete_node n2:next
      modified := true
    if (d bloc_stick_rec n2)
      modified := true
    n2 :> n2 next

method e bloc_stick id
  arg_rw DocumentEditorContext e ; arg Str id
  implicit e
    var Pointer:StorageNode n :> d search_node id
    if exists:n and (d bloc_stick_rec n)
      bloc_overwrite id


#-------------------------------------------------------------------------
#  Main interface


ui_function tree_view n head
  arg StorageNode n ; arg Str head
  para stick
    style use "view_tab"
      text head
    style use "view_tag"
      text n:tag
    var CBool found := n first_attr (var Str a) (var Str v)
    while found
      text " "
      style use "view_attr"
        text a
      text " "
      style use (shunt n:tag="text" and a="" "view_text" "view_value")
        text string:v
      found := n next_attr a v
    text " "
    style use "view_id"
      text n:id
  var Pointer:StorageNode n2 :> n first
  while exists:n2
    tree_view n2 head+"  "
    n2 :> n2 next


ui_function document_editor url
  arg Str url
  if not (url eparse "/" any:(var Str site) "/" any:(var Str category) "/" any:(var Str object) "/" any:(var Str fiber))
    console "wrong url" eol
    url_return
    return
  ovar DocumentEditorContext e
  e context :> context
  e d :> (storage_object site category object fiber StorageDocument) map StorageDocument
  if not (exists e:d)
    var Link:StorageControl c :> storage_control site category object
    if not exists:c
      console "no control" eol
      url_return
      return
    c fiber_create fiber "StorageDocument"
    e d :> (storage_object site category object fiber StorageDocument) map StorageDocument
    if not (exists e:d)
      console "no fiber" eol
      url_return
      return
    var Pointer:StorageNode n1 :> e:d create_node "" "document"
    var Pointer:StorageNode n2 :> e:d create_node generate_id "para"
    e:d stick n2 stick_tail n1
    var Pointer:StorageNode n3 :> e:d create_node generate_id "text"
    e:d set_attr n3 "" ""
    e:d stick n3 stick_tail n2
  eif false
    var Pointer:StorageNode n :> e:d search_node ""
    if exists:n and n:tag="sequence"
      e:d set_tag n "document"
  implicit e
    style_copy "" "link"
    style_set "link" "standard/text/color" (color rgb 0 0 192)
    style_copy "" "tree_view"
    style_set "tree_view" "standard/para/wrap" false
    style_copy "tree_view" "view_tab"
    style_set "view_tab" "standard/text/font" "Bitstream Vera Sans Mono"
    style_copy "tree_view" "view_tag"
    style_set "view_tag" "standard/text/color" (color rgb 96 0 0)
    style_copy "tree_view" "view_attr"
    style_set "view_attr" "standard/text/font" "Bitstream Vera Sans Mono Oblique"
    style_set "view_attr" "standard/text/size" 10/72*25.4
    style_set "view_attr" "standard/text/color" (color rgb 0 96 0)
    style_copy "tree_view" "view_value"
    style_set "view_value" "standard/text/color" (color rgb 0 96 0)
    style_copy "tree_view" "view_text"
    style_copy "tree_view" "view_id"
    style_set "view_id" "standard/text/font" "Bitstream Vera Sans"
    style_set "view_id" "standard/text/size" 8/72*25.4
    style_set "view_id" "standard/text/color" (color rgb 128 128 128)
    window top
      section "parameters"
        void
    window left
      section "menu" dynamic
        if menu="insert"
          button "title" key "alt e"
            if (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
              bloc_cut
              var Str id2 := bloc_create_after cid "title"
              focus id2 0
          eol
          button "header" key "alt h"
            if (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
              bloc_cut
              var Str id2 := bloc_create_after cid "header"
              focus id2 0
          eol
          button "para" key "alt p" selected action="para"
            if (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
              bloc_cut
              var Str id2 := bloc_create_after cid "para"
              focus id2 0
          eol
          button "table" key "alt t" active false
            void
          eol
          button "subpage" key "alt s"
            if (d locate cid cindex (var Pointer:StorageNode node) (var Int index)) and node:parent:is_bloc
              text_cut
              var Pointer:StorageNode link :> d create_node generate_id "link"
              var Str id := generate_id
              d set_attr link "url" id
              d set_attr link "master" "true"
              d stick link stick_after node
              var Pointer:StorageNode txt :> d create_node generate_id "text"
              d stick txt stick_tail link
              bloc_overwrite cid
              focus cid cindex+1
          eol
          button "exit" key "escape"
            menu := "" ; action := ""
            section_replay "menu"
            section_overwrite "help"
              void
        eif menu="view"
          button "exit" key "escape"
            menu := "" ; action := ""
            section_replay "menu"
            section_overwrite "help"
              void
            section_overwrite "document"
              var Pointer:StorageNode n :> e:d search_node ""
              if exists:n
                n send e:context:connection true
        else
          button "navigate" key "alt n" selected action="navigate"
            action := shunt action<>"navigate" "navigate" ""
            section_replay "menu"
            section_overwrite "help"
              if action="navigate"
                text "Clic on the link you want to follow."
          eol
          button "type in" key "alt i"
            menu := "insert" ; action := ""
            section_replay "menu"
            section_overwrite "help"
              void
          eol
          button "attribute" key "alt a" active false
            void
          eol
          button "tree view" key "alt v"
            menu := "view" ; action := ""
            section_replay "menu"
            section_overwrite "help"
              void
            section_overwrite "document"
              style use "tree_view"
                var Pointer:StorageNode n :> e:d search_node ""
                if exists:n
                  tree_view n ""
          eol
          button "exit" key "alt x"
            pending_flush
            url_return
    window main
      hook
        section "document"
          var Pointer:StorageNode n :> e:d search_node ""
          if exists:n
            n send e:context:connection true
      event
        if action="view"
          void
        eif event="character"
          pending += utf8_decode key
        eif event="uncharacter"
          void
        else
          pending_flush
          if event="press" and key="button1"
            e aid := shunt (pointer_section 0 2)="f " (pointer_section 2 pointer_section:len) pointer_section ; e aindex := pointer_index
            if action="navigate" and (d locate e:aid e:aindex (var Pointer:StorageNode node) (var Int index))
              while exists:node and not node:is_bloc
                if node:tag="link" and (url eparse "/" any:(var Str site) "/" any:(var Str category) "/" any:(var Str object) "/" any:(var Str fiber))
                  var Str url2 := (context:url 0 context:url:len-context:subpath:len)+site+"/"+category+"/"+(node attr "url")+"/"+fiber
                  url_call url2
                  return
                node :> node parent
            focus e:aid e:aindex
          eif event="release" and key="button1"
            e bid := shunt (pointer_section 0 2)="f " (pointer_section 2 pointer_section:len) pointer_section ; e bindex := pointer_index
          eif event="press" and key="backspace"
            if cindex>0 and (d locate cid cindex-1 (var Pointer:StorageNode node) (var Int index))
              var Str32 t := utf8_decode (node attr "")
              d set_attr node "" (utf8_encode (t 0 index)+(t index+1 t:len))
              bloc_overwrite cid
              focus cid cindex-1
            eif cindex=0
              var Pointer:StorageNode n :> d search_node cid
              if exists:n and n:is_bloc and (exists n:previous) and n:previous:is_bloc
                var Str id := n:previous id ; var Int index := (d count id)-1
                var Pointer:StorageNode n2 :> n first
                while exists:n2
                  var Pointer:StorageNode n3 :> n2 next
                  d stick n2 stick_tail n:previous
                  n2 :> n3
                bloc_delete n:id
                bloc_stick id
                bloc_overwrite id
                focus id index
          eif event="press" and key="delete"
            if (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
              var Str32 t := utf8_decode (node attr "")
              if t:len>0
                d set_attr node "" (utf8_encode (t 0 index)+(t index+1 t:len))
                bloc_stick cid
                bloc_overwrite cid
                focus cid cindex
              eif (d count cid)=1
                bloc_delete cid
          eif event="press" and key="ctrl delete"
            if (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
              bloc_delete cid
          eif event="press" and key="enter" and (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
            var Str32 t := utf8_decode (node attr "")
            d set_attr node "" (utf8_encode (t 0 index)+"[lf]")
            var Pointer:StorageNode txt :> d create_node generate_id "text"
            d stick txt stick_after node
            d set_attr txt "" utf8_encode:(t index t:len)
            bloc_overwrite cid
            focus cid cindex+2              
          eif event="press" and key="left"
            if cindex>0
              focus cid cindex-1
          eif event="press" and key="right"
            if cindex+1<(d count cid)
              focus cid cindex+1
          eif event="press" and key="home"
            focus cid 0
          eif event="press" and key="end"
            focus cid (d count cid)-1
          else
            void # console "event '"+event+"' key '"+key+"'" eol
    window bottom
      section "help"
        void