Commit b43e7387 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Improved HTML generation

parent e5ac807a
...@@ -13,12 +13,13 @@ ...@@ -13,12 +13,13 @@
-} -}
module Html.CurryHtml (source2html) where module Html.CurryHtml (source2html) where
import Data.Maybe (fromMaybe, isJust) import Data.Char (toLower)
import Data.Maybe (fromMaybe, isJust)
import Curry.Base.Ident (QualIdent (..), unqualify) import Curry.Base.Ident (QualIdent (..), unqualify)
import Curry.Base.Message (fromIO) import Curry.Base.Message (fromIO)
import Curry.Files.PathUtils import Curry.Files.PathUtils
(readModule, writeModule, lookupCurryFile, dropExtension, takeFileName) (readModule, lookupCurryFile, dropExtension, takeFileName)
import Curry.Syntax (lexSource) import Curry.Syntax (lexSource)
import Html.SyntaxColoring import Html.SyntaxColoring
...@@ -28,39 +29,32 @@ import CompilerOpts (Options(..), TargetType (..)) ...@@ -28,39 +29,32 @@ import CompilerOpts (Options(..), TargetType (..))
import Frontend (parse, fullParse) import Frontend (parse, fullParse)
--- translate source file into HTML file with syntaxcoloring --- translate source file into HTML file with syntaxcoloring
--- @param outputfilename
--- @param sourcefilename --- @param sourcefilename
source2html :: Options -> String -> IO () source2html :: Options -> FilePath -> IO ()
source2html opts sourcefilename = do source2html opts f = do
let imports = optImportPaths opts let baseName = dropExtension f
outputfilename = fromMaybe "" $ optOutput opts modulname = takeFileName baseName
sourceprogname = dropExtension sourcefilename outFileOpt = fromMaybe "" $ optOutput opts
output' = if null outputfilename outFile = if null outFileOpt then baseName ++ "_curry.html"
then sourceprogname ++ "_curry.html" else outFileOpt
else outputfilename srcFile <- lookupCurryFile (optImportPaths opts) f
modulname = takeFileName sourceprogname program <- filename2program opts (fromMaybe f srcFile)
fullfname <- lookupCurryFile imports sourcefilename writeFile outFile (program2html modulname program)
program <- filename2program opts (fromMaybe sourcefilename fullfname)
(if null outputfilename then writeModule True output'
else writeFile output')
(program2html modulname program)
--- @param importpaths --- @param importpaths
--- @param filename --- @param filename
--- @return program --- @return program
filename2program :: Options -> String -> IO Program filename2program :: Options -> String -> IO Program
filename2program opts filename = do filename2program opts f = do
mbModule <- readModule filename mbModule <- readModule f
case mbModule of case mbModule of
Nothing -> abortWith ["Missing file: " ++ filename] Nothing -> abortWith ["Missing file: " ++ f]
Just cont -> do Just src -> do
typingParseRes <- fromIO $ fullParse opts filename cont typed <- fromIO $ fullParse opts f src
fullParseRes <- fromIO $ fullParse (opts { optTargetTypes = [UntypedAbstractCurry]}) filename cont checked <- fromIO $ fullParse (opts { optTargetTypes = [UntypedAbstractCurry]}) f src
let parseRes = parse filename cont let parsed = parse f src
lexRes = lexSource filename cont lexed = lexSource f src
return $ genProgram cont [typingParseRes, fullParseRes, parseRes] lexRes return $ genProgram src [typed, checked, parsed] lexed
-- generates htmlcode with syntax highlighting -- generates htmlcode with syntax highlighting
-- @param modulname -- @param modulname
...@@ -77,37 +71,6 @@ program2html modulname codes = ...@@ -77,37 +71,6 @@ program2html modulname codes =
concatMap (code2html True . (\ (_, _, c) -> c)) codes ++ concatMap (code2html True . (\ (_, _, c) -> c)) codes ++
"<pre>\n</body>\n</html>" "<pre>\n</body>\n</html>"
-- which code has which color
-- @param code
-- @return color of the code
code2class :: Code -> String
code2class (Keyword _) = "keyword"
code2class (Space _) = ""
code2class NewLine = ""
code2class (ConstructorName ConstrPattern _) = "constructorname_constrpattern"
code2class (ConstructorName ConstrCall _) = "constructorname_constrcall"
code2class (ConstructorName ConstrDecla _) = "constructorname_constrdecla"
code2class (ConstructorName OtherConstrKind _) = "constructorname_otherconstrkind"
code2class (Function InfixFunction _) = "function_infixfunction"
code2class (Function TypSig _) = "function_typsig"
code2class (Function FunDecl _) = "function_fundecl"
code2class (Function FunctionCall _) = "function_functioncall"
code2class (Function OtherFunctionKind _) = "function_otherfunctionkind"
code2class (ModuleName _) = "modulename"
code2class (Commentary _) = "commentary"
code2class (NumberCode _) = "numbercode"
code2class (StringCode _) = "stringcode"
code2class (CharCode _) = "charcode"
code2class (Symbol _) = "symbol"
code2class (Identifier IdDecl _) = "identifier_iddecl"
code2class (Identifier IdOccur _) = "identifier_idoccur"
code2class (Identifier UnknownId _) = "identifier_unknownid"
code2class (TypeConstructor TypeDecla _) = "typeconstructor_typedecla"
code2class (TypeConstructor TypeUse _) = "typeconstructor_typeuse"
code2class (TypeConstructor TypeExport _) = "typeconstructor_typeexport"
code2class (CodeWarning _ _) = "codewarning"
code2class (NotParsed _) = "notparsed"
code2html :: Bool -> Code -> String code2html :: Bool -> Code -> String
code2html ownClass code@(CodeWarning _ c) = code2html ownClass code@(CodeWarning _ c) =
(if ownClass then spanTag (code2class code) else id) (code2html False c) (if ownClass then spanTag (code2class code) else id) (code2html False c)
...@@ -115,9 +78,9 @@ code2html ownClass code@(Commentary _) = ...@@ -115,9 +78,9 @@ code2html ownClass code@(Commentary _) =
(if ownClass then spanTag (code2class code) else id) (if ownClass then spanTag (code2class code) else id)
(replace '<' "<span>&lt</span>" (code2string code)) (replace '<' "<span>&lt</span>" (code2string code))
code2html ownClass c code2html ownClass c
| isCall c && ownClass = maybe tag (addHtmlLink tag) (getQualIdent c) | isCall c && ownClass = maybe tag (addHtmlLink tag) (getQualIdent c)
| isDecl c && ownClass = maybe tag (addHtmlAnchor tag) (getQualIdent c) | isDecl c && ownClass = maybe tag (addHtmlAnchor tag) (getQualIdent c)
| otherwise = tag | otherwise = tag
where tag = (if ownClass then spanTag (code2class c) else id) where tag = (if ownClass then spanTag (code2class c) else id)
(htmlQuote (code2string c)) (htmlQuote (code2string c))
...@@ -125,13 +88,35 @@ spanTag :: String -> String -> String ...@@ -125,13 +88,35 @@ spanTag :: String -> String -> String
spanTag [] str = str spanTag [] str = str
spanTag cl str = "<span class=\"" ++ cl ++ "\">" ++ str ++ "</span>" spanTag cl str = "<span class=\"" ++ cl ++ "\">" ++ str ++ "</span>"
-- which code has which color
-- @param code
-- @return color of the code
code2class :: Code -> String
code2class (Keyword _) = "keyword"
code2class (Space _) = ""
code2class NewLine = ""
code2class (ConstructorName k _) = "constructorname_" ++ showLower k
code2class (Function k _) = "function_" ++ showLower k
code2class (ModuleName _) = "modulename"
code2class (Commentary _) = "commentary"
code2class (NumberCode _) = "numbercode"
code2class (StringCode _) = "stringcode"
code2class (CharCode _) = "charcode"
code2class (Symbol _) = "symbol"
code2class (Identifier k _) = "identifier_" ++ showLower k
code2class (TypeConstructor k _) = "typeconstructor_" ++ showLower k
code2class (CodeWarning _ _) = "codewarning"
code2class (NotParsed _) = "notparsed"
showLower :: Show a => a -> String
showLower = map toLower . show
replace :: Char -> String -> String -> String replace :: Char -> String -> String -> String
replace old new = foldr (\ x -> if x == old then (new ++) else ([x] ++)) "" replace old new = foldr (\ x -> if x == old then (new ++) else ([x] ++)) ""
addHtmlAnchor :: String -> QualIdent -> String addHtmlAnchor :: String -> QualIdent -> String
addHtmlAnchor str qualIdent = "<a name=\"" ++ addHtmlAnchor str qid = "<a name=\"" ++ anchor ++ "\"></a>" ++ str
string2urlencoded (show (unqualify qualIdent)) ++ where anchor = string2urlencoded (show (unqualify qid))
"\"></a>" ++ str
addHtmlLink :: String -> QualIdent -> String addHtmlLink :: String -> QualIdent -> String
addHtmlLink str qid = addHtmlLink str qid =
...@@ -146,15 +131,15 @@ addHtmlLink str qid = ...@@ -146,15 +131,15 @@ addHtmlLink str qid =
isCall :: Code -> Bool isCall :: Code -> Bool
isCall (TypeConstructor TypeExport _) = True isCall (TypeConstructor TypeExport _) = True
isCall (TypeConstructor _ _) = False isCall (TypeConstructor _ _) = False
isCall (Identifier _ _) = False isCall (Identifier _ _) = False
isCall code = not (isDecl code) && isJust (getQualIdent code) isCall code = not (isDecl code) && isJust (getQualIdent code)
isDecl :: Code -> Bool isDecl :: Code -> Bool
isDecl (ConstructorName ConstrDecla _) = True isDecl (ConstructorName ConstrDecla _) = True
isDecl (Function FunDecl _) = True isDecl (Function FunDecl _) = True
isDecl (TypeConstructor TypeDecla _) = True isDecl (TypeConstructor TypeDecla _) = True
isDecl _ = False isDecl _ = False
-- Translates arbitrary strings into equivalent urlencoded string. -- Translates arbitrary strings into equivalent urlencoded string.
string2urlencoded :: String -> String string2urlencoded :: String -> String
......
This diff is collapsed.
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