+
+foo
" +-- +-- Result: +-- +-- > "foo" +-- +-- This also works for incomplete tags +-- +-- Example: +-- +-- > stripTags "foo "foo"
+stripTags :: String -> String
+stripTags [] = []
+stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs
+stripTags (x : xs) = x : stripTags xs
+
+
+--------------------------------------------------------------------------------
+-- | HTML-escape a string
+--
+-- Example:
+--
+-- > escapeHtml "Me & Dean"
+--
+-- Result:
+--
+-- > "Me & Dean"
+escapeHtml :: String -> String
+escapeHtml = renderHtml . toHtml
diff --git a/src/Hakyll/Web/Html/RelativizeUrls.hs b/src/Hakyll/Web/Html/RelativizeUrls.hs
new file mode 100644
--- /dev/null
+++ b/src/Hakyll/Web/Html/RelativizeUrls.hs
@@ -0,0 +1,52 @@
+--------------------------------------------------------------------------------
+-- | This module exposes a function which can relativize URL's on a webpage.
+--
+-- This means that one can deploy the resulting site on
+-- @http:\/\/example.com\/@, but also on @http:\/\/example.com\/some-folder\/@
+-- without having to change anything (simply copy over the files).
+--
+-- To use it, you should use absolute URL's from the site root everywhere. For
+-- example, use
+--
+-- > 
+--
+-- in a blogpost. When running this through the relativize URL's module, this
+-- will result in (suppose your blogpost is located at @\/posts\/foo.html@:
+--
+-- > 
+module Hakyll.Web.Html.RelativizeUrls
+ ( relativizeUrls
+ , relativizeUrlsWith
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.List (isPrefixOf)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Item
+import Hakyll.Web.Html
+
+
+--------------------------------------------------------------------------------
+-- | Compiler form of 'relativizeUrls' which automatically picks the right root
+-- path
+relativizeUrls :: Item String -> Compiler (Item String)
+relativizeUrls item = do
+ route <- getRoute $ itemIdentifier item
+ return $ case route of
+ Nothing -> item
+ Just r -> fmap (relativizeUrlsWith $ toSiteRoot r) item
+
+
+--------------------------------------------------------------------------------
+-- | Relativize URL's in HTML
+relativizeUrlsWith :: String -- ^ Path to the site root
+ -> String -- ^ HTML to relativize
+ -> String -- ^ Resulting HTML
+relativizeUrlsWith root = withUrls rel
+ where
+ isRel x = "/" `isPrefixOf` x && not ("//" `isPrefixOf` x)
+ rel x = if isRel x then root ++ x else x
diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Page.hs
+++ /dev/null
@@ -1,156 +0,0 @@
--- | A page is a key-value mapping, representing a page on your site
---
--- A page is an important concept in Hakyll. It is a key-value mapping, and has
--- one field with an arbitrary type. A 'Page' thus consists of
---
--- * metadata (of the type @Map String String@);
---
--- * the actual value (of the type @a@).
---
--- Usually, the value will be a 'String' as well, and the value will be the body
--- of the page.
---
--- However, this is certainly no restriction. For example, @Page ByteString@
--- could be used to represent a binary item (e.g. an image) and some metadata.
---
--- Pages can be constructed using Haskell, but they are usually parsed from a
--- file. The file format for pages is pretty straightforward.
---
--- > This is a simple page
--- > consisting of two lines.
---
--- This is a valid page with two lines. If we load this in Hakyll, there would
--- be no metadata, and the body would be the given text. Let's look at a page
--- with some metadata:
---
--- > ---
--- > title: Alice's Adventures in Wonderland
--- > author: Lewis Caroll
--- > year: 1865
--- > ---
--- >
--- > Chapter I
--- > =========
--- >
--- > Down the Rabbit-Hole
--- > --------------------
--- >
--- > Alice was beginning to get very tired of sitting by her sister on the bank,
--- > and of having nothing to do: once or twice she had peeped into the book her
--- > sister was reading, but it had no pictures or conversations in it, "and
--- > what is the use of a book," thought Alice "without pictures or
--- > conversation?"
--- >
--- > ...
---
--- As you can see, we construct a metadata header in Hakyll using @---@. Then,
--- we simply list all @key: value@ pairs, and end with @---@ again. This page
--- contains three metadata fields and a body. The body is given in markdown
--- format, which can be easily rendered to HTML by Hakyll, using pandoc.
---
-{-# LANGUAGE DeriveDataTypeable #-}
-module Hakyll.Web.Page
- ( Page (..)
- , fromBody
- , fromMap
- , toMap
- , readPageCompiler
- , pageCompiler
- , pageCompilerWith
- , pageCompilerWithPandoc
- , pageCompilerWithFields
- , addDefaultFields
- ) where
-
-import Prelude hiding (id)
-import Control.Category (id)
-import Control.Arrow (arr, (>>^), (&&&), (>>>))
-import System.FilePath (takeBaseName, takeDirectory)
-import qualified Data.Map as M
-
-import Text.Pandoc (Pandoc, ParserState, WriterOptions)
-
-import Hakyll.Core.Identifier
-import Hakyll.Core.Compiler
-import Hakyll.Core.Resource
-import Hakyll.Web.Page.Internal
-import Hakyll.Web.Page.Read
-import Hakyll.Web.Page.Metadata
-import Hakyll.Web.Pandoc
-import Hakyll.Web.Template
-import Hakyll.Web.Urls
-
--- | Create a page from a body, without metadata
---
-fromBody :: a -> Page a
-fromBody = Page M.empty
-
--- | Read a page (do not render it)
---
-readPageCompiler :: Compiler Resource (Page String)
-readPageCompiler = getResourceString >>^ readPage
-
--- | Read a page, add default fields, substitute fields and render using pandoc
---
-pageCompiler :: Compiler Resource (Page String)
-pageCompiler =
- pageCompilerWith defaultHakyllParserState defaultHakyllWriterOptions
-
--- | A version of 'pageCompiler' which allows you to specify your own pandoc
--- options
---
-pageCompilerWith :: ParserState -> WriterOptions
- -> Compiler Resource (Page String)
-pageCompilerWith state options = pageCompilerWithPandoc state options id
-
--- | An extension of 'pageCompilerWith' which allows you to specify a custom
--- pandoc transformer for the content
---
-pageCompilerWithPandoc :: ParserState -> WriterOptions
- -> (Pandoc -> Pandoc)
- -> Compiler Resource (Page String)
-pageCompilerWithPandoc state options f = cached cacheName $
- readPageCompiler >>> addDefaultFields >>> arr applySelf
- >>> pageReadPandocWith state
- >>> arr (fmap (writePandocWith options . f))
- where
- cacheName = "Hakyll.Web.Page.pageCompilerWithPandoc"
-
--- | This is another, even more advanced version of 'pageCompilerWithPandoc'.
--- This function allows you to provide an arrow which is applied before the
--- fields in a page are rendered. This means you can use this extra customizable
--- stage to add custom fields which are inserted in the page.
---
-pageCompilerWithFields :: ParserState -> WriterOptions
- -> (Pandoc -> Pandoc)
- -> Compiler (Page String) (Page String)
- -> Compiler Resource (Page String)
-pageCompilerWithFields state options f g =
- readPageCompiler >>> addDefaultFields >>> g >>> arr applySelf
- >>> pageReadPandocWith state
- >>> arr (fmap (writePandocWith options . f))
-
--- | Add a number of default metadata fields to a page. These fields include:
---
--- * @$url$@
---
--- * @$category$@
---
--- * @$title$@
---
--- * @$path$@
---
-addDefaultFields :: Compiler (Page a) (Page a)
-addDefaultFields = (getRoute &&& id >>^ uncurry addRoute)
- >>> (getIdentifier &&& id >>^ uncurry addIdentifier)
- where
- -- Add root and url, based on route
- addRoute Nothing = id
- addRoute (Just r) = trySetField "url" (toUrl r)
-
- -- Add title and category, based on identifier
- addIdentifier i = trySetField "title" (takeBaseName p)
- . trySetField "category" (takeBaseName $ takeDirectory p)
- . trySetField "path" p
- where
- p = toFilePath i
diff --git a/src/Hakyll/Web/Page/Internal.hs b/src/Hakyll/Web/Page/Internal.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Page/Internal.hs
+++ /dev/null
@@ -1,50 +0,0 @@
--- | Internal representation of the page datatype
---
-{-# LANGUAGE DeriveDataTypeable #-}
-module Hakyll.Web.Page.Internal
- ( Page (..)
- , fromMap
- , toMap
- ) where
-
-import Control.Applicative ((<$>), (<*>))
-import Data.Monoid (Monoid, mempty, mappend)
-
-import Data.Map (Map)
-import Data.Binary (Binary, get, put)
-import Data.Typeable (Typeable)
-import qualified Data.Map as M
-
-import Hakyll.Core.Writable
-
--- | Type used to represent pages
---
-data Page a = Page
- { pageMetadata :: Map String String
- , pageBody :: a
- } deriving (Eq, Show, Typeable)
-
-instance Monoid a => Monoid (Page a) where
- mempty = Page M.empty mempty
- mappend (Page m1 b1) (Page m2 b2) =
- Page (M.union m1 m2) (mappend b1 b2)
-
-instance Functor Page where
- fmap f (Page m b) = Page m (f b)
-
-instance Binary a => Binary (Page a) where
- put (Page m b) = put m >> put b
- get = Page <$> get <*> get
-
-instance Writable a => Writable (Page a) where
- write p (Page _ b) = write p b
-
--- | Create a metadata page, without a body
---
-fromMap :: Monoid a => Map String String -> Page a
-fromMap m = Page m mempty
-
--- | Convert a page to a map. The body will be placed in the @body@ key.
---
-toMap :: Page String -> Map String String
-toMap (Page m b) = M.insert "body" b m
diff --git a/src/Hakyll/Web/Page/List.hs b/src/Hakyll/Web/Page/List.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Page/List.hs
+++ /dev/null
@@ -1,82 +0,0 @@
--- | Provides an easy way to combine several pages in a list. The applications
--- are obvious:
---
--- * A post list on a blog
---
--- * An image list in a gallery
---
--- * A sitemap
---
-module Hakyll.Web.Page.List
- ( setFieldPageList
- , pageListCompiler
- , chronological
- , recentFirst
- , sortByBaseName
- ) where
-
-import Control.Arrow ((>>>), arr)
-import Data.List (sortBy)
-import Data.Monoid (Monoid, mconcat)
-import Data.Ord (comparing)
-import System.FilePath (takeBaseName)
-
-import Hakyll.Core.Compiler
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Web.Page
-import Hakyll.Web.Page.Metadata
-import Hakyll.Web.Template
-
--- | Set a field of a page to a listing of pages
---
-setFieldPageList :: ([Page String] -> [Page String])
- -- ^ Determines list order
- -> Identifier Template
- -- ^ Applied to every page
- -> String
- -- ^ Key indicating which field should be set
- -> Pattern (Page String)
- -- ^ Selects pages to include in the list
- -> Compiler (Page String) (Page String)
- -- ^ Compiler that sets the page list in a field
-setFieldPageList sort template key pattern =
- requireAllA pattern $ setFieldA key $ pageListCompiler sort template
-
--- | Create a list of pages
---
-pageListCompiler :: ([Page String] -> [Page String]) -- ^ Determine list order
- -> Identifier Template -- ^ Applied to pages
- -> Compiler [Page String] String -- ^ Compiles page list
-pageListCompiler sort template =
- arr sort >>> applyTemplateToList template >>> arr concatPages
-
--- | Apply a template to every page in a list
---
-applyTemplateToList :: Identifier Template
- -> Compiler [Page String] [Page String]
-applyTemplateToList identifier =
- require identifier $ \posts template -> map (applyTemplate template) posts
-
--- | Concatenate the bodies of a page list
---
-concatPages :: Monoid m => [Page m] -> m
-concatPages = mconcat . map pageBody
-
--- | Sort pages chronologically. This function assumes that the pages have a
--- @year-month-day-title.extension@ naming scheme -- as is the convention in
--- Hakyll.
---
-chronological :: [Page a] -> [Page a]
-chronological = sortBy $ comparing $ takeBaseName . getField "path"
-
--- | The reverse of 'chronological'
---
-recentFirst :: [Page a] -> [Page a]
-recentFirst = reverse . chronological
-
--- | Deprecated, see 'chronological'
---
-sortByBaseName :: [Page a] -> [Page a]
-sortByBaseName = chronological
-{-# DEPRECATED sortByBaseName "Use chronological" #-}
diff --git a/src/Hakyll/Web/Page/Metadata.hs b/src/Hakyll/Web/Page/Metadata.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Page/Metadata.hs
+++ /dev/null
@@ -1,235 +0,0 @@
--- | Provides various functions to manipulate the metadata fields of a page
---
-module Hakyll.Web.Page.Metadata
- ( getField
- , getFieldMaybe
- , setField
- , trySetField
- , setFieldA
- , setFieldPage
- , renderField
- , changeField
- , copyField
- , renderDateField
- , renderDateFieldWith
- , renderModificationTime
- , renderModificationTimeWith
- , copyBodyToField
- , copyBodyFromField
- , comparePagesByDate
- ) where
-
-import Control.Arrow (Arrow, arr, (>>>), (***), (&&&))
-import Control.Category (id)
-import Control.Monad (msum)
-import Data.List (intercalate)
-import Data.Maybe (fromMaybe)
-import Data.Ord (comparing)
-import Prelude hiding (id)
-import System.FilePath (takeFileName)
-import System.Locale (TimeLocale, defaultTimeLocale)
-import qualified Data.Map as M
-
-import Data.Time.Calendar (Day (..))
-import Data.Time.Clock (UTCTime (..))
-import Data.Time.Format (parseTime, formatTime)
-
-import Hakyll.Web.Page.Internal
-import Hakyll.Core.Util.String
-import Hakyll.Core.Identifier
-import Hakyll.Core.Compiler
-import Hakyll.Core.Resource.Provider
-
--- | Get a metadata field. If the field does not exist, the empty string is
--- returned.
---
-getField :: String -- ^ Key
- -> Page a -- ^ Page
- -> String -- ^ Value
-getField key = fromMaybe "" . getFieldMaybe key
-
--- | Get a field in a 'Maybe' wrapper
---
-getFieldMaybe :: String -- ^ Key
- -> Page a -- ^ Page
- -> Maybe String -- ^ Value, if found
-getFieldMaybe key = M.lookup key . pageMetadata
-
--- | Version of 'trySetField' which overrides any previous value
---
-setField :: String -- ^ Key
- -> String -- ^ Value
- -> Page a -- ^ Page to add it to
- -> Page a -- ^ Resulting page
-setField k v (Page m b) = Page (M.insert k v m) b
-
--- | Add a metadata field. If the field already exists, it is not overwritten.
---
-trySetField :: String -- ^ Key
- -> String -- ^ Value
- -> Page a -- ^ Page to add it to
- -> Page a -- ^ Resulting page
-trySetField k v (Page m b) = Page (M.insertWith (flip const) k v m) b
-
--- | Arrow-based variant of 'setField'. Because of it's type, this function is
--- very usable together with the different 'require' functions.
---
-setFieldA :: Arrow a
- => String -- ^ Key
- -> a x String -- ^ Value arrow
- -> a (Page b, x) (Page b) -- ^ Resulting arrow
-setFieldA k v = id *** v >>> arr (uncurry $ flip $ setField k)
-
--- | Set a field of a page to the contents of another page
---
-setFieldPage :: String -- ^ Key to add the page under
- -> Identifier (Page String) -- ^ Page to add
- -> Compiler (Page a) (Page a) -- ^ Page compiler
-setFieldPage key page = id &&& require_ page >>> setFieldA key (arr pageBody)
-
--- | Do something with a metadata value, but keep the old value as well. If the
--- key given is not present in the metadata, nothing will happen. If the source
--- and destination keys are the same, the value will be changed (but you should
--- use 'changeField' for this purpose).
---
-renderField :: 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
- -> Page a -- ^ Page on which this should be applied
- -> Page a -- ^ Resulting page
-renderField src dst f page = case M.lookup src (pageMetadata page) of
- Nothing -> page
- Just value -> setField dst (f value) page
-
--- | Change a metadata value.
---
--- > import Data.Char (toUpper)
--- > changeField "title" (map toUpper)
---
--- Will put the title in UPPERCASE.
---
-changeField :: String -- ^ Key to change.
- -> (String -> String) -- ^ Function to apply on the value.
- -> Page a -- ^ Page to change
- -> Page a -- ^ Resulting page
-changeField key = renderField key key
-
--- | Make a copy of a metadata field (put the value belonging to a certain key
--- under some other key as well)
---
-copyField :: String -- ^ Key to copy
- -> String -- ^ Destination to copy to
- -> Page a -- ^ Page on which this should be applied
- -> Page a -- ^ Resulting page
-copyField src dst = renderField src dst id
-
--- | When the metadata has a field called @published@ in one of the
--- following formats then this function can render the date.
---
--- * @Sun, 01 Feb 2000 13:00:00 UT@ (RSS date format)
---
--- * @2000-02-01T13:00:00Z@ (Atom date format)
---
--- * @February 1, 2000 1:00 PM@ (PM is usually uppercase)
---
--- * @February 1, 2000@ (assumes 12:00 AM for the time)
---
--- Alternatively, when the metadata has a field called @path@ in a
--- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages)
--- and no @published@ metadata field set, this function can render
--- the date.
---
--- > renderDateField "date" "%B %e, %Y" "Date unknown"
---
--- Will render something like @January 32, 2010@.
---
-renderDateField :: String -- ^ Key in which the rendered date should be placed
- -> String -- ^ Format to use on the date
- -> String -- ^ Default value, in case the date cannot be parsed
- -> Page a -- ^ Page on which this should be applied
- -> Page a -- ^ Resulting page
-renderDateField = renderDateFieldWith defaultTimeLocale
-
--- | This is an extended version of 'renderDateField' that allows you to
--- specify a time locale that is used for outputting the date. For more
--- details, see 'renderDateField'.
---
-renderDateFieldWith :: TimeLocale -- ^ Output time locale
- -> String -- ^ Destination key
- -> String -- ^ Format to use on the date
- -> String -- ^ Default value
- -> Page a -- ^ Target page
- -> Page a -- ^ Resulting page
-renderDateFieldWith locale key format defaultValue page =
- setField key renderTimeString page
- where
- renderTimeString = fromMaybe defaultValue $ do
- time <- getUTCMaybe locale page
- return $ formatTime locale format time
-
--- | Parser to try to extract and parse the time from the @published@
--- field or from the filename. See 'renderDateField' for more information.
-getUTCMaybe :: TimeLocale -- ^ Output time locale
- -> Page a -- ^ Input page
- -> Maybe UTCTime -- ^ Parsed UTCTime
-getUTCMaybe locale page = msum $
- [fromField "published" fmt | fmt <- formats] ++
- [fromField "date" fmt | fmt <- formats] ++
- [ getFieldMaybe "path" page >>= parseTime' "%Y-%m-%d" .
- intercalate "-" . take 3 . splitAll "-" . takeFileName
- ]
- where
- parseTime' f str = parseTime locale f str
- fromField k fmt = getFieldMaybe k page >>= parseTime' fmt
-
- formats =
- [ "%a, %d %b %Y %H:%M:%S UT"
- , "%Y-%m-%dT%H:%M:%SZ"
- , "%Y-%m-%d %H:%M:%S"
- , "%Y-%m-%d"
- , "%B %e, %Y %l:%M %p"
- , "%B %e, %Y"
- ]
-
--- | Set the modification time as a field in the page
-renderModificationTime :: String
- -- ^ Destination key
- -> String
- -- ^ Format to use on the time
- -> Compiler (Page String) (Page String)
- -- ^ Resulting compiler
-renderModificationTime = renderModificationTimeWith defaultTimeLocale
-
-renderModificationTimeWith :: TimeLocale
- -- ^ Output time locale
- -> String
- -- ^ Destination key
- -> String
- -- ^ Format to use on the time
- -> Compiler (Page String) (Page String)
- -- ^ Resulting compiler
-renderModificationTimeWith locale key format =
- id &&& (getResource >>> getResourceWith resourceModificationTime) >>>
- setFieldA key (arr (formatTime locale format))
-
--- | Copy the body of a page to a metadata field
---
-copyBodyToField :: String -- ^ Destination key
- -> Page String -- ^ Target page
- -> Page String -- ^ Resulting page
-copyBodyToField key page = setField key (pageBody page) page
-
--- | Copy a metadata field to the page body
---
-copyBodyFromField :: String -- ^ Source key
- -> Page String -- ^ Target page
- -> Page String -- ^ Resulting page
-copyBodyFromField key page = fmap (const $ getField key page) page
-
--- | Compare pages by the date and time parsed as in 'renderDateField',
--- where 'LT' implies earlier, and 'GT' implies later. For more details,
--- see 'renderDateField'.
-comparePagesByDate :: Page a -> Page a -> Ordering
-comparePagesByDate = comparing $ fromMaybe zero . getUTCMaybe defaultTimeLocale
- where
- zero = UTCTime (ModifiedJulianDay 0) 0
diff --git a/src/Hakyll/Web/Page/Read.hs b/src/Hakyll/Web/Page/Read.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Page/Read.hs
+++ /dev/null
@@ -1,61 +0,0 @@
--- | Module providing a function to parse a page from a file
---
-module Hakyll.Web.Page.Read
- ( readPage
- ) where
-
-import Control.Applicative ((<$>), (<*>), (<*), (<|>))
-import qualified Data.Map as M
-
-import Text.Parsec.Char (alphaNum, anyChar, char, oneOf, string)
-import Text.Parsec.Combinator (choice, many1, manyTill, option, skipMany1)
-import Text.Parsec.Prim (many, parse, skipMany, ())
-import Text.Parsec.String (Parser)
-
-import Hakyll.Core.Util.String
-import Hakyll.Web.Page.Internal
-
--- | Space or tab, no newline
-inlineSpace :: Parser Char
-inlineSpace = oneOf ['\t', ' '] "space"
-
--- | Parse Windows newlines as well (i.e. "\n" or "\r\n")
-newline :: Parser String
-newline = string "\n" -- Unix
- <|> string "\r\n" -- DOS
-
--- | Parse a single metadata field
---
-metadataField :: Parser (String, String)
-metadataField = do
- key <- manyTill alphaNum $ char ':'
- skipMany1 inlineSpace "space followed by metadata for: " ++ key
- value <- manyTill anyChar newline
- trailing' <- many trailing
- return (key, trim $ value ++ concat trailing')
- where
- trailing = (++) <$> many1 inlineSpace <*> manyTill anyChar newline
-
--- | Parse a metadata block, including delimiters and trailing newlines
---
-metadata :: Parser [(String, String)]
-metadata = do
- open <- many1 (char '-') <* many inlineSpace <* newline
- metadata' <- many metadataField
- _ <- choice $ map (string . replicate (length open)) ['-', '.']
- skipMany inlineSpace
- skipMany1 newline
- return metadata'
-
--- | Parse a Hakyll page
---
-page :: Parser ([(String, String)], String)
-page = do
- metadata' <- option [] metadata
- body <- many anyChar
- return (metadata', body)
-
-readPage :: String -> Page String
-readPage input = case parse page "page" input of
- Left err -> error (show err)
- Right (md, b) -> Page (M.fromList md) b
diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs
--- a/src/Hakyll/Web/Pandoc.hs
+++ b/src/Hakyll/Web/Pandoc.hs
@@ -1,113 +1,118 @@
--- | Module exporting pandoc bindings
---
+--------------------------------------------------------------------------------
+-- | Module exporting convenient pandoc bindings
module Hakyll.Web.Pandoc
( -- * The basic building blocks
readPandoc
, readPandocWith
, writePandoc
, writePandocWith
+ , renderPandoc
+ , renderPandocWith
- -- * Functions working on pages/compilers
- , pageReadPandoc
- , pageReadPandocWith
- , pageReadPandocWithA
- , pageRenderPandoc
- , pageRenderPandocWith
+ -- * Derived compilers
+ , pandocCompiler
+ , pandocCompilerWith
+ , pandocCompilerWithTransform
-- * Default options
, defaultHakyllParserState
, defaultHakyllWriterOptions
) where
-import Prelude hiding (id)
-import Control.Applicative ((<$>))
-import Control.Arrow ((>>>), (>>^), (&&&), (***))
-import Control.Category (id)
-import Data.Maybe (fromMaybe)
-import Text.Pandoc
+--------------------------------------------------------------------------------
+import Control.Applicative ((<$>))
+import Text.Pandoc
-import Hakyll.Core.Compiler
-import Hakyll.Core.Identifier
-import Hakyll.Core.Util.Arrow
-import Hakyll.Web.Pandoc.FileType
-import Hakyll.Web.Page.Internal
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Item
+import Hakyll.Web.Pandoc.FileType
+
+
+--------------------------------------------------------------------------------
-- | Read a string using pandoc, with the default options
---
-readPandoc :: FileType -- ^ Determines how parsing happens
- -> Maybe (Identifier a) -- ^ Optional, for better error messages
- -> String -- ^ String to read
- -> Pandoc -- ^ Resulting document
+readPandoc :: Item String -- ^ String to read
+ -> Item Pandoc -- ^ Resulting document
readPandoc = readPandocWith defaultHakyllParserState
+
+--------------------------------------------------------------------------------
-- | Read a string using pandoc, with the supplied options
---
-readPandocWith :: ParserState -- ^ Parser options
- -> FileType -- ^ Determines parsing method
- -> Maybe (Identifier a) -- ^ Optional, for better error messages
- -> String -- ^ String to read
- -> Pandoc -- ^ Resulting document
-readPandocWith state fileType' id' = case fileType' of
- Html -> readHtml state
- LaTeX -> readLaTeX state
- LiterateHaskell t ->
- readPandocWith state {stateLiterateHaskell = True} t id'
- Markdown -> readMarkdown state
- Rst -> readRST state
- Textile -> readTextile state
- t -> error $
- "Hakyll.Web.readPandocWith: I don't know how to read a file of the " ++
- "type " ++ show t ++ fromMaybe "" (fmap ((" for: " ++) . show) id')
+readPandocWith :: ParserState -- ^ Parser options
+ -> Item String -- ^ String to read
+ -> Item Pandoc -- ^ Resulting document
+readPandocWith state item = fmap (reader state (itemFileType item)) item
+ where
+ reader s t = case t of
+ Html -> readHtml s
+ LaTeX -> readLaTeX s
+ LiterateHaskell t' -> reader s {stateLiterateHaskell = True} t'
+ Markdown -> readMarkdown s
+ Rst -> readRST s
+ Textile -> readTextile s
+ _ -> error $
+ "Hakyll.Web.readPandocWith: I don't know how to read a file of the " ++
+ "type " ++ show t ++ " for: " ++ show (itemIdentifier item)
+
+--------------------------------------------------------------------------------
-- | Write a document (as HTML) using pandoc, with the default options
---
-writePandoc :: Pandoc -- ^ Document to write
- -> String -- ^ Resulting HTML
+writePandoc :: Item Pandoc -- ^ Document to write
+ -> Item String -- ^ Resulting HTML
writePandoc = writePandocWith defaultHakyllWriterOptions
+
+--------------------------------------------------------------------------------
-- | Write a document (as HTML) using pandoc, with the supplied options
---
writePandocWith :: WriterOptions -- ^ Writer options for pandoc
- -> Pandoc -- ^ Document to write
- -> String -- ^ Resulting HTML
-writePandocWith = writeHtmlString
+ -> Item Pandoc -- ^ Document to write
+ -> Item String -- ^ Resulting HTML
+writePandocWith options = fmap $ writeHtmlString options
--- | Read the resource using pandoc
---
-pageReadPandoc :: Compiler (Page String) (Page Pandoc)
-pageReadPandoc = pageReadPandocWith defaultHakyllParserState
--- | Read the resource using pandoc
---
-pageReadPandocWith :: ParserState -> Compiler (Page String) (Page Pandoc)
-pageReadPandocWith state = constA state &&& id >>> pageReadPandocWithA
+--------------------------------------------------------------------------------
+-- | Render the resource using pandoc
+renderPandoc :: Item String -> Item String
+renderPandoc =
+ renderPandocWith defaultHakyllParserState defaultHakyllWriterOptions
--- | Read the resource using pandoc. This is a (rarely needed) variant, which
--- comes in very useful when the parser state is the result of some arrow.
---
-pageReadPandocWithA :: Compiler (ParserState, Page String) (Page Pandoc)
-pageReadPandocWithA =
- id *** id &&& getIdentifier &&& getFileType >>^ pageReadPandocWithA'
- where
- pageReadPandocWithA' (s, (p, (i, t))) = readPandocWith s t (Just i) <$> p
+--------------------------------------------------------------------------------
-- | Render the resource using pandoc
---
-pageRenderPandoc :: Compiler (Page String) (Page String)
-pageRenderPandoc =
- pageRenderPandocWith defaultHakyllParserState defaultHakyllWriterOptions
+renderPandocWith :: ParserState -> WriterOptions -> Item String -> Item String
+renderPandocWith state options = writePandocWith options . readPandocWith state
--- | Render the resource using pandoc
---
-pageRenderPandocWith :: ParserState
- -> WriterOptions
- -> Compiler (Page String) (Page String)
-pageRenderPandocWith state options =
- pageReadPandocWith state >>^ fmap (writePandocWith options)
+--------------------------------------------------------------------------------
+-- | Read a page render using pandoc
+pandocCompiler :: Compiler (Item String)
+pandocCompiler =
+ pandocCompilerWith defaultHakyllParserState defaultHakyllWriterOptions
+
+
+--------------------------------------------------------------------------------
+-- | A version of 'pandocCompiler' which allows you to specify your own pandoc
+-- options
+pandocCompilerWith :: ParserState -> WriterOptions -> Compiler (Item String)
+pandocCompilerWith state options = pandocCompilerWithTransform state options id
+
+
+--------------------------------------------------------------------------------
+-- | An extension of 'pandocCompilerWith' which allows you to specify a custom
+-- pandoc transformation for the content
+pandocCompilerWithTransform :: ParserState -> WriterOptions
+ -> (Pandoc -> Pandoc)
+ -> Compiler (Item String)
+pandocCompilerWithTransform state options f = cached cacheName $
+ writePandocWith options . fmap f . readPandocWith state <$> getResourceBody
+ where
+ cacheName = "Hakyll.Web.Page.pageCompilerWithPandoc"
+
+
+--------------------------------------------------------------------------------
-- | The default reader options for pandoc parsing in hakyll
---
defaultHakyllParserState :: ParserState
defaultHakyllParserState = defaultParserState
{ -- The following option causes pandoc to read smart typography, a nice
@@ -115,8 +120,9 @@
stateSmart = True
}
+
+--------------------------------------------------------------------------------
-- | The default writer options for pandoc rendering in hakyll
---
defaultHakyllWriterOptions :: WriterOptions
defaultHakyllWriterOptions = defaultWriterOptions
{ -- This option causes literate haskell to be written using '>' marks in
diff --git a/src/Hakyll/Web/Pandoc/Biblio.hs b/src/Hakyll/Web/Pandoc/Biblio.hs
--- a/src/Hakyll/Web/Pandoc/Biblio.hs
+++ b/src/Hakyll/Web/Pandoc/Biblio.hs
@@ -1,3 +1,4 @@
+--------------------------------------------------------------------------------
-- | Wraps pandocs bibiliography handling
--
-- In order to add a bibliography, you will need a bibliography file (e.g.
@@ -6,68 +7,96 @@
-- refer to these files when you use 'pageReadPandocBiblio'. This function also
-- takes a parser state for completeness -- you can use
-- 'defaultHakyllParserState' if you're unsure.
---
-{-# LANGUAGE Arrows, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hakyll.Web.Pandoc.Biblio
( CSL
, cslCompiler
, Biblio (..)
, biblioCompiler
- , pageReadPandocBiblio
+ , readPandocBiblio
) where
-import Control.Applicative ((<$>))
-import Control.Arrow (arr, returnA)
-import Data.Typeable (Typeable)
-import Data.Binary (Binary (..))
-import Text.Pandoc (Pandoc, ParserState (..))
-import Text.Pandoc.Biblio (processBiblio)
-import qualified Text.CSL as CSL
+--------------------------------------------------------------------------------
+import Control.Applicative ((<$>))
+import Data.Binary (Binary (..))
+import Data.Typeable (Typeable)
+import qualified Text.CSL as CSL
+import Text.Pandoc (Pandoc, ParserState (..))
+import Text.Pandoc.Biblio (processBiblio)
-import Hakyll.Core.Compiler
-import Hakyll.Core.Identifier
-import Hakyll.Core.Resource
-import Hakyll.Core.Writable
-import Hakyll.Web.Page
-import Hakyll.Web.Pandoc
-newtype CSL = CSL FilePath
- deriving (Binary, Show, Typeable, Writable)
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Identifier
+import Hakyll.Core.Item
+import Hakyll.Core.Writable
+import Hakyll.Web.Pandoc
-cslCompiler :: Compiler Resource CSL
-cslCompiler = arr (CSL . unResource)
+--------------------------------------------------------------------------------
+data CSL = CSL
+ deriving (Show, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance Binary CSL where
+ put CSL = return ()
+ get = return CSL
+
+
+--------------------------------------------------------------------------------
+instance Writable CSL where
+ -- Shouldn't be written.
+ write _ _ = return ()
+
+
+--------------------------------------------------------------------------------
+cslCompiler :: Compiler (Item CSL)
+cslCompiler = makeItem CSL
+
+
+--------------------------------------------------------------------------------
newtype Biblio = Biblio [CSL.Reference]
deriving (Show, Typeable)
+
+--------------------------------------------------------------------------------
instance Binary Biblio where
-- Ugly.
get = Biblio . read <$> get
put (Biblio rs) = put $ show rs
+
+--------------------------------------------------------------------------------
instance Writable Biblio where
+ -- Shouldn't be written.
write _ _ = return ()
-biblioCompiler :: Compiler Resource Biblio
-biblioCompiler = unsafeCompiler $
- fmap Biblio . CSL.readBiblioFile . unResource
-pageReadPandocBiblio :: ParserState
- -> Identifier CSL
- -> Identifier Biblio
- -> Compiler (Page String) (Page Pandoc)
-pageReadPandocBiblio state csl refs = proc page -> do
- CSL csl' <- require_ csl -< ()
- Biblio refs' <- require_ refs -< ()
+--------------------------------------------------------------------------------
+biblioCompiler :: Compiler (Item Biblio)
+biblioCompiler = do
+ filePath <- toFilePath <$> getUnderlying
+ makeItem =<< unsafeCompiler (Biblio <$> CSL.readBiblioFile filePath)
+
+
+--------------------------------------------------------------------------------
+readPandocBiblio :: ParserState
+ -> Item CSL
+ -> Item Biblio
+ -> (Item String)
+ -> Compiler (Item Pandoc)
+readPandocBiblio state csl biblio item = do
-- We need to know the citation keys, add then *before* actually parsing the
-- actual page. If we don't do this, pandoc won't even consider them
-- citations!
- let cits = map CSL.refId refs'
- state' = state {stateCitations = stateCitations state ++ cits}
- pandocPage <- pageReadPandocWithA -< (state', page)
- let pandoc = pageBody pandocPage
- pandoc' <- unsafeCompiler processBiblio' -< (csl', refs', pandoc)
- returnA -< pandocPage {pageBody = pandoc'}
- where
- processBiblio' (c, r, p) = processBiblio c Nothing r p
+ let Biblio refs = itemBody biblio
+ cits = map CSL.refId refs
+ state' = state {stateCitations = stateCitations state ++ cits}
+ pandoc = itemBody $ readPandocWith state' item
+ cslPath = toFilePath $ itemIdentifier csl
+ pandoc' <- unsafeCompiler $ processBiblio cslPath Nothing refs pandoc
+ return $ fmap (const pandoc') item
diff --git a/src/Hakyll/Web/Pandoc/FileType.hs b/src/Hakyll/Web/Pandoc/FileType.hs
--- a/src/Hakyll/Web/Pandoc/FileType.hs
+++ b/src/Hakyll/Web/Pandoc/FileType.hs
@@ -1,20 +1,24 @@
+--------------------------------------------------------------------------------
-- | A module dealing with pandoc file extensions and associated file types
---
module Hakyll.Web.Pandoc.FileType
( FileType (..)
, fileType
- , getFileType
+ , itemFileType
) where
-import System.FilePath (takeExtension)
-import Control.Arrow ((>>^))
-import Hakyll.Core.Identifier
-import Hakyll.Core.Compiler
+--------------------------------------------------------------------------------
+import System.FilePath (takeExtension)
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Identifier
+import Hakyll.Core.Item
+
+
+--------------------------------------------------------------------------------
-- | Datatype to represent the different file types Hakyll can deal with by
-- default
---
data FileType
= Binary
| Css
@@ -28,8 +32,9 @@
| Textile
deriving (Eq, Ord, Show, Read)
+
+--------------------------------------------------------------------------------
-- | Get the file type for a certain file. The type is determined by extension.
---
fileType :: FilePath -> FileType
fileType = fileType' . takeExtension
where
@@ -53,7 +58,8 @@
fileType' ".txt" = PlainText
fileType' _ = Binary -- Treat unknown files as binary
+
+--------------------------------------------------------------------------------
-- | Get the file type for the current file
---
-getFileType :: Compiler a FileType
-getFileType = getIdentifier >>^ fileType . toFilePath
+itemFileType :: Item a -> FileType
+itemFileType = fileType . toFilePath . itemIdentifier
diff --git a/src/Hakyll/Web/Preview/Poll.hs b/src/Hakyll/Web/Preview/Poll.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Preview/Poll.hs
+++ /dev/null
@@ -1,43 +0,0 @@
--- | Interval-based implementation of preview polling
---
-{-# LANGUAGE CPP #-}
-module Hakyll.Web.Preview.Poll
- ( previewPoll
- ) where
-
-import Control.Applicative ((<$>))
-import Control.Concurrent (threadDelay)
-import Control.Monad (filterM)
-#if MIN_VERSION_directory(1,2,0)
-import Data.Time (getCurrentTime)
-#else
-import System.Time (getClockTime)
-#endif
-import System.Directory (getModificationTime, doesFileExist)
-
-import Hakyll.Core.Configuration
-
--- | A preview thread that periodically recompiles the site.
---
-previewPoll :: HakyllConfiguration -- ^ Configuration
- -> IO [FilePath] -- ^ Updating action
- -> IO () -- ^ Can block forever
-previewPoll _ update = do
-#if MIN_VERSION_directory(1,2,0)
- time <- getCurrentTime
-#else
- time <- getClockTime
-#endif
- loop time =<< update
- where
- delay = 1000000
- loop time files = do
- threadDelay delay
- files' <- filterM doesFileExist files
- filesTime <- case files' of
- [] -> return time
- _ -> maximum <$> mapM getModificationTime files'
-
- if filesTime > time || files' /= files
- then loop filesTime =<< update
- else loop time files'
diff --git a/src/Hakyll/Web/Preview/Server.hs b/src/Hakyll/Web/Preview/Server.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Preview/Server.hs
+++ /dev/null
@@ -1,40 +0,0 @@
--- | Implements a basic static file server for previewing options
---
-{-# LANGUAGE OverloadedStrings #-}
-module Hakyll.Web.Preview.Server
- ( staticServer
- ) where
-
-import Control.Monad.Trans (liftIO)
-
-import qualified Snap.Core as Snap
-import qualified Snap.Http.Server as Snap
-import qualified Snap.Util.FileServe as Snap
-
--- | Serve a given directory
---
-static :: FilePath -- ^ Directory to serve
- -> (FilePath -> IO ()) -- ^ Pre-serve hook
- -> Snap.Snap ()
-static directory preServe =
- Snap.serveDirectoryWith directoryConfig directory
- where
- directoryConfig :: Snap.DirectoryConfig Snap.Snap
- directoryConfig = Snap.fancyDirectoryConfig
- { Snap.preServeHook = liftIO . preServe
- }
-
--- | Main method, runs a static server in the given directory
---
-staticServer :: FilePath -- ^ Directory to serve
- -> (FilePath -> IO ()) -- ^ Pre-serve hook
- -> Int -- ^ Port to listen on
- -> IO () -- ^ Blocks forever
-staticServer directory preServe port =
- Snap.httpServe config $ static directory preServe
- where
- -- Snap server config
- config = Snap.setPort port
- $ Snap.setAccessLog Snap.ConfigNoLog
- $ Snap.setErrorLog Snap.ConfigNoLog
- $ Snap.emptyConfig
diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs
--- a/src/Hakyll/Web/Tags.hs
+++ b/src/Hakyll/Web/Tags.hs
@@ -1,11 +1,12 @@
--- | Module containing some specialized functions to deal with tags.
--- This Module follows certain conventions. My advice is to stick with them if
--- possible.
+--------------------------------------------------------------------------------
+-- | This module containing some specialized functions to deal with tags. It
+-- assumes you follow some conventions.
--
--- More concrete: all functions in this module assume that the tags are
--- located in the @tags@ field, and separated by commas. An example file
--- @foo.markdown@ could look like:
+-- We support two types of tags: tags and categories.
--
+-- To use default tags, use 'buildTags'. Tags are placed in a comma-separated
+-- metadata field like this:
+--
-- > ---
-- > author: Philip K. Dick
-- > title: Do androids dream of electric sheep?
@@ -14,150 +15,184 @@
-- > The novel is set in a post-apocalyptic near future, where the Earth and
-- > its populations have been damaged greatly by Nuclear...
--
--- All the following functions would work with such a format. In addition to
--- tags, Hakyll also supports categories. The convention when using categories
--- is to place pages in subdirectories.
+-- To use categories, use the 'buildCategories' function. Categories are
+-- determined by the direcetory a page is in, for example, the post
--
--- An example, the page @posts\/coding\/2010-01-28-hakyll-categories.markdown@
--- Tags or categories are read using the @readTags@ and @readCategory@
--- functions. This module only provides functions to work with tags:
--- categories are represented as tags. This is perfectly possible: categories
--- only have an additional restriction that a page can only have one category
--- (instead of multiple tags).
+-- > posts/coding/2010-01-28-hakyll-categories.markdown
--
-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, Arrows #-}
+-- will receive the @coding@ category.
+--
+-- Advanced users may implement custom systems using 'buildTagsWith' if desired.
+--
+-- In the above example, we would want to create a page which lists all pages in
+-- the @coding@ category, for example, with the 'Identifier':
+--
+-- > tags/coding.html
+--
+-- This is where the first parameter of 'buildTags' and 'buildCategories' comes
+-- in. In the above case, we used the function:
+--
+-- > fromCapture "tags/*.html" :: String -> Identifier
+--
+-- The 'tagsRules' function lets you generate such a page for each tag in the
+-- 'Rules' monad.
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
module Hakyll.Web.Tags
- ( Tags (..)
+ ( Tags
, getTags
- , readTagsWith
- , readTags
- , readCategory
+ , buildTagsWith
+ , buildTags
+ , buildCategories
+ , tagsRules
, renderTagCloud
, renderTagList
- , renderTagsField
- , renderTagsFieldWith
- , renderCategoryField
+ , tagsField
+ , categoryField
, sortTagsBy
, caseInsensitiveTags
) where
-import Prelude hiding (id)
-import Control.Category (id)
-import Control.Applicative ((<$>))
-import Data.Char (toLower)
-import Data.Ord (comparing)
-import qualified Data.Map as M
-import Data.List (intersperse, intercalate, sortBy)
-import Control.Arrow (arr, (&&&), (>>>), (***), (<<^), returnA)
-import Data.Maybe (catMaybes, fromMaybe)
-import Data.Monoid (mconcat)
-import Data.Typeable (Typeable)
-import Data.Binary (Binary, get, put)
-import Text.Blaze.Html.Renderer.String (renderHtml)
-import Text.Blaze.Html ((!), toHtml, toValue)
-import qualified Text.Blaze.Html5 as H
-import qualified Text.Blaze.Html5.Attributes as A
+--------------------------------------------------------------------------------
+import Control.Arrow ((&&&))
+import Control.Monad (foldM, forM, forM_)
+import Data.Char (toLower)
+import Data.List (intercalate, intersperse,
+ sortBy)
+import qualified Data.Map as M
+import Data.Maybe (catMaybes, fromMaybe)
+import Data.Monoid (mconcat)
+import Data.Ord (comparing)
+import System.FilePath (takeBaseName, takeDirectory)
+import Text.Blaze.Html (toHtml, toValue, (!))
+import Text.Blaze.Html.Renderer.String (renderHtml)
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as A
-import Hakyll.Web.Page
-import Hakyll.Web.Page.Metadata
-import Hakyll.Web.Urls
-import Hakyll.Core.Writable
-import Hakyll.Core.Identifier
-import Hakyll.Core.Compiler
-import Hakyll.Core.Util.String
--- | Data about tags
---
-data Tags a = Tags
- { tagsMap :: [(String, [Page a])]
- } deriving (Show, Typeable)
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Dependencies
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+import Hakyll.Core.Item
+import Hakyll.Core.Metadata
+import Hakyll.Core.Rules
+import Hakyll.Core.Util.String
+import Hakyll.Web.Template.Context
+import Hakyll.Web.Html
-instance Binary a => Binary (Tags a) where
- get = Tags <$> get
- put (Tags m) = put m
-instance Writable (Tags a) where
- write _ _ = return ()
+--------------------------------------------------------------------------------
+-- | Data about tags
+data Tags = Tags
+ { tagsMap :: [(String, [Identifier])]
+ , tagsMakeId :: String -> Identifier
+ , tagsDependency :: Dependency
+ } deriving (Show)
+
+--------------------------------------------------------------------------------
-- | Obtain tags from a page in the default way: parse them from the @tags@
-- metadata field.
---
-getTags :: Page a -> [String]
-getTags = map trim . splitAll "," . getField "tags"
+getTags :: MonadMetadata m => Identifier -> m [String]
+getTags identifier = do
+ metadata <- getMetadata identifier
+ return $ maybe [] (map trim . splitAll ",") $ M.lookup "tags" metadata
--- | Obtain categories from a page
---
-getCategory :: Page a -> [String]
-getCategory = return . getField "category"
+--------------------------------------------------------------------------------
+-- | Obtain categories from a page.
+getCategory :: MonadMetadata m => Identifier -> m [String]
+getCategory = return . return . takeBaseName . takeDirectory . toFilePath
--- | Higher-level function to read tags
---
-readTagsWith :: (Page a -> [String]) -- ^ Function extracting tags from a page
- -> [Page a] -- ^ Pages
- -> Tags a -- ^ Resulting tags
-readTagsWith f pages = Tags
- { tagsMap = M.toList $
- foldl (M.unionWith (++)) M.empty (map readTagsWith' pages)
- }
+
+--------------------------------------------------------------------------------
+-- | Higher-order function to read tags
+buildTagsWith :: MonadMetadata m
+ => (Identifier -> m [String])
+ -> Pattern
+ -> (String -> Identifier)
+ -> m Tags
+buildTagsWith f pattern makeId = do
+ ids <- getMatches pattern
+ tagMap <- foldM addTags M.empty ids
+ return $ Tags (M.toList tagMap) makeId (PatternDependency pattern ids)
where
-- Create a tag map for one page
- readTagsWith' page =
- let tags = f page
- in M.fromList $ zip tags $ repeat [page]
+ addTags tagMap id' = do
+ tags <- f id'
+ let tagMap' = M.fromList $ zip tags $ repeat [id']
+ return $ M.unionWith (++) tagMap tagMap'
--- | Read a tagmap using the @tags@ metadata field
---
-readTags :: [Page a] -> Tags a
-readTags = readTagsWith getTags
--- | Read a tagmap using the @category@ metadata field
---
-readCategory :: [Page a] -> Tags a
-readCategory = readTagsWith getCategory
+--------------------------------------------------------------------------------
+buildTags :: MonadMetadata m => Pattern -> (String -> Identifier) -> m Tags
+buildTags = buildTagsWith getTags
+
+--------------------------------------------------------------------------------
+buildCategories :: MonadMetadata m => Pattern -> (String -> Identifier)
+ -> m Tags
+buildCategories = buildTagsWith getCategory
+
+
+--------------------------------------------------------------------------------
+tagsRules :: Tags -> (String -> Pattern -> Rules ()) -> Rules ()
+tagsRules tags rules =
+ forM_ (tagsMap tags) $ \(tag, identifiers) ->
+ create [tagsMakeId tags tag] $
+ rulesExtraDependencies [tagsDependency tags] $
+ rules tag $ fromList identifiers
+
+
+--------------------------------------------------------------------------------
-- | Render tags in HTML
---
-renderTags :: (String -> Identifier (Page a))
- -- ^ Produce a link
- -> (String -> String -> Int -> Int -> Int -> String)
+renderTags :: (String -> String -> Int -> Int -> Int -> String)
-- ^ Produce a tag item: tag, url, count, min count, max count
-> ([String] -> String)
-- ^ Join items
- -> Compiler (Tags a) String
+ -> Tags
-- ^ Tag cloud renderer
-renderTags makeUrl makeItem concatItems = proc (Tags tags) -> do
+ -> Compiler String
+renderTags makeHtml concatHtml tags = do
-- In tags' we create a list: [((tag, route), count)]
- tags' <- mapCompiler ((id &&& (getRouteFor <<^ makeUrl)) *** arr length)
- -< tags
+ tags' <- forM (tagsMap tags) $ \(tag, ids) -> do
+ route' <- getRoute $ tagsMakeId tags tag
+ return ((tag, route'), length ids)
+ -- TODO: We actually need to tell a dependency here!
+
let -- Absolute frequencies of the pages
freqs = map snd tags'
-- The minimum and maximum count found
(min', max')
| null freqs = (0, 1)
- | otherwise = (minimum &&& maximum) freqs
+ | otherwise = (minimum &&& maximum) freqs
-- Create a link for one item
- makeItem' ((tag, url), count) =
- makeItem tag (toUrl $ fromMaybe "/" url) count min' max'
+ makeHtml' ((tag, url), count) =
+ makeHtml tag (toUrl $ fromMaybe "/" url) count min' max'
-- Render and return the HTML
- returnA -< concatItems $ map makeItem' tags'
+ return $ concatHtml $ map makeHtml' tags'
+
+--------------------------------------------------------------------------------
-- | Render a tag cloud in HTML
---
-renderTagCloud :: (String -> Identifier (Page a))
- -- ^ Produce a link for a tag
- -> Double
+-- TODO: Maybe produce a Context here
+renderTagCloud :: Double
-- ^ Smallest font size, in percent
-> Double
-- ^ Biggest font size, in percent
- -> Compiler (Tags a) String
- -- ^ Tag cloud renderer
-renderTagCloud makeUrl minSize maxSize =
- renderTags makeUrl makeLink (intercalate " ")
+ -> Tags
+ -- ^ Input tags
+ -> Compiler String
+ -- ^ Rendered cloud
+renderTagCloud minSize maxSize = renderTags makeLink (intercalate " ")
where
makeLink tag url count min' max' = renderHtml $
H.a ! A.style (toValue $ "font-size: " ++ size count min' max')
@@ -171,61 +206,67 @@
size' = floor $ minSize + relative * (maxSize - minSize)
in show (size' :: Int) ++ "%"
+
+--------------------------------------------------------------------------------
-- | Render a simple tag list in HTML, with the tag count next to the item
---
-renderTagList :: (String -> Identifier (Page a)) -> Compiler (Tags a) (String)
-renderTagList makeUrl = renderTags makeUrl makeLink (intercalate ", ")
+-- TODO: Maybe produce a Context here
+renderTagList :: Tags -> Compiler (String)
+renderTagList = renderTags makeLink (intercalate ", ")
where
makeLink tag url count _ _ = renderHtml $
H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")")
+
+--------------------------------------------------------------------------------
-- | Render tags with links with custom function to get tags. It is typically
-- together with 'getTags' like this:
---
+--
-- > renderTagsFieldWith (customFunction . getTags)
-- > "tags" (fromCapture "tags/*")
---
-renderTagsFieldWith :: (Page a -> [String]) -- ^ Function to get the tags
- -> String -- ^ Destination key
- -> (String -> Identifier a) -- ^ Create a link for a tag
- -> Compiler (Page a) (Page a) -- ^ Resulting compiler
-renderTagsFieldWith tags destination makeUrl =
- id &&& arr tags >>> setFieldA destination renderTags'
- where
- -- Compiler creating a comma-separated HTML string for a list of tags
- renderTags' :: Compiler [String] String
- renderTags' = arr (map $ id &&& makeUrl)
- >>> mapCompiler (id *** getRouteFor)
- >>> arr (map $ uncurry renderLink)
- >>> arr (renderHtml . mconcat . intersperse ", " . catMaybes)
+tagsFieldWith :: (Identifier -> Compiler [String]) -- ^ Get the tags
+ -> String -- ^ Destination key
+ -> Tags -- ^ Tags structure
+ -> Context a -- ^ Resulting context
+tagsFieldWith getTags' key tags = field key $ \item -> do
+ tags' <- getTags' $ itemIdentifier item
+ links <- forM tags' $ \tag -> do
+ route' <- getRoute $ tagsMakeId tags tag
+ return $ renderLink tag route'
+ return $ renderHtml $ mconcat $ intersperse ", " $ catMaybes $ links
+ where
-- Render one tag link
renderLink _ Nothing = Nothing
renderLink tag (Just filePath) = Just $
H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag
+
+--------------------------------------------------------------------------------
-- | Render tags with links
---
-renderTagsField :: String -- ^ Destination key
- -> (String -> Identifier a) -- ^ Create a link for a tag
- -> Compiler (Page a) (Page a) -- ^ Resulting compiler
-renderTagsField = renderTagsFieldWith getTags
+tagsField :: String -- ^ Destination key
+ -> Tags -- ^ Tags
+ -> Context a -- ^ Context
+tagsField = tagsFieldWith getTags
+
+--------------------------------------------------------------------------------
-- | Render the category in a link
---
-renderCategoryField :: String -- ^ Destination key
- -> (String -> Identifier a) -- ^ Create a category link
- -> Compiler (Page a) (Page a) -- ^ Resulting compiler
-renderCategoryField = renderTagsFieldWith getCategory
+categoryField :: String -- ^ Destination key
+ -> Tags -- ^ Tags
+ -> Context a -- ^ Context
+categoryField = tagsFieldWith getCategory
+
+--------------------------------------------------------------------------------
-- | Sort tags using supplied function. First element of the tuple passed to
-- the comparing function is the actual tag name.
---
-sortTagsBy :: ((String, [Page a]) -> (String, [Page a]) -> Ordering)
- -> Compiler (Tags a) (Tags a)
-sortTagsBy f = arr $ Tags . sortBy f . tagsMap
+sortTagsBy :: ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)
+ -> Tags -> Tags
+sortTagsBy f t = t {tagsMap = sortBy f (tagsMap t)}
+
+--------------------------------------------------------------------------------
-- | Sample sorting function that compares tags case insensitively.
---
-caseInsensitiveTags :: (String, [Page a]) -> (String, [Page a]) -> Ordering
+caseInsensitiveTags :: (String, [Identifier]) -> (String, [Identifier])
+ -> Ordering
caseInsensitiveTags = comparing $ map toLower . fst
diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs
--- a/src/Hakyll/Web/Template.hs
+++ b/src/Hakyll/Web/Template.hs
@@ -1,7 +1,7 @@
-- | This module provides means for reading and applying 'Template's.
--
--- Templates are tools to convert data (pages) into a string. They are
--- perfectly suited for laying out your site.
+-- Templates are tools to convert items into a string. They are perfectly suited
+-- for laying out your site.
--
-- Let's look at an example template:
--
@@ -22,9 +22,6 @@
-- >