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 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
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 '<' = "<" esc1 '&' = "&" 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