Skip to content

GitLab

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

Improved HTML generation: Support for hierarchical modules, HTML5

parent 2d476d6e
Hide whitespace changes
Inline Side-by-side
curry-frontend.cabal
View file @ 0f3765d6
......@@ -23,15 +23,19 @@ Stability: experimental
Extra-Source-Files: LIESMICH
Data-Files: src/Html/currydoc.css
Flag split-syb
Description: Has the syb functionality been split into the package syb?
Default: True
Flag network-uri
description: Get Network.URI from the network-uri package
default: True
Executable cymake
hs-source-dirs: src
Main-is: cymake.hs
Build-Depends: base == 4.*, curry-base == 0.3.10
, containers, directory, mtl, process, transformers, syb
if flag(network-uri)
build-depends: network-uri >= 2.6
else
build-depends: network < 2.6
ghc-options: -Wall
Other-Modules:
Base.CurryTypes
......
src/Html/CurryHtml.hs
View file @ 0f3765d6
......@@ -15,19 +15,22 @@ module Html.CurryHtml (source2html) where
import Control.Monad.Writer
import Data.List (mapAccumL)
import Data.Maybe (fromMaybe, isJust)
import System.FilePath ((</>), dropFileName, takeBaseName)
import Network.URI (escapeURIString, isUnreserved)
import System.FilePath ((</>), dropFileName, joinPath, takeBaseName)
import Curry.Base.Ident (QualIdent (..), unqualify)
import Curry.Base.Ident (ModuleIdent (..), QualIdent (..), unqualify)
import Curry.Base.Monad
import Curry.Base.Pretty (text)
import Curry.Files.Filenames (moduleNameToFile)
import Curry.Files.PathUtils (readModule, lookupCurryFile)
import Curry.Syntax (Module, lexSource)
import Curry.Syntax (Module (..), lexSource)
import Html.SyntaxColoring
import Base.Messages
import CompilerOpts (Options (..))
import CompilerOpts (Options (..), WarnOpts (..))
import CurryBuilder (buildCurry)
import Modules (loadAndCheckModule)
import Transformations (qual)
......@@ -39,22 +42,22 @@ source2html opts f = do
let baseName = takeBaseName f
outDir = fromMaybe (dropFileName f) $ optHtmlDir opts
outFile = outDir </> baseName ++ "_curry.html"
program <- filename2program opts (fromMaybe f srcFile)
liftIO $ writeFile outFile (program2html baseName program)
srcFile <- liftIO $ lookupCurryFile ("." : optImportPaths opts) f
(m, program) <- filename2program opts (fromMaybe f srcFile)
liftIO $ writeFile outFile (program2html m program)
-- @param importpaths
-- @param filename
-- @return program
filename2program :: Options -> String -> CYIO [Code]
filename2program :: Options -> String -> CYIO (ModuleIdent, [Code])
filename2program opts f = do
mbModule <- liftIO $ readModule f
case mbModule of
Nothing -> failMessages [message $ text $ "Missing file: " ++ f]
Just src -> do
toks <- liftCYM $ lexSource f src
typed <- fullParse opts f src
return (genProgram typed toks)
toks <- liftCYM $ lexSource f src
typed@(Module _ m _ _ _) <- fullParse opts f src
return (m, genProgram typed toks)
-- |Return the syntax tree of the source program 'src' (type 'Module'; see
-- Module "CurrySyntax").after inferring the types of identifiers.
......@@ -65,20 +68,26 @@ filename2program opts f = do
fullParse :: Options -> FilePath -> String -> CYIO Module
fullParse opts fn _ = do
buildCurry (opts { optTargetTypes = []}) fn
(env, mdl) <- loadAndCheckModule opts fn
(env, mdl) <- loadAndCheckModule opts' fn
return (fst $ qual opts env mdl)
where
opts' = opts { optWarnOpts = (optWarnOpts opts) { wnWarn = False }
, optTargetTypes = []
}
-- generates htmlcode with syntax highlighting
-- @param modulname
-- @param a program
-- @return HTMLcode
program2html :: String -> [Code] -> String
program2html modulname codes = unlines
program2html :: ModuleIdent -> [Code] -> String
program2html m codes = unlines
[ "<!DOCTYPE html>"
, "<html>", "<head>", "<title>Module " ++ modulname ++ "</title>"
, "<link rel=\"stylesheet\" type=\"text/css\" href=\"currydoc.css\"/>"
, "<html>", "<head>"
, "<meta http-equiv=\"Content-Type\" content=\"text/html;charset=utf-8\" />"
, "<title>" ++ titleHtml ++ "</title>"
, "<link rel=\"stylesheet\" type=\"text/css\" href=\"" ++ styleLink ++ "\"/>"
, "</head>"
, "<body style=\"font-family:'Courier New', Arial;\">"
, "<body>"
, "<table><tbody><tr>"
, "<td class=\"linenumbers\"><pre>" ++ lineHtml ++ "</pre></td>"
, "<td class=\"sourcecode\"><pre>" ++ codeHtml ++ "</pre></td>"
......@@ -87,21 +96,35 @@ program2html modulname codes = unlines
, "</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>"
titleHtml = "Module " ++ show m
styleLink = makeTopPath m </> "currydoc.css"
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))
| 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)
where tag = spanTag (code2class c) "" (escCode c)
escCode :: Code -> String
escCode = htmlQuote . code2string
escIdent :: QualIdent -> String
escIdent = string2urlencoded . show . unqualify
spanTag :: String -> String -> String -> String
spanTag clV idV str
| null clV && null idV = str
| otherwise = "<span" ++ codeclass ++ idValue ++ ">"
++ str ++ "</span>"
where
codeclass = if null clV then "" else " class=\"" ++ clV ++ "\""
idValue = if null idV then "" else " id=\"" ++ idV ++ "\""
-- which code has which css class
-- @param code
......@@ -123,23 +146,21 @@ 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] ++)) ""
addHtmlLink :: ModuleIdent -> String -> QualIdent -> String
addHtmlLink m str qid =
"<a href=\"" ++ modPath ++ "#" ++ fragment ++ "\">" ++ str ++ "</a>"
where
modPath = maybe "" (makeRelativePath m) mmid
fragment = string2urlencoded (show ident)
(mmid, ident) = (qidModule qid, qidIdent qid)
addHtmlAnchor :: String -> QualIdent -> String
addHtmlAnchor str qid = "<a name=\"" ++ anchor ++ "\"></a>" ++ str
where anchor = string2urlencoded (show (unqualify qid))
makeRelativePath :: ModuleIdent -> ModuleIdent -> String
makeRelativePath cur new
| cur == new = ""
| otherwise = makeTopPath cur </> moduleNameToFile new ++ "_curry.html"
addHtmlLink :: String -> QualIdent -> String
addHtmlLink str qid =
let (maybeModIdent, ident) = (qidModule qid, qidIdent qid) in
"<a href=\"" ++
maybe "" (\ x -> show x ++ "_curry.html") maybeModIdent ++
"#" ++
string2urlencoded (show ident) ++
"\">" ++
str ++
"</a>"
makeTopPath :: ModuleIdent -> String
makeTopPath m = joinPath $ replicate (length (midQualifiers m) - 1) ".."
isCall :: Code -> Bool
isCall (TypeCons TypeExport _) = True
......@@ -150,27 +171,28 @@ isCall (Identifier _ _) = False
isCall c = not (isDecl c) && isJust (getQualIdent c)
isDecl :: Code -> Bool
isDecl (DataCons ConsDeclare _) = True
isDecl (Function FuncDeclare _) = True
isDecl (TypeCons TypeDeclare _) = True
isDecl _ = False
isDecl (DataCons ConsDeclare _) = True
isDecl (Function FuncDeclare _) = True
isDecl (TypeCons TypeDeclare _) = True
isDecl (Label LabelDeclare _) = True
isDecl _ = False
-- Translates arbitrary strings into equivalent urlencoded string.
string2urlencoded :: String -> String
string2urlencoded = id
string2urlencoded = escapeURIString isUnreserved
htmlQuote :: String -> String
htmlQuote [] = []
htmlQuote (c : cs)
| c == '<' = "&lt;" ++ htmlQuote cs
| c == '>' = "&gt;" ++ htmlQuote cs
| c == '&' = "&amp;" ++ htmlQuote cs
| c == '"' = "&quot;" ++ htmlQuote cs
| c == '\228' = "&auml;" ++ htmlQuote cs
| c == '\246' = "&ouml;" ++ htmlQuote cs
| c == '\252' = "&uuml;" ++ htmlQuote cs
| c == '\196' = "&Auml;" ++ htmlQuote cs
| c == '\214' = "&Ouml;" ++ htmlQuote cs
| c == '\220' = "&Uuml;" ++ htmlQuote cs
| c == '\223' = "&szlig;" ++ htmlQuote cs
| otherwise = c : htmlQuote cs
| c == '<' = "&lt;" ++ htmlQuote cs
| c == '>' = "&gt;" ++ htmlQuote cs
| c == '&' = "&amp;" ++ htmlQuote cs
| c == '"' = "&quot;" ++ htmlQuote cs
| c == 'ä' = "&auml;" ++ htmlQuote cs
| c == 'ö' = "&ouml;" ++ htmlQuote cs
| c == 'ü' = "&uuml;" ++ htmlQuote cs
| c == 'Ä' = "&Auml;" ++ htmlQuote cs
| c == 'Ö' = "&Ouml;" ++ htmlQuote cs
| c == 'Ü' = "&Uuml;" ++ htmlQuote cs
| c == 'ß' = "&szlig;" ++ htmlQuote cs
| otherwise = c : htmlQuote cs
src/Html/SyntaxColoring.hs
View file @ 0f3765d6
{- |
Module : $Header$
Description : Split module into code fragments
Copyright : (c) ?? , someone else
2014, Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
This module arranges the tokens of the module into different code
categories for HTML presentation. The parsed and typechecked module
is used to establish links between used identifiers and their definitions.
-}
module Html.SyntaxColoring
( Code (..), TypeUsage (..), ConsUsage (..)
, IdentUsage (..), FuncUsage (..)
, IdentUsage (..), FuncUsage (..), LabelUsage (..)
, genProgram, code2string, getQualIdent
) where
import Data.Function (on)
import Data.List (intercalate)
import Data.List (intercalate, sortBy)
import Curry.Base.Ident
import Curry.Base.Position
......@@ -13,6 +29,7 @@ import Curry.Syntax
import Base.Messages
-- |Type of codes which are distinguished for HTML output
data Code
= Keyword String
| Space Int
......@@ -67,7 +84,6 @@ data LabelUsage
| LabelRefer
deriving Show
-- @param list with parse-Results with descending quality,
-- e.g. [typingParse, fullParse, parse]
-- @param lex-Result
......@@ -82,6 +98,7 @@ getQualIdent (DataCons _ qid) = Just qid
getQualIdent (Function _ qid) = Just qid
getQualIdent (Identifier _ qid) = Just qid
getQualIdent (TypeCons _ qid) = Just qid
getQualIdent (Label _ qid) = Just qid
getQualIdent _ = Nothing
tokenToCodes :: Position -> [Code] -> [(Position, Token)] -> [Code]
......@@ -95,8 +112,8 @@ tokenToCodes curPos ids toks@((pos, tok) : ts)
= Space colDiff : tokenToCodes (incr curPos colDiff) ids toks
| isPragmaToken tok
= let (pragmas, (end:rest)) = break (isPragmaEnd . snd) toks
pragmaStr = intercalate " " $ map (showToken . snd) (pragmas ++ [end])
in Pragma pragmaStr : tokenToCodes (incr curPos (length pragmaStr)) ids rest
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
......@@ -114,7 +131,7 @@ tokenToCodes curPos ids toks@((pos, tok) : ts)
code2string :: Code -> String
code2string (Keyword s) = s
code2string (Space i) = concat (replicate i " ")
code2string (Space i) = replicate i ' '
code2string NewLine = "\n"
code2string (Pragma s) = s
code2string (DataCons _ qid) = idName $ unqualify qid
......@@ -143,7 +160,8 @@ tokenToCode tok@(Token cat _)
$ showToken tok
| cat `elem` whiteSpaceCategories = Space 0
| cat `elem` pragmaCategories = Pragma (showToken tok)
| otherwise = error $ "SyntaxColoring.tokenToCode: " ++ showToken tok
| otherwise = internalError $
"SyntaxColoring.tokenToCode: Unknown token" ++ showToken tok
numCategories :: [Category]
numCategories = [IntTok, FloatTok]
......@@ -205,26 +223,24 @@ declPos (ExternalDecl p _ ) = p
declPos (PatternDecl p _ _ ) = p
declPos (FreeDecl p _ ) = p
lessDecl :: Decl -> Decl -> Bool
lessDecl = (<) `on` declPos
lessImportDecl :: ImportDecl -> ImportDecl -> Bool
lessImportDecl = (<) `on` (\ (ImportDecl p _ _ _ _) -> p)
cmpDecl :: Decl -> Decl -> Ordering
cmpDecl = compare `on` declPos
qsort :: (a -> a -> Bool) -> [a] -> [a]
qsort _ [] = []
qsort less (x:xs) = concat [ qsort less [y | y <- xs, less y x]
, [x], qsort less [y | y <- xs, not $ less y x]]
cmpImportDecl :: ImportDecl -> ImportDecl -> Ordering
cmpImportDecl = compare `on` (\ (ImportDecl p _ _ _ _) -> p)
-- -----------------------------------------------------------------------------
-- Extract all identifiers mentioned in the source code as a Code entity
-- in the order of their occurrence. The extracted information is then used
-- to enrich the identifier tokens with additional information, e.g., for
-- link generation.
-- -----------------------------------------------------------------------------
idsModule :: Module -> [Code]
idsModule (Module _ mid es is ds) =
let hdrCodes = ModuleName mid : idsExportSpec es
impCodes = concatMap idsImportDecl (qsort lessImportDecl is)
dclCodes = concatMap idsDecl (qsort lessDecl ds)
impCodes = concatMap idsImportDecl (sortBy cmpImportDecl is)
dclCodes = concatMap idsDecl (sortBy cmpDecl ds)
in map (addModuleIdent mid) $ hdrCodes ++ impCodes ++ dclCodes
addModuleIdent :: ModuleIdent -> Code -> Code
......@@ -311,14 +327,16 @@ idsTypeExpr (RecordType fs mty) = concatMap idsFieldType fs
++ maybe [] idsTypeExpr mty
idsFieldType :: ([Ident], TypeExpr) -> [Code]
idsFieldType (fs, ty) = map (Label LabelDeclare . qualify) fs ++ idsTypeExpr ty
idsFieldType (fs, ty) = map (Label LabelDeclare . qualify . unRenameIdent) fs
++ idsTypeExpr ty
idsEquation :: Equation -> [Code]
idsEquation (Equation _ lhs rhs) = idsLhs lhs ++ idsRhs rhs
idsLhs :: Lhs -> [Code]
idsLhs (FunLhs f ps) = Function FuncDeclare (qualify f) : concatMap idsPat ps
idsLhs (OpLhs p1 op p2) = idsPat p1 ++ [Function FuncDeclare $ qualify op] ++ idsPat p2
idsLhs (OpLhs p1 op p2) = idsPat p1 ++ [Function FuncDeclare $ qualify op]
++ idsPat p2
idsLhs (ApLhs lhs ps) = idsLhs lhs ++ concatMap idsPat ps
idsRhs :: Rhs -> [Code]
......@@ -334,7 +352,8 @@ idsPat (NegativePattern _ _) = []
idsPat (VariablePattern v) = [Identifier IdDeclare (qualify v)]
idsPat (ConstructorPattern qid ps) = DataCons ConsPattern qid
: concatMap idsPat ps
idsPat (InfixPattern p1 qid p2) = idsPat p1 ++ DataCons ConsPattern qid : idsPat p2
idsPat (InfixPattern p1 qid p2) = idsPat p1 ++
DataCons ConsPattern qid : idsPat p2
idsPat (ParenPattern p) = idsPat p
idsPat (TuplePattern _ ps) = concatMap idsPat ps
idsPat (ListPattern _ ps) = concatMap idsPat ps
......@@ -342,9 +361,9 @@ idsPat (AsPattern v p) = Identifier IdDeclare (qualify v) : idsPat p
idsPat (LazyPattern _ p) = idsPat p
idsPat (FunctionPattern qid ps) = Function FuncCall qid
: concatMap idsPat ps
idsPat (InfixFuncPattern p1 f p2) = idsPat p1 ++ Function FuncInfix f : idsPat p2
idsPat (RecordPattern _ _) =
internalError "SyntaxColoring.idsPat: record pattern"
idsPat (InfixFuncPattern p1 f p2) = idsPat p1 ++
Function FuncInfix f : idsPat p2
idsPat (RecordPattern fs _) = concatMap (idsField idsPat) fs
idsExpr :: Expression -> [Code]
idsExpr (Literal _) = []
......@@ -372,11 +391,14 @@ idsExpr (Let ds e) = concatMap idsDecl ds ++ idsExpr e
idsExpr (Do stmts e) = concatMap idsStmt stmts ++ idsExpr e
idsExpr (IfThenElse _ e1 e2 e3) = concatMap idsExpr [e1, e2, e3]
idsExpr (Case _ _ e alts) = idsExpr e ++ concatMap idsAlt alts
idsExpr (RecordConstr fs) = concatMap idsField fs
where idsField (Field _ l e) = Label LabelRefer (qualify l) : idsExpr e
idsExpr (RecordSelection e l) = idsExpr e ++ [Label LabelRefer (qualify l)]
idsExpr (RecordUpdate fs e) = concatMap idsField fs ++ idsExpr e
where idsField (Field _ l e') = Label LabelRefer (qualify l) : idsExpr e'
idsExpr (RecordConstr fs) = concatMap (idsField idsExpr) fs
idsExpr (RecordSelection e l)
= idsExpr e ++ [Label LabelRefer (qualify $ unRenameIdent l)]
idsExpr (RecordUpdate fs e) = concatMap (idsField idsExpr) fs
++ idsExpr e
idsField :: (a -> [Code]) -> Field a -> [Code]
idsField f (Field _ l x) = Label LabelRefer (qualify $ unRenameIdent l) : f x
idsInfix :: InfixOp -> [Code]
idsInfix (InfixOp qid) = [Function FuncInfix qid]
......
src/Html/currydoc.css
View file @ 0f3765d6
/* Use monospace fonts for typewriter styles */
pre, tt, code { font-family: monospace }
/* Use always white background */
body { background: white; color: black }
body {
background: white;
color: black;
font-family: monospace;
}
/* Show hyperlinks without underscore */
a:visited, a:link, a:active { text-decoration: none }
a:visited, a:link, a:active {
text-decoration: none;
background: lightyellow;
}
.linenumbers {
width : 40px;
......@@ -19,16 +23,16 @@ a:visited, a:link, a:active { text-decoration: none }
padding-left: 10px;
}
.pragma { color : green }
.comment { color : green }
.keyword { color : blue }
.symbol { color : #C0C0C0 }
.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 }
.pragma { color : green }
.comment { color : green }
.keyword { color : blue }
.symbol { color : red }
.type { color : orange }
.cons { color : magenta }
.label { color : darkgreen }
.func { color : purple }
.ident { color : black }
.module { color : brown }
.number { color : teal }
.string { color : maroon }
.char { color : maroon }
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