Improve tag handling a bit

3 files changed, 70 insertions, 55 deletions

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)}
 
 
 --------------------------------------------------------------------------------