HLex2html.hs

{-+
This module defines the function #hlex2html#, which translates the output from
an early pass of the lexical analyzer to HTML. It can also make use of cross
reference information to link identifiers to their definitions.

The generated HTML is intended to be part of the body of a web page,
thus it does not include the #head# or #body# tags.
-}
module HLex2html({-hlex2html,-}hlex2html',simpleHlex2html) where
import RefsTypes --hiding (isDef)
import MUtils(apSnd)
import Char(isSpace{-,isAlpha-},isAlphaNum)
import HsTokens
import SrcLoc1
import LitTxt(toHTMLblock)
import PathUtils(normf)
import HLexTagModuleNames
import PrettyPrint(pp)

--------------------------------------------------------------------------------
type ModuleContext = (FilePath,[(FilePath,Module)]) -- (this,other) modules
type LexTokens = [(Token,(Pos,String))]
type URL = String
type HTML = String

simpleHlex2html :: LexTokens -> HTML
--hlex2html  :: ModuleContext -> (Refs,LexTokens) -> HTML
hlex2html' :: (Module->URL) -> ModuleContext -> (Refs,LexTokens) -> HTML
--------------------------------------------------------------------------------

simpleHlex2html = hlex2html' undefined dummy . (,) []
  where dummy = ("",[("",noModule)])

hlex2html' srcURL (thisf,fm) =
     normal . tokens2html srcURL (thisf,thism,fm) . uncurry merge .
     apSnd convModuleNames
  where Just thism = lookup thisf fm

{-+
The functions #normal#, #pre#, and #code# implement a state machine that
handles the insertion of properly nested #pre# and #div# tags.
-}

-- Normal text mode, in which literate comments can be output:
normal [] = []
normal ((LiterateComment,(_,s)):ts) = toHTMLblock s++normal ts
normal ((Whitespace,(p,s)):ts) | noCodeOnLine (line p) ts = s++normal ts -- indented code??
normal ((Commentstart,(Pos{column=1},s1)):(Comment,(_,s2)):ts) =
        preStart++cmntesc (s1++s2)++pre ts
normal ((Comment,ps1):(Whitespace,ps2):ts) | isBlockComment ps1 ps2 =
        preStart++cmntesc (snd ps1++snd ps2)++pre ts
normal ts = codeStart++code ts

-- Inside a <pre> block, where blank lines and block comments can be output:
pre [] = preEnd
pre ((LiterateComment,(_,s)):ts) = preEnd++toHTMLblock s++normal ts
pre ((Whitespace,(_,s)):ts) = s++pre ts
pre ((Commentstart,(Pos{column=1},s1)):(Comment,(_,s2)):ts) =
        cmntesc (s1++s2)++pre ts
pre ((Comment,ps1):(Whitespace,ps2):ts) | isBlockComment ps1 ps2 =
        cmntesc (snd ps1++snd ps2)++pre ts
pre ts = preEnd++codeStart++code ts

-- Inside a code, where code and ordinary comments can be output:
code [] = codeEnd
code ((LiterateComment,(_,s)):ts) = codeEnd++toHTMLblock s++normal ts
code ((Commentstart,(_,s1)):(Comment,(_,s2)):ts) = cmntesc (s1++s2)++code ts
code ((Comment,ps1):(Whitespace,ps2):ts) | isBlockComment ps1 ps2 =
        codeEnd++preStart++cmntesc (snd ps1++snd ps2)++pre ts
code ((Comment,(_,s))   :ts) = cmntesc s++code ts
code ((Whitespace,(_,s))   :ts) = s++code ts
code ((_,(_,s)):ts) = s++code ts

preStart = "<pre>"
preEnd = "</pre>"
codeStart = "<div class=code><pre>"
codeEnd = "</pre></div>"

isBlockComment (Pos{column=1},'{':'-':_) (_,s) | '\n' `elem` s = True
isBlockComment _ _ = False

noCodeOnLine l ts =
    all ((`elem` notCode).fst) (takeWhile ((==l).line.fst.snd) ts)
  where notCode = [LiterateComment,Whitespace{-,Commentstart,Comment-}]

cmntesc = cmnt . esc

--------------------------------------------------------------------------------

tokens2html srcURL rs = map (token2html srcURL rs)

token2html :: (Module->URL)->(FilePath,Module,[(FilePath,Module)])->
	      ((Token,(Pos,String)),Maybe Orig)->
	      (Token,(Pos,String))
token2html _      _    ((LiterateComment,ps@(_,"> ")),_) = (Whitespace,ps)
token2html _      _                ((NestedComment,s),_) = nestedcomment s
token2html srcURL (thisf,thism,fm) ((t,(p,s)),r) = (t,(p,f (esc s)))
  where
    moduleLink s = 
      case [m|(f,m)<-fm,sameModuleName s m] of
        [m] -> link (srcURL m)
	_ -> modname
    f = case t of
	  ModuleName -> if sameModuleName s thism || thism==noModule
		        then modname
		        else moduleLink s
	  ModuleAlias -> modname
	  Reservedid -> b
	  Reservedop -> b
	  Conid -> conp
	  Consym -> consymp
	  Qconid -> conp
	  Qconsym -> consymp
	  Varid -> varp
	  Specialid -> b
	  Varsym -> varsymp
	  Qvarid -> varp
	  Qvarsym -> varsymp
--	  Literal -> lit -- obsolete
          IntLit -> lit
          FloatLit -> lit
	  CharLit -> lit
	  StringLit -> lit
	  {-
	  Whitespace -> 
	  Special
	  -}
	  _ -> id
    varp = var (info "var" "" p)
    conp = con (info "con" "" p)
    varsymp = var (info "var" "op" p)
    consymp = con (info "con" "op" p)
    modname = con (Nothing,[("class","mod")])

    info cl op p =
      case r of
	Just (n,role,sp,rs) | n==s ->
	    (link,
	     (if isDef role
	     then (("id",rstarget sp rs):)
	     else id) $
	       [("class",ty++cl++op),("title",n++": "++title)])
          where
            ty = if isType sp then "t" else ""
            ttag t = if isType t then "t" else "v"

	    link = case links of
		     [Just link] -> Just link
		     _ -> Nothing
	    title = case titles of
		      [] -> "not in scope"
		      _  -> unwords titles
	    (links,titles) = unzip (map shr rs)


	    sht T = "type"
	    sht V = "value"
	    sht Cl = "class"
	    sht (Co n) = "constructor of "++n
	    sht (Me n) = "method of class "++n
	    sht (Fi n) = "field of type "++n

            shr (t,p) =
		apSnd (("a "++sht t)++) $
		if role==DP
		then (Nothing," bound here")
		else if isDef role
	             then (Nothing," defined here")
		     else shrp t p
	    shrp t (Left (m,n)) =
	      if m==thism
	      then (Just ("#"++tmangle t n)," defined in this module")
	      else (Just (srcURL m++"#"++tmangle t n)," defined in module "++pp m)
	    shrp _ (Right p'@(f,rc)) =
		if p'==(thisf,p)
		then (Nothing," defined here")
		else if f==thisf
		     then (Just ("#"++shPos' rc),
		           " defined in this module at "++shPos rc)
		     else (Just (srcURL m++"#"++shPos' rc),
		           " defined in module "++pp m++" at "++show p')
	      where Just m = lookup (normf f) fm

	    --shpos (f,(y,x)) = show (SrcLoc f 0 y x) -- hmm
	    --shrc (y,x) = show y++":"++show x
	    --shrc' (y,x) = show y++"."++show x

            rstarget t = rtarget t . head
	    rtarget t = either (gtarget t) ptarget . snd
	    gtarget t = tmangle t . snd
	    ptarget = shPos' . snd
	    tmangle t p = ttag t++mangle p
 
	_ -> (Nothing,attrs)
         where
           attrs = if thism==noModule
		   then [("class",cl++op)]
		   else [("title","Hmm. Info missing")]

--isDef r =  r `elem` [DT,DL,DP,DC]

b = ctx "b"
var (optl,as) = optlink optl . ctx' "var" as
con (optl,as) = optlink optl . ctx' "b"  as
lit = ctx' "span" [("class","lit")]

optlink = maybe id link
link url = ctx' "a" [("href",url)]

cmnt = ctx' "span" [("class","cmnt")]

-- Some nested comments, {-+ ... -}, are treated like literate comments...
nestedcomment ps@(p,s) =
  case s of
    '{':'-':'+':c:s' | isSpace c ->
         case reverse s' of
           '}':'-':s -> (LiterateComment,(p,reverse s))
           _ -> (NestedComment,ps) -- Can't happen
    _ -> (NestedComment,ps)

ctx t s = tag t++s++endtag t
ctx' t as s = tag (t++shas as)++s++endtag t
  where
    shas = concatMap sha
    sha (n,v) = ' ':n++"="++quote v

tag t = "<"++t++">"
endtag t = tag ('/':t)

esc = concatMap esc1
  where esc1 '<' = "&lt;"
	esc1 '&' = "&amp;"
	esc1 c = [c]

quote s =
  if all isAlphaNum s
  then s
  else '"':s++"\""

mangle = concatMap mangle1
  where
    mangle1 c = if isAlphaNum c
		then [c]
		else '.':show (fromEnum c) -- hmm