Bookshelf-0.1.3: Generate.hs
-- Copyright (C) 2009 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 Emil Axelsson <emax@chalmers.se>
-- License : GNU GPL, version 2 or above
--
-- Maintainer : Emil Axelsson <emax@chalmers.se>
--
-- Convertion 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
data MetaInfo = MetaInfo
{ title :: [Inline]
, authors :: [[Inline]]
, date :: [Inline]
, comment :: [Inline]
}
deriving (Eq, Show)
data Context = Context
{ -- | Optional link to CSS file
cssLink_ :: Maybe FilePath
-- | Optional editor command
, editor_ :: Maybe String
-- | Show the edit/regenerate script?
, showScript_ :: Bool
-- | Path to root of bookshelf
, rootPath_ :: FilePath
-- | Path to current node, relative to the root
, relPath_ :: FilePath
}
deriving (Eq, Show)
data ShelfInfo = ShelfInfo
{ -- | The document's context
shelfContext :: Context
-- | The full name of the associated main document. `Nothing` means
-- that there is no main document.
, mainDocument :: Maybe String
-- | The full name of the shelf document.
, shelfDocument :: String
}
class HasContext a
where
cssLink :: a -> Maybe FilePath
editor :: a -> Maybe String
showScript :: a -> Bool
rootPath :: a -> FilePath
relPath :: a -> FilePath
instance HasContext Context
where
cssLink = cssLink_
editor = editor_
showScript = showScript_
rootPath = rootPath_
relPath = relPath_
instance HasContext ShelfInfo
where
cssLink = cssLink_ . shelfContext
editor = editor_ . shelfContext
showScript = showScript_ . shelfContext
rootPath = rootPath_ . shelfContext
relPath = relPath_ . shelfContext
-- | Move down to the given directory (affects `relPath_` and `cssLink_` in
-- `Context`).
moveDown :: Context -> String -> Context
moveDown context dir = context
{ relPath_ = relPath context </> dir
, cssLink_ = liftM (".." </>) $ cssLink context
}
-- | 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
-- | Adds the given blocks at the beginning of the document.
prependBlocks :: [Block] -> Pandoc -> Pandoc
prependBlocks bs' (Pandoc meta bs) = Pandoc meta (bs' ++ bs)
-- | 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
$ pandocStr "➤ Context:"
++ [Space]
++ 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
, HtmlInline "<b>/</b>"
, 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
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)
]
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.cs.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
authors' = map pandocStr authors
date' = pandocStr date
-- | 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
-- >
-- > Here comes the rest of the document.
-- > ...
-- > ...
--
-- 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
where
metaBullets = case blocks of
Header 1 [Str "Meta"] : BulletList bulls : _ -> bulls
_ -> []
bsTit : bsAuth : bsDate : bsComm : _ = metaBullets ++ repeat []
plain bs = do
[Plain is] <- Just bs
return is
field f bs = Fold.concat $ do
Str f' : Space : rest <- plain bs
guard (f==f')
return rest
parseAuthors bs = Fold.concat $ do
[Plain [Str "Authors:"], BulletList bulls] <- return bs
mapM plain bulls
title = field "Title:" bsTit
date = field "Date:" bsDate
comment = field "Comment:" bsComm
authors = parseAuthors bsAuth
-- | Makes an HTML header that links to the supplied CSS (if any).
makeHeader :: Context -> String
makeHeader context = case cssLink context of
Nothing -> ""
Just css
-> "<link rel=\"stylesheet\" href=\""
++ css
++ "\" type=\"text/css\" media=\"all\" />\n"
-- | @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
context = shelfContext shelfInfo
contextBlocks
= [RawHtml "<div class=\"bookshelf-meta\">", makeContextPath shelfInfo]
++ makeMainLink shelfInfo
++ [RawHtml "</div>", Para [LineBreak]]
html
= writeHtmlString wOpts
$ prependBlocks contextBlocks
$ processWith redirectLink
$ pandoc
meta = case mainDocument shelfInfo of
Nothing -> thisMeta
_ -> mainMeta
rOpts = defaultParserState
{ stateSmart = True
}
wOpts = defaultWriterOptions
{ writerStandalone = True
, writerTableOfContents = True
, writerHeader = makeHeader context
, writerIncludeAfter = editRegenerate shelfInfo ++ bookshelfCreds
}
-- | 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 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
]
]
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
-> [(String, MetaInfo)]
-> [(String, MetaInfo)]
-> [String]
-> [String]
-> String
makeIndex context shelfs infos ords dirs = writeHtmlString wOpts pandoc
where
wOpts = defaultWriterOptions
{ writerStandalone = True
, writerTableOfContents = False
, writerHeader = makeHeader context
, writerIncludeAfter = bookshelfCreds
}
pandoc = Pandoc meta
$ [makeContextPath (ShelfInfo context Nothing "")]
++ docBlocks
++ dirBlocks
where
dir = last $ splitDirectories $ relPath context
meta = Meta (pandocStr dir) [] []
docBlocks = do
guard (0 < length shelfs + length infos + length ords)
[ Header 1 [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 1 [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
]