# $Id: xodoc.xotcl,v 1.7 2000/11/29 22:20:15 neumann Exp $
package provide xoDoc 0.82 
#package require trace

@ @File {
  description {
    XOTcl documentation tool. Overloads the command @, which is used
    as a documentation token. 
  }
}

Class DocToken -parameter {
  {name ""}
  {docProperties ""}
}

DocToken proc sortTokenList l {
  foreach t $l {
    set names([$t set name]) $t
  }
  set sortedName [lsort [array names names]]
  set sortedList ""
  foreach n $sortedName {
    lappend sortedList [set names($n)]
  }
  return $sortedList
}

DocToken instproc evaluateDoc doc {
  foreach {p v} $doc {
    [self] set $p $v
    [self] lappend docProperties $p
  }
}
DocToken instproc capitalize string {
  if {$::tcl_version >= 8.3} {
    string toupper $string 0 0
  } else {
    return "[string toupper [string range $string 0 0]][string range $string 1 end]"
  }
}

@ DocToken instproc getDocPropertiesHTML {} {
    description {
	Returns list of properties as HTML.
    }
}
DocToken instproc getDocPropertiesHTML {} {
    set c ""
    foreach p [[self] set docProperties] { 
	if {[[self] exists $p]} {
	    append c "<p><em>" [[self] capitalize $p] ":</em>" 
	    if {[string equal $p "errorCodes"]} {
		# Build table with list of error codes.
		append c "<blockquote><table>"
		foreach {code desc} [[self] set $p] {
		    set code [string map [list < &lt\; > &gt\;] $code]
		    set desc [string map [list < &lt\; > &gt\;] $desc]
		    append c "<tr><td valign=\"top\"><b>$code</b><td>$desc"
		}
		append c "</table></blockquote>"
	    } else {
		append c [[self] reflowHTML "   " [[self] set $p]] \n\n
	    }
	}
    }

    return $c
}

DocToken instproc reflowHTML {left paragraph} {
  #set result ""
  #foreach line [split $paragraph \n] {
  #  if {![regexp {^ *$} $line]} {
  #    append result "$left$line<br>\n"
  #  }
  #}
  #return $result
  return $paragraph
}

Class DocFile -superclass DocToken
DocFile instproc printHTML {} {
  set c "<br><b> Filename: </b> <A href='[[self] set name]'>[[self] set name]</A>
        <br><br>\n"
  append c "[[self] getDocPropertiesHTML] <br>\n"
  return $c
}

Class DocPackage -superclass DocToken -parameter {
  {version ""}
  {type ""}
}

Class DocObj -superclass DocToken -parameter {
  {procList ""}
  cl
}
DocObj instproc getProcsHTML {} {
  set c ""
  set pl [DocToken sortTokenList [[self] procList]]
  if {[[self] istype DocCl]} {
    set pl [concat [DocToken sortTokenList [[self] instprocList]] $pl]
  }
  foreach p $pl {
    set pn [$p set name]
    set label($pn) "<a href=\"#[[self] set name]-$pn\">$pn</a>"
  }
  foreach l [lsort [array names label]] {
    if {$c != ""} {append c ", "}
    append c $label($l)
  }
  if {$c != ""} {append c "."}
  return $c
}
  
DocObj instproc printHTML {} {
  set c "<a name=\"[[self] set name]\"></a><h2> Object: <em> [[self] set name] </em> </h2>\n"
  if {[[self] exists cl]} {
    append c "<b>Class</b>: [[self] set cl] <br>\n"
  }
  if {[[self] exists heritage]} {
    append c "<b>Heritage</b>: [[self] set heritage] <br>\n"
  }

  set head "<b> Procs </b> "
  if {[[self] istype DocCl]} {
    set head "<b> Procs/Instprocs: </b> "
  }
  append c "$head \n [[self] getProcsHTML]" \
       "<br><p>\n" \
      [[self] getDocPropertiesHTML]
  return $c
}

Class DocCl -superclass DocObj -parameter {
  {instprocList ""}
}
DocCl instproc init args {
  [self] set obj [[self class] autoname clobj]
  next
}
DocCl instproc printHTML {} {
  regsub "<h2> Object:" [next] "<h2> Class:" r
  return $r
}
Class DocMetaCl
DocMetaCl instproc printHTML {} {
  regsub "<h2> Class:" [next] "<h2> Meta-Class:" r
  return $r
}

Class DocMethod -superclass DocToken -parameter {
  arguments
  returnValue
  obj
}

# Prints out method information as HTML.
DocMethod instproc printHTML {} {
  #[self] showVars
  set argText "\n"
  set a "<td><em>Arguments:</em> </td>"

  set anchor "[[self] set obj]-[[self] set name]"
  set c "<a name=\"$anchor\"></a>\n<li><b>[[self] set name] "

  if {[[self] exists arguments]} {
    foreach {arg argD} [[self] set arguments] {
	if {[llength $arg] > 1} {
	    # A default value was given to the argument.
	    append c " <em>?[lindex $arg 0]?</em>"
	    append argText "<tr valign=\"top\">$a<td>"
	    append argText "<b>?[lindex $arg 0]?</b>:" \
		[[self] reflowHTML "   " \
		     "$argD Default: \"[lindex $arg 1]\"."] \
                "</td></tr>\n"
	} else {
	    append c " <em>$arg</em>"
	    append argText "<tr valign=\"top\">$a<td><b>$arg</b>: " \
		"[[self] reflowHTML "   " $argD]</td></tr>\n"
	}
	set a "<td></td>"
    }
  }
  append c " </b><br>\n<table>\n" \
      $argText [[self] getDocPropertiesHTML] \n \
      </table> \n
  return $c
}

Class DocProc -superclass DocMethod
Class DocInstproc -superclass DocMethod

@ Class XODoc { description "Handler class for building a documentation database" }

Class XODoc -parameter {
  {objList ""}
  {packageList ""}
  {knownMetaclasses "Class"}
  {ns ""}
  fileToken
}

XODoc instproc init args {
  next
}

@ XODoc proc documentFileAsHTML {file "filename of the xotcl file to be documented"
			   docdir "directory to which the html file is written"} {
  description "Uses the xoDoc package to produce an HTML documentation of
               a specified file ***.xotcl. The file is written to ***.html
               in docdir"
  return "file basename without suffix"
}

XODoc proc documentFileAsHTML {file docdir} {
  set docdb [XODoc [XODoc autoname docdb]]
  ::@ set xoDocObj $docdb
  $docdb readFile $file
  set fb $file
  regexp {([^/]*)\.[^.]*$} $fb _ fb
  $docdb writeFile ${docdir}/$fb.html $fb [$docdb printHTML]
  $docdb destroy
  return $fb
}

XODoc instproc handleMethod {obj type name {argList ""} {doc ""}} {
  #puts stderr "+++Method $type $name $argList $doc"
  set procClass DocProc; set objCl DocObj
  if {$type == "instproc"} {set procCl DocInstproc; set objCl DocCl}
  set t [$procClass create [[self] autoname t]]
  
  set n [$t set name [string trimleft $name :]]
  $t set obj $obj

  set objFound 0
  foreach o [[self] set objList] {
    if {[$o set name] == $obj} {
      set objFound 1
      if {$type == "instproc" && ![$o istype DocCl]} {
	$o class DocCl
      }
      break
    }
  }
  if {$objFound == 0} {
    set o [$objCl create [[self] autoname t]]
    $o set name $obj
    [self] lappend objList $o
  }
  $o lappend ${type}List $t

  $t set arguments $argList 

  $t evaluateDoc $doc
}

XODoc instproc handleObj {class name args} {
  [self] instvar knownMetaclasses objList extensions
  set objCl DocObj
  if {[lsearch $class $knownMetaclasses] != -1} {
    set objCl DocCl
  }
	
  # if an instproc/proc has created an entry for this obj/class
  # -> use it and overwrite it with new info
  if {[set idx [lsearch $name $objList]] != -1} {
    set t [lindex $objList $idx]
    $t class $objCl
  } else {
    set t [$objCl create [[self] autoname t]]
    [self] lappend objList $t
  }

  $t set name $name

  set la [llength $args]

  # evaluate -superclass argument
  if {($la == 3 || $la == 2) && [lindex $args 0] == "-superclass"} {
    set heritage [$t set heritage [lindex $args 1]]
    foreach h $heritage {
      if {[lsearch $h $knownMetaclasses] != -1} {
	# A new metaclass was defined
	lappend knownMetaclasses $name
	$t class DocMetaCl
      }
    }
  }

  # evaluate documentation
  set doc ""
  if {$la == 1} {
    set doc [lindex $args 0]
  } elseif {$la == 3} {
    set doc [lindex $args 2]
  }
  $t evaluateDoc $doc
  $t set cl $class

  #puts stderr "+++Obj $name $args"
}

XODoc instproc handleFile doc {
  if {[[self] exists fileToken]} {
    [[self] set fileToken] evaluateDoc $doc
  }
}

XODoc instproc handlePackage args {
  #puts "$args"
  if {[llength $args] > 2} {
    set type [lindex $args 1]
    if {$type == "provide" || $type == "require"} {
    set t [DocPackage create [[self] autoname t]]
      [self] lappend packageList $t
      $t set name [lindex $args 2]
      $t set type $type
      if {[llength $args] > 3} {
	$t set version [lindex $args 3]
      }
    }
  }
}

XODoc instproc printHTML {} {
    [self] instvar extensions
  set c "<h2> Package/File Information </h2>"

  [self] instvar packageList
  if {[llength $packageList] > 0} {
    foreach t $packageList {
      if {[$t type] == "provide"} {
	append c "<b> Package provided: </b> [$t name] [$t version]<br>\n"
      } elseif {[$t type] == "require"} {
	append c "<b> Package required: </b> [$t name] [$t version]<br>\n"
      }
    }
  } else {
    append c "<b> No package provided/required </b><br>\n"
  }

    if {[info exists extensions]} {
	# Add list of extensions.
	foreach extension $extensions {
	    append c "<hr>"
	    append c "<h2>Document extension: <em>[$extension name]</em></h2>"
	    append c "<em>Description:</em> [$extension description]"
	}
    }

  set objList [DocToken sortTokenList [[self] objList]]

  if {[llength $objList]>0} {
    append c "<br><b>Defined Objects/Classes: </b> \n<ul>"
    foreach obj $objList {
      set on [$obj set name]
      append c "  <li><a href=\"#$on\"><em>$on</em></a>: \
	[$obj getProcsHTML]<br>\n"
    }
    append c "</ul>\n"
  }

  if {[[self] exists fileToken]} {
    append c "[[[self] set fileToken] printHTML]<br>"
  } else {
    append c "<b> No file information. </b><br>\n"
  }
  


  foreach t $objList {
    append c "<p><hr><p>\n" [$t printHTML]
    set pl [$t set procList]

    if {[$t istype DocCl]} {
      set ipl [$t set instprocList]
      if {[llength $ipl] > 0} {
	append c "<h3>Instprocs</h3>\n<ul>\n"
	foreach s $ipl {
	  append c [$s printHTML]
	}
	append c "</ul>\n"
      }
    }

    if {[llength $pl] > 0} {
      append c "<h3>Procs</h3>\n<ul>\n"
      foreach s $pl {
	append c [$s printHTML]
      }
      append c "</ul>\n"
    }
    #append c "<hr>\n"
  }
  return $c
}

XODoc instproc getCommand {content} {
  upvar $content c
  [self] instvar cmd
  if {[set line [string first "\n" $c]] != -1} {
    append cmd [string range $c 0 $line] \n
    set c [string range $c [expr $line + 1] end]
    if {[info complete $cmd]} {
      set r $cmd; set cmd ""
      return $r
    }
  } else {
    return ""
  }
  [self] getCommand c
}

XODoc instproc evaluateCommands {c} {
  while 1 {
    set command [[self] getCommand c]
    if {$command == ""} {
      break
    }
    #puts stderr "$command==========================="
    if {[regexp "^ *:*@ " $command]} {
      #puts stderr "$command==========================="
      eval $command
    } elseif {[regexp "^ *package " $command]} {
      #puts stderr "$command==========================="
      eval [self] handlePackage $command
    } elseif {[regexp "^ *namespace *eval *(\[^\{\]*) *\{(.*)\}\[^\}\]*$" $command _ namespace nsc]} {
      #puts stderr "$command==========================="
      [self] evaluateCommands $nsc 
   } 
  }
}
XODoc instproc readFile name {
  [self] set cmd ""

  set t [DocFile create [[self] autoname t]]  
  $t set name $name
  [self] set fileToken $t

  set f [open $name r]
  set c [read $f]
  close $f
  [self] evaluateCommands $c
}

XODoc instproc replaceFormatTags {fc} {
  regsub -all <@ $fc < fc
  regsub -all </@ $fc </ fc
  return $fc
}

XODoc instproc writeFile {filename name filecontent} {
    #set filename [[self] set DOCDIR]/$name.html

  set filecontent [[self] replaceFormatTags $filecontent]

    set content {
<html>
<head>
<title>XOTcl - Documentation -- $name</title>
</head>
<body bgcolor=FFFFFF>
<h1><IMG ALIGN=MIDDLE SRC = "./logo-100.jpg">$name</h1>
<hr>
<p> 

$filecontent

<p><hr>
<a HREF="./index.html">Back to index page.</a>
<br><hr><p>
</body>
</html>
    }

    set content [subst -nobackslashes -nocommands $content]
    #puts $content
    set f [open $filename w]
    puts $f $content
    close $f
}

Class XODocCmd -parameter {
  {xoDocObj ""}
} 
XODocCmd instproc unknown args {
    [self] instvar xoDocObj
    if {[llength $args] > 1} {
	switch [lindex $args 1] {
	    proc - instproc {
		return [eval $xoDocObj handleMethod $args]
	    }
	    default {
		switch [lindex $args 0] {
		    @File {
			return [$xoDocObj handleFile [lindex $args 1]]
		    }
		    default {
			return [eval $xoDocObj handleObj $args]
		    }
		}
	    }
	}
    }
    puts stderr "Unknown documentation: '$args'"
}
XODocCmd @