From a8182c9fc9379dff1e0dae1bc9a838a3c97c56c5 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <m@jaspervdj.be>
Date: Thu, 29 Nov 2012 12:04:57 +0100
Subject: Improve tag handling a bit
---
src/Hakyll/Core/Configuration.hs | 3 +-
src/Hakyll/Core/Runtime.hs | 1 +
src/Hakyll/Web/Tags.hs | 121 ++++++++++++++++++++++-----------------
3 files changed, 70 insertions(+), 55 deletions(-)
(limited to 'src')
diff --git a/src/Hakyll/Core/Configuration.hs b/src/Hakyll/Core/Configuration.hs
index c859585..4d34114 100644
--- a/src/Hakyll/Core/Configuration.hs
+++ b/src/Hakyll/Core/Configuration.hs
@@ -1,7 +1,8 @@
--------------------------------------------------------------------------------
-- | Exports a datastructure for the top-level hakyll configuration
module Hakyll.Core.Configuration
- ( Configuration (..)
+ ( Verbosity (..)
+ , Configuration (..)
, shouldIgnoreFile
, defaultConfiguration
) where
diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs
index 46c7d1e..99ba1a4 100644
--- a/src/Hakyll/Core/Runtime.hs
+++ b/src/Hakyll/Core/Runtime.hs
@@ -175,6 +175,7 @@ chase trail id'
routes <- runtimeRoutes <$> ask
store <- runtimeStore <$> ask
config <- runtimeConfiguration <$> ask
+ Logger.debug logger $ "Processing " ++ show id'
let compiler = todo M.! id'
read' = CompilerRead
diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs
index 2aa1cac..c5f2b1f 100644
--- a/src/Hakyll/Web/Tags.hs
+++ b/src/Hakyll/Web/Tags.hs
@@ -1,11 +1,11 @@
--------------------------------------------------------------------------------
--- | 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
@@ -15,26 +15,38 @@
-- > 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
+--
+-- > posts/coding/2010-01-28-hakyll-categories.markdown
+--
+-- 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':
--
--- An example, the page @posts\/coding\/2010-01-28-hakyll-categories.markdown@
--- Tags or categories are read using the @buildTags@ and @buildCategory@
--- 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).
+-- > 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
, buildTagsWith
, buildTags
- , buildCategory
+ , buildCategories
+ , tagsRules
, renderTagCloud
, renderTagList
, tagsField
@@ -46,8 +58,7 @@ module Hakyll.Web.Tags
--------------------------------------------------------------------------------
import Control.Arrow ((&&&))
-import Control.Monad (foldM, forM)
-import Data.Binary (Binary)
+import Control.Monad (foldM, forM, forM_)
import Data.Char (toLower)
import Data.List (intercalate, intersperse,
sortBy)
@@ -55,7 +66,6 @@ import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid (mconcat)
import Data.Ord (comparing)
-import Data.Typeable (Typeable)
import System.FilePath (takeBaseName, takeDirectory)
import Text.Blaze.Html (toHtml, toValue, (!))
import Text.Blaze.Html.Renderer.String (renderHtml)
@@ -69,23 +79,18 @@ 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.Core.Writable
import Hakyll.Web.Template.Context
import Hakyll.Web.Urls
--------------------------------------------------------------------------------
-- | Data about tags
--- TODO Make this a map instead of a list?
-newtype Tags = Tags
- { unTags :: [(String, [Identifier])]
- } deriving (Binary, Show, Typeable)
-
-
---------------------------------------------------------------------------------
-instance Writable Tags where
- write _ _ = return ()
+data Tags = Tags
+ { tagsMap :: [(String, [Identifier])]
+ , tagsMakeId :: String -> Identifier
+ } deriving (Show)
--------------------------------------------------------------------------------
@@ -105,11 +110,14 @@ getCategory = return . return . takeBaseName . takeDirectory . toFilePath
--------------------------------------------------------------------------------
-- | Higher-order function to read tags
buildTagsWith :: MonadMetadata m
- => (Identifier -> m [String]) -> Pattern -> m Tags
-buildTagsWith f pattern = do
+ => (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
+ return $ Tags (M.toList tagMap) makeId
where
-- Create a tag map for one page
addTags tagMap id' = do
@@ -117,34 +125,42 @@ buildTagsWith f pattern = do
let tagMap' = M.fromList $ zip tags $ repeat [id']
return $ M.unionWith (++) tagMap tagMap'
+
--------------------------------------------------------------------------------
--- | Read a tagmap using the @tags@ metadata field
-buildTags :: MonadMetadata m => Pattern -> m Tags
+buildTags :: MonadMetadata m => Pattern -> (String -> Identifier) -> m Tags
buildTags = buildTagsWith getTags
--------------------------------------------------------------------------------
--- | Read a tagmap using the @category@ metadata field
-buildCategory :: MonadMetadata m => Pattern -> m Tags
-buildCategory = buildTagsWith getCategory
+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) ->
+ match (fromGlob $ toFilePath $ tagsMakeId tags tag) $
+ rules tag $ fromList identifiers
--------------------------------------------------------------------------------
-- | Render tags in HTML
-renderTags :: (String -> Identifier)
- -- ^ Produce a tag page id
- -> (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
-> Tags
-- ^ Tag cloud renderer
-> Compiler String
-renderTags makeTagId makeHtml concatHtml (Tags tags) = do
+renderTags makeHtml concatHtml (Tags tags makeTagId) = do
-- In tags' we create a list: [((tag, route), count)]
tags' <- forM tags $ \(tag, ids) -> do
- route <- getRoute $ makeTagId tag
- return ((tag, route), length ids)
+ route' <- getRoute $ makeTagId 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'
@@ -165,9 +181,7 @@ renderTags makeTagId makeHtml concatHtml (Tags tags) = do
--------------------------------------------------------------------------------
-- | Render a tag cloud in HTML
-- TODO: Maybe produce a Context here
-renderTagCloud :: (String -> Identifier)
- -- ^ Produce a link for a tag
- -> Double
+renderTagCloud :: Double
-- ^ Smallest font size, in percent
-> Double
-- ^ Biggest font size, in percent
@@ -175,8 +189,7 @@ renderTagCloud :: (String -> Identifier)
-- ^ Input tags
-> Compiler String
-- ^ Rendered cloud
-renderTagCloud makeTagId minSize maxSize =
- renderTags makeTagId makeLink (intercalate " ")
+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')
@@ -194,8 +207,8 @@ renderTagCloud makeTagId minSize maxSize =
--------------------------------------------------------------------------------
-- | Render a simple tag list in HTML, with the tag count next to the item
-- TODO: Maybe produce a Context here
-renderTagList :: (String -> Identifier) -> Tags -> Compiler (String)
-renderTagList makeTagId = renderTags makeTagId makeLink (intercalate ", ")
+renderTagList :: Tags -> Compiler (String)
+renderTagList = renderTags makeLink (intercalate ", ")
where
makeLink tag url count _ _ = renderHtml $
H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")")
@@ -214,8 +227,8 @@ tagsFieldWith :: (Identifier -> Compiler [String]) -- ^ Get the tags
tagsFieldWith getTags' key makeTagId = field key $ \item -> do
tags <- getTags' $ itemIdentifier item
links <- forM tags $ \tag -> do
- route <- getRoute $ makeTagId tag
- return $ renderLink tag route
+ route' <- getRoute $ makeTagId tag
+ return $ renderLink tag route'
return $ renderHtml $ mconcat $ intersperse ", " $ catMaybes $ links
where
@@ -246,7 +259,7 @@ categoryField = tagsFieldWith getCategory
-- the comparing function is the actual tag name.
sortTagsBy :: ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)
-> Tags -> Tags
-sortTagsBy f = Tags . sortBy f . unTags
+sortTagsBy f t = t {tagsMap = sortBy f (tagsMap t)}
--------------------------------------------------------------------------------
--
cgit v1.2.3