Commit f351a076 authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Fixed representation of HTML documentation of Curry modules

parent 378e06d3
......@@ -20,8 +20,8 @@ import Network.URI (escapeURIString, isUnreserved)
import System.Directory (copyFile, doesFileExist)
import System.FilePath ((</>))
import Curry.Base.Ident ( ModuleIdent (..), QualIdent (..), unqualify
, moduleName)
import Curry.Base.Ident ( ModuleIdent (..), Ident (..), QualIdent (..)
, unqualify, moduleName)
import Curry.Base.Monad (CYIO, liftCYM, failMessages)
import Curry.Base.Pretty ((<+>), text, vcat)
import Curry.Files.PathUtils (readModule)
......@@ -112,25 +112,27 @@ program2html m codes = unlines
, "</html>"
]
where
titleHtml = "Module " ++ show m
titleHtml = "Module " ++ moduleName m
lineHtml = unlines $ map show [1 .. length (lines codeHtml)]
codeHtml = concat $ snd $ mapAccumL (code2html m) [] codes
code2html :: ModuleIdent -> [QualIdent] -> Code -> ([QualIdent], String)
code2html m defs c
| isCall c = (defs, maybe tag (addHtmlLink m tag) (getQualIdent c))
| isCall c = (defs, maybe tag (addEntityLink m tag) (getQualIdent c))
| isDecl c = case getQualIdent c of
Just i | i `notElem` defs
-> (i:defs, spanTag (code2class c) (escIdent i) (escCode c))
_ -> (defs, tag)
| otherwise = (defs, tag)
| otherwise = case c of
ModuleName m' -> (defs, addModuleLink m m' tag)
_ -> (defs, tag)
where tag = spanTag (code2class c) "" (escCode c)
escCode :: Code -> String
escCode = htmlQuote . code2string
escIdent :: QualIdent -> String
escIdent = htmlQuote . show . unqualify
escIdent = htmlQuote . idName . unqualify
spanTag :: String -> String -> String -> String
spanTag clV idV str
......@@ -160,12 +162,16 @@ code2class (NumberCode _) = "number"
code2class (StringCode _) = "string"
code2class (CharCode _) = "char"
addHtmlLink :: ModuleIdent -> String -> QualIdent -> String
addHtmlLink m str qid =
addModuleLink :: ModuleIdent -> ModuleIdent -> String -> String
addModuleLink m m' str
= "<a href=\"" ++ makeRelativePath m m' ++ "\">" ++ str ++ "</a>"
addEntityLink :: ModuleIdent -> String -> QualIdent -> String
addEntityLink m str qid =
"<a href=\"" ++ modPath ++ "#" ++ fragment ++ "\">" ++ str ++ "</a>"
where
modPath = maybe "" (makeRelativePath m) mmid
fragment = string2urlencoded (show ident)
fragment = string2urlencoded (idName ident)
(mmid, ident) = (qidModule qid, qidIdent qid)
makeRelativePath :: ModuleIdent -> ModuleIdent -> String
......
......@@ -21,7 +21,7 @@ module Html.SyntaxColoring
) where
import Data.Function (on)
import Data.List (intercalate, sortBy)
import Data.List (sortBy)
import Curry.Base.Ident
import Curry.Base.Position
......@@ -83,7 +83,7 @@ data IdentUsage
-- @param lex-Result
-- @return program
genProgram :: String -> Module -> [(Position, Token)] -> [Code]
genProgram fn m toks = tokenToCodes (first fn) (idsModule m) toks
genProgram fn m toks = encodeToks (first fn) (idsModule m) toks
-- @param code
-- @return qid if available
......@@ -94,43 +94,38 @@ getQualIdent (Identifier _ qid) = Just qid
getQualIdent (TypeCons _ qid) = Just qid
getQualIdent _ = Nothing
tokenToCodes :: Position -> [Code] -> [(Position, Token)] -> [Code]
tokenToCodes _ _ [] = []
tokenToCodes curPos ids toks@((pos, tok) : ts)
encodeToks :: Position -> [Code] -> [(Position, Token)] -> [Code]
encodeToks _ _ [] = []
encodeToks cur ids toks@((pos, tok) : ts)
-- advance line
| line curPos < line pos
= NewLine : tokenToCodes (nl curPos) ids toks
| line cur < line pos = NewLine : encodeToks (nl cur) ids toks
-- advance column
| column curPos < column pos
= Space colDiff : tokenToCodes (incr curPos colDiff) ids toks
| isPragmaToken tok
= let (pragmas, (end:rest)) = break (isPragmaEnd . snd) toks
str = intercalate " " $ map (showToken . snd) (pragmas ++ [end])
in Pragma str : tokenToCodes (incr curPos (length str)) ids rest
-- no identifier token
| not (isTokenIdentifier tok)
= tokenToCode tok : tokenToCodes newPos ids ts
-- identifier, but no more information
| null ids
= tokenToCode tok : tokenToCodes newPos ids ts
| tokenStr == code2string (head ids)
= head ids : tokenToCodes newPos (tail ids) ts
| otherwise
= tokenToCodes curPos (tail ids) toks
| column cur < column pos = let d = column pos - column cur
in Space d : encodeToks (incr cur d) ids toks
-- pragma token
| isPragmaToken tok = let (ps, (end:rest)) = break (isPragmaEnd . snd) toks
s = unwords $ map (showToken . snd) (ps ++ [end])
in Pragma s : encodeToks (incr cur (length s)) ids rest
-- identifier token
| isIdentTok tok = case ids of
[] -> encodeTok tok : encodeToks newPos [] ts
(i:is) | tokenStr == code2string i -> i : encodeToks newPos is ts
| otherwise -> encodeToks cur is toks
-- other token
| otherwise = encodeTok tok : encodeToks newPos ids ts
where
colDiff = column pos - column curPos
tokenStr = showToken tok
newPos = incr curPos (length tokenStr)
newPos = incr cur (length tokenStr)
code2string :: Code -> String
code2string (Keyword s) = s
code2string (Space i) = replicate i ' '
code2string NewLine = "\n"
code2string (Pragma s) = s
code2string (DataCons _ qid) = idName $ unqualify qid
code2string (TypeCons _ qid) = idName $ unqualify qid
code2string (Function _ qid) = idName $ unqualify qid
code2string (Identifier _ qid) = idName $ unqualify qid
code2string (DataCons _ qid) = qualName qid
code2string (TypeCons _ qid) = qualName qid
code2string (Function _ qid) = qualName qid
code2string (Identifier _ qid) = qualName qid
code2string (ModuleName mid) = moduleName mid
code2string (Commentary s) = s
code2string (NumberCode s) = s
......@@ -138,22 +133,22 @@ code2string (StringCode s) = s
code2string (CharCode s) = s
code2string (Symbol s) = s
tokenToCode :: Token -> Code
tokenToCode tok@(Token cat _)
| cat `elem` numCategories = NumberCode (showToken tok)
| cat == CharTok = CharCode (showToken tok)
| cat == StringTok = StringCode (showToken tok)
| cat `elem` keywordCategories = Keyword (showToken tok)
| cat `elem` specialIdentCategories = Keyword (showToken tok)
| cat `elem` punctuationCategories = Symbol (showToken tok)
| cat `elem` reservedOpsCategories = Symbol (showToken tok)
| cat `elem` commentCategories = Commentary (showToken tok)
| cat `elem` identCategories = Identifier IdUnknown $ qualify $ mkIdent
encodeTok :: Token -> Code
encodeTok tok@(Token c _)
| c `elem` numCategories = NumberCode (showToken tok)
| c == CharTok = CharCode (showToken tok)
| c == StringTok = StringCode (showToken tok)
| c `elem` keywordCategories = Keyword (showToken tok)
| c `elem` specialIdentCategories = Keyword (showToken tok)
| c `elem` punctuationCategories = Symbol (showToken tok)
| c `elem` reservedOpsCategories = Symbol (showToken tok)
| c `elem` commentCategories = Commentary (showToken tok)
| c `elem` identCategories = Identifier IdUnknown $ qualify $ mkIdent
$ showToken tok
| cat `elem` whiteSpaceCategories = Space 0
| cat `elem` pragmaCategories = Pragma (showToken tok)
| c `elem` whiteSpaceCategories = Space 0
| c `elem` pragmaCategories = Pragma (showToken tok)
| otherwise = internalError $
"SyntaxColoring.tokenToCode: Unknown token" ++ showToken tok
"SyntaxColoring.encodeTok: Unknown token" ++ showToken tok
numCategories :: [Category]
numCategories = [IntTok, FloatTok]
......@@ -187,13 +182,13 @@ identCategories :: [Category]
identCategories = [Id, QId, Sym, QSym, SymDot, SymMinus, SymMinusDot]
isPragmaToken :: Token -> Bool
isPragmaToken (Token cat _) = cat `elem` pragmaCategories
isPragmaToken (Token c _) = c `elem` pragmaCategories
isPragmaEnd :: Token -> Bool
isPragmaEnd (Token cat _) = cat == PragmaEnd
isPragmaEnd (Token c _) = c == PragmaEnd
isTokenIdentifier :: Token -> Bool
isTokenIdentifier (Token cat _) = cat `elem` identCategories
isIdentTok :: Token -> Bool
isIdentTok (Token c _) = c `elem` identCategories
whiteSpaceCategories :: [Category]
whiteSpaceCategories = [EOF, VSemicolon, VRightBrace]
......@@ -233,19 +228,7 @@ idsModule (Module _ mid es is ds) =
let hdrCodes = ModuleName mid : idsExportSpec es
impCodes = concatMap idsImportDecl (sortBy cmpImportDecl is)
dclCodes = concatMap idsDecl (sortBy cmpDecl ds)
in map (addModuleIdent mid) $ hdrCodes ++ impCodes ++ dclCodes
addModuleIdent :: ModuleIdent -> Code -> Code
addModuleIdent mid c@(Function x qid)
| hasGlobalScope (unqualify qid) = Function x (qualQualify mid qid)
| otherwise = c
addModuleIdent mid cn@(DataCons x qid)
| not $ isQualified qid = DataCons x (qualQualify mid qid)
| otherwise = cn
addModuleIdent mid tc@(TypeCons x qid)
| not $ isQualified qid = TypeCons x (qualQualify mid qid)
| otherwise = tc
addModuleIdent _ c = c
in hdrCodes ++ impCodes ++ dclCodes
-- Exports
......@@ -496,8 +479,8 @@ showAttr (IntAttributes i _) = show i
showAttr (FloatAttributes f _) = show f
showAttr (StringAttributes s _) = show s
showAttr (IdentAttributes m i)
| null m = show $ qualify (mkIdent i)
| otherwise = show $ qualifyWith (mkMIdent m) (mkIdent i)
| null m = idName $ (mkIdent i)
| otherwise = qualName $ qualifyWith (mkMIdent m) (mkIdent i)
showAttr (OptionsAttributes mt s) = showTool mt ++ ' ' : s
showTool :: Maybe String -> String
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment