diff --git a/data/templates/atom-item.xml b/data/templates/atom-item.xml new file mode 100644 --- /dev/null +++ b/data/templates/atom-item.xml @@ -0,0 +1,7 @@ + + $title + + $absolute/$url + $timestamp + $description + diff --git a/data/templates/atom.xml b/data/templates/atom.xml new file mode 100644 --- /dev/null +++ b/data/templates/atom.xml @@ -0,0 +1,12 @@ + + + $title + + + $absolute/$url + + $authorName + + $timestamp + $body + diff --git a/data/templates/rss-item.xml b/data/templates/rss-item.xml new file mode 100644 --- /dev/null +++ b/data/templates/rss-item.xml @@ -0,0 +1,7 @@ + + $title + $absolute/$url + $description + $timestamp + $absolute/$url + diff --git a/data/templates/rss.xml b/data/templates/rss.xml new file mode 100644 --- /dev/null +++ b/data/templates/rss.xml @@ -0,0 +1,12 @@ + + + + $title + $absolute + $description + + $timestamp + $body + + diff --git a/hakyll.cabal b/hakyll.cabal --- a/hakyll.cabal +++ b/hakyll.cabal @@ -1,55 +1,63 @@ -Name: hakyll -Version: 1.4 +Name: hakyll +Version: 2.0 -Synopsis: A simple static site generator library. -Description: - A simple static site generator library, mainly aimed at - creating blogs and brochure sites. -Author: Jasper Van der Jeugt -Maintainer: jaspervdj@gmail.com -Homepage: http://jaspervdj.be/hakyll -Bug-Reports: http://github.com/jaspervdj/Hakyll/issues -License: BSD3 -License-File: LICENSE -Category: Text -Cabal-Version: >= 1.6 +Synopsis: A simple static site generator library. +Description: A simple static site generator library, mainly aimed at + creating blogs and brochure sites. +Author: Jasper Van der Jeugt +Maintainer: jaspervdj@gmail.com +Homepage: http://jaspervdj.be/hakyll +Bug-Reports: http://github.com/jaspervdj/Hakyll/issues +License: BSD3 +License-File: LICENSE +Category: Text +Cabal-Version: >= 1.6 +Data-Dir: data +Data-Files: templates/atom.xml + templates/atom-item.xml + templates/rss.xml + templates/rss-item.xml -build-type: Simple +build-type: Simple source-repository head - type: git - location: git://github.com/jaspervdj/Hakyll.git + type: git + location: git://github.com/jaspervdj/Hakyll.git library - ghc-options: -Wall - hs-source-dirs: src/ - build-depends: base >= 4 && < 5, - filepath >= 1.1, - directory >= 1, - containers >= 0.1, - pandoc >= 1, - regex-base >= 0.83, - regex-tdfa >= 0.92, - network >= 2, - mtl >= 1.1, - old-locale >= 1, - old-time >= 1, - time >= 1, - binary >= 0.5, - QuickCheck >= 2 - exposed-modules: Network.Hakyll.SimpleServer - Text.Hakyll - Text.Hakyll.Context - Text.Hakyll.File - Text.Hakyll.Hakyll - Text.Hakyll.Regex - Text.Hakyll.Render - Text.Hakyll.Renderable - Text.Hakyll.Renderables - Text.Hakyll.Page - Text.Hakyll.Util - Text.Hakyll.Tags - Text.Hakyll.Internal.Cache - Text.Hakyll.Internal.CompressCss - Text.Hakyll.Internal.Render - Text.Hakyll.Internal.Template + ghc-options: -Wall + hs-source-dirs: src + build-depends: base >= 4 && < 5, + filepath >= 1.1, + directory >= 1, + containers >= 0.1, + pandoc >= 1, + regex-base >= 0.83, + regex-tdfa >= 0.92, + network >= 2, + mtl >= 1.1, + old-locale >= 1, + old-time >= 1, + time >= 1, + binary >= 0.5, + QuickCheck >= 2 + exposed-modules: Network.Hakyll.SimpleServer + Text.Hakyll + Text.Hakyll.Context + Text.Hakyll.ContextManipulations + Text.Hakyll.CreateContext + Text.Hakyll.File + Text.Hakyll.HakyllMonad + Text.Hakyll.Regex + Text.Hakyll.Render + Text.Hakyll.HakyllAction + Text.Hakyll.Paginate + Text.Hakyll.Util + Text.Hakyll.Tags + Text.Hakyll.Feed + other-modules: Paths_hakyll + Text.Hakyll.Internal.Cache + Text.Hakyll.Internal.CompressCss + Text.Hakyll.Internal.FileType + Text.Hakyll.Internal.Page + Text.Hakyll.Internal.Template diff --git a/src/Network/Hakyll/SimpleServer.hs b/src/Network/Hakyll/SimpleServer.hs --- a/src/Network/Hakyll/SimpleServer.hs +++ b/src/Network/Hakyll/SimpleServer.hs @@ -143,16 +143,16 @@ Nothing -> [] where result = lookup (takeExtension fileName) [ (".css", "text/css") - , (".gif", "image/gif") - , (".htm", "text/html") - , (".html", "text/html") - , (".jpeg", "image/jpeg") - , (".jpg", "image/jpeg") - , (".js", "text/javascript") - , (".png", "image/png") - , (".txt", "text/plain") - , (".xml", "text/xml") - ] + , (".gif", "image/gif") + , (".htm", "text/html") + , (".html", "text/html") + , (".jpeg", "image/jpeg") + , (".jpg", "image/jpeg") + , (".js", "text/javascript") + , (".png", "image/png") + , (".txt", "text/plain") + , (".xml", "text/xml") + ] -- | Respond to an incoming request. respond :: Handle -> Server () diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs --- a/src/Text/Hakyll.hs +++ b/src/Text/Hakyll.hs @@ -22,22 +22,29 @@ import System.Time (getClockTime) import Network.Hakyll.SimpleServer (simpleServer) -import Text.Hakyll.Hakyll +import Text.Hakyll.HakyllMonad import Text.Hakyll.File -- | The default hakyll configuration. defaultHakyllConfiguration :: HakyllConfiguration defaultHakyllConfiguration = HakyllConfiguration - { additionalContext = M.empty - , siteDirectory = "_site" - , cacheDirectory = "_cache" - , enableIndexUrl = False - , previewPollDelay = 1000000 + { absoluteUrl = "" + , additionalContext = M.empty + , siteDirectory = "_site" + , cacheDirectory = "_cache" + , enableIndexUrl = False + , previewPollDelay = 1000000 } --- | Main function to run Hakyll with the default configuration. -hakyll :: Hakyll () -> IO () -hakyll = hakyllWithConfiguration defaultHakyllConfiguration +-- | Main function to run Hakyll with the default configuration. The +-- absolute URL is only used in certain cases, for example RSS feeds et +-- cetera. +hakyll :: String -- ^ Absolute URL of your site. Used in certain cases. + -> Hakyll () -- ^ You code. + -> IO () +hakyll absolute = hakyllWithConfiguration configuration + where + configuration = defaultHakyllConfiguration { absoluteUrl = absolute } -- | Main function to run hakyll with a custom configuration. hakyllWithConfiguration :: HakyllConfiguration -> Hakyll () -> IO () @@ -47,6 +54,7 @@ ["clean"] -> clean ["preview", p] -> preview buildFunction (read p) ["preview"] -> preview buildFunction 8000 + ["rebuild"] -> clean >> buildFunction ["server", p] -> server (read p) ["server"] -> server 8000 _ -> help @@ -90,6 +98,7 @@ ++ name ++ " clean Clean up and remove cache.\n" ++ name ++ " help Show this message.\n" ++ name ++ " preview [port] Run a server and autocompile.\n" + ++ name ++ " rebuild Clean up and build again.\n" ++ name ++ " server [port] Run a local test server.\n" -- | Start a server at the given port number. diff --git a/src/Text/Hakyll/Context.hs b/src/Text/Hakyll/Context.hs --- a/src/Text/Hakyll/Context.hs +++ b/src/Text/Hakyll/Context.hs @@ -1,82 +1,11 @@ --- | Module containing various functions to manipulate contexts. +-- | This (quite small) module exports the datatype used for contexts. A +-- @Context@ is a simple key-value mapping. You can render these @Context@s +-- with templates, and manipulate them in various ways. module Text.Hakyll.Context ( Context - , ContextManipulation - , renderValue - , changeValue - , renderDate - , changeExtension ) where -import qualified Data.Map as M import Data.Map (Map) -import System.Locale (defaultTimeLocale) -import System.FilePath (takeFileName, addExtension, dropExtension) -import Data.Time.Format (parseTime, formatTime) -import Data.Time.Clock (UTCTime) -import Data.Maybe (fromMaybe) -import Text.Hakyll.Regex (substituteRegex) - --- | Type for a context. +-- | Datatype used for key-value mappings. type Context = Map String String - --- | Type for context manipulating functions. -type ContextManipulation = Context -> Context - --- | Do something with a value in a @Context@, but keep the old value as well. --- This is probably the most common function to construct a --- @ContextManipulation@. -renderValue :: String -- ^ Key of which the value should be copied. - -> String -- ^ Key the value should be copied to. - -> (String -> String) -- ^ Function to apply on the value. - -> ContextManipulation -renderValue src dst f context = case M.lookup src context of - Nothing -> context - (Just value) -> M.insert dst (f value) context - --- | Change a value in a @Context@. --- --- > import Data.Char (toUpper) --- > changeValue "title" (map toUpper) --- --- Will put the title in UPPERCASE. -changeValue :: String -- ^ Key of which the value should be changed. - -> (String -> String) -- ^ Function to apply on the value. - -> ContextManipulation -changeValue key = renderValue key key - --- | When the context has a key called @path@ in a @yyyy-mm-dd-title.extension@ --- format (default for pages), this function can render the date. --- --- > renderDate "date" "%B %e, %Y" "Date unknown" --- --- Will render something like @January 32, 2010@. -renderDate :: String -- ^ Key in which the rendered date should be placed. - -> String -- ^ Format to use on the date. - -> String -- ^ Default value when the date cannot be parsed. - -> ContextManipulation -renderDate key format defaultValue context = M.insert key value context - where - value = fromMaybe defaultValue pretty - pretty = do filePath <- M.lookup "path" context - let dateString = substituteRegex "^([0-9]*-[0-9]*-[0-9]*).*" "\\1" - (takeFileName filePath) - time <- parseTime defaultTimeLocale - "%Y-%m-%d" - dateString :: Maybe UTCTime - return $ formatTime defaultTimeLocale format time - --- | Change the extension of a file. This is only needed when you want to --- render, for example, mardown to @.php@ files instead of @.html@ files. --- --- > renderChainWith (changeExtension "php") --- > ["templates/default.html"] --- > (createPagePath "test.markdown") --- --- Will render to @test.php@ instead of @test.html@. -changeExtension :: String -- ^ Extension to change to. - -> ContextManipulation -changeExtension extension = changeValue "url" changeExtension' - where - changeExtension' = flip addExtension extension . dropExtension diff --git a/src/Text/Hakyll/ContextManipulations.hs b/src/Text/Hakyll/ContextManipulations.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/ContextManipulations.hs @@ -0,0 +1,93 @@ +-- | This module exports a number of functions that produce @HakyllAction@s to +-- manipulate @Context@s. +module Text.Hakyll.ContextManipulations + ( renderValue + , changeValue + , copyValue + , renderDate + , changeExtension + , renderBody + ) where + +import Control.Arrow (arr) +import System.Locale (defaultTimeLocale) +import System.FilePath (takeFileName, addExtension, dropExtension) +import Data.Time.Format (parseTime, formatTime) +import Data.Time.Clock (UTCTime) +import Data.Maybe (fromMaybe) +import qualified Data.Map as M + +import Text.Hakyll.Regex (substituteRegex) +import Text.Hakyll.HakyllAction (HakyllAction) +import Text.Hakyll.Context (Context) + +-- | Do something with a value in a @Context@, but keep the old value as well. +-- If the key given is not present in the @Context@, nothing will happen. +renderValue :: String -- ^ Key of which the value should be copied. + -> String -- ^ Key the value should be copied to. + -> (String -> String) -- ^ Function to apply on the value. + -> HakyllAction Context Context +renderValue source destination f = arr $ \context -> + case M.lookup source context of + Nothing -> context + (Just value) -> M.insert destination (f value) context + +-- | Change a value in a @Context@. +-- +-- > import Data.Char (toUpper) +-- > changeValue "title" (map toUpper) +-- +-- Will put the title in UPPERCASE. +changeValue :: String -- ^ Key to change. + -> (String -> String) -- ^ Function to apply on the value. + -> HakyllAction Context Context +changeValue key = renderValue key key + +-- | Copy a value from one key to another in a @Context@. +copyValue :: String -- ^ Source key. + -> String -- ^ Destination key. + -> HakyllAction Context Context +copyValue source destination = renderValue source destination id + +-- | When the context has a key called @path@ in a +-- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages), +-- this function can render the date. +-- +-- > renderDate "date" "%B %e, %Y" "Date unknown" +-- +-- Will render something like @January 32, 2010@. +renderDate :: String -- ^ Key in which the rendered date should be placed. + -> String -- ^ Format to use on the date. + -> String -- ^ Default key, in case the date cannot be parsed. + -> HakyllAction Context Context +renderDate key format defaultValue = renderValue "path" key renderDate' + where + renderDate' filePath = fromMaybe defaultValue $ do + let dateString = substituteRegex "^([0-9]*-[0-9]*-[0-9]*).*" "\\1" + (takeFileName filePath) + time <- parseTime defaultTimeLocale + "%Y-%m-%d" + dateString :: Maybe UTCTime + return $ formatTime defaultTimeLocale format time + +-- | Change the extension of a file. This is only needed when you want to +-- render, for example, mardown to @.php@ files instead of @.html@ files. +-- +-- > changeExtension "php" +-- +-- Will render @test.markdown@ to @test.php@ instead of @test.html@. +changeExtension :: String -- ^ Extension to change to. + -> HakyllAction Context Context +changeExtension extension = changeValue "url" changeExtension' + where + changeExtension' = flip addExtension extension . dropExtension + +-- | Change the body of a file using a certain manipulation. +-- +-- > import Data.Char (toUpper) +-- > renderBody (map toUpper) +-- +-- Will put the entire body of the page in UPPERCASE. +renderBody :: (String -> String) + -> HakyllAction Context Context +renderBody = renderValue "body" "body" diff --git a/src/Text/Hakyll/CreateContext.hs b/src/Text/Hakyll/CreateContext.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/CreateContext.hs @@ -0,0 +1,97 @@ +-- | A module that provides different ways to create a @Context@. These +-- functions all use the @HakyllAction@ arrow, so they produce values of the +-- type @HakyllAction () Context@. +module Text.Hakyll.CreateContext + ( createPage + , createCustomPage + , createListing + , combine + , combineWithUrl + ) where + +import qualified Data.Map as M +import Control.Arrow (second) +import Control.Monad (liftM2, mplus) +import Control.Applicative ((<$>)) + +import Text.Hakyll.File +import Text.Hakyll.Context +import Text.Hakyll.HakyllAction +import Text.Hakyll.Render +import Text.Hakyll.Internal.Page + +-- | Create a @Context@ from a page file stored on the disk. This is probably +-- the most common way to create a @Context@. +createPage :: FilePath -> HakyllAction () Context +createPage path = HakyllAction + { actionDependencies = [path] + , actionUrl = Just $ toUrl path + , actionFunction = const (readPage path) + } + +-- | Create a "custom page" @Context@. +-- +-- The association list given maps keys to values for substitution. Note +-- that as value, you can either give a @String@ or a +-- @HakyllAction () String@. The latter is preferred for more complex data, +-- since it allows dependency checking. A @String@ is obviously more simple +-- to use in some cases. +createCustomPage :: FilePath + -> [(String, Either String (HakyllAction () String))] + -> HakyllAction () Context +createCustomPage url association = HakyllAction + { actionDependencies = dataDependencies + , actionUrl = Just $ return url + , actionFunction = \_ -> M.fromList <$> assoc' + } + where + mtuple (a, b) = b >>= \b' -> return (a, b') + toHakyllString = second (either return runHakyllAction) + assoc' = mapM (mtuple . toHakyllString) $ ("url", Left url) : association + dataDependencies = map snd association >>= getDependencies + getDependencies (Left _) = [] + getDependencies (Right x) = actionDependencies x + +-- | A @createCustomPage@ function specialized in creating listings. +-- +-- This function creates a listing of a certain list of @Context@s. Every +-- item in the list is created by applying the given template to every +-- renderable. You can also specify additional context to be included in the +-- @CustomPage@. +createListing :: FilePath -- ^ Destination of the page. + -> [FilePath] -- ^ Templates to render items with. + -> [HakyllAction () Context] -- ^ Renderables in the list. + -> [(String, Either String (HakyllAction () String))] + -> HakyllAction () Context +createListing url templates renderables additional = + createCustomPage url context + where + context = ("body", Right concatenation) : additional + concatenation = renderAndConcat templates renderables + +-- | Combine two @Context@s. The url will always be taken from the first +-- @Renderable@. Also, if a `$key` is present in both renderables, the +-- value from the first @Context@ will be taken as well. +-- +-- You can see this as a this as a @union@ between two mappings. +combine :: HakyllAction () Context -> HakyllAction () Context + -> HakyllAction () Context +combine x y = HakyllAction + { actionDependencies = actionDependencies x ++ actionDependencies y + , actionUrl = actionUrl x `mplus` actionUrl y + , actionFunction = \_ -> + liftM2 M.union (runHakyllAction x) (runHakyllAction y) + } + +-- | Combine two @Context@s and set a custom URL. This behaves like @combine@, +-- except that for the @url@ field, the given URL is always chosen. +combineWithUrl :: FilePath + -> HakyllAction () Context + -> HakyllAction () Context + -> HakyllAction () Context +combineWithUrl url x y = combine' + { actionUrl = Just $ return url + , actionFunction = \_ -> M.insert "url" url <$> runHakyllAction combine' + } + where + combine' = combine x y diff --git a/src/Text/Hakyll/Feed.hs b/src/Text/Hakyll/Feed.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/Feed.hs @@ -0,0 +1,111 @@ +-- | A Module that allows easy rendering of RSS feeds. If you use this module, +-- you must make sure you set the `absoluteUrl` field in the main Hakyll +-- configuration. +-- +-- Apart from that, the main rendering functions (@renderRss@, @renderAtom@) +-- all assume that you pass the list of items so that the most recent entry +-- in the feed is the first item in the list. +-- +-- Also note that the @Context@s should have (at least) the following +-- fields to produce a correct feed: +-- +-- - @$title@: Title of the item. +-- +-- - @$description@: Description to appear in the feed. +-- +-- - @$url@: URL to the item - this is usually set automatically. +-- +-- Furthermore, the feed will be generated, but will be incorrect (it won't +-- validate) if an empty list is passed. +module Text.Hakyll.Feed + ( FeedConfiguration (..) + , renderRss + , renderAtom + ) where + +import Control.Arrow ((>>>), second) +import Control.Monad.Reader (liftIO) +import Data.Maybe (fromMaybe) +import qualified Data.Map as M + +import Text.Hakyll.Context (Context) +import Text.Hakyll.CreateContext (createListing) +import Text.Hakyll.ContextManipulations (renderDate) +import Text.Hakyll.HakyllMonad (Hakyll) +import Text.Hakyll.Render (render, renderChain) +import Text.Hakyll.HakyllAction + +import Paths_hakyll + +-- | This is a data structure to keep the configuration of a feed. +data FeedConfiguration = FeedConfiguration + { -- | Url of the feed (relative to site root). For example, @rss.xml@. + feedUrl :: String + , -- | Title of the feed. + feedTitle :: String + , -- | Description of the feed. + feedDescription :: String + , -- | Name of the feed author. + feedAuthorName :: String + } + +-- | This is an auxiliary function to create a listing that is, in fact, a feed. +-- The items should be sorted on date. +createFeed :: FeedConfiguration -- ^ Feed configuration. + -> [HakyllAction () Context] -- ^ Items to include. + -> FilePath -- ^ Feed template. + -> FilePath -- ^ Item template. + -> HakyllAction () Context +createFeed configuration renderables template itemTemplate = + listing >>> render template + where + listing = createListing (feedUrl configuration) + [itemTemplate] renderables additional + + additional = map (second $ Left . ($ configuration)) + [ ("title", feedTitle) + , ("description", feedDescription) + , ("authorName", feedAuthorName) + ] ++ updated + + -- Take the first timestamp, which should be the most recent. + updated = let action = createHakyllAction $ + return . fromMaybe "foo" . M.lookup "timestamp" + toTuple r = ("timestamp", Right $ r >>> action) + in map toTuple $ take 1 renderables + + +-- | Abstract function to render any feed. +renderFeed :: FeedConfiguration -- ^ Feed configuration. + -> [HakyllAction () Context] -- ^ Items to include in the feed. + -> FilePath -- ^ Feed template. + -> FilePath -- ^ Item template. + -> Hakyll () +renderFeed configuration renderables template itemTemplate = do + template' <- liftIO $ getDataFileName template + itemTemplate' <- liftIO $ getDataFileName itemTemplate + let renderFeed' = createFeed configuration renderables + template' itemTemplate' + renderChain [] renderFeed' + +-- | Render an RSS feed with a number of items. +renderRss :: FeedConfiguration -- ^ Feed configuration. + -> [HakyllAction () Context] -- ^ Items to include in the feed. + -> Hakyll () +renderRss configuration renderables = + renderFeed configuration (map (>>> renderRssDate) renderables) + "templates/rss.xml" "templates/rss-item.xml" + where + renderRssDate = renderDate "timestamp" "%a, %d %b %Y %H:%M:%S UT" + "No date found." + +-- | Render an Atom feed with a number of items. +renderAtom :: FeedConfiguration -- ^ Feed configuration. + -> [HakyllAction () Context] -- ^ Items to include in the feed. + -> Hakyll () +renderAtom configuration renderables = + renderFeed configuration (map (>>> renderAtomDate) renderables) + "templates/atom.xml" "templates/atom-item.xml" + where + renderAtomDate = renderDate "timestamp" "%Y-%m-%dT%H:%M:%SZ" + "No date found." diff --git a/src/Text/Hakyll/File.hs b/src/Text/Hakyll/File.hs --- a/src/Text/Hakyll/File.hs +++ b/src/Text/Hakyll/File.hs @@ -20,9 +20,11 @@ import System.Time (ClockTime) import Control.Monad import Data.List (isPrefixOf, sortBy) +import Data.Ord (comparing) import Control.Monad.Reader (liftIO) -import Text.Hakyll.Hakyll +import Text.Hakyll.HakyllMonad +import Text.Hakyll.Internal.FileType (isRenderableFile) -- | Auxiliary function to remove pathSeparators form the start. We don't deal -- with absolute paths here. We also remove $root from the start. @@ -61,7 +63,7 @@ toUrl path = do enableIndexUrl' <- askHakyll enableIndexUrl -- If the file does not have a renderable extension, like for -- example favicon.ico, we don't have to change it at all. - return $ if not hasRenderableExtension + return $ if not (isRenderableFile path) then path -- If index url's are enabled, we create pick it -- unless the page is an index already. @@ -69,23 +71,9 @@ then indexUrl else withSimpleHtmlExtension where - hasRenderableExtension = takeExtension path `elem` [ ".markdown" - , ".md" - , ".mdn" - , ".mdwn" - , ".mkd" - , ".mkdn" - , ".mkdwn" - , ".rst" - , ".text" - , ".tex" - , ".lhs" - , ".htm" - , ".html" - ] - isIndex = (dropExtension $ takeFileName path) == "index" + isIndex = dropExtension (takeFileName path) == "index" withSimpleHtmlExtension = flip addExtension ".html" $ dropExtension path - indexUrl = (dropExtension path) ++ "/" + indexUrl = dropExtension path ++ "/" -- | Get the relative url to the site root, for a given (absolute) url @@ -131,7 +119,7 @@ sortByBaseName :: [FilePath] -> [FilePath] sortByBaseName = sortBy compareBaseName where - compareBaseName f1 f2 = compare (takeFileName f1) (takeFileName f2) + compareBaseName = comparing takeFileName -- | A filter that takes all file names with a given extension. Prefix the -- extension with a dot: diff --git a/src/Text/Hakyll/Hakyll.hs b/src/Text/Hakyll/Hakyll.hs deleted file mode 100644 --- a/src/Text/Hakyll/Hakyll.hs +++ /dev/null @@ -1,33 +0,0 @@ --- | Module describing the Hakyll monad stack. -module Text.Hakyll.Hakyll - ( HakyllConfiguration (..) - , Hakyll - , askHakyll - ) where - -import Control.Monad.Reader (ReaderT, ask) -import Control.Monad (liftM) - -import Text.Hakyll.Context (Context) - --- | Hakyll global configuration type. -data HakyllConfiguration = HakyllConfiguration - { -- | An additional context to use when rendering. This additional context - -- is used globally. - additionalContext :: Context - , -- | Directory where the site is placed. - siteDirectory :: FilePath - , -- | Directory for cache files. - cacheDirectory :: FilePath - , -- | Enable index links. - enableIndexUrl :: Bool - , -- | Delay between polls in preview mode. - previewPollDelay :: Int - } - --- | Our custom monad stack. -type Hakyll = ReaderT HakyllConfiguration IO - --- | Simplified @ask@ function for the Hakyll monad stack. -askHakyll :: (HakyllConfiguration -> a) -> Hakyll a -askHakyll = flip liftM ask diff --git a/src/Text/Hakyll/HakyllAction.hs b/src/Text/Hakyll/HakyllAction.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/HakyllAction.hs @@ -0,0 +1,95 @@ +-- | This is the module which exports @HakyllAction@. +module Text.Hakyll.HakyllAction + ( HakyllAction (..) + , createHakyllAction + , createSimpleHakyllAction + , createFileHakyllAction + , chain + , runHakyllAction + , runHakyllActionIfNeeded + ) where + +import Control.Arrow +import Control.Category +import Control.Monad ((<=<), mplus, unless) +import Control.Monad.Reader (liftIO) +import Prelude hiding ((.), id) +import System.IO (hPutStrLn, stderr) + +import Text.Hakyll.File (toDestination, isFileMoreRecent) +import Text.Hakyll.HakyllMonad + +-- | Type used for rendering computations that carry along dependencies. +data HakyllAction a b = HakyllAction + { -- | Dependencies of the @HakyllAction@. + actionDependencies :: [FilePath] + , -- | URL pointing to the result of this @HakyllAction@. + actionUrl :: Maybe (Hakyll FilePath) + , -- | The actual render function. + actionFunction :: a -> Hakyll b + } + +-- | Create a @HakyllAction@ from a function. +createHakyllAction :: (a -> Hakyll b) -- ^ Function to execute. + -> HakyllAction a b +createHakyllAction f = id { actionFunction = f } + +-- | Create a @HakyllAction@ from a simple @Hakyll@ value. +createSimpleHakyllAction :: Hakyll b -- ^ Hakyll value to pass on. + -> HakyllAction () b +createSimpleHakyllAction = createHakyllAction . const + +-- | Create a @HakyllAction@ that operates on one file. +createFileHakyllAction :: FilePath -- ^ File to operate on. + -> Hakyll b -- ^ Value to pass on. + -> HakyllAction () b -- ^ The resulting action. +createFileHakyllAction path action = HakyllAction + { actionDependencies = [path] + , actionUrl = Just $ return path + , actionFunction = const action + } + +-- | Run a @HakyllAction@ now. +runHakyllAction :: HakyllAction () a -- ^ Render action to run. + -> Hakyll a -- ^ Result of the action. +runHakyllAction action = actionFunction action () + +-- | Run a @HakyllAction@, but only when it is out-of-date. At this point, the +-- @actionUrl@ field must be set. +runHakyllActionIfNeeded :: HakyllAction () () -- ^ Action to run. + -> Hakyll () -- ^ Empty result. +runHakyllActionIfNeeded action = do + url <- case actionUrl action of + (Just u) -> u + Nothing -> error "No url when checking dependencies." + destination <- toDestination url + valid <- isFileMoreRecent destination $ actionDependencies action + unless valid $ do liftIO $ hPutStrLn stderr $ "Rendering " ++ destination + runHakyllAction action + +-- | Chain a number of @HakyllAction@ computations. +chain :: [HakyllAction a a] -- ^ Actions to chain. + -> HakyllAction a a -- ^ Resulting action. +chain [] = id +chain list = foldl1 (>>>) list + +instance Category HakyllAction where + id = HakyllAction + { actionDependencies = [] + , actionUrl = Nothing + , actionFunction = return + } + + x . y = HakyllAction + { actionDependencies = actionDependencies x ++ actionDependencies y + , actionUrl = actionUrl x `mplus` actionUrl y + , actionFunction = actionFunction x <=< actionFunction y + } + +instance Arrow HakyllAction where + arr f = id { actionFunction = return . f } + + first x = x + { actionFunction = \(y, z) -> do y' <- actionFunction x y + return (y', z) + } diff --git a/src/Text/Hakyll/HakyllMonad.hs b/src/Text/Hakyll/HakyllMonad.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/HakyllMonad.hs @@ -0,0 +1,50 @@ +-- | Module describing the Hakyll monad stack. +module Text.Hakyll.HakyllMonad + ( HakyllConfiguration (..) + , Hakyll + , askHakyll + , getAdditionalContext + ) where + +import Control.Monad.Reader (ReaderT, ask) +import Control.Monad (liftM) +import qualified Data.Map as M + +import Text.Hakyll.Context (Context) + +-- | Our custom monad stack. +type Hakyll = ReaderT HakyllConfiguration IO + +-- | Hakyll global configuration type. +data HakyllConfiguration = HakyllConfiguration + { -- | Absolute URL of the site. + absoluteUrl :: String + , -- | An additional context to use when rendering. This additional context + -- is used globally. + additionalContext :: Context + , -- | Directory where the site is placed. + siteDirectory :: FilePath + , -- | Directory for cache files. + cacheDirectory :: FilePath + , -- | Enable index links. + enableIndexUrl :: Bool + , -- | Delay between polls in preview mode. + previewPollDelay :: Int + } + +-- | Simplified @ask@ function for the Hakyll monad stack. +-- +-- Usage would typically be something like: +-- +-- > doSomething :: a -> b -> Hakyll c +-- > doSomething arg1 arg2 = do +-- > siteDirectory' <- askHakyll siteDirectory +-- > ... +-- +askHakyll :: (HakyllConfiguration -> a) -> Hakyll a +askHakyll = flip liftM ask + +getAdditionalContext :: HakyllConfiguration -> Context +getAdditionalContext configuration = + M.insert "absolute" (absoluteUrl configuration) + (additionalContext configuration) diff --git a/src/Text/Hakyll/Internal/Cache.hs b/src/Text/Hakyll/Internal/Cache.hs --- a/src/Text/Hakyll/Internal/Cache.hs +++ b/src/Text/Hakyll/Internal/Cache.hs @@ -6,9 +6,10 @@ import Control.Monad ((<=<)) import Control.Monad.Reader (liftIO) -import Text.Hakyll.Hakyll (Hakyll) -import Text.Hakyll.File import Data.Binary + +import Text.Hakyll.File +import Text.Hakyll.HakyllMonad (Hakyll) -- | We can store all datatypes instantiating @Binary@ to the cache. The cache -- directory is specified by the @HakyllConfiguration@, usually @_cache@. diff --git a/src/Text/Hakyll/Internal/FileType.hs b/src/Text/Hakyll/Internal/FileType.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/Internal/FileType.hs @@ -0,0 +1,48 @@ +-- | A module dealing with file extensions and associated file types. +module Text.Hakyll.Internal.FileType + ( FileType (..) + , getFileType + , isRenderable + , isRenderableFile + ) where + +import System.FilePath (takeExtension) + +-- | Datatype to represent the different file types Hakyll can deal with. +data FileType = Html + | LaTeX + | LiterateHaskellMarkdown + | Markdown + | ReStructuredText + | Text + | UnknownFileType + deriving (Eq, Ord, Show, Read) + +-- | Get the file type for a certain file. The type is determined by extension. +getFileType :: FilePath -> FileType +getFileType = getFileType' . takeExtension + where + getFileType' ".htm" = Html + getFileType' ".html" = Html + getFileType' ".lhs" = LiterateHaskellMarkdown + getFileType' ".markdown" = Markdown + getFileType' ".md" = Markdown + getFileType' ".mdn" = Markdown + getFileType' ".mdown" = Markdown + getFileType' ".mdwn" = Markdown + getFileType' ".mkd" = Markdown + getFileType' ".mkdwn" = Markdown + getFileType' ".rst" = ReStructuredText + getFileType' ".tex" = LaTeX + getFileType' ".text" = Text + getFileType' ".txt" = Text + getFileType' _ = UnknownFileType + +-- | Check if a certain @FileType@ is renderable. +isRenderable :: FileType -> Bool +isRenderable UnknownFileType = False +isRenderable _ = True + +-- | Check if a certain file is renderable. +isRenderableFile :: FilePath -> Bool +isRenderableFile = isRenderable . getFileType diff --git a/src/Text/Hakyll/Internal/Page.hs b/src/Text/Hakyll/Internal/Page.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/Internal/Page.hs @@ -0,0 +1,123 @@ +-- | A module for dealing with @Page@s. This module is mostly internally used. +module Text.Hakyll.Internal.Page + ( readPage + ) where + +import qualified Data.Map as M +import Data.List (isPrefixOf) +import Data.Char (isSpace) +import Control.Monad.Reader (liftIO) +import System.FilePath + +import Text.Pandoc + +import Text.Hakyll.Context (Context) +import Text.Hakyll.File +import Text.Hakyll.HakyllMonad +import Text.Hakyll.Regex (substituteRegex, matchesRegex) +import Text.Hakyll.Util (trim) +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) + where + readFunction ReStructuredText = readRST + readFunction LaTeX = readLaTeX + readFunction Markdown = readMarkdown + readFunction LiterateHaskellMarkdown = readMarkdown + readFunction t = error $ "Cannot render " ++ show t + + readOptions LiterateHaskellMarkdown = + 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 $ getFileType path + sectionFunctions = map (readSection renderFunction) + (True : repeat False) + + -- Read file. + contents <- liftIO $ readFile path + url <- toUrl path + let sections = splitAtDelimiters $ lines contents + sectionsData = concat $ zipWith ($) sectionFunctions sections + context = M.fromList $ + ("url", url) : ("path", path) : 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 diff --git a/src/Text/Hakyll/Internal/Render.hs b/src/Text/Hakyll/Internal/Render.hs deleted file mode 100644 --- a/src/Text/Hakyll/Internal/Render.hs +++ /dev/null @@ -1,67 +0,0 @@ --- | Internal module do some low-level rendering. -module Text.Hakyll.Internal.Render - ( substitute - , regularSubstitute - , finalSubstitute - , pureRenderWith - , pureRenderAndConcatWith - , pureRenderChainWith - , writePage - ) where - -import qualified Data.Map as M -import Control.Monad.Reader (liftIO) -import Data.List (foldl') -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.Template - --- | A pure render function. -pureRenderWith :: ContextManipulation -- ^ Manipulation to apply on the context. - -> Template -- ^ Template to use for rendering. - -> Context -- ^ Renderable object to render with given template. - -> Context -- ^ The body of the result will contain the render. -pureRenderWith manipulation template context = - -- Ignore $root when substituting here. We will only replace that in the - -- final render (just before writing). - let contextIgnoringRoot = M.insert "root" "$root" (manipulation context) - body = regularSubstitute template contextIgnoringRoot - in M.insert "body" body context - --- | A pure renderAndConcat function. -pureRenderAndConcatWith :: ContextManipulation -- ^ Manipulation to apply. - -> [Template] -- ^ Templates to use. - -> [Context] -- ^ Different renderables. - -> String -pureRenderAndConcatWith manipulation templates = - concatMap renderAndConcat - where - renderAndConcat = fromMaybe "" . M.lookup "body" - . pureRenderChainWith manipulation templates - --- | A pure renderChain function. -pureRenderChainWith :: ContextManipulation - -> [Template] - -> Context - -> Context -pureRenderChainWith manipulation templates context = - let initial = manipulation context - in foldl' (flip $ pureRenderWith id) initial templates - --- | Write a page to the site destination. Final action after render --- chains and such. -writePage :: Page -> Hakyll () -writePage page = do - additionalContext' <- askHakyll additionalContext - url <- getUrl page - destination <- toDestination url - let context = additionalContext' `M.union` M.singleton "root" (toRoot url) - makeDirectories destination -    -- Substitute $root here, just before writing. - liftIO $ writeFile destination $ finalSubstitute (fromString $ getBody page) - context 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 @@ -19,8 +19,8 @@ import Test.QuickCheck -import Text.Hakyll.Hakyll (Hakyll) import Text.Hakyll.Context (Context) +import Text.Hakyll.HakyllMonad (Hakyll) import Text.Hakyll.Internal.Cache -- | Datatype used for template substitutions. diff --git a/src/Text/Hakyll/Page.hs b/src/Text/Hakyll/Page.hs deleted file mode 100644 --- 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/Paginate.hs b/src/Text/Hakyll/Paginate.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/Paginate.hs @@ -0,0 +1,89 @@ +-- | Module aimed to paginate web pages. +module Text.Hakyll.Paginate + ( PaginateConfiguration (..) + , defaultPaginateConfiguration + , paginate + ) where + +import Control.Applicative ((<$>)) + +import Text.Hakyll.Context (Context) +import Text.Hakyll.CreateContext +import Text.Hakyll.HakyllAction +import Text.Hakyll.Util (link) + +-- | A configuration for a pagination. +data PaginateConfiguration = PaginateConfiguration + { -- | Label for the link to the previous page. + previousLabel :: String + , -- | Label for the link to the next page. + nextLabel :: String + , -- | Label for the link to the first page. + firstLabel :: String + , -- | Label for the link to the last page. + lastLabel :: String + } + +-- | A simple default configuration for pagination. +defaultPaginateConfiguration :: PaginateConfiguration +defaultPaginateConfiguration = PaginateConfiguration + { previousLabel = "Previous" + , nextLabel = "Next" + , firstLabel = "First" + , lastLabel = "Last" + } + +-- | The most important function for pagination. This function operates on a +-- list of @Context@s (the pages), and basically just adds fields to them +-- by combining them with a custom page. +-- +-- The following metadata fields will be added: +-- +-- - @$previous@: A link to the previous page. +-- +-- - @$next@: A link to the next page. +-- +-- - @$first@: A link to the first page. +-- +-- - @$last@: A link to the last page. +-- +-- - @$index@: 1-based index of the current page. +-- +-- - @$length@: Total number of pages. +-- +-- When @$previous@ or @$next@ are not available, they will be just a label +-- without a link. The same goes for when we are on the first or last page for +-- @$first@ and @$last@. +paginate :: PaginateConfiguration + -> [HakyllAction () Context] + -> [HakyllAction () Context] +paginate configuration renderables = paginate' Nothing renderables (1 :: Int) + where + -- Create a link with a given label, taken from the configuration. + linkWithLabel f r = Right $ case actionUrl r of + Just l -> createSimpleHakyllAction $ link (f configuration) <$> l + Nothing -> error "No link found for pagination." + + -- The main function that creates combined renderables by recursing over + -- the list of items. + paginate' _ [] _ = [] + paginate' maybePrev (x:xs) index = + let (previous, first) = case maybePrev of + (Just r) -> ( linkWithLabel previousLabel r + , linkWithLabel firstLabel (head renderables) ) + Nothing -> ( Left $ previousLabel configuration + , Left $ firstLabel configuration ) + (next, last') = case xs of + (n:_) -> ( linkWithLabel nextLabel n + , linkWithLabel lastLabel (last renderables) ) + [] -> ( Left $ nextLabel configuration + , Left $ lastLabel configuration ) + customPage = createCustomPage "" + [ ("previous", previous) + , ("next", next) + , ("first", first) + , ("last", last') + , ("index", Left $ show index) + , ("length", Left $ show $ length renderables) + ] + in (x `combine` customPage) : paginate' (Just x) xs (index + 1) diff --git a/src/Text/Hakyll/Regex.hs b/src/Text/Hakyll/Regex.hs --- a/src/Text/Hakyll/Regex.hs +++ b/src/Text/Hakyll/Regex.hs @@ -15,7 +15,7 @@ matchRegexAll = matchM -- | Replaces every occurance of the given regexp with the replacement string. -subRegex :: Regex -- ^ Search pattern +subRegex :: Regex -- ^ Search pattern -> String -- ^ Input string -> String -- ^ Replacement text -> String -- ^ Output string @@ -41,7 +41,8 @@ in case matchRegexAll regexp inp of Nothing -> inp Just (lead, match', trail, groups) -> - lead ++ lookup' match' replacement groups ++ subRegex regexp trail replacement + lead ++ lookup' match' replacement groups + ++ subRegex regexp trail replacement -- | Splits a string based on a regular expression. The regular expression -- should identify one delimiter. diff --git a/src/Text/Hakyll/Render.hs b/src/Text/Hakyll/Render.hs --- a/src/Text/Hakyll/Render.hs +++ b/src/Text/Hakyll/Render.hs @@ -1,87 +1,74 @@ -- | Module containing rendering functions. All these functions are used to -- render files to the @_site@ directory. module Text.Hakyll.Render - ( depends - , render - , renderWith + ( render , renderAndConcat - , renderAndConcatWith , renderChain - , renderChainWith , static , css + , writePage ) where -import Control.Monad (unless) +import Control.Arrow ((>>>)) +import Control.Applicative ((<$>)) import Control.Monad.Reader (liftIO) import System.Directory (copyFile) +import Data.Maybe (fromMaybe) +import qualified Data.Map as M -import Text.Hakyll.Hakyll (Hakyll) -import Text.Hakyll.Context (ContextManipulation) -import Text.Hakyll.Page -import Text.Hakyll.Renderable +import Text.Hakyll.Context (Context) +import Text.Hakyll.HakyllMonad (Hakyll, askHakyll, getAdditionalContext) import Text.Hakyll.File -import Text.Hakyll.Internal.Template (readTemplate) +import Text.Hakyll.HakyllAction import Text.Hakyll.Internal.CompressCss -import Text.Hakyll.Internal.Render - --- | Execute an IO action only when the cache is invalid. -depends :: FilePath -- ^ File to be rendered or created. - -> [FilePath] -- ^ Files the render depends on. - -> Hakyll () -- ^ IO action to execute when the file is out of date. - -> Hakyll () -depends file dependencies action = do - destination <- toDestination file - valid <- isFileMoreRecent destination dependencies - unless valid action +import Text.Hakyll.Internal.Template --- | Render to a Page. -render :: Renderable a - => FilePath -- ^ Template to use for rendering. - -> a -- ^ Renderable object to render with given template. - -> Hakyll Page -- ^ The body of the result will contain the render. -render = renderWith id +-- | A pure render function - used internally. +pureRender :: Template -- ^ Template to use for rendering. + -> Context -- ^ Renderable object to render with given template. + -> Context -- ^ The body of the result will contain the render. +pureRender template context = + -- Ignore $root when substituting here. We will only replace that in the + -- final render (just before writing). + let contextIgnoringRoot = M.insert "root" "$root" context + body = regularSubstitute template contextIgnoringRoot + in M.insert "body" body context --- | Render to a Page. This function allows you to manipulate the context --- first. -renderWith :: Renderable a - => ContextManipulation -- ^ Manipulation to apply on the context. - -> FilePath -- ^ Template to use for rendering. - -> a -- ^ Renderable object to render with given template. - -> Hakyll Page -- ^ The body of the result will contain the render. -renderWith manipulation templatePath renderable = do - template <- readTemplate templatePath - context <- toContext renderable - return $ fromContext $ pureRenderWith manipulation template context +-- | This is the most simple render action. You render a @Context@ with a +-- template, and get back the result. +render :: FilePath -- ^ Template to use for rendering. + -> HakyllAction Context Context -- ^ The render computation. +render templatePath = HakyllAction + { actionDependencies = [templatePath] + , actionUrl = Nothing + , actionFunction = \context -> + flip pureRender context <$> readTemplate templatePath + } --- | Render each renderable with the given templates, then concatenate the +-- | Render each @Context@ with the given templates, then concatenate the -- result. So, basically this function: -- --- * Takes every renderable. +-- - Takes every @Context@. -- --- * Renders every renderable with all given templates. This is comparable +-- - Renders every @Context@ with all given templates. This is comparable -- with a renderChain action. -- --- * Concatenates the result. --- -renderAndConcat :: Renderable a - => [FilePath] -- ^ Templates to apply on every renderable. - -> [a] -- ^ Renderables to render. - -> Hakyll String -renderAndConcat = renderAndConcatWith id +-- - Concatenates the result and returns that as a @String@. +renderAndConcat :: [FilePath] + -> [HakyllAction () Context] + -> HakyllAction () String +renderAndConcat templatePaths renderables = HakyllAction + { actionDependencies = renders >>= actionDependencies + , actionUrl = Nothing + , actionFunction = actionFunction' + } + where + render' = chain (map render templatePaths) + renders = map (>>> render') renderables --- | Render each renderable with the given templates, then concatenate the --- result. This function allows you to specify a @ContextManipulation@ to --- apply on every @Renderable@. -renderAndConcatWith :: Renderable a - => ContextManipulation - -> [FilePath] - -> [a] - -> Hakyll String -renderAndConcatWith manipulation templatePaths renderables = do - templates <- mapM readTemplate templatePaths - contexts <- mapM toContext renderables - return $ pureRenderAndConcatWith manipulation templates contexts + actionFunction' _ = do + contexts <- mapM runHakyllAction renders + return $ concatMap (fromMaybe "" . M.lookup "body") contexts -- | Chain a render action for a page with a number of templates. This will -- also write the result to the site destination. This is the preferred way @@ -93,38 +80,45 @@ -- -- This code will first render @warning.html@ using @templates/notice.html@, -- and will then render the result with @templates/default.html@. -renderChain :: Renderable a => [FilePath] -> a -> Hakyll () -renderChain = renderChainWith id - --- | A more custom render chain that allows you to specify a --- @ContextManipulation@ which to apply on the context when it is read first. -renderChainWith :: Renderable a - => ContextManipulation -> [FilePath] -> a -> Hakyll () -renderChainWith manipulation templatePaths renderable = do - url <- getUrl renderable - depends url dependencies render' +renderChain :: [FilePath] + -> HakyllAction () Context + -> Hakyll () +renderChain templatePaths initial = + runHakyllActionIfNeeded renderChainWith' where - dependencies = getDependencies renderable ++ templatePaths - render' = do - templates <- mapM readTemplate templatePaths - context <- toContext renderable - let result = pureRenderChainWith manipulation templates context - writePage $ fromContext result + renderChainWith' = initial >>> chain' >>> writePage + chain' = chain $ map render templatePaths -- | Mark a certain file as static, so it will just be copied when the site is -- generated. static :: FilePath -> Hakyll () -static source = do destination <- toDestination source - depends destination [source] (action destination) +static source = runHakyllActionIfNeeded static' where - action destination = do makeDirectories destination - liftIO $ copyFile source destination + static' = createFileHakyllAction source $ do + destination <- toDestination source + makeDirectories destination + liftIO $ copyFile source destination -- | Render a css file, compressing it. css :: FilePath -> Hakyll () -css source = do destination <- toDestination source - depends destination [source] (css' destination) +css source = runHakyllActionIfNeeded css' where - css' destination = do contents <- liftIO $ readFile source - makeDirectories destination - liftIO $ writeFile destination (compressCss contents) + css' = createFileHakyllAction source $ do + contents <- liftIO $ readFile source + destination <- toDestination source + makeDirectories destination + liftIO $ writeFile destination (compressCss contents) + +-- | Write a page to the site destination. Final action after render +-- chains and such. +writePage :: HakyllAction Context () +writePage = createHakyllAction $ \initialContext -> do + additionalContext' <- askHakyll getAdditionalContext + let url = fromMaybe (error "No url defined at write time.") + (M.lookup "url" initialContext) + body = fromMaybe "" (M.lookup "body" initialContext) + let context = additionalContext' `M.union` M.singleton "root" (toRoot url) + destination <- toDestination url + makeDirectories destination + -- Substitute $root here, just before writing. + liftIO $ writeFile destination $ finalSubstitute (fromString body) context diff --git a/src/Text/Hakyll/Renderable.hs b/src/Text/Hakyll/Renderable.hs deleted file mode 100644 --- a/src/Text/Hakyll/Renderable.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Text.Hakyll.Renderable - ( Renderable(toContext, getDependencies, getUrl) - ) where - -import Text.Hakyll.Hakyll (Hakyll) -import Text.Hakyll.Context (Context) - --- | A class for datatypes that can be rendered to pages. -class Renderable a where - -- | Get a context to do substitutions with. - toContext :: a -> Hakyll Context - - -- | Get the dependencies for the renderable. This is used for cache - -- invalidation. - getDependencies :: a -> [FilePath] - - -- | Get the destination for the renderable. - getUrl :: a -> Hakyll FilePath diff --git a/src/Text/Hakyll/Renderables.hs b/src/Text/Hakyll/Renderables.hs deleted file mode 100644 --- a/src/Text/Hakyll/Renderables.hs +++ /dev/null @@ -1,158 +0,0 @@ -module Text.Hakyll.Renderables - ( CustomPage - , createCustomPage - , createListing - , createListingWith - , PagePath - , createPagePath - , CombinedRenderable - , combine - , combineWithUrl - ) where - -import qualified Data.Map as M -import Control.Arrow (second) -import Control.Monad (liftM) - -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 - --- | A custom page. -data CustomPage = CustomPage - { customPageUrl :: String, - customPageDependencies :: [FilePath], - customPageContext :: [(String, Either String (Hakyll String))] - } - --- | Create a custom page. --- --- The association list given maps keys to values for substitution. Note --- that as value, you can either give a @String@ or a @Hakyll String@. --- A @Hakyll String@ is preferred for more complex data, since it allows --- dependency checking. A @String@ is obviously more simple to use in some --- cases. -createCustomPage :: String -- ^ Destination of the page, relative to _site. - -> [FilePath] -- ^ Dependencies of the page. - -> [(String, Either String (Hakyll String))] -- ^ Mapping. - -> CustomPage -createCustomPage = CustomPage - --- | A @createCustomPage@ function specialized in creating listings. --- --- This function creates a listing of a certain list of @Renderable@s. Every --- item in the list is created by applying the given template to every --- renderable. You can also specify additional context to be included in the --- @CustomPage@. --- --- > let customPage = createListingWith --- > "index.html" -- Destination of the page. --- > "templates/postitem.html" -- Path to template to --- > -- render the items with. --- > posts -- ^ Renderables to create the list with. --- > [("title", "Home")] -- ^ Additional context -createListing :: (Renderable a) - => String -- ^ Destination of the page. - -> FilePath -- ^ Template to render all items with. - -> [a] -- ^ Renderables in the list. - -> [(String, String)] -- ^ Additional context. - -> CustomPage -createListing = createListingWith id - --- | A @createCustomPage@ function specialized in creating listings. --- --- In addition to @createListing@, this function allows you to specify an --- extra @ContextManipulation@ for all @Renderable@s given. -createListingWith :: (Renderable a) - => ContextManipulation -- ^ Manipulation for the renderables. - -> String -- ^ Destination of the page. - -> FilePath -- ^ Template to render all items with. - -> [a] -- ^ Renderables in the list. - -> [(String, String)] -- ^ Additional context. - -> CustomPage -createListingWith manipulation url template renderables additional = - createCustomPage url dependencies context - where - dependencies = template : concatMap getDependencies renderables - context = ("body", Right concatenation) : additional' - concatenation = renderAndConcatWith manipulation [template] renderables - additional' = map (second Left) additional - -instance Renderable CustomPage where - getDependencies = customPageDependencies - getUrl = return . customPageUrl - toContext page = do - values <- mapM (either return id . snd) (customPageContext page) - let pairs = zip (map fst $ customPageContext page) values - return $ M.fromList $ ("url", customPageUrl page) : pairs - --- | PagePath is a class that wraps a FilePath. This is used to render Pages --- without reading them first through use of caching. -data 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 - --- | A combination of two other renderables. -data CombinedRenderable a b = CombinedRenderable a b - | CombinedRenderableWithUrl FilePath a b - deriving (Ord, Eq, Read, Show) - --- | Combine two renderables. The url will always be taken from the first --- @Renderable@. Also, if a `$key` is present in both renderables, the --- value from the first @Renderable@ will be taken as well. --- --- Since renderables are always more or less key-value maps, you can see --- this as a @union@ between two maps. -combine :: (Renderable a, Renderable b) => a -> b -> CombinedRenderable a b -combine = CombinedRenderable - --- | Combine two renderables and set a custom URL. This behaves like @combine@, --- except that for the @url@ field, the given URL is always chosen. -combineWithUrl :: (Renderable a, Renderable b) - => FilePath - -> a - -> b - -> CombinedRenderable a b -combineWithUrl = CombinedRenderableWithUrl - --- Render combinations. -instance (Renderable a, Renderable b) - => Renderable (CombinedRenderable a b) where - - -- Add the dependencies. - getDependencies (CombinedRenderable a b) = - getDependencies a ++ getDependencies b - getDependencies (CombinedRenderableWithUrl _ a b) = - getDependencies a ++ getDependencies b - - -- Take the url from the first renderable, or the specified URL. - getUrl (CombinedRenderable a _) = getUrl a - getUrl (CombinedRenderableWithUrl url _ _) = return url - - -- Take a union of the contexts. - toContext (CombinedRenderable a b) = do - c1 <- toContext a - c2 <- toContext b - return $ c1 `M.union` c2 - toContext (CombinedRenderableWithUrl url a b) = do - c <- toContext (CombinedRenderable a b) - return $ M.singleton "url" url `M.union` c diff --git a/src/Text/Hakyll/Tags.hs b/src/Text/Hakyll/Tags.hs --- a/src/Text/Hakyll/Tags.hs +++ b/src/Text/Hakyll/Tags.hs @@ -18,8 +18,6 @@ -- is to place pages in subdirectories. -- -- An example, the page @posts\/coding\/2010-01-28-hakyll-categories.markdown@ --- would be placed under the `coding` category. --- -- Tags or categories are read using the @readTagMap@ and @readCategoryMap@ -- functions. Because categories are implemented using tags - categories can -- be seen as tags, with the restriction that a page can only have one @@ -33,6 +31,7 @@ ( TagMap , readTagMap , readCategoryMap + , withTagMap , renderTagCloud , renderTagLinks ) where @@ -40,16 +39,16 @@ import qualified Data.Map as M import Data.List (intercalate) import Data.Maybe (fromMaybe, maybeToList) -import Control.Monad (foldM) -import Control.Arrow (second) +import Control.Arrow (second, (>>>)) import Control.Applicative ((<$>)) import System.FilePath -import Text.Hakyll.Hakyll -import Text.Hakyll.Context +import Text.Hakyll.Context (Context) +import Text.Hakyll.ContextManipulations (changeValue) +import Text.Hakyll.CreateContext (createPage) +import Text.Hakyll.HakyllMonad (Hakyll) import Text.Hakyll.Regex -import Text.Hakyll.Renderable -import Text.Hakyll.Renderables +import Text.Hakyll.HakyllAction import Text.Hakyll.Util import Text.Hakyll.Internal.Cache import Text.Hakyll.Internal.Template @@ -59,75 +58,98 @@ -- This is a map associating tags or categories to the appropriate pages -- using that tag or category. In the case of categories, each path will only -- appear under one category - this is not the case with tags. -type TagMap = M.Map String [PagePath] +type TagMap = M.Map String [HakyllAction () Context] -- | Read a tag map. This is a internally used function that can be used for -- tags as well as for categories. readMap :: (Context -> [String]) -- ^ Function to get tags from a context. -> String -- ^ Unique identifier for the tagmap. - -> [PagePath] - -> Hakyll TagMap -readMap getTagsFunction identifier paths = do - isCacheMoreRecent' <- isCacheMoreRecent fileName (getDependencies =<< paths) - if isCacheMoreRecent' then M.fromAscList <$> getFromCache fileName - else do tagMap <- readTagMap' - storeInCache (M.toAscList tagMap) fileName - return tagMap + -> [FilePath] + -> HakyllAction () TagMap +readMap getTagsFunction identifier paths = HakyllAction + { actionDependencies = paths + , actionUrl = Nothing + , actionFunction = actionFunction' + } where fileName = "tagmaps" identifier - readTagMap' = foldM addPaths M.empty paths - addPaths current path = do - context <- toContext path + actionFunction' _ = do + isCacheMoreRecent' <- isCacheMoreRecent fileName paths + assocMap <- if isCacheMoreRecent' + then M.fromAscList <$> getFromCache fileName + else do assocMap' <- readTagMap' + storeInCache (M.toAscList assocMap') fileName + return assocMap' + return $ M.map (map createPage) assocMap + + -- TODO: preserve order + readTagMap' :: Hakyll (M.Map String [FilePath]) + readTagMap' = do + pairs' <- concat <$> mapM pairs paths + return $ M.fromListWith (flip (++)) pairs' + + -- | Read a page, and return an association list where every tag is + -- associated with some paths. Of course, this will always be just one + -- @FilePath@ here. + pairs :: FilePath -> Hakyll [(String, [FilePath])] + pairs path = do + context <- runHakyllAction $ createPage path let tags = getTagsFunction context - addPaths' = flip (M.insertWith (++)) [path] - return $ foldr addPaths' current tags + return $ map (\tag -> (tag, [path])) tags -- | Read a @TagMap@, using the @tags@ metadata field. -readTagMap :: String -- ^ Unique identifier for the map. - -> [PagePath] -- ^ Paths to get tags from. - -> Hakyll TagMap -readTagMap = readMap getTagsFunction +readTagMap :: String -- ^ Unique identifier for the map. + -> [FilePath] -- ^ Paths to get tags from. + -> HakyllAction () TagMap +readTagMap = readMap getTagsFunction where getTagsFunction = map trim . splitRegex "," . fromMaybe [] . M.lookup "tags" -- | Read a @TagMap@, using the subdirectories the pages are placed in. -readCategoryMap :: String -- ^ Unique identifier for the map. - -> [PagePath] -- ^ Paths to get tags from. - -> Hakyll TagMap +readCategoryMap :: String -- ^ Unique identifier for the map. + -> [FilePath] -- ^ Paths to get tags from. + -> HakyllAction () TagMap readCategoryMap = readMap $ maybeToList . M.lookup "category" +withTagMap :: HakyllAction () TagMap + -> (String -> [HakyllAction () Context] -> Hakyll ()) + -> Hakyll () +withTagMap tagMap function = runHakyllAction (tagMap >>> action) + where + action = createHakyllAction (mapM_ (uncurry function) . M.toList) + -- | Render a tag cloud. -renderTagCloud :: TagMap -- ^ Map as produced by @readTagMap@. - -> (String -> String) -- ^ Function to produce an url for a tag. - -> Float -- ^ Smallest font size, in percent. - -> Float -- ^ Biggest font size, in percent. - -> String -- ^ Result of the render. -renderTagCloud tagMap urlFunction minSize maxSize = - intercalate " " $ map renderTag tagCount +renderTagCloud :: (String -> String) -- ^ Function to produce an url for a tag. + -> Float -- ^ Smallest font size, in percent. + -> Float -- ^ Biggest font size, in percent. + -> HakyllAction TagMap String +renderTagCloud urlFunction minSize maxSize = createHakyllAction renderTagCloud' where - renderTag :: (String, Float) -> String - renderTag (tag, count) = - finalSubstitute linkTemplate $ M.fromList [ ("size", sizeTag count) - , ("url", urlFunction tag) - , ("tag", tag) - ] + renderTagCloud' tagMap = + return $ intercalate " " $ map (renderTag tagMap) (tagCount tagMap) + + renderTag tagMap (tag, count) = + finalSubstitute linkTemplate $ M.fromList + [ ("size", sizeTag tagMap count) + , ("url", urlFunction tag) + , ("tag", tag) + ] + linkTemplate = fromString "$tag" - sizeTag :: Float -> String - sizeTag count = show size' ++ "%" + sizeTag tagMap count = show (size' :: Int) ++ "%" where - size' :: Int - size' = floor $ minSize + relative count * (maxSize - minSize) + size' = floor $ minSize + relative tagMap count * (maxSize - minSize) - minCount = minimum $ map snd tagCount - maxCount = maximum $ map snd tagCount - relative count = (count - minCount) / (maxCount - minCount) + minCount = minimum . map snd . tagCount + maxCount = maximum . map snd . tagCount + relative tagMap count = (count - minCount tagMap) / + (maxCount tagMap - minCount tagMap) - tagCount :: [(String, Float)] - tagCount = map (second $ fromIntegral . length) $ M.toList tagMap + tagCount = map (second $ fromIntegral . length) . M.toList -- | Render all tags to links. -- @@ -140,7 +162,7 @@ -- Note that it is your own responsibility to ensure a page with such an url -- exists. renderTagLinks :: (String -> String) -- ^ Function to produce an url for a tag. - -> ContextManipulation + -> HakyllAction Context Context renderTagLinks urlFunction = changeValue "tags" renderTagLinks' where renderTagLinks' = intercalate ", "