#!/usr/bin/tclsh
#------------------------------>  Tcl - script  <-----------------------------#
#- Copyright (C) 199x by International Computer Science Institute            -#
#- This file is part of the GNU Sather package. It is free software; you may -#
#- redistribute  and/or modify it under the terms of the  GNU General Public -#
#- License (GPL)  as  published  by the  Free  Software  Foundation;  either -#
#- version 2 of the license, or (at your option) any later version.          -#
#- This  program  is distributed  in the  hope that it will  be  useful, but -#
#- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY -#
#- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/GPL for more details.        -#
#- The license text is also available from:  Free Software Foundation, Inc., -#
#- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     -#
#------------->  Please email comments to <bug-sather@gnu.org>  <-------------#

# Called by gen_html
# generates lined-*-.gen files
# This has to be one of the slowest ways to do things, but
# it works... and is ok for html
# This script converts a Sather source file into a prettified
# HTML version. No hypertext links are generated.  
# For use with the pointer files genrated by the browser,
# the sather source file is given tags on each line number...

# Problems:
# Highlighting between "pre" conditions and "is"
# value classes (like FLT)
# after the routine "class_name" in test classes
# There is a problem with 2 ends in a row? see CHAR...

# To do:
# Make line numbers sparser (only needed if at a routine or class)
#
# Provide HTML highlinghting of sather text. 
# This consists of marking each line with a line number label


# Whether the preliminary -- before comments shoudl be stripped or not
set gStripDashes 0

set loadInfo true
set programName "gen_html_sa_files"
source "$env(SATHER_HOME)/Browser/Web/common_funcs"


proc run { } {
    puts "Generating Htmlified sather files"
    set fileList [ makeFileList ]
    processFiles ${fileList}
}

# Running consists of converting all sather files in the current directory
# into lined-<sather-file-name>.gen.html which has the html version of the file
proc processFiles { allFiles } {
    puts "Number of files:"
    puts [ llength ${allFiles} ]
    set i 0
    foreach fname ${allFiles} {
	incr i
	debugPuts "gen_html_sa_files: Converting ${fname} to prettified html"
	set infile [open ${fname} r]
	set fileNameOnly [getFileName ${fname}]
	set outfilename "lined-${fileNameOnly}.gen.html"
	puts "Generating $i)${fileNameOnly}"
	set outfile [open $outfilename w]
	set txt [read $infile]
	close $infile
	puts $outfile "<body bgcolor=#e8e8e8>\n"
	puts ${outfile} "<h1><center><font color=purple>${fileNameOnly}</font></h1></center><hr>"
	puts $outfile  "<font size=-1><i>Generated by gen_html_sa_files from <a href=\"http://www.icsi.berkeley.edu/~sather\">ICSI</a>. Contact <a href=\"mailto:gomes@icsi.berkeley.edu\">gomes@icsi.berkeley.edu</a> for details</font></i>"
	# Find any information about the destinations, if available
	#fd set funcDestText [getAllFile "gen_func_dests"]
	#fd set funcDestinations ${funcDestText}
	# If function destinations become available again, 
	# delete the comments beginnning with fd.
	set funcDestinations { }
	set funcDestsForFile { }
	foreach fileDest ${funcDestinations} {
	    # puts "File dest:${fileDest}"
	    set funcFileName [lindex ${fileDest} 0 ]
	    set funcFileNameOnly  [getFileName ${funcFileName}]
	    # puts "Func file name:${funcFileName} ${funcFileNameOnly}"
	    if { ${fileNameOnly} == ${funcFileNameOnly} } {
		set funcDestsForFile ${fileDest}
	    }
	}
	# puts "Destinations:${funcDestsForFile}"
	markupSather $txt $outfile ${funcDestsForFile}
	close $outfile
    }
}

proc makeFileList { } {
    # Return a list of files from the module
    global gClassDef
    
    if { [file exists "gen_files_from_shortflat" ] } {
	source "gen_files_from_shortflat"
	puts "Found file listing generated by gen_html_shortflat"
	set fileList ${short_flat_files}
    } else {
	puts "Did not find file listing generated by gen_html_shortflat"
	puts "Using class definitions instead. May miss some files"
	set fileList ""
	set classes [array names gClassDef]
	puts "Making file list"
	foreach class ${classes} {
	    set cdef $gClassDef(${class})
	    set classFileName [lindex ${cdef} 0]
	    if {[lsearch ${fileList} ${classFileName}] == -1} {
		lappend fileList ${classFileName}
		# puts stdout "${classFileName}" nonewline
		debugPuts "Adding file: ${classFileName}"
	    }
	}
    }
    # return { "/u/gomes/Sather/Sather/Library/Strings/str.sa" }
    return ${fileList}
}

# ######################## MAIN ROUTINE #################################
# Basic idea:
# Split up file into lines
# Split each line into a code and a comment part (to avoid hassles caused
# by getting confused by stuff in comments)
# Process code part -> htmlifyCode
# Process comment part -> htmlifyComment
# Glue the two together and add a tag for the line number
proc markupSather { txt outFile funcDests } {
    
    set nDefs [llength ${funcDests}]
    set curDefPos 1
    
    set txtl [ split $txt "\n" ]
    set txtlsize [ llength $txtl ] 
    # debugPuts "split text"

    puts $outFile "<pre> "
    set lineno 0
    # debugPuts "starting loop"
    while { $lineno < $txtlsize } {
	puts -nonewline "${lineno}"
	# puts "Line: $lineno Last clause used:${curDefPos} Num clauses:${nDefs}"

	# Code to handle function defitinitions
	set actualLine [expr ${lineno} + 1]
	set funcDefText ""
	set searchDefPos ${curDefPos} 
	while { ${searchDefPos}  < ${nDefs} } {
	    set searchDef [lindex ${funcDests} ${searchDefPos}]
	    set searchLine [lindex  ${searchDef} 1 ]
	    # puts "Searching clause:${searchDefPos} Line in clause:${searchLine} "
	    if { ${searchLine} == ${actualLine} } {
		# Line matches. Add it to marker text
		incr curDefPos
		set searchFunc [lindex ${searchDef} 0 ]
		set searchTarg [lindex ${searchDef} 3 ]
		set searchTargLine [lindex ${searchDef} 4 ]
		set searchTargFileOnly [getFileName ${searchTarg}]
		set funcDefText "${funcDefText} <a href=lined-${searchTargFileOnly}.gen.html#Line${searchTargLine}>${searchFunc}</a>"
		# puts "Augmenting function:${funcDefText}"
	    }
	    if { ${searchLine} > ${actualLine} } {
		# Overshot. can quit for now
		set searchDefPos ${nDefs}
	    }
	    incr searchDefPos
	}
	if { ${funcDefText} != ""} {
	    set funcDefText "<font color=red>--${funcDefText}</font>"
	}
	# End of code to handle function definitions

	set lineTag ""
	set thisline [ lindex $txtl $lineno ]
	# Find the location of the beginning of the comment (-1 if no comment
	# on this line)
	set comPt [string first "--"  ${thisline}]
	# Escape all > and < signs (problems with html otherwise)
	regsub -all ">" ${thisline} "\\&gt;" thisline
	regsub -all "<" ${thisline} "\\&lt;" thisline
	
	# debugPuts "Looking for comments"
	if {$comPt == -1 } {		
	    # IF there was no comment on this line, just deal with the code
	    set htmlCode [htmlifyCode ${thisline} ]
	    set htmlComment ""
	} else {
	    # Get the comment part of the line
	    set comPart [string range ${thisline} ${comPt} end]
	    # Determine the end of the code part and get it
	    if {$comPt == 0} {
		# Deal with the case where the comment begins the line
		# and there is no code i.e. comPt = 0 and [expr $comPt -1] = -1
		set codePart ""
	    } else {
		# Otherwise the code is the string upto the comment
		set codePart [string range ${thisline} 0 [expr $comPt - 1]]
	    }

	    # Prettify code and comment
	    set htmlCode [htmlifyCode ${codePart} ]
	    set htmlComment [htmlifyComment ${comPart}]
	}
	# Some futzing aroud to handle line numbers that start at 0 vs. 1
	set actualLine [expr $lineno + 1]
	set lineTag "<a Name=\"Line${actualLine}\"></a>"
	puts $outFile "${lineTag}${htmlCode}${htmlComment}${funcDefText}" 
	incr lineno
    }
    puts $outFile "</pre>"
}

debugPuts "souring htmlifycode"
proc htmlifyCode { codePart  } {
    set retVal ${codePart}


    set isPt [string first "is" ${codePart}]
    set prePt [string first "pre" ${codePart}]
    set postPt [string first "post" ${codePart}]
    set firstHead $codePart
    if {$prePt != -1 } {
	set firstHead  [string range ${codePart} 0 [expr $prePt -1]]
    } elseif {$postPt != -1 } {
	set firstHead  [string range ${codePart} 0 [expr $postPt -1]]
    } elseif {$isPt != -1 } {
	set firstHead  [string range ${codePart} 0 [expr $isPt -1]]
    }
    # Include clauses
    # Substitute all "include" classname in the current level
    # Could put this at the outermost level, but it is 
    # more efficient to do it here
    set match [regexp {(include )([A-Z_0-9]+)} ${codePart} ]
    if { ${match}} {
	regsub  -all {(include )([A-Z][A-Z_0-9,\{\}]*)} ${codePart} \
		"<b><font color=black>\\0</font></b>" retVal
	return ${retVal}
    }
    
    set match [regexp {^(type |class |external class|value class |abstract class |immutable class |partial class )} ${codePart} ]
    if { ${match} } {
	set retVal "<hr>\n<h3><font color=red>${firstHead}</font></h3>\n<b><font color=black>${codePart}</b></font>"
	return ${retVal}
    }   
    set match [regexp {(attr )([a-zA-Z_0-9]+)} ${codePart} ]
    if { ${match}} {
	regsub {^(.*)(attr )([a-zA-Z_0-9]+)(.*)$} ${codePart} \
		"\\1\\2<b><font color=blue>\\3</font></b>\\4" retVal
	return ${retVal}
    }

    set match [regexp {(const )([a-zA-Z_0-9]+)} ${codePart} ]
    if { ${match}} {
	regsub {^(.*)(const )([a-zA-Z_0-9]+)(.*)$} ${codePart} \
		"\\1\\2<font color=firebrick><b>\\3</b></font>\\4" retVal
	return ${retVal}
    }

    set match [regexp {(shared )([a-zA-Z_0-9]+)} ${codePart} ]
    if { ${match}} {
	regsub {^(.*)(shared )([a-zA-Z_0-9]+)(.*)$} ${codePart} \
		"\\1\\2<font color=firebrick><b>\\3</b></font>\\4" retVal
	return ${retVal}
    }

    set match [regexp {^  ( |  )end;.*$} ${codePart} ]
    if { ${match} } {
	return ${codePart}
    }   
    # Private routines
    set match [regexp {^  ( |  )(private )*([a-z][a-zA-Z_0-9!]*)} ${codePart} ]
    if { ${match} } {
	regsub  {^  ( |  )(private )*([a-z][a-zA-Z_0-9!]*)(.*$)} ${codePart}\
		"  \\1\\2<b><font color=purple>\\3</font></b>\\4" retVal
	return ${retVal}
    }   

    return ${retVal}
}


debugPuts "sourcing htmlifycomments"
# Deal with comments. 
# Check for some html and replace
proc htmlifyComment { commentPart } {
    global gStripDashes

    set retVal ${commentPart}
    # Convert mailto: to web link
    set matchMail [regexp {mailto:} ${retVal}]
    if { ${matchMail} } {
	regsub {(mailto:)([-a-z@_\./~A-Z0-9]+)($|[ \t\n])} ${retVal} \
		"<a href=\"mailto:\\2\">\\2</a>\\3" retVal
    }

    # Convert http: to web link
    set matchHttp [regexp {http://} ${retVal}]
    if { ${matchHttp} } {
	regsub {(http://[-a-z_./~A-Z0-9]+)([ \n\t]|$)} ${retVal} "<a href=\"\\1\">\\1</a>" retVal
    }
    # convert the standard emacs email to a web link
    set matchAddr [regexp {;(.+)@([-a-zA-Z_\.0-9]+)\&} ${retVal}]
    if { ${matchAddr} } {
	regsub {;([-a-zA-Z\._0-9]+)@([-a-zA-Z_\.0-9]+)(\&)}  ${retVal}\
		"<a href=\"mailto:\\1@\\2\"><b>\\1@\\2</b></a>\\3" retVal
    }

    # convert sather-bugs specially to web link
    set matchBugs [regexp {("bug-sather@gnu.org")} ${retVal}]
    if { ${matchBugs} } {
	regsub {"(bug-sather@gnu.org)"} ${retVal}\
	    "<a href=\"mailto:\\1\"><b>\\1</b></a>" retVal
    }


    # Convert ----- lines to horizontal rules
    set match [regexp {^------[-]*[ \t]*$} ${retVal} ]
    if { ${match} } {
	regsub  -- {^------[-]*[ \t]*$} ${retVal} "<HR>" retVal
	return ${retVal}
    }

    # Convert --==== lines to horizontal rules
    set match [regexp {^--==[=]*[ \t]*$} ${retVal} ]
    if { ${match} } {
	regsub  -- {^--==[=]*[ \t]*$} ${retVal} "<HR>" retVal
	return ${retVal}
    }
    # Convert Author: lines to bold
    set match [regexp {(.*)(Author: .*)$} ${retVal} ]
    if { ${match} } {
	regsub {(.*)(Author:)(.*)$} ${retVal} \
		"\\1<b>\\2</b>\\3" retVal
    }
    # Color comments maroon
    regsub  {([ \t]*)--(.*)} ${retVal} "\\1<font color=maroon><i>\\0</i></font>" retVal
    regsub {(International Computer Science Institute)} ${retVal} \
		"<a href=\"http://www.icsi.berkeley.edu/~sather\"><b>International Computer Science Institute</b></a>" retVal
	# The -- is needed to mark end of options to regsub
    return $retVal
}

debugPuts "ready to run"



run



