module Text.Hakyll.Page
( Page
, fromContext
, getValue
, getBody
, readPage
) where
import qualified Data.Map as M
import Data.List (isPrefixOf)
import Data.Char (isSpace)
import Data.Maybe (fromMaybe)
import Control.Monad (liftM, replicateM)
import Control.Monad.Reader (liftIO)
import System.FilePath
import Test.QuickCheck
import Text.Pandoc
import Data.Binary
import Text.Hakyll.Internal.Cache
import Text.Hakyll.Hakyll
import Text.Hakyll.File
import Text.Hakyll.Util (trim)
import Text.Hakyll.Context (Context)
import Text.Hakyll.Renderable
import Text.Hakyll.Regex (substituteRegex, matchesRegex)
data Page = Page Context
deriving (Show, Read, Eq)
fromContext :: Context -> Page
fromContext = Page
getValue :: String -> Page -> String
getValue str (Page page) = fromMaybe [] $ M.lookup str page
getPageURL :: Page -> String
getPageURL (Page page) = fromMaybe (error "No page url") $ M.lookup "url" page
getPagePath :: Page -> String
getPagePath (Page page) =
fromMaybe (error "No page path") $ M.lookup "path" page
getBody :: Page -> String
getBody (Page page) = fromMaybe [] $ M.lookup "body" page
readerOptions :: ParserState
readerOptions = defaultParserState { stateSmart = True }
writerOptions :: WriterOptions
writerOptions = defaultWriterOptions
getRenderFunction :: String -> (String -> String)
getRenderFunction ".html" = id
getRenderFunction ext = writeHtmlString writerOptions
. readFunction ext (readOptions ext)
where
readFunction ".rst" = readRST
readFunction ".tex" = readLaTeX
readFunction _ = readMarkdown
readOptions ".lhs" = readerOptions { stateLiterateHaskell = True }
readOptions _ = readerOptions
splitAtDelimiters :: [String] -> [[String]]
splitAtDelimiters [] = []
splitAtDelimiters ls@(x:xs)
| isDelimiter x = let (content, rest) = break isDelimiter xs
in (x : content) : splitAtDelimiters rest
| otherwise = [ls]
isDelimiter :: String -> Bool
isDelimiter = isPrefixOf "---"
readSection :: (String -> String)
-> Bool
-> [String]
-> [(String, String)]
readSection _ _ [] = []
readSection renderFunction isFirst ls
| not isDelimiter' = body ls
| isNamedDelimiter = readSectionMetaData ls
| isFirst = readSimpleMetaData (tail ls)
| otherwise = body (tail ls)
where
isDelimiter' = isDelimiter (head ls)
isNamedDelimiter = head ls `matchesRegex` "^----* *[a-zA-Z0-9][a-zA-Z0-9]*"
body ls' = [("body", renderFunction $ unlines ls')]
readSimpleMetaData = map readPair . filter (not . all isSpace)
readPair = trimPair . break (== ':')
trimPair (key, value) = (trim key, trim $ tail value)
readSectionMetaData [] = []
readSectionMetaData (header:value) =
let key = substituteRegex "[^a-zA-Z0-9]" "" header
in [(key, renderFunction $ unlines value)]
readPageFromFile :: FilePath -> Hakyll Page
readPageFromFile path = do
let renderFunction = getRenderFunction $ takeExtension path
sectionFunctions = map (readSection renderFunction)
(True : repeat False)
contents <- liftIO $ readFile path
let sections = splitAtDelimiters $ lines contents
context = concat $ zipWith ($) sectionFunctions sections
page = fromContext $ M.fromList $
category ++
[ ("url", url)
, ("path", path)
] ++ context
return page
where
url = toURL path
category = let dirs = splitDirectories $ takeDirectory path
in [("category", last dirs) | not (null dirs)]
readPage :: FilePath -> Hakyll Page
readPage path = do
isCacheMoreRecent' <- isCacheMoreRecent fileName [path]
if isCacheMoreRecent' then getFromCache fileName
else do page <- readPageFromFile path
storeInCache page fileName
return page
where
fileName = "pages" </> path
instance Renderable Page where
getDependencies = (:[]) . getPagePath
getURL = getPageURL
toContext (Page page) = return page
instance Binary Page where
put (Page context) = put $ M.toAscList context
get = liftM (Page . M.fromAscList) get
arbitraryPage :: Gen Page
arbitraryPage = do keys <- listOf key'
values <- arbitrary
return $ Page $ M.fromList $ zip keys values
where
key' = do l <- choose (5, 10)
replicateM l $ choose ('a', 'z')
instance Arbitrary Page where
arbitrary = arbitraryPage
shrink (Page context) = map (Page . flip M.delete context) $ M.keys context