mirror of https://gitlab.com/QEF/q-e.git
557 lines
13 KiB
Tcl
557 lines
13 KiB
Tcl
|
|
namespace eval ::helpdoc::schema {
|
|
|
|
# here is the definition of Tcl-commands that are used in schema
|
|
|
|
proc rootelement {name code} { uplevel 1 [list ::helpdoc::rootelement $name $code] }
|
|
proc element {name code} { uplevel 1 [list ::helpdoc::element $name $code] }
|
|
proc attribute {name code} { uplevel 1 [list ::helpdoc::attribute $name $code] }
|
|
proc @ {name code} { uplevel 1 [list ::helpdoc::@ $name $code] }
|
|
|
|
proc word {} { uplevel 1 [list ::helpdoc::word] }
|
|
proc string {} { uplevel 1 [list ::helpdoc::String] }
|
|
proc text {} { uplevel 1 [list ::helpdoc::text] }
|
|
proc clist {} { uplevel 1 [list ::helpdoc::clist] }
|
|
proc plist {} { uplevel 1 [list ::helpdoc::plist] }
|
|
|
|
proc ident {} { uplevel 1 [list ::helpdoc::ident] }
|
|
|
|
proc define {name code} { uplevel 1 [list ::helpdoc::define $name $code] }
|
|
proc ref {name} { uplevel 1 [list ::helpdoc::ref $name] }
|
|
|
|
proc optional {code} { uplevel 1 [list ::helpdoc::optional $code] }
|
|
proc interleave {code} { uplevel 1 [list ::helpdoc::interleave $code] }
|
|
proc choice {code} { uplevel 1 [list ::helpdoc::choice $code] }
|
|
proc ? {code} { uplevel 1 [list ::helpdoc::? $code] }
|
|
proc * {code} { uplevel 1 [list ::helpdoc::* $code] }
|
|
proc + {code} { uplevel 1 [list ::helpdoc::+ $code] }
|
|
|
|
proc ancestorElements {} { uplevel 1 [list ::helpdoc::ancestorElements] }
|
|
}
|
|
|
|
# actual implementation of commands ...
|
|
|
|
proc ::helpdoc::rootelement {name code} {
|
|
variable elemList
|
|
variable itemList
|
|
variable stackArr
|
|
variable state
|
|
|
|
parseMsg_ $name; puts ""
|
|
incr state(depth)
|
|
|
|
if { $state(rootVisited) } {
|
|
::tclu::abort "more than one rootelement; there can be only one !"
|
|
}
|
|
set state(rootVisited) 1
|
|
set state(rootElem) $name
|
|
|
|
lappend elemList $name
|
|
lappend itemList $name
|
|
|
|
|
|
$stackArr(currentElem) push $name
|
|
#eval $code
|
|
namespace eval schema $code
|
|
$stackArr(currentElem) pop
|
|
|
|
incr state(depth) -1
|
|
parseMsgOK_ $name
|
|
}
|
|
|
|
proc ::helpdoc::element {name code} {
|
|
variable elemList
|
|
variable itemList
|
|
variable state
|
|
variable stackArr
|
|
variable elemArr
|
|
|
|
parseMsg_ $name; puts ""
|
|
incr state(depth)
|
|
|
|
# check that $name does not exists
|
|
if { [::tclu::lpresent $elemList $name] } {
|
|
::tclu::abort "element \"$name\" already defined"
|
|
}
|
|
lappend elemList $name
|
|
lappend itemList $name
|
|
|
|
$stackArr(optional) push 0
|
|
$stackArr(interleave) push 0
|
|
|
|
set parentElem [$stackArr(currentElem) peek]
|
|
|
|
lappend elemArr(ELEMLIST,$parentElem) $name
|
|
lappend elemArr(OPTIONAL,$parentElem,$name) [$stackArr(optional) peek]
|
|
lappend elemArr(INTERLEAVE,$parentElem,$name) [$stackArr(interleave) peek]
|
|
lappend elemArr(REPETITION,$parentElem,$name) [$stackArr(repetition) peek]
|
|
|
|
$stackArr(currentElem) push $name
|
|
#eval $code
|
|
namespace eval schema $code
|
|
$stackArr(currentElem) pop
|
|
|
|
$stackArr(optional) pop
|
|
$stackArr(interleave) pop
|
|
|
|
incr state(depth) -1
|
|
parseMsgOK_ $name
|
|
}
|
|
|
|
proc ::helpdoc::@ {name code} {
|
|
# PURPOSE: used to define the @-prefixed tags
|
|
variable atTags
|
|
|
|
parseMsg_ $name;
|
|
|
|
# let's register the @ command at its type ...
|
|
|
|
set type [lindex $code 0]
|
|
|
|
switch -exact $type {
|
|
empty {
|
|
lappend atTags(empty) $name
|
|
}
|
|
special {
|
|
set regex [lindex $code 1]
|
|
if { $regex eq {} } {
|
|
::tclu::abort "no regexp specified for special type @-prefixed command @name"
|
|
}
|
|
lappend atTags(special) $name
|
|
set atTags(regexp,$name) $regex
|
|
}
|
|
word {
|
|
lappend atTags(word) $name
|
|
}
|
|
varname {
|
|
lappend atTags(varname) $name
|
|
}
|
|
text - list - string - clist - plist {
|
|
lappend atTags(text) $name
|
|
}
|
|
default {
|
|
::tclu::abort "unsupported content/datatype ($code) for @-prefixed command $name, must be obe of empty, word, varname, text, or special"
|
|
}
|
|
}
|
|
|
|
puts ok;
|
|
}
|
|
|
|
proc ::helpdoc::attribute {name code} {
|
|
# so far we assume attributes have arbitrary values (which means
|
|
# we ignore code)
|
|
|
|
variable itemList
|
|
variable stackArr
|
|
variable elemArr
|
|
|
|
parseMsg_ $name
|
|
|
|
set currentElem [$stackArr(currentElem) peek]
|
|
|
|
lappend itemList $name
|
|
lappend elemArr(ATTRLIST,$currentElem) $name
|
|
lappend attrArr(OPTIONAL,$currentElem) [$stackArr(optional) peek]
|
|
|
|
puts ok
|
|
}
|
|
|
|
|
|
proc ::helpdoc::define {name code} {
|
|
variable defineArr
|
|
variable itemList
|
|
|
|
parseMsg_ $name;
|
|
|
|
lappend itemList $name
|
|
set defineArr($name) $code
|
|
|
|
puts ok
|
|
}
|
|
|
|
|
|
proc ::helpdoc::empty {} {
|
|
variable stackArr
|
|
variable elemArr
|
|
set currentElem [$stackArr(currentElem) peek]
|
|
set elemArr(EMPTY,$currentElem) 1; # so far not used ...
|
|
}
|
|
|
|
proc ::helpdoc::word {} {
|
|
variable stackArr
|
|
variable elemArr
|
|
set currentElem [$stackArr(currentElem) peek]
|
|
set elemArr(WORD,$currentElem) 1
|
|
}
|
|
|
|
proc ::helpdoc::String {} {
|
|
# BEWARE: so far can be called only from element (because
|
|
# attribute does not yet support ...)
|
|
variable stackArr
|
|
variable elemArr
|
|
set currentElem [$stackArr(currentElem) peek]
|
|
set elemArr(STRING,$currentElem) 1
|
|
}
|
|
|
|
|
|
proc ::helpdoc::text {} {
|
|
# BEWARE: so far can be called only from element (because
|
|
# attribute does not yet support ...)
|
|
variable stackArr
|
|
variable elemArr
|
|
set currentElem [$stackArr(currentElem) peek]
|
|
set elemArr(TEXT,$currentElem) 1
|
|
}
|
|
|
|
|
|
proc ::helpdoc::clist {} {
|
|
variable stackArr
|
|
variable elemArr
|
|
set currentElem [$stackArr(currentElem) peek]
|
|
set elemArr(CLIST,$currentElem) 1
|
|
}
|
|
|
|
|
|
proc ::helpdoc::plist {} {
|
|
variable stackArr
|
|
variable elemArr
|
|
set currentElem [$stackArr(currentElem) peek]
|
|
set elemArr(PLIST,$currentElem) 1
|
|
}
|
|
|
|
|
|
proc ::helpdoc::ref {name} {
|
|
variable stackArr
|
|
variable elemArr
|
|
variable defineArr
|
|
|
|
parseMsg_ $name;
|
|
|
|
if { [info exists defineArr($name)] } {
|
|
puts ""
|
|
# the ref points to define, evaluate it
|
|
#eval $defineArr($name)
|
|
namespace eval schema $defineArr($name)
|
|
parseMsgOK_;
|
|
return
|
|
}
|
|
|
|
set currentElem [$stackArr(currentElem) peek]
|
|
|
|
if { $currentElem != "" } {
|
|
lappend elemArr(REFLIST,$currentElem) $name
|
|
|
|
lappend elemArr(OPTIONAL,$currentElem,$name) [$stackArr(optional) peek]
|
|
lappend elemArr(INTERLEAVE,$currentElem,$name) [$stackArr(interleave) peek]
|
|
lappend elemArr(REPETITION,$currentElem,$name) [$stackArr(repetition) peek]
|
|
} else {
|
|
::tclu::abort "can't use \"ref\" outside element definition"
|
|
}
|
|
|
|
puts ok
|
|
}
|
|
|
|
proc ::helpdoc::ident {} {
|
|
variable stackArr
|
|
variable elemArr
|
|
|
|
set currentElem [$stackArr(currentElem) peek]
|
|
|
|
if { $currentElem != "" } {
|
|
set elemArr(IDENT,$currentElem) 1
|
|
} else {
|
|
::tclu::abort "can't use \"ident\" outside element definition"
|
|
}
|
|
}
|
|
|
|
proc ::helpdoc::optional {code} {
|
|
variable stackArr
|
|
variable state
|
|
|
|
parseMsg_; puts ""
|
|
incr state(depth)
|
|
|
|
$stackArr(optional) push 1
|
|
# eval $code
|
|
namespace eval schema $code
|
|
$stackArr(optional) pop
|
|
|
|
incr state(depth) -1
|
|
parseMsgOK_
|
|
}
|
|
|
|
proc ::helpdoc::interleave {code} {
|
|
variable stackArr
|
|
variable state
|
|
|
|
parseMsg_; puts ""
|
|
incr state(depth)
|
|
|
|
$stackArr(interleave) push 1
|
|
# eval $code
|
|
namespace eval schema $code
|
|
$stackArr(interleave) pop
|
|
|
|
incr state(depth) -1
|
|
parseMsgOK_
|
|
}
|
|
|
|
proc ::helpdoc::choice {code} {
|
|
variable stackArr
|
|
variable state
|
|
|
|
# TODO: implement the CHOICE; so far this proc is dummy
|
|
parseMsg_; puts ""
|
|
incr state(depth)
|
|
|
|
#eval $code
|
|
namespace eval schema $code
|
|
|
|
incr state(depth) -1
|
|
parseMsgOK_
|
|
}
|
|
|
|
proc ::helpdoc::ancestorElements {} {
|
|
parseMsg_
|
|
# DO nothing (this means no validation for correctness will be done)
|
|
puts ok
|
|
}
|
|
|
|
proc ::helpdoc::? {code} {
|
|
repetition_ $code
|
|
}
|
|
proc ::helpdoc::* {code} {
|
|
repetition_ $code
|
|
}
|
|
proc ::helpdoc::+ {code} {
|
|
repetition_ $code
|
|
}
|
|
proc ::helpdoc::repetition_ {code} {
|
|
variable stackArr
|
|
variable state
|
|
|
|
set type [tag -2]
|
|
uplevel 1 "parseMsg_; puts {}"
|
|
incr state(depth)
|
|
|
|
$stackArr(repetition) push $type
|
|
#eval $code
|
|
namespace eval schema $code
|
|
$stackArr(repetition) pop
|
|
|
|
incr state(depth) -1
|
|
uplevel 1 "parseMsgOK_"
|
|
}
|
|
|
|
|
|
proc ::helpdoc::assignRefs_ {} {
|
|
variable elemList
|
|
variable elemArr
|
|
|
|
foreach elem $elemList {
|
|
if { [info exists elemArr(REFLIST,$elem)] } {
|
|
# we have a ref
|
|
puts -nonewline " $elem --> "
|
|
foreach ref $elemArr(REFLIST,$elem) {
|
|
# check if ref points to "define"
|
|
lappend elemArr(ELEMLIST,$elem) $ref
|
|
|
|
puts -nonewline "$ref "
|
|
|
|
# check that $ref exists
|
|
if { ! [::tclu::lpresent $elemList $ref] } {
|
|
puts ""
|
|
::tclu::abort "the \"$ref\" element has not been defined, yet it is referenced"
|
|
}
|
|
}
|
|
puts ""
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
proc ::helpdoc::createTagCmds_ {} {
|
|
variable state
|
|
variable elemList
|
|
|
|
if { $state(rootElem) == {} } {
|
|
::tclu::abort "rootelement was not defined"
|
|
}
|
|
|
|
# create the rootelement cmd
|
|
puts " creating $state(rootElem) cmd ... ok"
|
|
proc ::helpdoc::tag::$state(rootElem) {args} {
|
|
eval ::helpdoc::rootnameTag_ $args
|
|
}
|
|
|
|
# create all elements cmds
|
|
|
|
foreach elem $elemList {
|
|
if { $elem != $state(rootElem) } {
|
|
puts -nonewline " creating $elem cmd ... "
|
|
proc ::helpdoc::tag::$elem {args} {
|
|
eval ::helpdoc::elementTag_ $args
|
|
}
|
|
puts ok
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
# for the time being ...
|
|
proc helpdoc::parseMsg_ {{name {}}} {
|
|
variable state
|
|
|
|
set indent [::textutil::blank [expr (1+$state(depth)) * 3]]
|
|
|
|
set tag [string toupper [tag -2]]
|
|
puts -nonewline "${indent}parsing $tag $name ... "
|
|
}
|
|
|
|
proc helpdoc::parseMsgOK_ {{name {}}} {
|
|
variable state
|
|
|
|
set indent [::textutil::blank [expr (1+$state(depth)) * 3]]
|
|
|
|
set tag [string toupper [tag -2]]
|
|
|
|
if { $name == "" } {
|
|
puts "${indent}OK - parsing $tag completed"
|
|
} else {
|
|
puts "${indent}OK - parsing $tag $name completed"
|
|
}
|
|
}
|
|
|
|
|
|
proc ::helpdoc::createAtcmdRegexp_ {} {
|
|
# PURPOSE: create regexps that will be used to properly substitute all @tags within correponding XML or TXT analogues ...
|
|
variable atTags
|
|
variable xml_re
|
|
|
|
if { ! [array exists atTags] } {
|
|
return
|
|
}
|
|
|
|
# create regexps
|
|
|
|
# empty
|
|
if { [info exists atTags(empty)] } {
|
|
|
|
set tag_re [join $atTags(empty) |]
|
|
set xml_re(empty) "@($tag_re)(?=\\s+)"
|
|
#puts "empty tags regexp: $xml_re(empty)"
|
|
}
|
|
|
|
# word
|
|
if { [info exists atTags(word)] } {
|
|
|
|
set tag_re [join $atTags(word) |]
|
|
append xml_re(word) "@($tag_re)"
|
|
# 1
|
|
append xml_re(word) {\s+(\S*[^\s\.\?\!\;\),]+)}; # ".!?,:;)" are excluded as last characters from word
|
|
# 2
|
|
#puts "word tags regexp: $xml_re(word)"
|
|
}
|
|
|
|
# varname
|
|
if { [info exists atTags(varname)] } {
|
|
|
|
set tag_re [join $atTags(varname) |]
|
|
append xml_re(varname) "@($tag_re)"
|
|
# 1
|
|
append xml_re(varname) {\s+(\w+([%]\w+)*)}
|
|
# 2 3
|
|
#puts "varname tags regexp: $xml_re(varname)"
|
|
}
|
|
|
|
# text
|
|
if { [info exists atTags(text)] } {
|
|
|
|
set tag_re [join $atTags(text) |]
|
|
|
|
set xml_re(text,tagsonly) "@($tag_re)"
|
|
append xml_re(text) "@($tag_re)"
|
|
# 1
|
|
append xml_re(text) {\s+((?:\{)((?:\{.*\}|[^\{])*)(?:\})|([^\s<]+))}
|
|
# 2 3 4
|
|
#puts "text tags regexp: $xml_re(text)"
|
|
}
|
|
}
|
|
|
|
|
|
proc ::helpdoc::xml_atTags {content} {
|
|
# PURPOSE: substitute all instances of @tag within the $content with the XML's <tag></tag> or <tag/>
|
|
variable xml_re
|
|
|
|
# empty
|
|
if { [info exists xml_re(empty)] } {
|
|
|
|
set content [regsub -all $xml_re(empty) $content {<\1/>}]
|
|
}
|
|
|
|
# varname & word
|
|
foreach item {varname word} {
|
|
|
|
if { [info exists xml_re($item)] } {
|
|
set content [regsub -all "$xml_re($item)" $content {<\1>\2</\1>}]
|
|
}
|
|
}
|
|
|
|
# text
|
|
if { [info exists xml_re(text)] } {
|
|
|
|
while { [regexp $xml_re(text,tagsonly) $content] } {
|
|
set content [regsub -all $xml_re(text) $content {<\1>\3\4</\1>}]
|
|
|
|
# safety check: prevent infinite loop if something goes wrong ...
|
|
incr i
|
|
if { $i > 100 } {break}
|
|
}
|
|
}
|
|
return $content
|
|
}
|
|
|
|
|
|
proc ::helpdoc::txt_atTags {content} {
|
|
# PURPOSE: either ignore all specially treat all instances of
|
|
# @tag's within the $content with as to get read of @tags in the
|
|
# generated TXT representation
|
|
variable xml_re
|
|
|
|
# special processing for tag: hr
|
|
|
|
set content [regsub -all {(@hr)} $content \
|
|
_____________________________________________________________________]
|
|
|
|
|
|
# other tags ...
|
|
|
|
# empty
|
|
if { [info exists xml_re(empty)] } {
|
|
|
|
set content [regsub -all $xml_re(empty) $content {}]
|
|
}
|
|
|
|
# varname & word
|
|
foreach item {varname word} {
|
|
|
|
if { [info exists xml_re($item)] } {
|
|
set content [regsub -all "$xml_re($item)" $content {\2}]
|
|
}
|
|
}
|
|
|
|
# text
|
|
if { [info exists xml_re(text)] } {
|
|
|
|
while { [regexp $xml_re(text,tagsonly) $content] } {
|
|
set content [regsub -all $xml_re(text) $content {\3\4}]
|
|
|
|
# safety check: prevent infinite loop if something goes wrong ...
|
|
incr i
|
|
if { $i > 100 } {break}
|
|
}
|
|
}
|
|
|
|
return $content
|
|
}
|