From 192c4a16ea01c9398a55f61025425d8e0e87e0f8 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 4 Mar 2010 09:50:25 +0100 Subject: Work on migration to arrows. Compulation fails. - Update readPage to produce a Hakyll Context. - Update createPagePath to produce a Context Arrow. - Move Page to internal modules. --- src/Text/Hakyll/Internal/Page.hs | 181 ++++++++++++++++++++++++++++++++++++ src/Text/Hakyll/Internal/Render.hs | 2 +- src/Text/Hakyll/Page.hs | 185 ------------------------------------- src/Text/Hakyll/Render.hs | 4 +- src/Text/Hakyll/Renderables.hs | 23 ++--- 5 files changed, 192 insertions(+), 203 deletions(-) create mode 100644 src/Text/Hakyll/Internal/Page.hs delete mode 100644 src/Text/Hakyll/Page.hs (limited to 'src/Text') diff --git a/src/Text/Hakyll/Internal/Page.hs b/src/Text/Hakyll/Internal/Page.hs new file mode 100644 index 0000000..92e7249 --- /dev/null +++ b/src/Text/Hakyll/Internal/Page.hs @@ -0,0 +1,181 @@ +-- | A module for dealing with @Page@s. This module is mostly internally used. +module Text.Hakyll.Internal.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.RenderAction +import Text.Hakyll.Regex (substituteRegex, matchesRegex) + +-- | A Page is basically key-value mapping. Certain keys have special +-- meanings, like for example url, body and title. +data Page = Page Context + deriving (Ord, Eq, Show, Read) + +-- | Create a Page from a key-value mapping. +fromContext :: Context -> Page +fromContext = Page + +-- | Obtain a value from a page. Will resturn an empty string when nothing is +-- found. +getValue :: String -> Page -> String +getValue str (Page page) = fromMaybe [] $ M.lookup str page + +-- | Get the URL for a certain page. This should always be defined. If +-- not, it will error. +getPageUrl :: Page -> String +getPageUrl (Page page) = fromMaybe (error "No page url") $ M.lookup "url" page + +-- | Get the original page path. +getPagePath :: Page -> String +getPagePath (Page page) = + fromMaybe (error "No page path") $ M.lookup "path" page + +-- | Get the body for a certain page. When not defined, the body will be +-- empty. +getBody :: Page -> String +getBody (Page page) = fromMaybe [] $ M.lookup "body" page + +-- | 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 :: String -> (String -> String) +getRenderFunction ".html" = id +getRenderFunction ".htm" = 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 + +-- | 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] + +-- | Check if the given string is a metadata delimiter. +isDelimiter :: String -> Bool +isDelimiter = isPrefixOf "---" + +-- | Read one section of a page. +readSection :: (String -> String) -- ^ Render function. + -> Bool -- ^ If this section is the first section in the page. + -> [String] -- ^ Lines in the section. + -> [(String, String)] -- ^ Key-values extracted. +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)] + +-- | Read a page from a file. Metadata is supported, and if the filename +-- has a @.markdown@ extension, it will be rendered using pandoc. +readPageFromFile :: FilePath -> Hakyll Context +readPageFromFile path = do + let renderFunction = getRenderFunction $ takeExtension path + sectionFunctions = map (readSection renderFunction) + (True : repeat False) + + -- Read file. + contents <- liftIO $ readFile path + let sections = splitAtDelimiters $ lines contents + sectionsData = concat $ zipWith ($) sectionFunctions sections + context = M.fromList $ category ++ sectionsData + + return context + where + category = let dirs = splitDirectories $ takeDirectory path + in [("category", last dirs) | not (null dirs)] + +-- | Read a page. Might fetch it from the cache if available. Otherwise, it will +-- read it from the file given and store it in the cache. +readPage :: FilePath -> Hakyll Context +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 + +-- Make pages renderable. +instance Renderable Page where + getDependencies = (:[]) . getPagePath + getUrl = return . getPageUrl + toContext (Page page) = return page + +-- Make pages serializable. +instance Binary Page where + put (Page context) = put $ M.toAscList context + get = liftM (Page . M.fromAscList) get + +-- | Generate an arbitrary page. +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') + +-- Make pages testable +instance Arbitrary Page where + arbitrary = arbitraryPage + shrink (Page context) = map (Page . flip M.delete context) $ M.keys context diff --git a/src/Text/Hakyll/Internal/Render.hs b/src/Text/Hakyll/Internal/Render.hs index 49e6be2..00b74a7 100644 --- a/src/Text/Hakyll/Internal/Render.hs +++ b/src/Text/Hakyll/Internal/Render.hs @@ -16,9 +16,9 @@ import Data.Maybe (fromMaybe) import Text.Hakyll.Context (Context, ContextManipulation) import Text.Hakyll.Renderable -import Text.Hakyll.Page import Text.Hakyll.File import Text.Hakyll.Hakyll +import Text.Hakyll.Internal.Page import Text.Hakyll.Internal.Template -- | A pure render function. diff --git a/src/Text/Hakyll/Page.hs b/src/Text/Hakyll/Page.hs deleted file mode 100644 index 54f9c84..0000000 --- a/src/Text/Hakyll/Page.hs +++ /dev/null @@ -1,185 +0,0 @@ --- | A module for dealing with @Page@s. This module is mostly internally used. -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) - --- | A Page is basically key-value mapping. Certain keys have special --- meanings, like for example url, body and title. -data Page = Page Context - deriving (Ord, Eq, Show, Read) - --- | Create a Page from a key-value mapping. -fromContext :: Context -> Page -fromContext = Page - --- | Obtain a value from a page. Will resturn an empty string when nothing is --- found. -getValue :: String -> Page -> String -getValue str (Page page) = fromMaybe [] $ M.lookup str page - --- | Get the URL for a certain page. This should always be defined. If --- not, it will error. -getPageUrl :: Page -> String -getPageUrl (Page page) = fromMaybe (error "No page url") $ M.lookup "url" page - --- | Get the original page path. -getPagePath :: Page -> String -getPagePath (Page page) = - fromMaybe (error "No page path") $ M.lookup "path" page - --- | Get the body for a certain page. When not defined, the body will be --- empty. -getBody :: Page -> String -getBody (Page page) = fromMaybe [] $ M.lookup "body" page - --- | 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 :: String -> (String -> String) -getRenderFunction ".html" = id -getRenderFunction ".htm" = 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 - --- | 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] - --- | Check if the given string is a metadata delimiter. -isDelimiter :: String -> Bool -isDelimiter = isPrefixOf "---" - --- | Read one section of a page. -readSection :: (String -> String) -- ^ Render function. - -> Bool -- ^ If this section is the first section in the page. - -> [String] -- ^ Lines in the section. - -> [(String, String)] -- ^ Key-values extracted. -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)] - --- | Read a page from a file. Metadata is supported, and if the filename --- has a @.markdown@ extension, it will be rendered using pandoc. -readPageFromFile :: FilePath -> Hakyll Page -readPageFromFile path = do - let renderFunction = getRenderFunction $ takeExtension path - sectionFunctions = map (readSection renderFunction) - (True : repeat False) - - -- Read file. - contents <- liftIO $ readFile path - url <- toUrl path - let sections = splitAtDelimiters $ lines contents - context = concat $ zipWith ($) sectionFunctions sections - page = fromContext $ M.fromList $ - category ++ - [ ("url", url) - , ("path", path) - ] ++ context - - return page - where - category = let dirs = splitDirectories $ takeDirectory path - in [("category", last dirs) | not (null dirs)] - --- | Read a page. Might fetch it from the cache if available. Otherwise, it will --- read it from the file given and store it in the cache. -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 - --- Make pages renderable. -instance Renderable Page where - getDependencies = (:[]) . getPagePath - getUrl = return . getPageUrl - toContext (Page page) = return page - --- Make pages serializable. -instance Binary Page where - put (Page context) = put $ M.toAscList context - get = liftM (Page . M.fromAscList) get - --- | Generate an arbitrary page. -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') - --- Make pages testable -instance Arbitrary Page where - arbitrary = arbitraryPage - shrink (Page context) = map (Page . flip M.delete context) $ M.keys context diff --git a/src/Text/Hakyll/Render.hs b/src/Text/Hakyll/Render.hs index 64fc0ab..98d1a3c 100644 --- a/src/Text/Hakyll/Render.hs +++ b/src/Text/Hakyll/Render.hs @@ -18,12 +18,12 @@ import System.Directory (copyFile) import Text.Hakyll.Hakyll (Hakyll) import Text.Hakyll.Context (ContextManipulation) -import Text.Hakyll.Page import Text.Hakyll.Renderable import Text.Hakyll.File -import Text.Hakyll.Internal.Template (readTemplate) import Text.Hakyll.Internal.CompressCss +import Text.Hakyll.Internal.Page import Text.Hakyll.Internal.Render +import Text.Hakyll.Internal.Template (readTemplate) -- | Execute an IO action only when the cache is invalid. depends :: FilePath -- ^ File to be rendered or created. diff --git a/src/Text/Hakyll/Renderables.hs b/src/Text/Hakyll/Renderables.hs index 136bd85..42c05cc 100644 --- a/src/Text/Hakyll/Renderables.hs +++ b/src/Text/Hakyll/Renderables.hs @@ -11,18 +11,18 @@ module Text.Hakyll.Renderables import qualified Data.Map as M import Control.Arrow (second) -import Control.Monad (liftM, liftM2, mplus) +import Control.Monad (liftM2, mplus) import Control.Applicative ((<$>)) import Data.Binary import Text.Hakyll.Hakyll (Hakyll) -import Text.Hakyll.Page import Text.Hakyll.Renderable import Text.Hakyll.File import Text.Hakyll.Context import Text.Hakyll.Render import Text.Hakyll.RenderAction +import Text.Hakyll.Internal.Page -- | Create a custom page. -- @@ -90,19 +90,12 @@ newtype PagePath = PagePath FilePath deriving (Ord, Eq, Read, Show) -- | Create a PagePath from a FilePath. -createPagePath :: FilePath -> PagePath -createPagePath = PagePath - --- We can render filepaths -instance Renderable PagePath where - getDependencies (PagePath path) = return path - getUrl (PagePath path) = toUrl path - toContext (PagePath path) = readPage path >>= toContext - --- We can serialize filepaths -instance Binary PagePath where - put (PagePath path) = put path - get = liftM PagePath get +createPagePath :: FilePath -> RenderAction () Context +createPagePath path = RenderAction + { actionDependencies = [path] + , actionDestination = Just $ toUrl path + , actionFunction = const (readPage path) + } -- | A combination of two other renderables. data CombinedRenderable a b = CombinedRenderable a b -- cgit v1.2.3