-- Copyright (C) 2009-2013 Emil Axelsson <emax@chalmers.se>
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-- |
-- Copyright : Copyright (C) 2009-2012 Emil Axelsson <emax@chalmers.se>
-- License : GNU GPL, version 2 or above
--
-- Maintainer : Emil Axelsson <emax@chalmers.se>
--
-- Conversion of shelf documents to HTML.
module Generate where
import Control.Monad
import qualified Data.Foldable as Fold
import Data.Function
import Data.List
import System.FilePath
import Text.CSL.Pandoc (processCites)
import Text.Pandoc
import Text.Pandoc.Error
import Types
-- | Checks wether a path starts with @http:\/\/@.
isHttp :: FilePath -> Bool
isHttp path = ("http://" `isPrefixOf` path) || ("https://" `isPrefixOf` path)
-- | Drops the @file:\/\/@ prefix (if any) of a path.
dropFile :: FilePath -> FilePath
dropFile path = case stripPrefix "file://" path of
Just path' -> path'
Nothing -> path
-- | Drops the label (if any) from a path. For example
--
-- > dropLabel "/dir/file.html#label" == "/dir/file.html"
-- > dropLabel "/dir/file.html" == "/dir/file.html"
dropLabel :: FilePath -> FilePath
dropLabel = takeWhile (/='#')
-- | Applies the function to the path without its label (if any) (see
-- `dropLabel`), and adds the label back to the result again.
underLabel :: (FilePath -> FilePath) -> (FilePath -> FilePath)
underLabel f pathLab = f path ++ label
where
(path,label) = break (=='#') pathLab
-- | Redirects a link to a @.shelf@ file, by changing the @.shelf@ extension to
-- @.shelf.html@. Links to non-shelf files are passed through unchanged.
redirect :: FilePath -> FilePath
redirect path = underLabel redir path
where
redir path
| takeExtension path == ".shelf" = path ++ ".html"
| otherwise = path
-- | Lifts `redirect` to Pandoc inline elements (links).
redirectLink :: Inline -> Inline
redirectLink (Link is (path,tit)) = Link is (redirect path, tit)
redirectLink i = i
-- | Collects local links (at most one) from a Pandoc inline element.
localLink :: Inline -> [FilePath]
localLink inl = case inl of
Link _ (path,_) -> linked path
Image _ (path,_) -> linked path
_ -> []
where
linked path = do
guard (not $ isHttp path)
return (dropLabel $ dropFile path)
-- | Assumes that the input string is plain text, without any markdown syntax.
pandocStr :: String -> [Inline]
pandocStr = intersperse Space . map Str . words
rawHtml :: String -> Block
rawHtml = RawBlock (Format "html")
-- | Displays the relative path, with each directory name linked to its index
-- file. If the `shelfDocument` field is not empty, a link to the document
-- source will be added at the end of the relative path.
makeContextPath :: ShelfInfo -> Block
makeContextPath shelfInfo = Plain
[ Emph
$ concat (reverse [link n dir | (n,dir) <- [0..] `zip` reverse nodes])
++ fileLink
, LineBreak
]
where
nodes = splitDirectories $ relPath shelfInfo
name = shelfDocument shelfInfo
link n dir =
[ Link
(pandocStr dir)
(index, "Go to directory '" ++ dir ++ "'")
, Space
, Str "/"
, Space
]
where
index = joinPath (replicate n "..") </> "index.html"
fileLink = do
guard (not $ null name)
return $ Link (pandocStr name) (name, "View document source")
-- | Makes a link to the main document, if any. The result has 0 or 1 element.
makeMainLink :: ShelfInfo -> [Block]
makeMainLink shelfInfo = do
Just name <- return $ mainDocument shelfInfo
return $ Plain $ return $ Emph
[ Str "➤"
, Space
, Link (pandocStr "Main document") (name, "View main document")
]
bookshelfCreds :: String
bookshelfCreds =
"<div id=\"footer\">\n\
\ Organized by <a href=\"http://www.cse.chalmers.se/~emax/bookshelf/Manual.shelf.html\">Bookshelf</a>\n\
\</div>\n"
-- | Extracts title block information.
extractMeta :: Pandoc -> MetaInfo
extractMeta (Pandoc meta _) = MetaInfo (docTitle meta) (docAuthors meta) (docDate meta) [] []
-- | Extracts meta information about the \"main\" document from a shelf
-- document. The document body will be matched against the following form:
--
-- > Meta
-- > ====
-- >
-- > * Title: Title of document
-- > * Authors:
-- > * Author number 1
-- > * Author number 2
-- > * etc.
-- > * Date: Some string indicating date
-- > * Comment: Some comment
-- > * Keywords:
-- > * Keyword 1
-- > * Keyword 2
-- > * etc.
-- >
-- > Here comes the rest of the document.
-- > ...
-- > ...
--
-- (The header can also be a lower-level header.)
-- If the document doesn't have the above form, some or all of the returned
-- fields may be empty. However, the function does some attempt to handle
-- partial specifications. In particular, the fields are matched from the top,
-- so it's fine to leave out fields at the bottom.
parseMainMeta :: Pandoc -> MetaInfo
parseMainMeta (Pandoc _ blocks) = MetaInfo title authors date comment keywords
where
metaBullets = case blocks of
Header _ _ [Str "Meta"] : BulletList bulls : _ -> bulls
_ -> []
bsTit : bsAuth : bsDate : bsComm : bsKeyw : _ = metaBullets ++ repeat []
plain bs = do
[Plain is] <- Just bs
return is
field f bs = Fold.concat $ do
Str f' : rest <- plain bs
guard (f==f')
return rest
parseList f bs = Fold.concat $ do
[Plain [Str f'], BulletList bulls] <- return bs
guard (f==f')
mapM plain bulls
title = field "Title:" bsTit
date = field "Date:" bsDate
comment = field "Comment:" bsComm
authors = parseList "Authors:" bsAuth
keywords = parseList "Keywords:" bsKeyw
-- | Give the css option for the template that links to the supplied CSS (if any).
makeCss :: Context -> [(String, String)]
makeCss context = case cssLink context of
Just css -> [("css", css)]
_ -> [("css", "http://www.cse.chalmers.se/~emax/bookshelf.css")]
-- | Give the math option to supply to the HTML writer
makeMath :: Context -> HTMLMathMethod
makeMath context
| Just l <- mathjaxLink context = if null l
then MathJax "http://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML"
else MathJax l
| mathml context = MathML Nothing
| otherwise = PlainMath
-- | @markdownToHtml shelfInfo markdown = (html,links,meta)@:
--
-- Converts a shelf document to HTML. The result also contains a list of all
-- local links in the document as well as meta information, in case such a
-- specification is given. If the document is not linked to a main document, the
-- returned meta information is taken from the title block (see Pandoc's
-- markdown syntax). If the document has a main document, the meta information
-- is obtained as specified in `parseMainMeta`.
markdownToHtml :: ShelfInfo -> String -> (String, [FilePath], MetaInfo)
markdownToHtml shelfInfo markdown = (html,links,meta)
where
pandoc = handleError $ readMarkdown def{readerSmart=True} markdown
links = queryWith localLink pandoc
thisMeta = extractMeta pandoc
mainMeta = parseMainMeta pandoc
contextBlocks
= [rawHtml "<div class=\"bookshelf-meta\">", makeContextPath shelfInfo]
++ makeMainLink shelfInfo
++ [rawHtml "</div>"]
before = writeHtmlString def (Pandoc nullMeta contextBlocks)
html
= writeHtmlString wOpts
$ processCites style refs
$ bottomUp redirectLink
$ pandoc
meta = case mainDocument shelfInfo of
Nothing -> thisMeta
_ -> mainMeta
refs = references $ shelfContext shelfInfo
style = cslStyle $ shelfContext shelfInfo
after = bookshelfCreds
cssInclude = makeCss $ shelfContext shelfInfo
mathMethod = makeMath $ shelfContext shelfInfo
wVars =
[ ("include-after", after)
, ("include-before", before)
] ++ cssInclude
wOpts = def
{ writerStandalone = True
, writerTemplate = htmlTemplate $ shelfContext shelfInfo
, writerVariables = wVars
, writerTableOfContents = True
, writerHTMLMathMethod = mathMethod
, writerHighlight = True
}
-- | If the title is empty in the `MetaInfo`, it gets set to the supplied
-- string; otherwise nothing is changed.
fixTitle :: MetaInfo -> String -> MetaInfo
fixTitle meta tit = case title meta of
[] -> meta {title = pandocStr tit}
_ -> meta
-- | @listDocument file meta view info@:
--
-- Makes an item for the given document to be displayed in the directory index.
-- The link text is taken from the `title` field in @meta@. The other fields of
-- @meta@ will be put in a bullet list underneath. @file@ is the file name of
-- document. @view@ is a supplementary name of the document that will appear in
-- the link title. The @info@ argument will be inlined directly after the link.
listDocument :: String -> MetaInfo -> String -> [Inline] -> [Block]
listDocument file meta view info =
[ Plain $ [Link (title meta) (file, "View '" ++ view ++ "'")] ++ info'
, BulletList $ filter (not . null) $
[ bullet $ concat $ intersperse [Str ",", Space] $ authors meta
, bullet $ date meta
, bullet $ comment meta
, bullet $ concat $ intersperse [Str ",", Space] $ keywords meta
]
]
where
info' = do
guard (not $ null info)
[Space, Emph info]
bullet is = do
guard (not $ null is)
[Plain [Emph is]]
-- | Makes an item for a shelf document to be displayed in the directory index
listShelfDoc :: (FilePath, MetaInfo) -> [Block]
listShelfDoc (doc,meta) = listDocument docShelfHtml meta' doc' []
where
doc' = dropExtension doc
docShelfHtml = doc `addExtension` ".html"
meta' = fixTitle meta doc'
-- | Makes an item for an ordinary document with meta info to be displayed in the directory index
listInfoDoc :: (FilePath, MetaInfo) -> [Block]
listInfoDoc (doc,meta) = listDocument doc meta' doc info
where
meta' = fixTitle meta doc
docShelfHtml = replaceExtension doc ".shelf" `addExtension` ".html"
info =
[ Str "("
, Link
(pandocStr "info")
(docShelfHtml, "View document information")
, Str ")"
]
-- | Makes an item for an ordinary document without meta info to be displayed in the directory index
listOrdDoc :: Monad m => String -> m Block
listOrdDoc doc = return $ Plain
[Link (pandocStr doc) (doc, "View '" ++ doc ++ "'")]
-- | Makes an item for an sub-directory to be displayed in the directory index
listDir :: Monad m => String -> m Block
listDir dir = return $ Plain
[ Link
(pandocStr dir)
(dir </> "index.html", "Go to directory '" ++ dir ++ "'")
, LineBreak
]
-- | @makeIndex context shelfs infos ords dirs@:
--
-- Makes an HTML file with the index of the current directory. @shelfs@ is a
-- list of shelf documents (file name + meta information) that are not
-- associated with a main document. @infos@ is a list of ordinary documents that
-- have an associated info document. @ords@ is a list ordinary documents that
-- have no associated info document. @dirs@ is a list of all sub-directories.
makeIndex
:: Context
-> [(FilePath, MetaInfo)]
-> [(FilePath, MetaInfo)]
-> [FilePath]
-> [FilePath]
-> String
makeIndex context shelfs infos ords dirs = writeHtmlString wOpts pandoc
where
contextBlocks =
[ rawHtml "<div class=\"bookshelf-meta\">"
, makeContextPath (ShelfInfo context Nothing "")
, rawHtml "</div>"
]
before = writeHtmlString def (Pandoc nullMeta contextBlocks)
after = bookshelfCreds
wVars =
[ ("include-before", before)
, ("include-after", after)
] ++ makeCss context
wOpts = def
{ writerStandalone = True
, writerTemplate = htmlTemplate context
, writerVariables = wVars
, writerTableOfContents = False
, writerHTMLMathMethod = makeMath context
}
shelfBlocks = map listShelfDoc $ sortBy (compare `on` fst) shelfs
infoBlocks = map listInfoDoc $ sortBy (compare `on` fst) infos
ordBlocks = map listOrdDoc $ sort ords
docBlocks = do
guard (0 < length shelfs + length infos + length ords)
[ Header 2 nullAttr [Str "Documents"]
, BulletList shelfBlocks
, BulletList infoBlocks
, BulletList ordBlocks
]
dirBlocks = do
guard (not $ null dirs)
[Header 2 nullAttr [Str "Directories"]] ++ [BulletList $ map listDir $ sort dirs]
pandoc = Pandoc nullMeta ([Para [LineBreak]] ++ docBlocks ++ dirBlocks)