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