-- 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>
module Main where
import Control.Monad
import Data.List
import Data.Traversable (traverse)
import System.Directory
import System.FilePath
import System.Console.ParseArgs
import Text.CSL
import Text.Pandoc
import Text.Pandoc.Shared
import Types
import Generate
-- | Makes a file path relative to a directory. Both supplied paths are assumed to be absolute, and
-- not including "..". Such paths are returned by 'canonicalizePath'.
makeRel
:: FilePath -- ^ Directory
-> FilePath -- ^ File
-> FilePath
makeRel dir file = joinPath $ rel (splitDirectories dir) (splitDirectories file)
where
rel [] fs = fs
rel (d:ds) (f:fs) | d==f = rel ds fs
rel ds fs = replicate (length ds) ".." ++ fs
downPath :: FilePath -> FilePath
downPath f
| isAbsolute f = f
| isHttp f = f
| otherwise = ".." </> f
-- | Move down to the given directory (affects paths in `Context`).
moveDown :: Context -> FilePath -> Context
moveDown context dir = context
{ relPath_ = relPath context </> dir
, cssLink_ = fmap downPath $ cssLink context
}
-- | @getDirectoryContentsSeparated path = (dirs, files)@
--
-- Returns the files and directories under @path@:
--
-- @dirs@ is a list of all directories (@.@ and @..@ excluded);
-- @files@ is a list of all files.
getDirectoryContentsSeparated :: FilePath -> IO ([FilePath], [FilePath])
getDirectoryContentsSeparated path = do
conts <- getDirectoryContents path
isDirs <- sequence [ doesDirectoryExist (path </> cont) | cont <- conts]
let files = [cont | (cont,isDir) <- zip conts isDirs, not isDir, relevant cont]
dirs = [cont | (cont,isDir) <- zip conts isDirs, isDir, relevant cont]
return (dirs,files)
where
relevant x = not $ "." `isPrefixOf` x
-- | @getShelfContents path = (shelfs, infos, ords, dirs)@
--
-- Returns the documents and directories under @path@:
--
-- @shelfs@ is a list of all shelf documents that are not info documents.
--
-- @infos@ is a list of ordinary documents that have associated info documents.
--
-- @ords@ is a list of ordinary documents that don't have associated info
-- documents.
--
-- @dirs@ is a list of all directories (@.@ and @..@ excluded).
--
-- Files/directories with an associated @.ignore@ file are excluded from the
-- results.
getShelfContents :: FilePath -> IO ([FilePath], [FilePath], [FilePath], [FilePath])
getShelfContents path = do
(ds,fs) <- getDirectoryContentsSeparated path
let (ignores,fs') = partition ((".ignore"==) . takeExtension) fs
ignores' = map dropExtension ignores
files = filter (`notElem` ignores') fs'
dirs = filter (`notElem` ignores') ds
(possShelfs,nonShelfs) = partition ((".shelf"==) . takeExtension) files
possInfos = map (flip replaceExtension "shelf") nonShelfs
hasInfo file = replaceExtension file "shelf" `elem` possShelfs
hasMain file = file `elem` possInfos
(infos,ords) = partition hasInfo nonShelfs
shelfs = filter (not . hasMain) possShelfs
return (shelfs,infos,ords,dirs)
-- | Removes the file @index.html@ (if existing) and files with the extension
-- @.shelf.html@ from the given directory.
clearPreviouslyGenerated :: FilePath -> IO ()
clearPreviouslyGenerated path = do
(_,files) <- getDirectoryContentsSeparated path
let prevFiles = filter prevGenerated files
mapM_ (removeFile . (path</>)) prevFiles
where
prevGenerated file = file=="index.html" || shelfHtml
where
(init,ext1) = splitExtension file
ext2 = takeExtension init
shelfHtml = ext1==".html" && ext2==".shelf"
-- | Converts the markdown file @file@ to the HTML file @file.html@ and returns
-- meta information for the document.
convertShelfDoc :: ShelfInfo -> IO MetaInfo
convertShelfDoc shelfInfo = do
let name = shelfDocument shelfInfo
markdown <- readFile name
let (html,links,meta) = markdownToHtml shelfInfo markdown
writeFile (name ++ ".html") html
forM_ links $ \link -> do
existsFile <- doesFileExist link
existsDir <- doesDirectoryExist link
unless (existsFile || existsDir) $ putStrLn $ warning link
return meta
where
warning link
= "*Warning: link '"
++ link
++ "' does not exist in '"
++ (relPath shelfInfo </> shelfDocument shelfInfo)
++ "'."
-- | Generates the (sub-)bookshelf in the directory @rootPath\</\>relPath@ (see
-- `Context`).
generateBookshelf :: Context -> IO ()
generateBookshelf context = do
clearPreviouslyGenerated path
(shelfs,infos,ords,dirs) <- getShelfContents path
setCurrentDirectory path
shelfMetas <- mapM (convertShelfDoc . shelfInfoS) shelfs
infoMetas <- mapM (convertShelfDoc . shelfInfoI) infos
writeFile "index.html" $ makeIndex
context
(zip shelfs shelfMetas)
(zip infos infoMetas)
ords
dirs
mapM_ (generateBookshelf . moveDown context) dirs
where
path = rootPath context </> relPath context
shelfInfoS name = ShelfInfo context Nothing name
shelfInfoI name = ShelfInfo context (Just name) (replaceExtension name ".shelf")
argSpec :: [Arg String]
argSpec =
[ Arg { argIndex = "Bib"
, argName = Just "bib"
, argAbbr = Just 'b'
, argData = argDataOptional "bibliography file" ArgtypeString
, argDesc = "Path to bibliography file"
}
, Arg { argIndex = "CSL"
, argName = Just "csl"
, argAbbr = Nothing
, argData = argDataOptional "CSL file" ArgtypeString
, argDesc = "Path to CSL style file"
}
, Arg { argIndex = "CSS"
, argName = Just "css"
, argAbbr = Just 'c'
, argData = argDataOptional "CSS file" ArgtypeString
, argDesc = "Path or URL to CSS style sheet"
}
, Arg { argIndex = "MathJax"
, argName = Just "mathjax"
, argAbbr = Just 'm'
, argData = argDataOptional "MathJax.js file" ArgtypeString
, argDesc = "URL to MathJax.js file (use \"\" to get the default URL)"
}
, Arg { argIndex = "MathML"
, argName = Just "mathml"
, argAbbr = Nothing
, argData = Nothing
, argDesc = "Use MathML for math rendering"
}
, Arg { argIndex = "Source"
, argName = Nothing
, argAbbr = Nothing
, argData = argDataRequired "source" ArgtypeString
, argDesc = "Root directory of bookshelf to be generated"
}
]
main :: IO ()
main = do
args <- parseArgsIO ArgsComplete argSpec
tmpl <- getDefaultTemplate Nothing "html"
tmpl' <- case tmpl of
Left msg -> error $ show msg
Right tmpl -> return tmpl
let bib = getArg args "Bib"
csl = getArg args "CSL"
cStyle <- parseCSL =<< case csl of
Just cslFile -> readFile cslFile
_ -> readDataFileUTF8 Nothing "default.csl"
refs <- case bib of
Nothing -> return []
Just bibFile -> readBiblioFile bibFile
let Just path = getArg args "Source"
css = getArg args "CSS"
mathjax = getArg args "MathJax"
mathml = gotArg args "MathML"
isDir <- doesDirectoryExist path
unless isDir $ error $ "**Error: Source directory '" ++ path ++ "' does not exist."
absPath <- canonicalizePath path
let fixPath f
| isHttp f = return f
| otherwise = do
absf <- canonicalizePath f
return $ if isAbsolute path || isAbsolute f
then absf
else makeRel absPath absf
css' <- traverse fixPath css
let dirs = splitDirectories absPath
context = Context tmpl' cStyle refs css' mathjax mathml (joinPath $ init dirs) (last dirs)
generateBookshelf context