@@ -1,4 +1,4 @@
1−-- TODO: port
1+--------------------------------------------------------------------------------
2-- | Module containing some specialized functions to deal with tags.
2-- | Module containing some specialized functions to deal with tags.
3-- This Module follows certain conventions. My advice is to stick with them if
3-- This Module follows certain conventions. My advice is to stick with them if
4-- possible.
4-- possible.
@@ -20,117 +20,131 @@
20-- is to place pages in subdirectories.
20-- is to place pages in subdirectories.
22-- An example, the page @posts\/coding\/2010-01-28-hakyll-categories.markdown@
22-- An example, the page @posts\/coding\/2010-01-28-hakyll-categories.markdown@
23−-- Tags or categories are read using the @readTags@ and @readCategory@
23+-- Tags or categories are read using the @buildTags@ and @buildCategory@
24-- functions. This module only provides functions to work with tags:
24-- functions. This module only provides functions to work with tags:
25-- categories are represented as tags. This is perfectly possible: categories
25-- categories are represented as tags. This is perfectly possible: categories
26-- only have an additional restriction that a page can only have one category
26-- only have an additional restriction that a page can only have one category
27-- (instead of multiple tags).
27-- (instead of multiple tags).
28−--
28+{-# LANGUAGE Arrows #-}
29−{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, Arrows #-}
29+{-# LANGUAGE DeriveDataTypeable #-}
30+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
31+{-# LANGUAGE OverloadedStrings #-}
30module Hakyll.Web.Tags
32module Hakyll.Web.Tags
31 ( Tags (..)
33 ( Tags (..)
33− , readTagsWith
35+ , buildTagsWith
34− , readTags
36+ , buildTags
35− , readCategory
37+ , buildCategory
36 , renderTagCloud
38 , renderTagCloud
37 , renderTagList
39 , renderTagList
38− , renderTagsField
40+ , tagsField
39− , renderTagsFieldWith
41+ , categoryField
40− , renderCategoryField
41 , sortTagsBy
42 , sortTagsBy
42 , caseInsensitiveTags
43 , caseInsensitiveTags
45−import Prelude hiding (id)
46−import Control.Category (id)
47−import Control.Applicative ((<$>))
48−import Data.Char (toLower)
49−import Data.Ord (comparing)
50−import qualified Data.Map as M
51−import Data.List (intersperse, intercalate, sortBy)
52−import Control.Arrow (arr, (&&&), (>>>), (***), (<<^), returnA)
53−import Data.Maybe (catMaybes, fromMaybe)
54−import Data.Monoid (mconcat)
56−import Data.Typeable (Typeable)
57−import Data.Binary (Binary, get, put)
58−import Text.Blaze.Html.Renderer.String (renderHtml)
59−import Text.Blaze.Html ((!), toHtml, toValue)
60−import qualified Text.Blaze.Html5 as H
61−import qualified Text.Blaze.Html5.Attributes as A
63−import Hakyll.Web.Page
64−import Hakyll.Web.Page.Metadata
65−import Hakyll.Web.Urls
66−import Hakyll.Core.Writable
67−import Hakyll.Core.Identifier
68−import Hakyll.Core.Compiler
69−import Hakyll.Core.Util.Arrow
70−import Hakyll.Core.Util.String
47+--------------------------------------------------------------------------------
48+import Control.Arrow ((&&&))
49+import Control.Monad (foldM, forM)
50+import Data.Binary (Binary)
51+import Data.Char (toLower)
52+import Data.List (intercalate, intersperse,
54+import qualified Data.Map as M
55+import Data.Maybe (catMaybes, fromMaybe)
56+import Data.Monoid (mconcat)
57+import Data.Ord (comparing)
58+import Data.Typeable (Typeable)
59+import System.FilePath (takeBaseName, takeDirectory)
60+import Text.Blaze.Html (toHtml, toValue, (!))
61+import Text.Blaze.Html.Renderer.String (renderHtml)
62+import qualified Text.Blaze.Html5 as H
63+import qualified Text.Blaze.Html5.Attributes as A
66+--------------------------------------------------------------------------------
67+import Hakyll.Core.Compiler
68+import Hakyll.Core.Identifier
69+import Hakyll.Core.Item
70+import Hakyll.Core.Metadata
71+import Hakyll.Core.Util.String
72+import Hakyll.Core.Writable
73+import Hakyll.Web.Template.Context
74+import Hakyll.Web.Urls
77+--------------------------------------------------------------------------------
72-- | Data about tags
78-- | Data about tags
73−--
79+-- TODO Make this a map instead of a list?
74−data Tags a = Tags
80+newtype Tags = Tags
75− { tagsMap :: [(String, [Page a])]
81+ { unTags :: [(String, [Identifier])]
76− } deriving (Show, Typeable)
82+ } deriving (Binary, Show, Typeable)
78−instance Binary a => Binary (Tags a) where
85+--------------------------------------------------------------------------------
82−instance Writable (Tags a) where
86+instance Writable Tags where
83 write _ _ = return ()
87 write _ _ = return ()
90+--------------------------------------------------------------------------------
85-- | Obtain tags from a page in the default way: parse them from the @tags@
91-- | Obtain tags from a page in the default way: parse them from the @tags@
86-- metadata field.
92-- metadata field.
88−getTags :: Page a -> [String]
93+getTags :: MonadMetadata m => Identifier -> m [String]
94+getTags identifier = do
95+ metadata <- getMetadata identifier
89−getTags = map trim . splitAll "," . getField "tags"
96+ return $ maybe [] (map trim . splitAll ",") $ M.lookup "tags" metadata
98+--------------------------------------------------------------------------------
91−-- | Obtain categories from a page
99+-- | Obtain categories from a page.
93−getCategory :: Page a -> [String]
100+getCategory :: MonadMetadata m => Identifier -> m [String]
94−getCategory = return . getField "category"
101+getCategory = return . return . takeBaseName . takeDirectory . toFilePath
104+--------------------------------------------------------------------------------
96-- | Higher-level function to read tags
105-- | Higher-level function to read tags
97−--
106+buildTagsWith :: MonadMetadata m
98−readTagsWith :: (Page a -> [String]) -- ^ Function extracting tags from a page
107+ => (Identifier -> m [String]) -> [Identifier] -> m Tags
99− -> [Page a] -- ^ Pages
108+buildTagsWith f ids = do
100− -> Tags a -- ^ Resulting tags
109+ tagMap <- foldM addTags M.empty ids
101−readTagsWith f pages = Tags
110+ return $ Tags $ M.toList tagMap
102− { tagsMap = M.toList $
103− foldl (M.unionWith (++)) M.empty (map readTagsWith' pages)
106 -- Create a tag map for one page
112 -- Create a tag map for one page
107− readTagsWith' page =
113+ addTags tagMap id' = do
108− let tags = f page
114+ tags <- f id'
109− in M.fromList $ zip tags $ repeat [page]
115+ let tagMap' = M.fromList $ zip tags $ repeat [id']
116+ return $ M.unionWith (++) tagMap tagMap'
118+--------------------------------------------------------------------------------
111-- | Read a tagmap using the @tags@ metadata field
119-- | Read a tagmap using the @tags@ metadata field
112−--
120+-- TODO: Should use pattern
113−readTags :: [Page a] -> Tags a
121+buildTags :: MonadMetadata m => [Identifier] -> m Tags
114−readTags = readTagsWith getTags
122+buildTags = buildTagsWith getTags
125+--------------------------------------------------------------------------------
116-- | Read a tagmap using the @category@ metadata field
126-- | Read a tagmap using the @category@ metadata field
117−--
127+-- TODO: Should use pattern
118−readCategory :: [Page a] -> Tags a
128+buildCategory :: MonadMetadata m => [Identifier] -> m Tags
119−readCategory = readTagsWith getCategory
129+buildCategory = buildTagsWith getCategory
132+--------------------------------------------------------------------------------
121-- | Render tags in HTML
133-- | Render tags in HTML
123−renderTags :: (String -> Identifier (Page a))
134+renderTags :: (String -> Identifier)
124− -- ^ Produce a link
135+ -- ^ Produce a tag page id
125 -> (String -> String -> Int -> Int -> Int -> String)
136 -> (String -> String -> Int -> Int -> Int -> String)
126 -- ^ Produce a tag item: tag, url, count, min count, max count
137 -- ^ Produce a tag item: tag, url, count, min count, max count
127 -> ([String] -> String)
138 -> ([String] -> String)
128 -- ^ Join items
139 -- ^ Join items
129− -> Compiler (Tags a) String
140+ -> Tags
130 -- ^ Tag cloud renderer
141 -- ^ Tag cloud renderer
131−renderTags makeUrl makeItem concatItems = proc (Tags tags) -> do
143+renderTags makeTagId makeHtml concatHtml (Tags tags) = do
132 -- In tags' we create a list: [((tag, route), count)]
144 -- In tags' we create a list: [((tag, route), count)]
133− tags' <- mapA ((id &&& (getRouteFor <<^ makeUrl)) *** arr length) -< tags
145+ tags' <- forM tags $ \(tag, ids) -> do
146+ route <- getRoute $ makeTagId tag
147+ return ((tag, route), length ids)
135 let -- Absolute frequencies of the pages
149 let -- Absolute frequencies of the pages
136 freqs = map snd tags'
150 freqs = map snd tags'
@@ -138,27 +152,31 @@ renderTags makeUrl makeItem concatItems = proc (Tags tags) -> do
138 -- The minimum and maximum count found
152 -- The minimum and maximum count found
139 (min', max')
153 (min', max')
140 | null freqs = (0, 1)
154 | null freqs = (0, 1)
141− | otherwise = (minimum &&& maximum) freqs
155+ | otherwise = (minimum &&& maximum) freqs
143 -- Create a link for one item
157 -- Create a link for one item
144− makeItem' ((tag, url), count) =
158+ makeHtml' ((tag, url), count) =
145− makeItem tag (toUrl $ fromMaybe "/" url) count min' max'
159+ makeHtml tag (toUrl $ fromMaybe "/" url) count min' max'
147 -- Render and return the HTML
161 -- Render and return the HTML
148− returnA -< concatItems $ map makeItem' tags'
162+ return $ concatHtml $ map makeHtml' tags'
165+--------------------------------------------------------------------------------
150-- | Render a tag cloud in HTML
166-- | Render a tag cloud in HTML
151−--
167+-- TODO: Maybe produce a Context here
152−renderTagCloud :: (String -> Identifier (Page a))
168+renderTagCloud :: (String -> Identifier)
153 -- ^ Produce a link for a tag
169 -- ^ Produce a link for a tag
154 -> Double
170 -> Double
155 -- ^ Smallest font size, in percent
171 -- ^ Smallest font size, in percent
156 -> Double
172 -> Double
157 -- ^ Biggest font size, in percent
173 -- ^ Biggest font size, in percent
158− -> Compiler (Tags a) String
174+ -> Tags
159− -- ^ Tag cloud renderer
175+ -- ^ Input tags
160−renderTagCloud makeUrl minSize maxSize =
178+renderTagCloud makeTagId minSize maxSize =
161− renderTags makeUrl makeLink (intercalate " ")
179+ renderTags makeTagId makeLink (intercalate " ")
163 makeLink tag url count min' max' = renderHtml $
181 makeLink tag url count min' max' = renderHtml $
164 H.a ! A.style (toValue $ "font-size: " ++ size count min' max')
182 H.a ! A.style (toValue $ "font-size: " ++ size count min' max')
@@ -172,61 +190,67 @@ renderTagCloud makeUrl minSize maxSize =
172 size' = floor $ minSize + relative * (maxSize - minSize)
190 size' = floor $ minSize + relative * (maxSize - minSize)
173 in show (size' :: Int) ++ "%"
191 in show (size' :: Int) ++ "%"
194+--------------------------------------------------------------------------------
175-- | Render a simple tag list in HTML, with the tag count next to the item
195-- | Render a simple tag list in HTML, with the tag count next to the item
176−--
196+-- TODO: Maybe produce a Context here
177−renderTagList :: (String -> Identifier (Page a)) -> Compiler (Tags a) (String)
197+renderTagList :: (String -> Identifier) -> Tags -> Compiler (String)
178−renderTagList makeUrl = renderTags makeUrl makeLink (intercalate ", ")
198+renderTagList makeTagId = renderTags makeTagId makeLink (intercalate ", ")
180 makeLink tag url count _ _ = renderHtml $
200 makeLink tag url count _ _ = renderHtml $
181 H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")")
201 H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")")
204+--------------------------------------------------------------------------------
183-- | Render tags with links with custom function to get tags. It is typically
205-- | Render tags with links with custom function to get tags. It is typically
184-- together with 'getTags' like this:
206-- together with 'getTags' like this:
186-- > renderTagsFieldWith (customFunction . getTags)
208-- > renderTagsFieldWith (customFunction . getTags)
187-- > "tags" (fromCapture "tags/*")
209-- > "tags" (fromCapture "tags/*")
188−--
210+tagsFieldWith :: (Identifier -> Compiler [String]) -- ^ Get the tags
189−renderTagsFieldWith :: (Page a -> [String]) -- ^ Function to get the tags
190− -> String -- ^ Destination key
211+ -> String -- ^ Destination key
191− -> (String -> Identifier a) -- ^ Create a link for a tag
212+ -> (String -> Identifier) -- ^ Create a link for a tag
192− -> Compiler (Page a) (Page a) -- ^ Resulting compiler
213+ -> Context a -- ^ Resulting context
193−renderTagsFieldWith tags destination makeUrl =
214+tagsFieldWith getTags' key makeTagId = field key $ \item -> do
194− id &&& arr tags >>> setFieldA destination renderTags'
215+ tags <- getTags' $ itemIdentifier item
195− where
216+ links <- forM tags $ \tag -> do
196− -- Compiler creating a comma-separated HTML string for a list of tags
217+ route <- getRoute $ makeTagId tag
197− renderTags' :: Compiler [String] String
198− renderTags' = arr (map $ id &&& makeUrl)
199− >>> mapA (id *** getRouteFor)
200− >>> arr (map $ uncurry renderLink)
218+ return $ renderLink tag route
201− >>> arr (renderHtml . mconcat . intersperse ", " . catMaybes)
220+ return $ renderHtml $ mconcat $ intersperse ", " $ catMaybes $ links
203 -- Render one tag link
222 -- Render one tag link
204 renderLink _ Nothing = Nothing
223 renderLink _ Nothing = Nothing
205 renderLink tag (Just filePath) = Just $
224 renderLink tag (Just filePath) = Just $
206 H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag
225 H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag
228+--------------------------------------------------------------------------------
208-- | Render tags with links
229-- | Render tags with links
210−renderTagsField :: String -- ^ Destination key
230+tagsField :: String -- ^ Destination key
211− -> (String -> Identifier a) -- ^ Create a link for a tag
231+ -> (String -> Identifier) -- ^ Create a link for a tag
212− -> Compiler (Page a) (Page a) -- ^ Resulting compiler
232+ -> Context a -- ^ Context
213−renderTagsField = renderTagsFieldWith getTags
233+tagsField = tagsFieldWith getTags
236+--------------------------------------------------------------------------------
215-- | Render the category in a link
237-- | Render the category in a link
217−renderCategoryField :: String -- ^ Destination key
238+categoryField :: String -- ^ Destination key
218− -> (String -> Identifier a) -- ^ Create a category link
239+ -> (String -> Identifier) -- ^ Create a category link
219− -> Compiler (Page a) (Page a) -- ^ Resulting compiler
240+ -> Context a -- ^ Context
220−renderCategoryField = renderTagsFieldWith getCategory
241+categoryField = tagsFieldWith getCategory
244+--------------------------------------------------------------------------------
222-- | Sort tags using supplied function. First element of the tuple passed to
245-- | Sort tags using supplied function. First element of the tuple passed to
223-- the comparing function is the actual tag name.
246-- the comparing function is the actual tag name.
225−sortTagsBy :: ((String, [Page a]) -> (String, [Page a]) -> Ordering)
247+sortTagsBy :: ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)
226− -> Compiler (Tags a) (Tags a)
248+ -> Tags -> Tags
227−sortTagsBy f = arr $ Tags . sortBy f . tagsMap
249+sortTagsBy f = Tags . sortBy f . unTags
252+--------------------------------------------------------------------------------
229-- | Sample sorting function that compares tags case insensitively.
253-- | Sample sorting function that compares tags case insensitively.
231−caseInsensitiveTags :: (String, [Page a]) -> (String, [Page a]) -> Ordering
254+caseInsensitiveTags :: (String, [Identifier]) -> (String, [Identifier])
232caseInsensitiveTags = comparing $ map toLower . fst
256caseInsensitiveTags = comparing $ map toLower . fst