HLex2html

module HLex2html({-hlex2html,-}hlex2html',simpleHlex2html) where
import RefsTypes --hiding (isDef)
import MUtils(apSnd)
import Char(isSpace{-,isAlpha-},isAlphaNum)
import HsTokens
import SrcLoc
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

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