{- |
Module : $Header$
Description : Generating HTML documentation
Copyright : (c) 2011 - 2014, 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 Control.Monad.Trans.Either
import Data.Maybe (fromMaybe, isJust)
import System.FilePath ((), dropFileName, takeBaseName)
import Curry.Base.Ident (QualIdent (..), unqualify)
import Curry.Base.Monad
import Curry.Base.Pretty (text)
import Curry.Files.PathUtils (readModule, lookupCurryFile)
import Curry.Syntax (Module, lexSource)
import Html.SyntaxColoring
import Base.Messages
import CompilerOpts (Options (..))
import CurryBuilder (buildCurry)
import Modules (loadAndCheckModule)
import Transformations (qual)
-- translate source file into HTML file with syntaxcoloring
-- @param sourcefilename
source2html :: Options -> FilePath -> CYIO ()
source2html opts f = do
let baseName = takeBaseName f
outDir = fromMaybe (dropFileName f) $ optHtmlDir opts
outFile = outDir baseName ++ "_curry.html"
srcFile <- liftIO $ lookupCurryFile (optImportPaths opts) f
program <- filename2program opts (fromMaybe f srcFile)
liftIO $ writeFile outFile (program2html baseName program)
-- @param importpaths
-- @param filename
-- @return 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
toks <- liftCYM $ lexSource f src
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
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 -> [Code] -> String
program2html modulname codes = unlines
[ ""
, "", "", "Module " ++ modulname ++ ""
, ""
, ""
, ""
, ""
, "" ++ lineHtml ++ " | "
, "" ++ codeHtml ++ " | "
, "
"
, ""
, ""
]
where
lineHtml = unlines $ map show [1 .. length (lines codeHtml)]
codeHtml = concatMap code2html codes
code2html :: Code -> String
code2html code@(Commentary _) =
spanTag (code2class code) (replace '<' "<" (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 = "" ++ str ++ ""
-- 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 (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] ++)) ""
addHtmlAnchor :: String -> QualIdent -> String
addHtmlAnchor str qid = "" ++ str
where anchor = string2urlencoded (show (unqualify qid))
addHtmlLink :: String -> QualIdent -> String
addHtmlLink str qid =
let (maybeModIdent, ident) = (qidModule qid, qidIdent qid) in
" show x ++ "_curry.html") maybeModIdent ++
"#" ++
string2urlencoded (show ident) ++
"\">" ++
str ++
""
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 = id
htmlQuote :: String -> String
htmlQuote [] = []
htmlQuote (c : cs)
| c == '<' = "<" ++ htmlQuote cs
| c == '>' = ">" ++ htmlQuote cs
| c == '&' = "&" ++ htmlQuote cs
| c == '"' = """ ++ htmlQuote cs
| c == '\228' = "ä" ++ htmlQuote cs
| c == '\246' = "ö" ++ htmlQuote cs
| c == '\252' = "ü" ++ htmlQuote cs
| c == '\196' = "Ä" ++ htmlQuote cs
| c == '\214' = "Ö" ++ htmlQuote cs
| c == '\220' = "Ü" ++ htmlQuote cs
| c == '\223' = "ß" ++ htmlQuote cs
| otherwise = c : htmlQuote cs