@@ -19,32 +19,37 @@
1919-- is to place pages in subdirectories.
2020--
2121-- An example, the page @posts\/coding\/2010-01-28-hakyll-categories.markdown@
22−-- Tags or categories are read using the @readTags@ and @readCategories@
22+-- Tags or categories are read using the @readTags@ and @readCategory@
2323-- functions. This module only provides functions to work with tags:
2424-- categories are represented as tags. This is perfectly possible: categories
2525-- only have an additional restriction that a page can only have one category
2626-- (instead of multiple tags).
2727--
28−{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
28+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, Arrows #-}
2929module Hakyll.Web.Tags
3030 ( Tags (..)
3131 , readTagsWith
3232 , readTags
33− , readCategories
33+ , readCategory
3434 , renderTagCloud
35+ , renderTagsField
36+ , renderCategoryField
3537 ) where
3638
39+import Prelude hiding (id)
40+import Control.Category (id)
3741import Control.Applicative ((<$>))
3842import Data.Map (Map)
3943import qualified Data.Map as M
4044import Data.List (intersperse)
41−import Control.Arrow (second, (&&&))
45+import Control.Arrow (arr, (&&&), (>>>), (***), (<<^), returnA)
46+import Data.Maybe (catMaybes, fromMaybe)
47+import Data.Monoid (mconcat)
4248
4349import Data.Typeable (Typeable)
4450import Data.Binary (Binary, get, put)
45−import Data.Monoid (mconcat)
4651import Text.Blaze.Renderer.String (renderHtml)
47−import Text.Blaze (Html, (!), toHtml, toValue)
52+import Text.Blaze ((!), toHtml, toValue)
4853import qualified Text.Blaze.Html5 as H
4954import qualified Text.Blaze.Html5.Attributes as A
5055
@@ -52,6 +57,8 @@ import Hakyll.Web.Page
5257import Hakyll.Web.Page.Metadata
5358import Hakyll.Web.Util.String
5459import Hakyll.Core.Writable
60+import Hakyll.Core.Identifier
61+import Hakyll.Core.Compiler
5562
5663-- | Data about tags
5764--
@@ -66,6 +73,16 @@ instance Binary a => Binary (Tags a) where
6673instance Writable (Tags a) where
6774 write _ _ = return ()
6875
76+-- | Obtain tags from a page
77+--
78+getTags :: Page a -> [String]
79+getTags = map trim . splitAll "," . getField "tags"
80+
81+-- | Obtain categories from a page
82+--
83+getCategory :: Page a -> [String]
84+getCategory = return . getField "category"
85+
6986-- | Higher-level function to read tags
7087--
7188readTagsWith :: (Page a -> [String]) -- ^ Function extracting tags from a page
@@ -83,42 +100,80 @@ readTagsWith f pages = Tags
83100-- | Read a tagmap using the @tags@ metadata field
84101--
85102readTags :: [Page a] -> Tags a
86−readTags = readTagsWith $ map trim . splitAll "," . getField "tags"
103+readTags = readTagsWith getTags
87104
88105-- | Read a tagmap using the @category@ metadata field
89106--
90−readCategories :: [Page a] -> Tags a
91−readCategories = readTagsWith $ return . getField "category"
107+readCategory :: [Page a] -> Tags a
108+readCategory = readTagsWith getCategory
92109
93110-- | Render a tag cloud in HTML
94111--
95−renderTagCloud :: (String -> String) -- ^ Function to produce an url for a tag
96− -> Double -- ^ Smallest font size, in percent
97− -> Double -- ^ Biggest font size, in percent
98− -> Tags a -- ^ Tags structure to render
99− -> String -- ^ Resulting HTML
100−renderTagCloud urlFunction minSize maxSize (Tags tags) = renderHtml $
101− mconcat $ intersperse " " $ map (uncurry renderTag) withCount
112+renderTagCloud :: (String -> Identifier) -- ^ Produce a link for a tag
113+ -> Double -- ^ Smallest font size, in percent
114+ -> Double -- ^ Biggest font size, in percent
115+ -> Compiler (Tags a) String -- ^ Tag cloud renderer
116+renderTagCloud makeUrl minSize maxSize = proc (Tags tags) -> do
117+ -- In tags' we create a list: [((tag, route), count)]
118+ tags' <- mapCompiler ((id &&& (getRouteFor <<^ makeUrl)) *** arr length)
119+ -< M.toList tags
120+
121+ let -- Absolute frequencies of the pages
122+ freqs = map snd tags'
123+
124+ -- Find out the relative count of a tag: on a scale from 0 to 1
125+ relative count = (fromIntegral count - min') / (1 + max' - min')
126+
127+ -- Show the relative size of one 'count' in percent
128+ size count =
129+ let size' = floor $ minSize + relative count * (maxSize - minSize)
130+ in show (size' :: Int) ++ "%"
131+
132+ -- The minimum and maximum count found, as doubles
133+ (min', max')
134+ | null freqs = (0, 1)
135+ | otherwise = (minimum &&& maximum) $ map fromIntegral freqs
136+
137+ -- Create a link for one item
138+ makeLink ((tag, url), count) =
139+ H.a ! A.style (toValue $ "font-size: " ++ size count)
140+ ! A.href (toValue $ fromMaybe "/" url)
141+ $ toHtml tag
142+
143+ -- Render and return the HTML
144+ returnA -< renderHtml $ mconcat $ intersperse " " $ map makeLink tags'
145+
146+-- | Render tags with links
147+--
148+renderTagsFieldWith :: (Page a -> [String]) -- ^ Function to get the tags
149+ -> String -- ^ Destination key
150+ -> (String -> Identifier) -- ^ Create a link for a tag
151+ -> Compiler (Page a) (Page a) -- ^ Resulting compiler
152+renderTagsFieldWith tags destination makeUrl =
153+ id &&& arr tags >>> setFieldA destination renderTags
102154 where
103− -- Tags composed with their count
104− withCount = map (second $ fromIntegral . length) $ M.toList tags
105−
106− -- Render one tag, given it's count
107− renderTag :: String -> Int -> Html
108− renderTag tag count =
109− H.a ! A.style (toValue $ "font-size: " ++ size count)
110− ! A.href (toValue $ urlFunction tag)
111− $ toHtml tag
112−
113− -- Show the relative size of one 'count' in percent
114− size count =
115− let size' = floor $ minSize + relative count * (maxSize - minSize)
116− in show (size' :: Int) ++ "%"
117−
118− -- Find out the relative count of a tag: on a scale from 0 to 1
119− relative count = (fromIntegral count - minCount) / (1 + maxCount - minCount)
120−
121− -- The minimum and maximum count found, as doubles
122− (minCount, maxCount)
123− | null withCount = (0, 1)
124− | otherwise = (minimum &&& maximum) $ map (fromIntegral . snd) withCount
155+ -- Compiler creating a comma-separated HTML string for a list of tags
156+ renderTags :: Compiler [String] String
157+ renderTags = arr (map $ id &&& makeUrl)
158+ >>> mapCompiler (id *** getRouteFor)
159+ >>> arr (map $ uncurry renderLink)
160+ >>> arr (renderHtml . mconcat . intersperse ", " . catMaybes)
161+
162+ -- Render one tag link
163+ renderLink _ Nothing = Nothing
164+ renderLink tag (Just filePath) = Just $
165+ H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag
166+
167+-- | Render tags with links
168+--
169+renderTagsField :: String -- ^ Destination key
170+ -> (String -> Identifier) -- ^ Create a link for a tag
171+ -> Compiler (Page a) (Page a) -- ^ Resulting compiler
172+renderTagsField = renderTagsFieldWith getTags
173+
174+-- | Render the category in a link
175+--
176+renderCategoryField :: String -- ^ Destination key
177+ -> (String -> Identifier) -- ^ Create a category link
178+ -> Compiler (Page a) (Page a) -- ^ Resulting compiler
179+renderCategoryField = renderTagsFieldWith getCategory