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 (takeExtension, (</>))
import Test.QuickCheck
import Text.Pandoc
import Data.Binary
import Text.Hakyll.Internal.Cache
import Text.Hakyll.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 $
[ ("url", url)
, ("path", path)
] ++ context
return page
where
url = toURL path
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