-- 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 (parseCSL, readBiblioFile)
import Text.CSL.Data (getDefaultCSL)
import Text.Pandoc (getDefaultTemplate)
import Text.Pandoc.UTF8 (toStringLazy)
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) $ warn link
return meta
where
warn link = putStrLn $ concat
[ "*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 <- fmap parseCSL $ case csl of
Just cslFile -> readFile cslFile
_ -> fmap toStringLazy getDefaultCSL
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