git.iko.soy/hakyll
on master help sign in
Separate pandoc from page reading, general caching
08c4d74Jasper Van der Jeugt
src/Text/Hakyll/CreateContext.hs+4−6
compare with master
unifiedsplit
@@ -13,21 +13,19 @@ import qualified Data.Map as M
13import Control.Arrow (second)
13import Control.Arrow (second)
14import Control.Monad (liftM2)
14import Control.Monad (liftM2)
15import Control.Applicative ((<$>))
15import Control.Applicative ((<$>))
16+import Control.Arrow ((>>>))
16
17
17−import Text.Hakyll.File
18import Text.Hakyll.Context
18import Text.Hakyll.Context
19import Text.Hakyll.HakyllAction
19import Text.Hakyll.HakyllAction
20import Text.Hakyll.Render
20import Text.Hakyll.Render
21import Text.Hakyll.Internal.Page
21import Text.Hakyll.Internal.Page
22+import Text.Hakyll.Pandoc
23+import Text.Hakyll.Internal.Cache
22
24
23-- | Create a @Context@ from a page file stored on the disk. This is probably
25-- | Create a @Context@ from a page file stored on the disk. This is probably
24-- the most common way to create a @Context@.
26-- the most common way to create a @Context@.
25createPage :: FilePath -> HakyllAction () Context
27createPage :: FilePath -> HakyllAction () Context
26−createPage path = HakyllAction
28+createPage path = cacheAction "pages" $ readPageAction path >>> renderAction
27− { actionDependencies = [path]
28− , actionUrl = Left $ toUrl path
29− , actionFunction = const (readPage path)
30− }
31
29
32-- | Create a "custom page" @Context@.
30-- | Create a "custom page" @Context@.
33--
31--
src/Text/Hakyll/Internal/Cache.hs+22
@@ -2,14 +2,17 @@ module Text.Hakyll.Internal.Cache
2 ( storeInCache
2 ( storeInCache
3 , getFromCache
3 , getFromCache
4 , isCacheMoreRecent
4 , isCacheMoreRecent
5+ , cacheAction
5 ) where
6 ) where
6
7
7import Control.Monad ((<=<))
8import Control.Monad ((<=<))
8import Control.Monad.Reader (liftIO)
9import Control.Monad.Reader (liftIO)
9import Data.Binary
10import Data.Binary
11+import System.FilePath ((</>))
10
12
11import Text.Hakyll.File
13import Text.Hakyll.File
12import Text.Hakyll.HakyllMonad (Hakyll)
14import Text.Hakyll.HakyllMonad (Hakyll)
15+import Text.Hakyll.HakyllAction
13
16
14-- | We can store all datatypes instantiating @Binary@ to the cache. The cache
17-- | We can store all datatypes instantiating @Binary@ to the cache. The cache
15-- directory is specified by the @HakyllConfiguration@, usually @_cache@.
18-- directory is specified by the @HakyllConfiguration@, usually @_cache@.
@@ -29,3 +32,22 @@ getFromCache = liftIO . decodeFile <=< toCache
29-- | Check if a file in the cache is more recent than a number of other files.
32-- | Check if a file in the cache is more recent than a number of other files.
30isCacheMoreRecent :: FilePath -> [FilePath] -> Hakyll Bool
33isCacheMoreRecent :: FilePath -> [FilePath] -> Hakyll Bool
31isCacheMoreRecent file depends = toCache file >>= flip isFileMoreRecent depends
34isCacheMoreRecent file depends = toCache file >>= flip isFileMoreRecent depends
35+
36+-- | Cache an entire arrow
37+--
38+cacheAction :: Binary a
39+ => String
40+ -> HakyllAction () a
41+ -> HakyllAction () a
42+cacheAction key action = action { actionFunction = const cacheFunction }
43+ where
44+ cacheFunction = do
45+ -- Construct a filename
46+ fileName <- fmap (key </>) $ either id (const $ return "unknown")
47+ $ actionUrl action
48+ -- Check the cache
49+ cacheOk <- isCacheMoreRecent fileName $ actionDependencies action
50+ if cacheOk then getFromCache fileName
51+ else do result <- actionFunction action ()
52+ storeInCache result fileName
53+ return result
src/Text/Hakyll/Internal/Page.hs+37−60
@@ -1,47 +1,29 @@
1-- | A module for dealing with @Page@s. This module is mostly internally used.
1-- | A module for dealing with @Page@s. This module is mostly internally used.
2module Text.Hakyll.Internal.Page
2module Text.Hakyll.Internal.Page
3+ ( PageSection (..)
3− ( readPage
4+ , readPage
5+ , readPageAction
4 ) where
6 ) where
5
7
6−import qualified Data.Map as M
7import Data.List (isPrefixOf)
8import Data.List (isPrefixOf)
8import Data.Char (isSpace)
9import Data.Char (isSpace)
9import Control.Monad.Reader (liftIO)
10import Control.Monad.Reader (liftIO)
10import System.FilePath
11import System.FilePath
11import Control.Monad.State (State, evalState, get, put)
12import Control.Monad.State (State, evalState, get, put)
12
13
13−import Text.Pandoc
14−
15−import Text.Hakyll.Context (Context (..))
16import Text.Hakyll.File
14import Text.Hakyll.File
17import Text.Hakyll.HakyllMonad
15import Text.Hakyll.HakyllMonad
16+import Text.Hakyll.HakyllAction
18import Text.Hakyll.Regex (substituteRegex, matchesRegex)
17import Text.Hakyll.Regex (substituteRegex, matchesRegex)
19import Text.Hakyll.Util (trim)
18import Text.Hakyll.Util (trim)
20−import Text.Hakyll.Internal.Cache
21−import Text.Hakyll.Internal.FileType
22−
23−-- | Get a render function for a given extension.
24−getRenderFunction :: FileType -> Hakyll (String -> String)
25−getRenderFunction Html = return id
26−getRenderFunction Text = return id
27−getRenderFunction UnknownFileType = return id
28−getRenderFunction fileType = do
29− parserState <- askHakyll pandocParserState
30− writerOptions <- askHakyll pandocWriterOptions
31− return $ writeHtmlString writerOptions
32− . readFunction fileType (readOptions parserState fileType)
33− where
34− readFunction ReStructuredText = readRST
35− readFunction LaTeX = readLaTeX
36− readFunction Markdown = readMarkdown
37− readFunction LiterateHaskellMarkdown = readMarkdown
38− readFunction t = error $ "Cannot render " ++ show t
39
19
40− readOptions options LiterateHaskellMarkdown = options
20+-- | Page info handle: (key, value, needs rendering)
41− { stateLiterateHaskell = True }
21+--
42− readOptions options _ = options
22+data PageSection = PageSection {unPageSection :: [(String, String, Bool)]}
23+ deriving (Show)
43
24
44-- | Split a page into sections.
25-- | Split a page into sections.
26+--
45splitAtDelimiters :: [String] -> State (Maybe String) [[String]]
27splitAtDelimiters :: [String] -> State (Maybe String) [[String]]
46splitAtDelimiters [] = return []
28splitAtDelimiters [] = return []
47splitAtDelimiters ls@(x:xs) = do
29splitAtDelimiters ls@(x:xs) = do
@@ -63,59 +45,54 @@ isPossibleDelimiter :: String -> Bool
63isPossibleDelimiter = isPrefixOf "---"
45isPossibleDelimiter = isPrefixOf "---"
64
46
65-- | Read one section of a page.
47-- | Read one section of a page.
66−readSection :: (String -> String) -- ^ Render function.
48+--
67− -> Bool -- ^ If this section is the first section in the page.
49+readSection :: Bool -- ^ If this section is the first section in the page.
68 -> [String] -- ^ Lines in the section.
50 -> [String] -- ^ Lines in the section.
69− -> [(String, String)] -- ^ Key-values extracted.
51+ -> PageSection -- ^ Key-values extracted.
70−readSection _ _ [] = []
52+readSection _ [] = PageSection []
71−readSection renderFunction isFirst ls
53+readSection isFirst ls
72 | not isDelimiter' = body ls
54 | not isDelimiter' = body ls
73− | isNamedDelimiter = readSectionMetaData ls
55+ | isNamedDelimiter = PageSection $ readSectionMetaData ls
74− | isFirst = readSimpleMetaData (drop 1 ls)
56+ | isFirst = PageSection $ readSimpleMetaData (drop 1 ls)
75 | otherwise = body (drop 1 ls)
57 | otherwise = body (drop 1 ls)
76 where
58 where
77 isDelimiter' = isPossibleDelimiter (head ls)
59 isDelimiter' = isPossibleDelimiter (head ls)
78 isNamedDelimiter = head ls `matchesRegex` "^----* *[a-zA-Z0-9][a-zA-Z0-9]*"
60 isNamedDelimiter = head ls `matchesRegex` "^----* *[a-zA-Z0-9][a-zA-Z0-9]*"
79− body ls' = [("body", renderFunction $ unlines ls')]
61+ body ls' = PageSection [("body", unlines ls', True)]
80
62
81 readSimpleMetaData = map readPair . filter (not . all isSpace)
63 readSimpleMetaData = map readPair . filter (not . all isSpace)
82 readPair = trimPair . break (== ':')
64 readPair = trimPair . break (== ':')
83− trimPair (key, value) = (trim key, trim $ drop 1 value)
65+ trimPair (key, value) = (trim key, trim (drop 1 value), False)
84
66
85 readSectionMetaData [] = []
67 readSectionMetaData [] = []
86 readSectionMetaData (header:value) =
68 readSectionMetaData (header:value) =
87 let key = substituteRegex "[^a-zA-Z0-9]" "" header
69 let key = substituteRegex "[^a-zA-Z0-9]" "" header
88− in [(key, renderFunction $ unlines value)]
70+ in [(key, unlines value, True)]
89
71
90−-- | Read a page from a file. Metadata is supported, and if the filename
72+-- | Read a page from a file. Metadata is supported.
91−-- has a @.markdown@ extension, it will be rendered using pandoc.
73+--
92−readPageFromFile :: FilePath -> Hakyll Context
74+readPage :: FilePath -> Hakyll [PageSection]
93−readPageFromFile path = do
75+readPage path = do
94− renderFunction <- getRenderFunction $ getFileType path
95− let sectionFunctions = map (readSection renderFunction)
76+ let sectionFunctions = map readSection $ True : repeat False
96− (True : repeat False)
97
77
98 -- Read file.
78 -- Read file.
99 contents <- liftIO $ readFile path
79 contents <- liftIO $ readFile path
100 url <- toUrl path
80 url <- toUrl path
101 let sections = evalState (splitAtDelimiters $ lines contents) Nothing
81 let sections = evalState (splitAtDelimiters $ lines contents) Nothing
102− sectionsData = concat $ zipWith ($) sectionFunctions sections
82+ sectionsData = zipWith ($) sectionFunctions sections
103− context = M.fromList $
104− ("url", url) : ("path", path) : category ++ sectionsData
105
83
106− return $ Context context
84+ return $ PageSection [ ("url", url, False)
85+ , ("path", path, False)
86+ ] : category : sectionsData
107 where
87 where
108 category = let dirs = splitDirectories $ takeDirectory path
88 category = let dirs = splitDirectories $ takeDirectory path
109− in [("category", last dirs) | not (null dirs)]
89+ in PageSection [("category", last dirs, False) | not (null dirs)]
110
90
111−-- | Read a page. Might fetch it from the cache if available. Otherwise, it will
91+-- | Read a page from a file. Metadata is supported.
112−-- read it from the file given and store it in the cache.
92+--
113−readPage :: FilePath -> Hakyll Context
93+readPageAction :: FilePath -> HakyllAction () [PageSection]
114−readPage path = do
94+readPageAction path = HakyllAction
115− isCacheMoreRecent' <- isCacheMoreRecent fileName [path]
95+ { actionDependencies = [path]
116− if isCacheMoreRecent' then getFromCache fileName
96+ , actionUrl = Left $ toUrl path
117− else do page <- readPageFromFile path
97+ , actionFunction = const $ readPage path
118− storeInCache page fileName
98+ }
119− return page
120− where
121− fileName = "pages" </> path
src/Text/Hakyll/Internal/Template.hs+5−1
@@ -7,6 +7,7 @@ module Text.Hakyll.Internal.Template
7 , finalSubstitute
7 , finalSubstitute
8 ) where
8 ) where
9
9
10+import Control.Arrow ((>>>))
10import Control.Applicative ((<$>))
11import Control.Applicative ((<$>))
11import Data.List (isPrefixOf)
12import Data.List (isPrefixOf)
12import Data.Char (isAlphaNum)
13import Data.Char (isAlphaNum)
@@ -16,6 +17,8 @@ import qualified Data.Map as M
16
17
17import Text.Hakyll.Context (Context (..))
18import Text.Hakyll.Context (Context (..))
18import Text.Hakyll.HakyllMonad (Hakyll)
19import Text.Hakyll.HakyllMonad (Hakyll)
20+import Text.Hakyll.HakyllAction
21+import Text.Hakyll.Pandoc
19import Text.Hakyll.Internal.Cache
22import Text.Hakyll.Internal.Cache
20import Text.Hakyll.Internal.Page
23import Text.Hakyll.Internal.Page
21import Text.Hakyll.Internal.Template.Template
24import Text.Hakyll.Internal.Template.Template
@@ -53,7 +56,8 @@ readTemplate path = do
53 where
56 where
54 fileName = "templates" </> path
57 fileName = "templates" </> path
55 readDefaultTemplate = do
58 readDefaultTemplate = do
56− page <- unContext <$> readPage path
59+ page <- unContext <$>
60+ runHakyllAction (readPageAction path >>> renderAction)
57 let body = fromMaybe (error $ "No body in template " ++ fileName)
61 let body = fromMaybe (error $ "No body in template " ++ fileName)
58 (M.lookup "body" page)
62 (M.lookup "body" page)
59 return $ fromString body
63 return $ fromString body
src/Text/Hakyll/Pandoc.hsnew file+48
@@ -0,0 +1,48 @@
1+module Text.Hakyll.Pandoc where
2+
3+import Data.Maybe (fromMaybe)
4+import qualified Data.Map as M
5+import Control.Arrow (second)
6+
7+import Text.Pandoc
8+
9+import Text.Hakyll.Internal.FileType
10+import Text.Hakyll.Internal.Page
11+import Text.Hakyll.HakyllMonad
12+import Text.Hakyll.HakyllAction
13+import Text.Hakyll.Context
14+
15+-- | Get a render function for a given extension.
16+--
17+getRenderFunction :: FileType -> Hakyll (String -> String)
18+getRenderFunction Html = return id
19+getRenderFunction Text = return id
20+getRenderFunction UnknownFileType = return id
21+getRenderFunction fileType = do
22+ parserState <- askHakyll pandocParserState
23+ writerOptions <- askHakyll pandocWriterOptions
24+ return $ writeHtmlString writerOptions
25+ . readFunction fileType (readOptions parserState fileType)
26+ where
27+ readFunction ReStructuredText = readRST
28+ readFunction LaTeX = readLaTeX
29+ readFunction Markdown = readMarkdown
30+ readFunction LiterateHaskellMarkdown = readMarkdown
31+ readFunction t = error $ "Cannot render " ++ show t
32+
33+ readOptions options LiterateHaskellMarkdown = options
34+ { stateLiterateHaskell = True }
35+ readOptions options _ = options
36+
37+-- | Path must be there
38+--
39+renderAction :: HakyllAction [PageSection] Context
40+renderAction = createHakyllAction $ \sections -> do
41+ let triples = unPageSection =<< sections
42+ path = fromMaybe "unknown" $ lookup "path"
43+ $ map (\(x, y, _) -> (x, y))
44+ $ triples
45+ render' <- getRenderFunction $ getFileType path
46+ let pairs = map (\(k, v, r) -> second (if r then render' else id) (k, v))
47+ triples
48+ return $ Context $ M.fromList pairs