checker.tcl

Go to the documentation of this file.

/*  -*- tcl -*-*/
/*  checker.tcl*/
/* */
/*  Code used inside of a checker interpreter to ensure correct usage of*/
/*  doctools formatting commands.*/
/* */
/*  Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>*/
/*  Copyright (c) 2004 Andreas Kupries <andreas_kupries@sourceforge.net>*/

/*  L10N*/

package require msgcat

ret  ::msgcat::mcunknown (type locale , type code) {
    return "unknown error code \"$code\" (for locale $locale)"
}

if {0} {
    puts stderr "Locale [::msgcat::mcpreferences]"
    foreach path [dt_search] {
    puts stderr "Catalogs: [::msgcat::mc
    }
} else {
    foreach path [dt_search] {
    ::msgcat::mc
    }
}

/*  State, and checker commands.*/
/*  -------------------------------------------------------------*/
/* */
/*  Note that the code below assumes that a command XXX provided by the*/
/*  formatter engine is accessible under the name 'fmt_XXX'.*/
/* */
/*  -------------------------------------------------------------*/

global state lstctx lstitem

/*  --------------+-----------------------+----------------------*/
/*  state       | allowed commands  | new state (if any)*/
/*  --------------+-----------------------+----------------------*/
/*  all except  | arg cmd opt comment   |*/
/*   for "done" | syscmd method option  |*/
/*      | widget fun type class |*/
/*      | package var file uri  |*/
/*      | strong emph namespace |*/
/*  --------------+-----------------------+----------------------*/
/*  manpage_begin   | manpage_begin     | header*/
/*  --------------+-----------------------+----------------------*/
/*  header  | moddesc titledesc | header*/
/*      | copyright keywords    |*/
/*      | require see_also  |*/
/*      +-----------------------+-----------*/
/*      | description       | body*/
/*  --------------+-----------------------+----------------------*/
/*  body        | section para list_end | body*/
/*      | list_begin lst_item   |*/
/*      | call bullet usage nl  |*/
/*      | example see_also  |*/
/*      | keywords sectref enum |*/
/*      | arg_def cmd_def   |*/
/*      | opt_def tkoption_def  |*/
/*      | subsection        |*/
/*      +-----------------------+-----------*/
/*      | example_begin     | example*/
/*      +-----------------------+-----------*/
/*      | manpage_end       | done*/
/*  --------------+-----------------------+----------------------*/
/*  example | example_end       | body*/
/*  --------------+-----------------------+----------------------*/
/*  done        |           |*/
/*  --------------+-----------------------+----------------------*/
/* */
/*  Additional checks*/
/*  --------------------------------------+----------------------*/
/*  list_begin/list_end         | Are allowed to nest.*/
/*  --------------------------------------+----------------------*/
/*  section             | Not allowed in list context*/
/* */
/*  arg_def             | Only in 'argument list'.*/
/*  cmd_def             | Only in 'command list'.*/
/*  nl para             | Only in list item context.*/
/*  opt_def             | Only in 'option list'.*/
/*  tkoption_def            | Only in 'tkoption list'.*/
/*      def/call            | Only in 'definition list'.*/
/*      enum                | Only in 'enum list'.*/
/*      item/bullet         | Only in 'bullet list'.*/
/*  --------------------------------------+----------------------*/

/*  -------------------------------------------------------------*/
/*  Helpers*/
ret  Error (type code , optional text ={)} {
    global state lstctx lstitem

    # Problematic command with all arguments (we strip the "ck_" prefix!)
    # -*- future -*- count lines of input, maintain history buffer, use
    # -*- future -*- that to provide some context here.

    set cmd  [lindex [info level 1] 0]
    set args [lrange [info level 1] 1 end]
    if {$args != {}} {append cmd " [join $args]"}

    /*  Use a message catalog to map the error code into a legible message.*/
     msg =  [::msgcat::mc $code]

    if {$text != {}} {
     msg =  [string map [list @ $text] $msg]
    }
    dt_error "Manpage error ($code), \"$cmd\" : ${msg}."
    return
}
ret  Warn (type code , type args) {
    set msg [::msgcat::mc $code]
    foreach {off line col} [dt_where] break
    set msg [eval [linsert $args 0 format $msg]]
    set msg "In macro at line $line, column $col:\n$msg"
    set msg [split $msg \n]
    set prefix "DocTools Warning ($code): "
    dt_warning "$prefix[join $msg "\n$prefix"]"
    return
}

ret  Is    (type s) {global state ; return [string equal $state $s]}
ret  IsNot (type s) {global state ; return [expr {![string equal $state $s]}]}
ret  Go    (type s) {Log " >>\[$s\]" ; global state ; set state $s; return}
ret  LPush (type l) {
    global lstctx lstitem
    set    lstctx [linsert $lstctx 0 $l $lstitem]
    return
}
ret  LPop () {
    global lstctx lstitem
    set    lstitem [lindex $lstctx 1]
    set    lstctx  [lrange $lstctx 2 end]
    return
}
ret  LSItem () {global lstitem ; set lstitem 1}
ret  LIs  (type l) {global lstctx ; string equal $l [lindex $lstctx 0]}
ret  LItem () {global lstitem ; return $lstitem}
ret  LNest () {
    global lstctx
    expr {[llength $lstctx] / 2}
}
ret  LOpen () {
    global lstctx
    expr {$lstctx != {}}
}
global    lmap ldmap
array  lmap =  {
    bullet   itemized    item     itemized
    arg      arguments   args     arguments
    opt      options     opts     options
    cmd      commands    cmds     commands
    enum     enumerated  tkoption tkoptions
}
array  ldmap =  {
    bullet   . arg . cmd . tkoption . opt .
}
ret  LMap (type what) {
    global lmap ldmap
    if {![info exists lmap($what)]} {
    return $what
    }
    if {[dt_deprecated] && [info exists ldmap($what)]} {
    Warn depr_ltype $what $lmap($what)
    }
    return $lmap($what)
}
ret  LValid (type what) {
    switch -exact -- $what {
    arguments   -
    commands    -
    definitions -
    enumerated  -
    itemized    -
    options     -
    tkoptions   {return 1}
    default     {return 0}
    }
}

ret  State () {global state ; return $state}
ret  Enter (type cmd) {Log "\[[State]\] $cmd"}

/* proc Log* {text} {puts -nonewline $text}*/
/* proc Log  {text} {puts            $text}*/
ret  Log* (type text) {}
ret  Log  (type text) {}


/*  -------------------------------------------------------------*/
/*  Framing*/
ret  ck_initialize () {
    global state   ; set state manpage_begin
    global lstctx  ; set lstctx [list]
    global lstitem ; set lstitem 0
    global sect    ; catch {unset sect} ; set sect() . ; unset sect()
    return
}
ret  ck_complete () {
    if {[Is done]} {
    if {![LOpen]} {
        return
    } else {
        Error end/open/list
    }
    } elseif {[Is example]} {
    Error end/open/example
    } else {
    Error end/open/mp
    }
    return
}
/*  -------------------------------------------------------------*/
/*  Plain text*/
ret  plain_text (type text) {
    # Only in body, not between list_begin and first item.
    # Ignore everything which is only whitespace ...

    set redux [string map [list " " "" "\t" "" "\n" ""] $text]
    if {$redux == {}} {return [fmt_plain_text $text]}
    if {[IsNot body] && [IsNot example]} {Error body}
    if {[LOpen] && ![LItem]} {Error nolisttxt}
    return [fmt_plain_text $text]
}

/*  -------------------------------------------------------------*/
/*  Variable handling ...*/

ret  vset (type var , type args) {
    switch -exact -- [llength $args] {
    0 {
        # Retrieve contents of variable VAR
        upvar #0 __$var data
        return $data
    }
    1 {
        # Set contents of variable VAR
        global __$var
        set    __$var [lindex $args 0]
        return "" ; # Empty string ! Nothing for output.
    }
    default {
        return -code error "wrong#args: set var ?value?"
    }
    }
}

/*  -------------------------------------------------------------*/
/*  Formatting commands*/
ret  manpage_begin (type title , type section , type version) {
    Enter manpage_begin
    if {[IsNot manpage_begin]} {Error mpbegin}
    Go header
    fmt_manpage_begin $title $section $version
}
ret  moddesc (type desc) {
    Enter moddesc
    if {[IsNot header]} {Error hdrcmd}
    fmt_moddesc $desc
}
ret  titledesc (type desc) {
    Enter titledesc
    if {[IsNot header]} {Error hdrcmd}
    fmt_titledesc $desc
}
ret  copyright (type text) {
    Enter copyright
    if {[IsNot header]} {Error hdrcmd}
    fmt_copyright $text
}
ret  manpage_end () {
    Enter manpage_end
    if {[IsNot body]} {Error bodycmd}
    Go done
    fmt_manpage_end
}
ret  require (type pkg , optional version ={)} {
    Enter require
    if {[IsNot header]} {Error reqcmd}
    fmt_require $pkg $version
}
ret  description () {
    Enter description
    if {[IsNot header]} {Error reqcmd}
    Go body
    fmt_description
}

global sect
ret  __sid (type name) {
    # Identical to 'c_sectionId' in mpformats/_common.tcl
    regsub -all {[  ]+} [string tolower [string trim $name]] _ id
    regsub -all {"} $id _ id ; # "
    return $id
}

ret  section (type name) {
    global sect

    Enter section
    if {[IsNot body]} {Error bodycmd}
    if {[LOpen]}      {Error nolistcmd}

    set sid [__sid $name]
    if {[info exists sect($sid)]} {
    Warn sectambig $name
    }
    set sect($sid) .

    fmt_section $name
}
ret  subsection (type name) {
    global sect

    Enter subsection
    if {[IsNot body]} {Error bodycmd}
    if {[LOpen]}      {Error nolistcmd}

    set sid [__sid $name]
    if {[info exists sect($sid)]} {
    Warn sectambig $name
    }
    set sect($sid) .

    fmt_subsection $name
}
ret  para () {
    Enter para
    if {[IsNot body]} {Error bodycmd}
    if {[LOpen]}      {
    if {![LItem]} {Error nolisthdr}
    fmt_nl
    } else {
    fmt_para
    }
}
ret  list_begin (type what , optional hint ={)} {
    Enter "list_begin $what $hint"
    if {[IsNot body]}        {Error bodycmd}
    if {[LOpen] && ![LItem]} {Error nolisthdr}
     what =  [LMap $what]
    if {![LValid $what]}     {Error invalidlist $what}
    LPush        $what
    fmt_list_begin $what $hint
}
ret  list_end () {
    Enter list_end
    if {[IsNot body]} {Error bodycmd}
    if {![LOpen]}     {Error listcmd}
    LPop
    fmt_list_end
}

/*  Deprecated command, and its common misspellings. Canon is 'def'.*/
ret  lst_item (optional text ={)} {
    if {[dt_deprecated]} {Warn depr_lstitem "\[lst_item\]"}
    def $text
}
ret  list_item (optional text ={)} {
    if {[dt_deprecated]} {Warn depr_lstitem "\[list_item\]"}
    def $text
}
ret  listitem  (optional text ={)} {
    if {[dt_deprecated]} {Warn depr_lstitem "\[listitem\]"}
    def $text
}
ret  lstitem   (optional text ={)} {
    if {[dt_deprecated]} {Warn depr_lstitem "\[lstitem\]"}
    def $text
}
ret  def (optional text ={)} {
    Enter def
    if {[IsNot body]}       {Error bodycmd}
    if {![LOpen]}           {Error listcmd}
    if {![LIs definitions]} {Error deflist}
    LSItem
    fmt_lst_item $text
}
ret  arg_def (type type , type name , optional mode ={)} {
    Enter arg_def
    if {[IsNot body]}       {Error bodycmd}
    if {![LOpen]}           {Error listcmd}
    if {![LIs arguments]}   {Error arg_list}
    LSItem
    fmt_arg_def $type $name $mode
}
ret  cmd_def (type command) {
    Enter cmd_def
    if {[IsNot body]}       {Error bodycmd}
    if {![LOpen]}           {Error listcmd}
    if {![LIs commands]}    {Error cmd_list}
    LSItem
    fmt_cmd_def $command
}
ret  opt_def (type name , optional arg ={)} {
    Enter opt_def
    if {[IsNot body]}       {Error bodycmd}
    if {![LOpen]}           {Error listcmd}
    if {![LIs options]}     {Error opt_list}
    LSItem
    fmt_opt_def $name $arg
}
ret  tkoption_def (type name , type dbname , type dbclass) {
    Enter tkoption_def
    if {[IsNot body]}       {Error bodycmd}
    if {![LOpen]}           {Error listcmd}
    if {![LIs tkoptions]}   {Error tkoption_list}
    LSItem
    fmt_tkoption_def $name $dbname $dbclass
}
ret  call (type cmd , type args) {
    Enter call
    if {[IsNot body]}       {Error bodycmd}
    if {![LOpen]}           {Error listcmd}
    if {![LIs definitions]} {Error deflist}
    LSItem
    eval [linsert $args 0 fmt_call $cmd]
}
/*  Deprecated. Use 'item'*/
ret  bullet () {
    if {[dt_deprecated]} {Warn depr_bullet "\[bullet\]"}
    item
}
ret  item () {
    Enter item
    if {[IsNot body]}    {Error bodycmd}
    if {![LOpen]}        {Error listcmd}
    if {![LIs itemized]} {Error bulletlist}
    LSItem
    fmt_bullet
}
ret  enum () {
    Enter enum
    if {[IsNot body]}      {Error bodycmd}
    if {![LOpen]}          {Error listcmd}
    if {![LIs enumerated]} {Error enumlist}
    LSItem
    fmt_enum
}
ret  example (type code) {
    Enter example
    return [example_begin][plain_text ${code}][example_end]
}
ret  example_begin () {
    Enter example_begin
    if {[IsNot body]}        {Error bodycmd}
    if {[LOpen] && ![LItem]} {Error nolisthdr}
    Go example
    fmt_example_begin
}
ret  example_end () {
    Enter example_end
    if {[IsNot example]} {Error examplecmd}
    Go body
    fmt_example_end
}
ret  see_also (type args) {
    Enter see_also
    if {[Is done]} {Error nodonecmd}
    # if {[IsNot body]} {Error bodycmd}
    # if {[LOpen]}      {Error nolistcmd}
    eval [linsert $args 0 fmt_see_also]
}
ret  keywords (type args) {
    Enter keywords
    if {[Is done]} {Error nodonecmd}
    # if {[IsNot body]} {Error bodycmd}
    # if {[LOpen]}      {Error nolistcmd}
    eval [linsert $args 0 fmt_keywords]
}
/*  nl - Deprecated*/
ret  nl () {
    if {[dt_deprecated]} {Warn depr_nl "\[nl\]"}
    para
}
ret  emph (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_emph $text
}
/*  strong - Deprecated*/
ret  strong (type text) {
    if {[dt_deprecated]} {Warn depr_strong "\[strong\]"}
    emph $text
}
ret  arg (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_arg $text
}
ret  cmd (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_cmd $text
}
ret  opt (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_opt $text
}
ret  comment (type text) {
    if {[Is done]} {Error nodonecmd}
    return ; #fmt_comment $text
}
ret  sectref (type name , optional label ={)} {
    if {[IsNot body]}        {Error bodycmd}
    if {[LOpen] && ![LItem]} {Error nolisthdr}
    if {![string length $label]} { label =  $name}
    fmt_sectref $name $label
}
ret  syscmd (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_syscmd $text
}
ret  method (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_method $text
}
ret  option (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_option $text
}
ret  widget (type text) {
    if {[Is done]} {Error nodonecmd}
    widget $text
}
ret  fun (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_fun $text
}
ret  type (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_type $text
}
ret  package (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_package $text
}
ret  class (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_class $text
}
ret  var (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_var $text
}
ret  file (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_file $text
}

/*  Special case: We must not overwrite the builtin namespace command,*/
/*  as it is required by the package "msgcat".*/
ret  _namespace (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_namespace $text
}
ret  uri (type text , optional label ={)} {
    if {[Is done]} {Error nodonecmd}
    /*  The label argument is left out when undefined so that we can*/
    /*  control old formatters as well, if the input is not using uri*/
    /*  labels.*/

    if {$label == {}} {
    fmt_uri $text
    } else {
    fmt_uri $text $label
    }
}
ret  usage (type args) {
    if {[Is done]} {Error nodonecmd}
    eval fmt_usage $args
}
ret  const (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_const $text
}
ret  term (type text) {
    if {[Is done]} {Error nodonecmd}
    fmt_term $text
}

/*  -------------------------------------------------------------*/