-- Copyright (C) 2009-2012 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 System.Directory import System.Environment import System.FilePath import System.Console.ParseArgs import Text.Pandoc import Types import Generate -- | Move down to the given directory (affects `relPath_` and `cssLink_` in -- `Context`). moveDown :: Context -> FilePath -> Context moveDown context dir = context { relPath_ = relPath context dir , cssLink_ = liftM (".." ) $ cssLink context , mathjaxLink_ = liftM (".." ) $ mathjaxLink 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 = "CSS" , argName = Just "css" , argAbbr = Just 'c' , argData = argDataOptional "CSS file" ArgtypeString , argDesc = "Path or URL to CSS style sheet" } , Arg { argIndex = "Editor" , argName = Just "editor" , argAbbr = Just 'e' , argData = argDataOptional "editor command" ArgtypeString , argDesc = "Command used for editing source files" } , Arg { argIndex = "MathJax" , argName = Just "mathjax" , argAbbr = Just 'm' , argData = argDataOptional "MathJax.js file" ArgtypeString , argDesc = "Path or URL to MathJax.js file" } , Arg { argIndex = "NoScript" , argName = Just "no-script" , argAbbr = Just 'n' , argData = Nothing , argDesc = "Do not display the edit/regenerate script" } , Arg { argIndex = "Source" , argName = Nothing , argAbbr = Nothing , argData = argDataRequired "source" ArgtypeString , argDesc = "Root directory of bookshelf to be generated" } ] main :: IO () main = do pwd <- getCurrentDirectory args <- parseArgsIO ArgsComplete argSpec tmpl <- getDefaultTemplate Nothing "html" tmpl' <- case tmpl of Left msg -> error $ show msg Right tmpl -> return tmpl let Just path = getArg args "Source" css = getArg args "CSS" mathjax = getArg args "MathJax" edit = getArg args "Editor" script = not $ gotArg args "NoScript" path' = pwd path dirs = splitDirectories path' css' = liftM (".." ) css mathjax' = liftM (".." ) mathjax mkContext ds = Context tmpl' css' mathjax' edit script (joinPath $ init ds) (last ds) isDir <- doesDirectoryExist path isFile <- doesFileExist path unless (isDir || isFile) $ err $ "Source '" ++ path ++ "' does not exist." if isDir then generateBookshelf (mkContext dirs) else do err $ "'" ++ path ++ "' is not a directory" unless (takeExtension path == ".shelf") $ err "Source file must have extension '.shelf'" let dirs' = init dirs setCurrentDirectory (joinPath $ init dirs) convertShelfDoc (ShelfInfo (mkContext dirs') Nothing (last dirs)) return () where err msg = error ("**Error: " ++ msg) -- TODO If the "not a directory" error is removed, it handles single shelf -- files as well. In this case, it treats the parent directory as the -- root, which is not ideal. It also ignores links to main documents, and -- it doesn't regenerate the index (which might then become inconsistent -- if meta information is changed). Don't forget to update the `argSpec` -- text if this feature is reintroduced.