Patch title: Release 85 bulk changes
Abstract:
File: /pliant/protocol/http/style/common.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/language/stream.pli"
module "/pliant/admin/file.pli"
module "/pliant/protocol/http/server.pli"
module "/pliant/util/encoding/neutral.pli"
module "/pliant/admin/md5.pli"
submodule "/pliant/graphic/color/rgb888.pli"
submodule "/pliant/protocol/http/stack.pli"


public
  constant html32 false
  constant database true
  constant slash "" # change it with " /" if you want XML files
  
if database
  submodule "/pliant/appli/database.pli"
  module "/pliant/language/data/string_cast.pli"


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

public 
  gvar Dictionary html_attr_dict
  gvar Sem html_attr_dict_sem

type HtmlAttribute
  field Int index <- undefined ; field Link:Type type ; field Arrow default
  field Str pliant_id ; field Str html_id
  field CBool encode <- false
  field uInt flag <- 0
  field Array:Str sequence

type HtmlTag
  field Int tag_open_index tag_close_index
  field Str pliant_id html_id
  field Dictionary attributes
  field Array:Str required
  field CBool subpage <- false ; field Int subpage_index ; field Str subpage_id
  field CBool body <- false
  field CBool hidden <- false
  field CBool newline <- false

export HtmlTag


#---------------------------------------------------------------------------
#  context
#  styling


method p request -> r
  arg HtmlPage p ; arg_C HttpRequest r
  r :> p:http_request
  
  r :> p http_request
 
method p server -> s
  arg HtmlPage p ; arg_C HttpServer s
  s :> p:http_request server
  
method p browser -> b
  arg HtmlPage p ; arg_C Str b
  b :> p:http_request browser_model
  
method p variable name -> value
  arg HtmlPage p ; arg Str name value
  if ("&"+p:request:form+"&"+p:request:url_options+"&" parse any (pattern "&"+name+"=") any:value "&" any)
    value := replace http_decode:value "[cr][lf]" "[lf]"
  else
    value := ""

export '. request' '. server' '. variable'
export '. request' '. server' '. browser' '. variable'


method p write raw
  arg_rw HtmlPage p ; arg Str raw
  p:http_stream writechars raw

#---------------------------------------------------------------------------
#  new tags helper
method p write_attributes
  arg_rw HtmlPage p
  p:html_stack walk (var Str id) (var Str value)
  while (p:html_stack another id value)
    p write " "
    p write id
    p write "=[dq]"
    p write value
    p write "[dq]"

export '. write' '. write_attributes'

function simple_bloc_tag_meta e tag
  arg_rw Expression e ; arg Str tag
  if e:size<>2 or not (e:0 cast HtmlPage)
    return
  e:1 compile ?
  e suckup e:0
  e add (instruction (the_function '. tag' HtmlPage Str Str) e:0:result (argument constant Str tag) (argument constant Str ""))
  e suckup e:1
  e add (instruction (the_function '. tag' HtmlPage Str Str) e:0:result (argument constant Str "/"+tag) (argument constant Str ""))
  e set_void_result

named_expression simple_bloc_tag_prototype
  meta id e
   simple_bloc_tag_meta e tag
  export id
method p map_attribute index -> a
  arg HtmlPage p ; arg Int index ; arg Address a
  a := p:html_stack map index

meta simple_bloc_tag e
  if e:size<>1 or not e:0:is_pure_ident
    return
  e compile_as (expression duplicate simple_bloc_tag_prototype substitute id (expression ident ". "+e:0:ident near e:0) substitute tag (expression constant e:0:ident near e:0))
meta '' e
  if e:size=2 and e:1:is_pure_ident
    var Link:HtmlTag t :> (pliant_general_dictionary first "pliant current tag") map HtmlTag
    if exists:t and (entry_type addressof:t)=HtmlTag
      var Link:HtmlAttribute a :> (t:attributes first e:1:ident) map HtmlAttribute
      if exists:a and (exists a:type) and (e:0 cast HtmlPage)
        e suckup e:0
        var Link:Argument r :> argument local (pointerto a:type)
        e add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int a:index) r)
        e set_result r access_read+access_write
      eif t:subpage and e:1:ident=t:subpage_id and (e:0 cast HtmlPage)
        e suckup e:0
        var Link:Argument r :> argument local Pointer:Str
        e add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int t:subpage_index) r)
        e set_result r access_read+access_write

meta '. attribute' e
  if e:size=3 and e:1:is_pure_ident and e:2:is_pure_ident
    var Pointer:Arrow c :> e:module first ". "+e:1:ident
    while c<>null and entry_type:c<>HtmlTag
      c :> e:module next ". "+e:1:ident c
    if c<>null
      var Link:HtmlTag t :> c map HtmlTag
      var Link:HtmlAttribute a :> (t:attributes first e:2:ident) map HtmlAttribute
      if exists:a and (exists a:type) and (e:0 cast HtmlPage)
        e suckup e:0
        var Link:Argument r :> argument local (pointerto a:type)
        e add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int a:index) r)
        e set_result r access_read+access_write
      eif t:subpage and e:2:ident=t:subpage_id and (e:0 cast HtmlPage)
        e suckup e:0
        var Link:Argument r :> argument local Pointer:Str
        e add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int t:subpage_index) r)
        e set_result r access_read+access_write

method p push_attribute index value type
  arg_rw HtmlPage p ; arg Int index ; arg Universal value ; arg Type type
  p:html_stack push index addressof:value type

meta '. push' e
  if e:size=3 and e:1:is_pure_ident
    var Link:HtmlTag t :> (pliant_general_dictionary first "pliant current tag") map HtmlTag
    if exists:t and (entry_type addressof:t)=HtmlTag
      var Link:HtmlAttribute a :> (t:attributes first e:1:ident) map HtmlAttribute
      if exists:a and (exists a:type) and (e:0 cast HtmlPage) and (e:2 cast a:type)
        e suckup e:0
        e suckup e:2
        e add (instruction (the_function '. push_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int a:index) e:2:result (argument mapped_constant Type a:type))
        e set_void_result
  eif e:size=4 and e:1:is_pure_ident and e:2:is_pure_ident
    var Pointer:Arrow c :> e:module first ". "+e:1:ident
    while c<>null and entry_type:c<>HtmlTag
      c :> e:module next ". "+e:1:ident c
    if c<>null
      var Link:HtmlTag t :> c map HtmlTag
      var Link:HtmlAttribute a :> (t:attributes first e:2:ident) map HtmlAttribute
      if exists:a and (exists a:type) and (e:0 cast HtmlPage) and (e:3 cast a:type)
        e suckup e:0
        e suckup e:3
        e add (instruction (the_function '. push_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int a:index) e:3:result (argument mapped_constant Type a:type))
        e set_void_result

meta has e
  if e:size=1 and e:0:is_pure_ident
    var Link:HtmlTag t :> (pliant_general_dictionary first "pliant current tag") map HtmlTag
    if exists:t and (entry_type addressof:t)=HtmlTag
      var Link:HtmlAttribute a :> (t:attributes first e:0:ident) map HtmlAttribute
      if exists:a and a:flag<>0
        e compile_as (expression immediat (flags .and. flag)<>0 substitute flag (expression constant a:flag near e))
 
export '. attribute' '' '. push' has


method p tag_hook_prototype tag flags fun
  arg_rw HtmlPage p ; arg HtmlTag tag ; arg uInt flags ; arg Function fun
  indirect

method p record_tag_hook index hook
  arg_rw HtmlPage p ; arg Int index ; arg Function hook
  var Pointer:Function ptr :> hook
  p:html_stack push index (addressof Pointer:Function ptr) Link:Function

named_expression style_tag_prototype
  method page 'pliant style tag function' tag flags
    arg_rw HtmlPage page ; arg HtmlTag tag ; arg uInt flags
    body

function style_tag_meta e open
  arg_rw Expression e ; arg CBool open
  if e:size=3 and (e:0 cast HtmlPage) and e:1:is_pure_ident and e:2:ident="{}"
    var Pointer:Arrow c :> pliant_general_dictionary first ". "+e:1:ident
    while c<>null and entry_type:c<>HtmlTag
      c :>  pliant_general_dictionary next ". "+e:1:ident c
    if c<>null and entry_type:c=HtmlTag
      var Link:HtmlTag t :> c map HtmlTag
      var Address mark := e:module mark
      e:module define "pliant current tag" addressof:t
      var Link:Expression ee :> expression duplicate style_tag_prototype substitute body e:2 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 style tag function") map Function
      e:module rewind mark
      if exists:f
        pliant_general_dictionary remove ". pliant style tag function" addressof:f
        e suckup e:0
        e add (instruction (the_function '. record_tag_hook' HtmlPage Int Function) e:0:result (argument constant Int (shunt open t:tag_open_index t:tag_close_index)) (argument mapped_constant Function f))
        e set_void_result

meta '. style_tag' e
  style_tag_meta e true

meta '. style_open' e
  style_tag_meta e true

meta '. style_close' e
  style_tag_meta e false

export '. style_tag' '. style_open' '. style_close'


#---------------------------------------------------------------------------
#  subpages helpers


function new_button_id e -> id
  arg Str id ; arg_rw Expression e
  if false
    var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
    part get_function
      if c=null or entry_type:c<>Function
        return ""
      var Link:Function current_function :> c map Function
      if (current_function:name parse word:"frozen" word:"expression" any)
        c :> pliant_general_dictionary next "pliant function" c
        restart get_function
    var Pointer:Int counter :> current_function:properties kmap "pliant style standard button counter" Int 0
  var Pointer:Int counter :> e:module:properties kmap "pliant style standard button counter" Int 0
  counter += 1
  var Str name := replace e:module:name " (internals)" ""
  var Str filename := replace name ".html" ".page"
  var Str timestamp := string (file_query filename standard):datetime
  timestamp := replace timestamp " " ""
  timestamp := replace timestamp "/" ""
  timestamp := replace timestamp ":" ""
  timestamp := replace timestamp "?" ""
  id := name+"|"+timestamp+"|"+string:counter


function update_button_types
  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
  var Link:List buttons :> current_function:properties kmap "pliant button types" List
  c :> buttons first
  while c<>null
    if entry_type:c=Type
      var Pointer:Type type :> c map Type
      for (var Int i) 0 type:nb_fields-1
        var Pointer:TypeField tf :> type field i
        if tf:name<>"page"
          if ((current_function:properties kmap "pliant editable variables" Dictionary) first tf:name)<>null
            tf:properties kmap "pliant editable" CBool := true
    c :> buttons next c

function notify_button_type t
  arg_rw Type t
  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
  var Link:List buttons :> current_function:properties kmap "pliant button types" List
  buttons append addressof:t  
  update_button_types   

function notify_editable_variable e
  arg_rw Expression 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:result:name<>""
    (current_function:properties kmap "pliant editable variables" Dictionary) kmap e:result:name CBool := true
    update_button_types   


function html_reset_context context
  arg_w Str context
  context := ""
    
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

function html_add_to_context context ident data fun
  arg_rw Str context ; arg Str ident ; arg Universal data ; arg Function fun
  context += "&"+ident+"="+http_encode:(to_string data "raw" fun)

if database

  function data_add_to_context context ident data
    arg_rw Str context ; arg Str ident ; arg Data_ data
    context += "&"+ident+"="+(http_encode data:path)

named_expression button_framework
  body
    
function button_expression e options button_id ctx -> ok
  arg_rw Expression e ; arg Str options ; arg_w Str button_id ; arg_w Link:Argument ctx ; arg CBool ok
  ok := false
  var Link:Function current_function
  var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
  if c<>null and entry_type:c=Function
    current_function :> c map Function
  else
    current_function :> new Function
  var Int index := options option "index" Int e:size-1
  var Link:Expression body :> expression duplicate button_framework substitute body e:index near e:index
  var List expressions byaddress ; var List functions ; var Link:Type type
  expressions append addressof:body
  byaddress append addressof:(new Ident (cast "page" Ident))
  body freeze expressions byaddress functions type ?
  copy_properties body:0 e:index
  var CBool stay := false
  for (var Int i) 0 body:size-1
    if body:i:is_pure_ident and (body:i:ident="reload_page" or body:i:ident="goto_backward" or body:i:ident="close")
      stay := true
  if (stay or (options option "stay")) and not (options option "nostay")
    type:properties kmap "http stay" Void := void
  ctx :> argument local Str
  e add (instruction (the_function html_reset_context Str) ctx)
  for (var Int i) 0 type:nb_fields-1
    var Pointer:TypeField tf :> type field i
    if tf:name<>"page"
      var Link:Expression id :> expression ident tf:name near body
      id compile ?
      var CBool data := database and id:is_data
      if database and data
        e suckup id
        e add (instruction (the_function data_add_to_context Str Str Data_) ctx (argument constant Str tf:name) id:result)
      eif ((current_function:properties kmap "pliant editable variables" Dictionary) first tf:name)=null
        var Pointer:Type t :> id:result:type real_data_type
        if not (id cast t)
          error error_id_compile "Cannot cast '"+tf:name+"' to a real data that could be passed back when the button is pressed."
          return
        var Pointer:Function function :> t get_generic_method to_index
        if not exists:function or function=(the_function '. to string' Universal Str -> Str)
        var Pointer:Function fun :> t get_generic_method to_index
        if not exists:fun or fun=(the_function '. to string' Universal Str -> Str)
          error error_id_compile "Cannot convert '"+tf:name+"' to a string that could be passed back when the button is pressed."
          return
        e suckup id
        e add (instruction (the_function html_add_to_context Str Str Universal Function) ctx (argument constant Str tf:name) id:result (argument mapped_constant Function function))
        e add (instruction (the_function html_add_to_context Str Str Universal Function) ctx (argument constant Str tf:name) id:result (argument mapped_constant Function fun))
  button_id := new_button_id e
  var Link:Function sub_function :> functions:first map Function
  # var Pointer:Arrow c :> current_function:properties first "style"
  # while c<>null
  #   if entry_type:c=Str
  #     sub_function:properties insert "style" false c
  #   c :> current_function:properties next "style" c
  http_record_dynamic_page button_id e:position sub_function type
  notify_button_type type
  ok := true

export simple_bloc_tag simple_bloc_tag_meta
export new_button_id notify_editable_variable notify_button_type button_expression


#---------------------------------------------------------------------------
#  colors
#  new tags helper


type PixelRGB888
  field uInt8 red green blue
method p tag_begin
  arg_rw HtmlPage p
  p:html_stack mark

function rgb_pixel r g b -> p
  arg Int r g b ; arg PixelRGB888 p
  p red := r ; p green := g ; p blue := b
method p set_attribute index value type
  arg_rw HtmlPage p ; arg Int index ; arg Universal value ; arg Type type
  p:html_stack push index addressof:value type

function lsh_pixel l s h -> p
  arg Float l s h ; arg PixelRGB888 p
  check h>=0 and h<360
  for (var Int i) 0 2
    var Float hi := h-120*i
    while hi<(-180)
      hi += 360
    while hi>=180
      hi -= 360
    var Float f := shunt hi<0 (1/60)*hi+2 -(1/60)*hi+2
    f := shunt f<=0 0 f>=1 1 f
    f :=  f*s/100 + l/100*(1-s/100)
    (addressof:p translate uInt8 i) map uInt8 := cast f*255 uInt
method p encode_attribute index value
  arg_rw HtmlPage p ; arg Int index ; arg Str value
  var Str encoded := html_encode value
  p:html_stack push index addressof:encoded Str

function component255 i -> c
  arg Int i ; arg Str c
  check i>=0 and i<256
  c := right (string i "radix 16") 2 "0"
method p set_extra id value
  arg_rw HtmlPage p ; arg Str id value
  p:html_stack set id value

method p html_encoding -> c
  arg PixelRGB888 p ; arg Str c
  c := "#"+(component255 p:red)+(component255 p:green)+(component255 p:blue)
method p set_extra id u f
  arg_rw HtmlPage p ; arg Str id ; arg Universal u ; arg Function f
  p:html_stack set id (to_string u "html" f)

export PixelRGB888 '. red' '. green' '. blue'
export lsh_pixel rgb_pixel '. html_encoding'
method p set_subpage index id context
  arg_rw HtmlPage p ; arg Int index ; arg Str id context
  var Str url := "button 0 0 "+id+" "+(p:request cipher context)+" "+(p:request generate_signature id+" "+context)
  p:html_stack push index addressof:url Str

method p tag_open tag flags
  arg_rw HtmlPage p ; arg HtmlTag tag ; arg uInt flags
  p tag_hook_prototype tag flags ((p:html_stack map tag:tag_open_index) map Pointer:Function)

method p tag_close tag flags
  arg_rw HtmlPage p ; arg HtmlTag tag ; arg uInt flags
  p tag_hook_prototype tag flags ((p:html_stack map tag:tag_close_index) map Pointer:Function)
  p:html_stack rewind

method p tag_end
  arg_rw HtmlPage p
  p:html_stack rewind

function active_type t access e
  arg HtmlTag t ; arg Int access ; arg_rw Expression e
  if t:hidden
    return
  if e:size<1 or not (e:0 cast HtmlPage)
    return
  e suckup e:0
  e add (instruction (the_function '. tag_begin' HtmlPage) e:0:result)
  var uInt flags := 0
  var Int i := 1 ; var Int stop := e:size-(shunt t:body or t:subpage 1 0)
  for (var Int j) 0 t:required:size-1
    var Link:HtmlAttribute a :> (t:attributes first t:required:j) map HtmlAttribute
    if (exists a:type)
      if i>=stop or not (e:i cast a:type)
        return
      e suckup e:i
      if a:encode
        if a:type=Str
          e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int a:index) e:i:result)
        else
          return
      else
        e add (instruction (the_function '. set_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int a:index) e:i:result (argument mapped_constant Type a:type))
    eif i>=stop or e:i:ident<>a:pliant_id
      return
    flags += a flag
    i += 1
  while i<stop
    if e:i:is_pure_ident
      var Link:HtmlAttribute a :> (t:attributes first e:i:ident) map HtmlAttribute
      if exists:a
        if a:sequence:size>0
          for (var Int j) 0 a:sequence:size-1
            var Link:HtmlAttribute b :> (t:attributes first a:sequence:j) map HtmlAttribute
            if not exists:b or not (exists b:type)
              return
            i += 1
            if i>=stop or not (e:i cast b:type)
              return
            e suckup e:i
            if b:encode
              if b:type=Str
                e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int b:index) e:i:result)
              else
                return
            else
              e add (instruction (the_function '. set_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int b:index) e:i:result (argument mapped_constant Type b:type))
            flags += b flag
        eif (exists a:type)
          i += 1
          if i>=stop or not (e:i cast a:type)
            return
          e suckup e:i
          if a:encode
            if a:type=Str
              e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int a:index) e:i:result)
            else
              return
          else
            e add (instruction (the_function '. set_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int a:index) e:i:result (argument mapped_constant Type a:type))
        flags += a flag
      else
        i += 1
        if i>=stop
          return
        e:i compile ?
        var Pointer:Type rt :> e:i:result:type:real_data_type
        e:i cast rt ?
        e suckup e:i
        if rt<>Str
          var Link:Function function :> rt get_generic_method to_index
          if addressof:function=null or addressof:function=addressof:(the_function '. to string' Universal Str -> Str)
            return
          e add (instruction (the_function '. set_extra' HtmlPage Str Universal Function) e:0:result (argument constant Str e:(i-1):ident) e:i:result (argument mapped_constant Function function))
        else
          e add (instruction (the_function '. set_extra' HtmlPage Str Str) e:0:result (argument constant Str e:(i-1):ident) e:i:result)
    eif e:i:ident="style" and e:i:size>=3 and e:i:0:is_pure_ident
      var Pointer:Arrow c :> e:module first ". "+e:i:0:ident
      while c<>null and entry_type:c<>HtmlTag
        c :> e:module next ". "+e:i:0:ident c
      if c=null
        return
      var Int j := 1
      while j<e:i:size
        var Link:HtmlAttribute a :> ((c map HtmlTag):attributes first e:i:j:ident) map HtmlAttribute
        if not exists:a
          return
        if a:sequence:size>0
          for (var Int k) 0 a:sequence:size-1
            var Link:HtmlAttribute b :> ((c map HtmlTag):attributes first a:sequence:k) map HtmlAttribute
            if not exists:b or not (exists b:type)
              return
            j += 1
            if j>=e:i:size or not (e:i:j cast b:type)
              return
            e suckup e:i:j
            if b:encode
              if b:type=Str
                e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int b:index) e:i:j:result)
              else
                return
            else
              e add (instruction (the_function '. set_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int b:index) e:i:j:result (argument mapped_constant Type b:type))
        eif (exists a:type)
          j += 1
          if j>=e:i:size or not (e:i:j cast a:type)
            return
          e suckup e:i:j
          if a:encode
            if a:type=Str
              e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int a:index) e:i:j:result)
            else
              return
          else
            e add (instruction (the_function '. set_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int a:index) e:i:j:result (argument mapped_constant Type a:type))
        else
          return
        j += 1
    else
      return
    i += 1
  if i<>stop
    return
  if t:subpage
    if not (button_expression e "" (var Str button_id) (var Link:Argument ctx))
      return
    e add (instruction (the_function '. set_subpage' HtmlPage Int Str Str) e:0:result (argument constant Int t:subpage_index) (argument constant Str button_id) ctx)
  e add (instruction (the_function '. tag_open' HtmlPage HtmlTag uInt) e:0:result (argument mapped_constant HtmlTag t) (argument constant uInt flags))
  if t:body
    e:i compile ?
    e suckup e:i
  if t:tag_close_index<>undefined
    e add (instruction (the_function '. tag_close' HtmlPage HtmlTag uInt) e:0:result (argument mapped_constant HtmlTag t) (argument constant uInt flags))
  else
    e add (instruction (the_function '. tag_end' HtmlPage) e:0:result)
  e set_void_result


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

meta sequence e
  if e:size<>2 or not e:0:is_pure_ident
    return
  var Link:HtmlTag t :> the_tag e
  if not exists:t
    return
  if e:size<1 or not e:0:is_pure_ident
    return
  var Address mark := e:module mark
  var Link:HtmlAttribute a :> new HtmlAttribute
  a pliant_id := e:0 ident ; a html_id := a pliant_id
  e:module define "pliant current html sequence" addressof:a
  e:1 compile
  e:module rewind mark ?
  if (t:attributes first a:pliant_id)=null
    a flag := 2^t:attributes:count
    t:attributes insert a:pliant_id true addressof:a
  e set_void_result

meta attr e
  var Link:HtmlTag t :> the_tag e
  if not exists:t
    return
  if e:size<1 or not e:0:is_pure_ident
    return
  var Link:HtmlAttribute a :> new HtmlAttribute
  a pliant_id := e:0 ident ; a html_id := a pliant_id
  var Int i := 1
  while i<e:size
    if (exists a:type) and a:type=Str and e:i:ident="encode"
      a encode := true ; i += 1
    eif e:i:ident="->" and i+1<e:size and e:(i+1):ident<>""
      a html_id := e:(i+1) ident ; i += 2
    eif (e:i constant Type)<>null
      a type :> (e:i constant Type) map Type ; i += 1
    eif (exists a:type) and (e:i constant a:type)<>null
      a default := entry_new a:type
      a:type copy_instance (e:i constant a:type) a:default
      i += 1
    else
      return
  if (t:attributes first a:pliant_id)=null
    a flag := 2^t:attributes:count
    t:attributes insert a:pliant_id true addressof:a
    var Pointer:Arrow c :> pliant_general_dictionary first "pliant current html sequence"
    if c<>null and entry_type:c=HtmlAttribute
      (c map HtmlAttribute) sequence += a pliant_id
  e set_void_result

meta subpage e
  var Link:HtmlTag t :> the_tag:e
  if exists:t and e:size=1 and e:0:ident<>""
    t subpage := true
    t subpage_id := e:0 ident
    e set_void_result

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

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

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

method p default_tag_hook t flags
  arg_rw HtmlPage p ; arg HtmlTag t ; arg uInt flags
  p write "<"
  p write t:html_id
  p write_attributes
  if t:newline
    p write ">[lf]"
  else
    p write ">"

method p default_tag_open_hook t flags
  arg_rw HtmlPage p ; arg HtmlTag t ; arg uInt flags
  p write "<"
  p write t:html_id
  p write_attributes
  p write ">"

method p default_tag_close_hook t flags
  arg_rw HtmlPage p ; arg HtmlTag t ; arg uInt flags
  p write "</"
  p write t:html_id
  # p write_attributes
  if t:newline
    p write ">[lf]"
  else
    p write ">"

method t record_attributes
  arg_rw HtmlTag t
  each a t:attributes type HtmlAttribute
    if a:index=undefined
      if (exists a:type)
        a index := html_stack_slot a:type a:default
      else
        a index := -1
    html_attr_dict_sem request
    html_attr_dict insert t:pliant_id+"/"+a:pliant_id true addressof:a
    html_attr_dict_sem release


meta html_tag e
  if e:size<2 or not e:0:is_pure_ident
    return
  var Pointer:Arrow c :> pliant_general_dictionary first ". "+e:0:ident
  while c<>null and entry_type:c<>HtmlTag
    c :>  pliant_general_dictionary next ". "+e:0:ident c
  var Link:HtmlTag t
  if c<>null
    t :> c map HtmlTag
  else
    t :> new HtmlTag
  t pliant_id := e:0 ident ; t html_id := t pliant_id
  var Int i := 1
  while i<e:size-1
    if e:i:ident="->"
      if i+1<e:size and e:(i+1):ident<>""
        t html_id := e:(i+1) ident
        i += 2
      else
        return
    eif e:i:is_pure_ident
      if c=null
        t required += e:i:ident
      i += 1
    else
      return
  var Address mark := e:module mark
  e:module define "pliant current html tag" addressof:t
  e:(e:size-1):compile ?
  e:module rewind mark
  for (var Int j) 0 t:required:size-1
    if (t:attributes first t:required:j)=null
      return
  t record_attributes
  if c=null
    if t:body
      var Pointer:Function f :> the_function '. default_tag_open_hook' HtmlPage HtmlTag uInt
      t tag_open_index := html_stack_slot Pointer:Function (addressof Pointer:Function f)
      var Pointer:Function f :> the_function '. default_tag_close_hook' HtmlPage HtmlTag uInt
      t tag_close_index := html_stack_slot Pointer:Function (addressof Pointer:Function f)
    else
      var Pointer:Function f :> the_function '. default_tag_hook' HtmlPage HtmlTag uInt
      t tag_open_index := html_stack_slot Pointer:Function (addressof Pointer:Function f)
      t tag_close_index := undefined
    if t:subpage
      t subpage_index := html_stack_slot Str null
    e define ". "+e:0:ident addressof:t e:module:actual
  e set_void_result

export html_tag sequence attr subpage body newline hidden


constant from_index (the_function '. from string' Universal Str Str CBool Int Int -> Status):generic_index

function from_string data string options may_skip skiped offset function -> status
  arg Universal data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Function function ; arg Status status
  indirect

method page parse_parameter values a attr_id tag_id -> status
  arg_rw HtmlPage page ; arg_rw Str values ; arg HtmlAttribute a ; arg Str attr_id tag_id ; arg ExtendedStatus status
  if not exists:a
    return (failure "Unknown attribute '"+attr_id+"' in tag '"+tag_id+"'")
  if a:sequence:size>0
    for (var Int k) 0 a:sequence:size-1
      var Link:HtmlAttribute b :> (html_attr_dict first tag_id+"/"+a:sequence:k) map HtmlAttribute
      status := page parse_parameter values b attr_id tag_id
      if status=failure
        return
    return
  if not (exists a:type)
    return (failure "Unsupported attribute '"+attr_id+"' in tag '"+tag_id+"'")
  var Pointer:Function fun :> a:type get_generic_method from_index
  if not exists:fun or fun=(the_function '. from string' Universal Str Str CBool Int Int -> Status)
    return (failure "Don't know how to parse attribute '"+attr_id+"' in tag '"+tag_id+"'")
  if (values parse "(" any:(var Str value) ")" any:(var Str remain))
    value := string value
    status := page parse_parameter value a attr_id tag_id
    values := remain
    return
  var Arrow obj := entry_new a:type
  status := from_string (obj map Universal) values "" true (var Int skiped) (var Int offset) fun
  if status=failure
    var Status retry := from_string (obj map Universal) values "raw" true (var Int skiped) (var Int offset) fun
    if retry=success and ((values skiped offset-skiped) search " " -1)=(-1)
      status := success
  if status=success
    page:html_stack push a:index obj a:type
    values := values offset values:len
  else
    status := failure "Incorrect value provided for attribute '"+attr_id+"' in tag '"+tag_id+"'[lf]"

method page html_attributes_setup
  arg_rw HtmlPage page
  var ExtendedStatus status := success
  html_attr_dict_sem rd_request
  part parse
    var Pointer:Str opt :> page:http_request:style_options
    var Int i := 0
    while { while (opt i 1)=" " { i += 1 } ; i<opt:len }
      var Int j := i+((opt i opt:len) search "[lf]" opt:len-i)
      if opt:i<>"#" and ((opt i j-i) parse any:(var Str tag_id) _ any:(var Str all))
        while { while (all 0 1)=" " { all := all 1 all:len } ; if (all 0 1)="#" { all := "" } ; all<>"" }
          if (all parse any:(var Str attr_id) _ any:(var Str values))
            var Link:HtmlAttribute a :> (html_attr_dict first tag_id+"/"+attr_id) map HtmlAttribute
            status := page parse_parameter values a attr_id tag_id
          else
            status := failure "No attribute provided for tag '"+tag_id+"'"
          if status=failure
            leave parse
          all := values
      i := j+1
  html_attr_dict_sem rd_release
  page:http_request style_options := shunt status=success "" status:message
  if status=failure
    console status:message eol

export '. html_attributes_setup'