-- Copyright (C) 2009-2012 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.Pandoc
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
-- | 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")
]
-- | Makes a section with commands for editing the current document and
-- regenerating the bookshelf.
editRegenerate :: ShelfInfo -> String
editRegenerate shelfInfo = guard (showScript shelfInfo) >> script
where
css = cssLink shelfInfo
edit = editor shelfInfo
mathjax = mathjaxLink shelfInfo
name = shelfDocument shelfInfo
relPth = relPath shelfInfo
rootPth = rootPath shelfInfo
edit' = case edit of
Just e -> e
Nothing -> "editor"
file = rootPth </> relPth </> name
root = rootPth </> head (splitDirectories relPth)
makeOpt (_, Nothing) = ""
makeOpt (flag, Just val) = flag ++ " " ++ show val
opts = filter (not . null) $ map makeOpt
[ ("--editor", edit)
, ("--css", css)
, ("--mathjax", mathjax)
]
editCmd = edit' ++ " " ++ show file
regenCmd = unwords ("bookshelf" : opts ++ [show root])
script =
"<p><br/></p>\n\
\<div class=\"bookshelf-meta\">\n\
\ <em>➤ Edit/regenerate this document:</em>\n\
\ <pre><code>" ++ editCmd ++ "\n" ++ regenCmd ++ "</code></pre>\n\
\</div>\n"
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 title authors date [] []
where
Meta title authors date = 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' : Str ":" : rest <- plain bs
guard (f==f')
return rest
parseList f bs = Fold.concat $ do
[Plain [Str f', Str ":"], 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 a css option for the template that links to the supplied CSS (if any).
makeCss :: Context -> [(String, String)]
makeCss context = case cssLink context of
Nothing -> []
Just css
-> [("css", css)]
-- | Give the math option to supply to the html writer
makeMath :: Context -> HTMLMathMethod
makeMath context = case mathjaxLink context of
Nothing -> PlainMath
Just l -> MathJax l
-- | @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 = readMarkdown rOpts markdown
links = queryWith localLink pandoc
thisMeta = extractMeta pandoc
mainMeta = parseMainMeta pandoc
contextBlocks
= [RawBlock "html" "<div class=\"bookshelf-meta\">", makeContextPath shelfInfo]
++ makeMainLink shelfInfo
++ [RawBlock "html" "</div>"]
before = writeHtmlString def (Pandoc (Meta [] [] []) contextBlocks)
html
= writeHtmlString wOpts
$ bottomUp redirectLink
$ pandoc
meta = case mainDocument shelfInfo of
Nothing -> thisMeta
_ -> mainMeta
rOpts = def
{ readerSmart = True
}
after = editRegenerate shelfInfo ++ 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
}
-- | 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]]
-- | @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 =
[ RawBlock "html" "<div class=\"bookshelf-meta\">"
, makeContextPath (ShelfInfo context Nothing "")
, RawBlock "html" "</div>"
]
before = writeHtmlString def (Pandoc (Meta [] [] []) 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
}
pandoc = Pandoc (Meta [] [] []) ([Para [LineBreak]] ++ docBlocks ++ dirBlocks)
docBlocks = do
guard (0 < length shelfs + length infos + length ords)
[ Header 2 nullAttr [Str "Documents"]
, BulletList shelfBlocks
, BulletList infoBlocks
, BulletList ordBlocks
]
shelfBlocks = map listShelfDoc $ sortBy (compare `on` fst) shelfs
infoBlocks = map listInfoDoc $ sortBy (compare `on` fst) infos
ordBlocks = map listOrdDoc $ sort ords
dirBlocks = do
guard (not $ null dirs)
[Header 2 nullAttr [Str "Directories"]] ++ [BulletList $ map listDir $ sort dirs]
listShelfDoc (doc,meta) = listDocument docShelfHtml meta' doc' []
where
doc' = dropExtension doc
docShelfHtml = doc `addExtension` ".html"
meta' = fixTitle meta doc'
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 ")"
]
listOrdDoc doc = return $ Plain
[Link (pandocStr doc) (doc, "View '" ++ doc ++ "'")]
listDir dir = return $ Plain
[ Link
(pandocStr dir)
(dir </> "index.html", "Go to directory '" ++ dir ++ "'")
, LineBreak
]