Bookshelf-0.1.1: Bookshelf.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>
module Main where
import Control.Monad
import Data.List
import System.Directory
import System.Environment
import System.FilePath
import qualified System.IO.UTF8 as UTF8
import System.Console.ParseArgs
import Generate
-- | @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 ([String], [String])
getDirectoryContentsSeparated path = do
conts <- getDirectoryContents path
isDirs <- sequence [ doesDirectoryExist (path </> cont) | cont <- conts]
let files = [cont | (cont,isDir) <- zip conts isDirs, not isDir]
dirs = [cont | (cont,isDir) <- zip conts isDirs, isDir, relevant cont]
return (dirs,files)
where
relevant = (`notElem` [".",".."])
-- | @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 ([String], [String], [String], [String])
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 <- UTF8.readFile name
let (html,links,meta) = markdownToHtml shelfInfo markdown
UTF8.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
UTF8.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 = "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
let Just path = getArg args "Source"
css = getArg args "CSS"
edit = getArg args "Editor"
script = not $ gotArg args "NoScript"
path' = pwd </> path
dirs = splitDirectories path'
css' = liftM (".." </>) css
mkContext ds = Context css' 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)
-- XXX 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.
-- XXX
-- Possible extensions
-- ===================
-- * Partial regeneration when only part of the directory has changed.
-- * Allow links relative to the source directory. Possible syntax: `"bookshelf://..."`
-- * Optionally check that `http://` links are valid.
-- * Let contents of `index.shelf` (if existing) be inserted into index.html.
-- The edit/regenerate script should come after the document, through
-- the `writerIncludeAfter` parameter. Otherwise it gets placed before
-- footnotes.