Proof-of-concept tag module

3 files changed, 67 insertions, 0 deletions

diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs
index 883da74..00d143e 100644
--- a/src/Hakyll/Web/Page.hs
+++ b/src/Hakyll/Web/Page.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 module Hakyll.Web.Page
     ( Page (..)
+    , getField
     , addField
     , toMap
     , pageRead
@@ -15,6 +16,7 @@ import Prelude hiding (id)
 import Control.Category (id)
 import Control.Arrow ((>>^), (&&&), (>>>))
 import System.FilePath (takeBaseName, takeDirectory)
+import Data.Maybe (fromMaybe)
 import Data.Map (Map)
 import qualified Data.Map as M
 
@@ -24,6 +26,14 @@ import Hakyll.Web.Page.Internal
 import Hakyll.Web.Page.Read
 import Hakyll.Web.Util.String
 
+-- | 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 "" . M.lookup key . pageMetadata
+
 -- | Add a metadata field. If the field already exists, it is not overwritten.
 --
 addField :: String  -- ^ Key
diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs
new file mode 100644
index 0000000..4986a31
--- /dev/null
+++ b/src/Hakyll/Web/Tags.hs
@@ -0,0 +1,42 @@
+module Hakyll.Web.Tags
+    ( Tags (..)
+    , readTagsWith
+    , readTags
+    , readCategories
+    ) where
+
+import Data.Map (Map)
+import qualified Data.Map as M
+
+import Hakyll.Web.Page
+import Hakyll.Web.Util.String
+
+-- | Data about tags
+--
+data Tags a = Tags
+    { tagsMap :: Map String [Page a]
+    } deriving (Show)
+
+-- | 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 = foldl (M.unionWith (++)) M.empty (map readTagsWith' pages)
+    }
+  where
+    -- Create a tag map for one page
+    readTagsWith' page =
+        let tags = f page
+        in M.fromList $ zip tags $ repeat [page]
+
+-- | Read a tagmap using the @tags@ metadata field
+--
+readTags :: [Page a] -> Tags a
+readTags = readTagsWith $ map trim . splitAll "," . getField "tags"
+
+-- | Read a tagmap using the @category@ metadata field
+--
+readCategories :: [Page a] -> Tags a
+readCategories = readTagsWith $ return . getField "category"
diff --git a/src/Hakyll/Web/Util/String.hs b/src/Hakyll/Web/Util/String.hs
index ed8b904..0dde74a 100644
--- a/src/Hakyll/Web/Util/String.hs
+++ b/src/Hakyll/Web/Util/String.hs
@@ -3,6 +3,7 @@
 module Hakyll.Web.Util.String
     ( trim
     , replaceAll
+    , splitAll
     , toUrl
     , toSiteRoot
     ) where
@@ -35,6 +36,20 @@ replaceAll pattern f source = replaceAll' source
                 (capture, after) = splitAt l tmp
             in before ++ f capture ++ replaceAll' after
 
+-- | A simple regex split function. The resulting list will contain no empty
+-- strings.
+--
+splitAll :: String    -- ^ Pattern
+         -> String    -- ^ String to split
+         -> [String]  -- ^ Result
+splitAll pattern = filter (not . null) . splitAll'
+  where
+    splitAll' src = case listToMaybe (src =~~ pattern) of
+        Nothing     -> [src]
+        Just (o, l) ->
+            let (before, tmp) = splitAt o src
+            in before : splitAll' (drop l tmp)
+
 -- | Convert a filepath to an URL starting from the site root
 --
 -- Example: