Added some tag cloud code.

1 files changed, 30 insertions, 0 deletions

diff --git a/src/Text/Hakyll/Tags.hs b/src/Text/Hakyll/Tags.hs
index 98fda86..ff373eb 100644
--- a/src/Text/Hakyll/Tags.hs
+++ b/src/Text/Hakyll/Tags.hs
@@ -1,14 +1,17 @@
 -- | Module containing some specialized functions to deal with tags.
 module Text.Hakyll.Tags
     ( readTagMap
+    , renderTagCloud
     ) where
 
 import qualified Data.Map as M
 import qualified Data.ByteString.Lazy.Char8 as B
+import qualified Data.List as L
 import Control.Monad
 
 import Text.Hakyll.Util
 import Text.Hakyll.Page
+import Control.Arrow
 
 -- | Read a tag map. This creates a map from tags to page paths. This function
 --   assumes the tags are located in the `tags` metadata field, separated by
@@ -19,3 +22,30 @@ readTagMap paths = foldM addPaths M.empty paths
             page <- readPage path
             let tags = map trim $ split "," $ B.unpack $ getValue ("tags") page
             return $ foldr (\t -> M.insertWith (++) t [path]) current tags
+
+-- | Render a tag cloud.
+renderTagCloud :: M.Map String [FilePath] -- ^ A tag map as produced by 'readTagMap'.
+               -> (String -> String) -- ^ Function that produces 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 =
+    L.intercalate " " $ map renderTag tagCount
+    where renderTag :: (String, Float) -> String
+          renderTag (tag, count) =  "<a style=\"font-size: "
+                                 ++ sizeTag count ++ "\" href=\""
+                                 ++ urlFunction tag ++ "\">"
+                                 ++ tag ++ "</a>"
+
+          sizeTag :: Float -> String
+          sizeTag count = show size' ++ "%"
+                where size' :: Int
+                      size' = floor (minSize + (relative count) * (maxSize - minSize))
+          
+          minCount = minimum $ map snd $ tagCount
+          maxCount = maximum $ map snd $ tagCount
+          relative count = (count - minCount) / (maxCount - minCount)
+
+          tagCount :: [(String, Float)]
+          tagCount = map (second $ fromIntegral . length) $ M.toList tagMap
+