-- Copyright (C) 2009-2013 Emil Axelsson -- -- 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 -- License : GNU GPL, version 2 or above -- -- Maintainer : Emil Axelsson 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