diff --git a/data/templates/rss.xml b/data/templates/rss.xml --- a/data/templates/rss.xml +++ b/data/templates/rss.xml @@ -1,4 +1,4 @@ - + $title diff --git a/hakyll.cabal b/hakyll.cabal --- a/hakyll.cabal +++ b/hakyll.cabal @@ -1,5 +1,5 @@ Name: hakyll -Version: 2.0 +Version: 2.1 Synopsis: A simple static site generator library. Description: A simple static site generator library, mainly aimed at @@ -39,8 +39,7 @@ old-locale >= 1, old-time >= 1, time >= 1, - binary >= 0.5, - QuickCheck >= 2 + binary >= 0.5 exposed-modules: Network.Hakyll.SimpleServer Text.Hakyll Text.Hakyll.Context diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs --- a/src/Text/Hakyll.hs +++ b/src/Text/Hakyll.hs @@ -21,19 +21,39 @@ import System.Directory (doesDirectoryExist, removeDirectoryRecursive) import System.Time (getClockTime) +import Text.Pandoc + import Network.Hakyll.SimpleServer (simpleServer) import Text.Hakyll.HakyllMonad import Text.Hakyll.File +-- | The default reader options for pandoc parsing. +defaultPandocParserState :: ParserState +defaultPandocParserState = defaultParserState + { -- The following option causes pandoc to read smart typography, a nice + -- and free bonus. + stateSmart = True + } + +-- | The default writer options for pandoc rendering. +defaultPandocWriterOptions :: WriterOptions +defaultPandocWriterOptions = defaultWriterOptions + { -- This option causes literate haskell to be written using '>' marks in + -- html, which I think is a good default. + writerLiterateHaskell = True + } + -- | The default hakyll configuration. defaultHakyllConfiguration :: HakyllConfiguration defaultHakyllConfiguration = HakyllConfiguration - { absoluteUrl = "" - , additionalContext = M.empty - , siteDirectory = "_site" - , cacheDirectory = "_cache" - , enableIndexUrl = False - , previewPollDelay = 1000000 + { absoluteUrl = "" + , additionalContext = M.empty + , siteDirectory = "_site" + , cacheDirectory = "_cache" + , enableIndexUrl = False + , previewPollDelay = 1000000 + , pandocParserState = defaultPandocParserState + , pandocWriterOptions = defaultPandocWriterOptions } -- | Main function to run Hakyll with the default configuration. The diff --git a/src/Text/Hakyll/HakyllMonad.hs b/src/Text/Hakyll/HakyllMonad.hs --- a/src/Text/Hakyll/HakyllMonad.hs +++ b/src/Text/Hakyll/HakyllMonad.hs @@ -10,6 +10,8 @@ import Control.Monad (liftM) import qualified Data.Map as M +import Text.Pandoc (ParserState, WriterOptions) + import Text.Hakyll.Context (Context) -- | Our custom monad stack. @@ -18,18 +20,22 @@ -- | Hakyll global configuration type. data HakyllConfiguration = HakyllConfiguration { -- | Absolute URL of the site. - absoluteUrl :: String + absoluteUrl :: String , -- | An additional context to use when rendering. This additional context -- is used globally. - additionalContext :: Context + additionalContext :: Context , -- | Directory where the site is placed. - siteDirectory :: FilePath + siteDirectory :: FilePath , -- | Directory for cache files. - cacheDirectory :: FilePath + cacheDirectory :: FilePath , -- | Enable index links. - enableIndexUrl :: Bool + enableIndexUrl :: Bool , -- | Delay between polls in preview mode. - previewPollDelay :: Int + previewPollDelay :: Int + , -- | Pandoc parsing options + pandocParserState :: ParserState + , -- | Pandoc writer options + pandocWriterOptions :: WriterOptions } -- | Simplified @ask@ function for the Hakyll monad stack. diff --git a/src/Text/Hakyll/Internal/Page.hs b/src/Text/Hakyll/Internal/Page.hs --- a/src/Text/Hakyll/Internal/Page.hs +++ b/src/Text/Hakyll/Internal/Page.hs @@ -1,5 +1,5 @@ -- | A module for dealing with @Page@s. This module is mostly internally used. -module Text.Hakyll.Internal.Page +module Text.Hakyll.Internal.Page ( readPage ) where @@ -8,6 +8,7 @@ import Data.Char (isSpace) import Control.Monad.Reader (liftIO) import System.FilePath +import Control.Monad.State (State, evalState, get, put) import Text.Pandoc @@ -19,28 +20,15 @@ import Text.Hakyll.Internal.Cache import Text.Hakyll.Internal.FileType --- | The default reader options for pandoc parsing. -readerOptions :: ParserState -readerOptions = defaultParserState - { -- The following option causes pandoc to read smart typography, a nice - -- and free bonus. - stateSmart = True - } - --- | The default writer options for pandoc rendering. -writerOptions :: WriterOptions -writerOptions = defaultWriterOptions - { -- This option causes literate haskell to be written using '>' marks in - -- html, which I think is a good default. - writerLiterateHaskell = True - } - -- | Get a render function for a given extension. -getRenderFunction :: FileType -> (String -> String) -getRenderFunction Html = id -getRenderFunction Text = id -getRenderFunction fileType = writeHtmlString writerOptions - . readFunction fileType (readOptions fileType) +getRenderFunction :: FileType -> Hakyll (String -> String) +getRenderFunction Html = return id +getRenderFunction Text = return id +getRenderFunction fileType = do + parserState <- askHakyll pandocParserState + writerOptions <- askHakyll pandocWriterOptions + return $ writeHtmlString writerOptions + . readFunction fileType (readOptions parserState fileType) where readFunction ReStructuredText = readRST readFunction LaTeX = readLaTeX @@ -48,21 +36,30 @@ readFunction LiterateHaskellMarkdown = readMarkdown readFunction t = error $ "Cannot render " ++ show t - readOptions LiterateHaskellMarkdown = - readerOptions { stateLiterateHaskell = True } - readOptions _ = readerOptions + readOptions options LiterateHaskellMarkdown = options + { stateLiterateHaskell = True } + readOptions options _ = options -- | Split a page into sections. -splitAtDelimiters :: [String] -> [[String]] -splitAtDelimiters [] = [] -splitAtDelimiters ls@(x:xs) - | isDelimiter x = let (content, rest) = break isDelimiter xs - in (x : content) : splitAtDelimiters rest - | otherwise = [ls] +splitAtDelimiters :: [String] -> State (Maybe String) [[String]] +splitAtDelimiters [] = return [] +splitAtDelimiters ls@(x:xs) = do + delimiter <- get + if not (isDelimiter delimiter x) + then return [ls] + else do let proper = takeWhile (== '-') x + (content, rest) = break (isDelimiter $ Just proper) xs + put $ Just proper + rest' <- splitAtDelimiters rest + return $ (x : content) : rest' + where + isDelimiter old = case old of + Nothing -> isPossibleDelimiter + (Just d) -> (== d) . takeWhile (== '-') -- | Check if the given string is a metadata delimiter. -isDelimiter :: String -> Bool -isDelimiter = isPrefixOf "---" +isPossibleDelimiter :: String -> Bool +isPossibleDelimiter = isPrefixOf "---" -- | Read one section of a page. readSection :: (String -> String) -- ^ Render function. @@ -76,7 +73,7 @@ | isFirst = readSimpleMetaData (tail ls) | otherwise = body (tail ls) where - isDelimiter' = isDelimiter (head ls) + isDelimiter' = isPossibleDelimiter (head ls) isNamedDelimiter = head ls `matchesRegex` "^----* *[a-zA-Z0-9][a-zA-Z0-9]*" body ls' = [("body", renderFunction $ unlines ls')] @@ -93,14 +90,14 @@ -- has a @.markdown@ extension, it will be rendered using pandoc. readPageFromFile :: FilePath -> Hakyll Context readPageFromFile path = do - let renderFunction = getRenderFunction $ getFileType path - sectionFunctions = map (readSection renderFunction) + renderFunction <- getRenderFunction $ getFileType path + let sectionFunctions = map (readSection renderFunction) (True : repeat False) -- Read file. contents <- liftIO $ readFile path url <- toUrl path - let sections = splitAtDelimiters $ lines contents + let sections = evalState (splitAtDelimiters $ lines contents) Nothing sectionsData = concat $ zipWith ($) sectionFunctions sections context = M.fromList $ ("url", url) : ("path", path) : category ++ sectionsData diff --git a/src/Text/Hakyll/Internal/Template.hs b/src/Text/Hakyll/Internal/Template.hs --- a/src/Text/Hakyll/Internal/Template.hs +++ b/src/Text/Hakyll/Internal/Template.hs @@ -1,5 +1,5 @@ module Text.Hakyll.Internal.Template - ( Template + ( Template (..) , fromString , readTemplate , substitute @@ -11,14 +11,11 @@ import Data.List (isPrefixOf) import Data.Char (isAlphaNum) import Data.Binary -import Control.Monad (liftM, liftM2, replicateM) -import Control.Applicative ((<$>)) +import Control.Monad (liftM, liftM2) import Data.Maybe (fromMaybe) import System.FilePath (()) import Control.Monad.Reader (liftIO) -import Test.QuickCheck - import Text.Hakyll.Context (Context) import Text.Hakyll.HakyllMonad (Hakyll) import Text.Hakyll.Internal.Cache @@ -91,32 +88,3 @@ 2 -> liftM EscapeCharacter get 3 -> return End _ -> error "Error reading template" - --- | Generate arbitrary templates from a given length. -arbitraryTemplate :: Int -> Gen Template -arbitraryTemplate 0 = return End -arbitraryTemplate length' = oneof [ do chunk <- chunk' - Chunk chunk <$> template' - , do key <- key' - Identifier key <$> template' - , EscapeCharacter <$> template' - ] - where - template' = arbitraryTemplate (length' - 1) - -- Generate keys. - key' = do l <- choose (5, 10) - replicateM l $ choose ('a', 'z') - -- Generate non-empty chunks. - chunk' = do string <- arbitrary - let sanitized = filter (/= '$') string - return $ if null sanitized then "foo" - else sanitized - --- | Make @Template@ testable. -instance Arbitrary Template where - arbitrary = choose (0, 20) >>= arbitraryTemplate - - shrink (Chunk chunk template) = [template, Chunk chunk End] - shrink (Identifier key template) = [template, Identifier key End] - shrink (EscapeCharacter template) = [template, EscapeCharacter End] - shrink End = []