{- |
Module : $Header$
Description : Generating HTML documentation
Copyright : (c) 2011 - 2015, Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
This module defines a function for generating HTML documentation pages
for Curry source modules.
-}
module Html.CurryHtml (source2html) where
import Control.Monad.Writer
import Data.List (mapAccumL)
import Data.Maybe (fromMaybe, isJust)
import Network.URI (escapeURIString, isUnreserved)
import System.Directory (copyFile, doesFileExist)
import System.FilePath (())
import Curry.Base.Ident ( ModuleIdent (..), QualIdent (..), unqualify
, moduleName)
import Curry.Base.Monad (CYIO, liftCYM, failMessages)
import Curry.Base.Pretty ((<+>), text, vcat)
import Curry.Files.PathUtils (readModule)
import Curry.Syntax (Module (..), lexSource)
import Html.SyntaxColoring
import Base.Messages (message)
import CompilerOpts (Options (..), WarnOpts (..))
import CurryBuilder (buildCurry, findCurry)
import Modules (loadAndCheckModule)
import Transformations (qual)
import Paths_curry_frontend (getDataFileName)
-- |'FilePath' of the CSS style file to be added to the documentation.
cssFile :: FilePath
cssFile = "currysource.css"
-- |Translate source file into HTML file with syntaxcoloring
source2html :: Options -> String -> CYIO ()
source2html opts s = do
srcFile <- findCurry opts s
(mid, doc) <- docModule opts srcFile
let outDir = fromMaybe "." $ optHtmlDir opts
outFile = outDir htmlFile mid
liftIO $ writeFile outFile doc
updateCSSFile outDir
-- |Update the CSS file
updateCSSFile :: FilePath -> CYIO ()
updateCSSFile dir = do
src <- liftIO $ getDataFileName cssFile
let target = dir cssFile
srcExists <- liftIO $ doesFileExist src
if srcExists then liftIO $ copyFile src target
else failMessages [message $ missingStyleFile src]
where
missingStyleFile f = vcat
[ text "Could not copy CSS style file:"
, text "File" <+> text ("`" ++ f ++ "'") <+> text "does not exist"
]
-- |Create the documentation for the module
docModule :: Options -> String -> CYIO (ModuleIdent, String)
docModule 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@(Module _ m _ _ _) <- fullParse opts f src
return (m, program2html m $ genProgram f 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
buildCurry (opts { optTargetTypes = []}) fn
(env, mdl) <- loadAndCheckModule opts' fn
return (snd $ qual (env, mdl))
where
opts' = opts { optWarnOpts = (optWarnOpts opts) { wnWarn = False }
, optTargetTypes = []
}
-- generates htmlcode with syntax highlighting
-- @param modulname
-- @param a program
-- @return HTMLcode
program2html :: ModuleIdent -> [Code] -> String
program2html m codes = unlines
[ ""
, "", ""
, ""
, "" ++ titleHtml ++ ""
, ""
, ""
, ""
, ""
, "" ++ lineHtml ++ " | "
, "" ++ codeHtml ++ " | "
, "
"
, ""
, ""
]
where
titleHtml = "Module " ++ show 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))
| 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 = htmlQuote . show . unqualify
spanTag :: String -> String -> String -> String
spanTag clV idV str
| null clV && null idV = str
| otherwise = ""
++ str ++ ""
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
-- @return css class of the code
code2class :: Code -> String
code2class (Space _) = ""
code2class NewLine = ""
code2class (Keyword _) = "keyword"
code2class (Pragma _) = "pragma"
code2class (Symbol _) = "symbol"
code2class (TypeCons _ _) = "type"
code2class (DataCons _ _) = "cons"
code2class (Function _ _) = "func"
code2class (Identifier _ _) = "ident"
code2class (ModuleName _) = "module"
code2class (Commentary _) = "comment"
code2class (NumberCode _) = "number"
code2class (StringCode _) = "string"
code2class (CharCode _) = "char"
addHtmlLink :: ModuleIdent -> String -> QualIdent -> String
addHtmlLink m str qid =
"" ++ str ++ ""
where
modPath = maybe "" (makeRelativePath m) mmid
fragment = string2urlencoded (show ident)
(mmid, ident) = (qidModule qid, qidIdent qid)
makeRelativePath :: ModuleIdent -> ModuleIdent -> String
makeRelativePath cur new | cur == new = ""
| otherwise = htmlFile new
htmlFile :: ModuleIdent -> String
htmlFile m = moduleName m ++ "_curry.html"
isCall :: Code -> Bool
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 (DataCons ConsDeclare _) = True
isDecl (Function FuncDeclare _) = True
isDecl (TypeCons TypeDeclare _) = True
isDecl _ = False
-- Translates arbitrary strings into equivalent urlencoded string.
string2urlencoded :: String -> String
string2urlencoded = escapeURIString isUnreserved
htmlQuote :: String -> String
htmlQuote [] = []
htmlQuote (c : cs)
| c == '<' = "<" ++ htmlQuote cs
| c == '>' = ">" ++ htmlQuote cs
| c == '&' = "&" ++ htmlQuote cs
| c == '"' = """ ++ htmlQuote cs
| c == 'ä' = "ä" ++ htmlQuote cs
| c == 'ö' = "ö" ++ htmlQuote cs
| c == 'ü' = "ü" ++ htmlQuote cs
| c == 'Ä' = "Ä" ++ htmlQuote cs
| c == 'Ö' = "Ö" ++ htmlQuote cs
| c == 'Ü' = "Ü" ++ htmlQuote cs
| c == 'ß' = "ß" ++ htmlQuote cs
| otherwise = c : htmlQuote cs