Skip to content

GitLab

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

Refactored HTML generation

parent 54df07fd
Expand all Hide whitespace changes
Inline Side-by-side
src/Html/CurryHtml.hs
View file @ e5d92b76
......@@ -16,7 +16,6 @@ module Html.CurryHtml (source2html) where
import Control.Monad.Writer
import Control.Monad.Trans.Either
import Data.Char (toLower)
import Data.Maybe (fromMaybe, isJust)
import System.FilePath ((</>), dropFileName, takeBaseName)
......@@ -24,14 +23,15 @@ import Curry.Base.Ident (QualIdent (..), unqualify)
import Curry.Base.Message
import Curry.Base.Pretty (text)
import Curry.Files.PathUtils (readModule, lookupCurryFile)
import Curry.Syntax (Module, lexSource, parseModule)
import Curry.Syntax (Module, lexSource)
import Html.SyntaxColoring
import Base.Messages
import CompilerOpts (Options(..), TargetType (..), defaultOptions)
import CompilerOpts (Options (..))
import CurryBuilder (buildCurry)
import Modules (loadAndCheckModule, checkModuleHeader)
import Modules (loadAndCheckModule)
import Transformations (qual)
--- translate source file into HTML file with syntaxcoloring
--- @param sourcefilename
......@@ -47,113 +47,84 @@ source2html opts f = do
--- @param importpaths
--- @param filename
--- @return program
filename2program :: Options -> String -> CYIO Program
filename2program :: Options -> String -> CYIO [Code]
filename2program opts f = do
mbModule <- liftIO $ readModule f
case mbModule of
Nothing -> left [message $ text $ "Missing file: " ++ f]
Just src -> do
typed <- liftIO $ fromIO $ fullParse opts f src
checked <- liftIO $ fromIO $ fullParse (opts { optTargetTypes = [UntypedAbstractCurry]}) f src
let parsed = parse f src
lexed = lexSource f src
return $ genProgram src [typed, checked, parsed] lexed
{- |Return the result of a syntactical analysis of the source program 'src'.
The result is the syntax tree of the program (type 'Module'; see Module
"CurrySyntax").
-}
parse :: FilePath -> String -> MessageM Module
parse fn src = parseModule fn src >>= genCurrySyntax
where
genCurrySyntax mod1 = do
checked <- lift $ runEitherT $ checkModuleHeader defaultOptions fn mod1
case checked of
Left hdrErrs -> failWith $ show $ head hdrErrs
Right mdl -> return mdl
{- |Return the syntax tree of the source program 'src' (type 'Module'; see
Module "CurrySyntax").after inferring the types of identifiers.
'fullParse' always searches for standard Curry libraries in the path
defined in the
environment variable "PAKCSLIBPATH". Additional search paths can
be defined using the argument 'paths'.
-}
fullParse :: Options -> FilePath -> String -> MessageIO Module
case runMsg (lexSource f src) of
Left e -> left [e]
Right (toks, _) -> do
typed <- fullParse opts f src
return (genProgram typed toks)
-- |Return the syntax tree of the source program 'src' (type 'Module'; see
-- Module "CurrySyntax").after inferring the types of identifiers.
-- 'fullParse' always searches for standard Curry libraries in the path
-- defined in the
-- environment variable "PAKCSLIBPATH". Additional search paths can
-- be defined using the argument 'paths'.
fullParse :: Options -> FilePath -> String -> CYIO Module
fullParse opts fn _ = do
errs <- liftIO $ makeInterfaces opts fn
if null errs
then do
checked <- liftIO $ runEitherT $ loadAndCheckModule opts fn
case checked of
Left errs' -> failWith $ show $ head errs'
Right (_, mod') -> return mod'
else failWith $ show $ head errs
-- Generates interface files for importes modules, if they don't exist or
-- if they are not up-to-date.
makeInterfaces :: Options -> FilePath -> IO [Message]
makeInterfaces opts fn = do
res <- runEitherT $ buildCurry opts fn
case res of
Left errs -> return errs
Right _ -> return []
buildCurry (opts { optTargetTypes = []}) fn
(env, mdl) <- loadAndCheckModule opts fn
return (fst $ qual opts env mdl)
-- generates htmlcode with syntax highlighting
-- @param modulname
-- @param a program
-- @return HTMLcode
program2html :: String -> Program -> String
program2html modulname codes =
"<html>\n<head>\n<title>Module " ++
modulname ++
"</title>\n" ++
"<link rel=\"stylesheet\" type=\"text/css\" href=\"currydoc.css\">" ++
"</link>\n</head>\n" ++
"<body style=\"font-family:'Courier New', Arial;\">\n<pre>\n" ++
concatMap (code2html True . (\ (_, _, c) -> c)) codes ++
"<pre>\n</body>\n</html>"
code2html :: Bool -> Code -> String
code2html ownClass code@(CodeWarning _ c) =
(if ownClass then spanTag (code2class code) else id) (code2html False c)
code2html ownClass code@(Commentary _) =
(if ownClass then spanTag (code2class code) else id)
(replace '<' "<span>&lt</span>" (code2string code))
code2html ownClass c
| isCall c && ownClass = maybe tag (addHtmlLink tag) (getQualIdent c)
| isDecl c && ownClass = maybe tag (addHtmlAnchor tag) (getQualIdent c)
| otherwise = tag
where tag = (if ownClass then spanTag (code2class c) else id)
(htmlQuote (code2string c))
program2html :: String -> [Code] -> String
program2html modulname codes = unlines
[ "<!DOCTYPE html>"
, "<html>", "<head>", "<title>Module " ++ modulname ++ "</title>"
, "<link rel=\"stylesheet\" type=\"text/css\" href=\"currydoc.css\"/>"
, "</head>"
, "<body style=\"font-family:'Courier New', Arial;\">"
, "<table><tbody><tr>"
, "<td class=\"linenumbers\"><pre>" ++ lineHtml ++ "</pre></td>"
, "<td class=\"sourcecode\"><pre>" ++ codeHtml ++ "</pre></td>"
, "</tr></tbody></table>"
, "</body>"
, "</html>"
]
where
lineHtml = unlines $ map show [1 .. length (lines codeHtml)]
codeHtml = concatMap code2html codes
code2html :: Code -> String
code2html code@(Commentary _) =
spanTag (code2class code) (replace '<' "<span>&lt</span>" (code2string code))
code2html c
| isCall c = maybe tag (addHtmlLink tag) (getQualIdent c)
| isDecl c = maybe tag (addHtmlAnchor tag) (getQualIdent c)
| otherwise = tag
where tag = spanTag (code2class c) (htmlQuote (code2string c))
spanTag :: String -> String -> String
spanTag [] str = str
spanTag cl str = "<span class=\"" ++ cl ++ "\">" ++ str ++ "</span>"
-- which code has which color
-- which code has which css class
-- @param code
-- @return color of the code
-- @return css class 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
code2class (Space _) = ""
code2class NewLine = ""
code2class (Keyword _) = "keyword"
code2class (Pragma _) = "pragma"
code2class (Symbol _) = "symbol"
code2class (TypeCons _ _) = "type"
code2class (DataCons _ _) = "cons"
code2class (Label _ _) = "label"
code2class (Function _ _) = "func"
code2class (Identifier _ _) = "ident"
code2class (ModuleName _) = "module"
code2class (Commentary _) = "comment"
code2class (NumberCode _) = "number"
code2class (StringCode _) = "string"
code2class (CharCode _) = "char"
replace :: Char -> String -> String -> String
replace old new = foldr (\ x -> if x == old then (new ++) else ([x] ++)) ""
......@@ -174,27 +145,22 @@ addHtmlLink str qid =
"</a>"
isCall :: Code -> Bool
isCall (TypeConstructor TypeExport _) = True
isCall (TypeConstructor _ _) = False
isCall (Identifier _ _) = False
isCall code = not (isDecl code) && isJust (getQualIdent code)
isCall (TypeCons TypeExport _) = True
isCall (TypeCons TypeImport _) = True
isCall (TypeCons TypeRefer _) = True
isCall (TypeCons _ _) = False
isCall (Identifier _ _) = False
isCall c = not (isDecl c) && isJust (getQualIdent c)
isDecl :: Code -> Bool
isDecl (ConstructorName ConstrDecla _) = True
isDecl (Function FunDecl _) = True
isDecl (TypeConstructor TypeDecla _) = True
isDecl _ = False
isDecl (DataCons ConsDeclare _) = True
isDecl (Function FuncDeclare _) = True
isDecl (TypeCons TypeDeclare _) = True
isDecl _ = False
-- Translates arbitrary strings into equivalent urlencoded string.
string2urlencoded :: String -> String
string2urlencoded = id
{-
string2urlencoded [] = []
string2urlencoded (c:cs)
| isAlphaNum c = c : string2urlencoded cs
| c == ' ' = '+' : string2urlencoded cs
| otherwise = show (ord c) ++ (if null cs then "" else ".") ++ string2urlencoded cs
-}
htmlQuote :: String -> String
htmlQuote [] = []
......
src/Html/SyntaxColoring.hs
View file @ e5d92b76
This diff is collapsed.
src/Html/currydoc.css
View file @ e5d92b76
......@@ -7,28 +7,28 @@ body { background: white; color: black }
/* Show hyperlinks without underscore */
a:visited, a:link, a:active { text-decoration: none }
.keyword { color:blue }
.constructorname_constrpattern { color : #FF00FF }
.constructorname_constrcall { color : #FF00FF }
.constructorname_constrdecla { color : #FF00FF }
.constructorname_otherconstrkind { color : #FF00FF }
.typeconstructor_typedecla { color : #ff7f50 }
.typeconstructor_typeuse { color : #ff7f50 }
.typeconstructor_typeexport { color : #ff7f50 }
.function_infixfunction { color : #800080 }
.function_typsig { color : #800080 }
.function_fundecl { color : #800080 }
.function_functioncall { color : #800080 }
.function_otherfunctionkind { color : #800080 }
.moduleName { color : #800000 }
.commentary { color : green }
.numberCode { color : #008080 }
.stringCode { color : #800000 }
.charCode { color : #800000 }
.linenumbers {
width : 40px;
text-align : right;
color : grey;
padding-right: 10px;
border-right : 1px solid grey;
}
.sourcecode {
padding-left: 10px;
}
.pragma { color : green }
.comment { color : green }
.keyword { color : blue }
.symbol { color : #C0C0C0 }
.identifier_iddecl { color : black }
.identifier_idoccur { color : black }
.identifier_unknownid { color : black }
.codeWarning {font-weight: bold;font-style:italic; color : red }
.codeError { font-style:italic; color : #a52a2a }
.notParsed { font-style:italic; color : #C0C0C0 }
\ No newline at end of file
.type { color : #ff7f50 }
.cons { color : #ff00ff }
.label { color : #90EE90 }
.func { color : #800080 }
.ident { color : black }
.module { color : #800000 }
.number { color : #008080 }
.string { color : #800000 }
.char { color : #800000 }
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