@@ -1,4 +1,4 @@
1−-- TODO: port
1+--------------------------------------------------------------------------------
22-- | Module containing some specialized functions to deal with tags.
33-- This Module follows certain conventions. My advice is to stick with them if
44-- possible.
@@ -20,117 +20,131 @@
2020-- is to place pages in subdirectories.
2121--
2222-- 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@
2424-- functions. This module only provides functions to work with tags:
2525-- categories are represented as tags. This is perfectly possible: categories
2626-- only have an additional restriction that a page can only have one category
2727-- (instead of multiple tags).
28−--
29−{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, Arrows #-}
28+{-# LANGUAGE Arrows #-}
29+{-# LANGUAGE DeriveDataTypeable #-}
30+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
31+{-# LANGUAGE OverloadedStrings #-}
3032module Hakyll.Web.Tags
3133 ( Tags (..)
3234 , getTags
33− , readTagsWith
34− , readTags
35− , readCategory
35+ , buildTagsWith
36+ , buildTags
37+ , buildCategory
3638 , renderTagCloud
3739 , renderTagList
38− , renderTagsField
39− , renderTagsFieldWith
40− , renderCategoryField
40+ , tagsField
41+ , categoryField
4142 , sortTagsBy
4243 , caseInsensitiveTags
4344 ) where
4445
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)
55−
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
62−
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
7146
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,
53+ sortBy)
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
64+
65+
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
75+
76+
77+--------------------------------------------------------------------------------
7278-- | Data about tags
73−--
74−data Tags a = Tags
75− { tagsMap :: [(String, [Page a])]
76− } deriving (Show, Typeable)
79+-- TODO Make this a map instead of a list?
80+newtype Tags = Tags
81+ { unTags :: [(String, [Identifier])]
82+ } deriving (Binary, Show, Typeable)
7783
78−instance Binary a => Binary (Tags a) where
79− get = Tags <$> get
80− put (Tags m) = put m
8184
82−instance Writable (Tags a) where
85+--------------------------------------------------------------------------------
86+instance Writable Tags where
8387 write _ _ = return ()
8488
89+
90+--------------------------------------------------------------------------------
8591-- | Obtain tags from a page in the default way: parse them from the @tags@
8692-- metadata field.
87−--
88−getTags :: Page a -> [String]
89−getTags = map trim . splitAll "," . getField "tags"
93+getTags :: MonadMetadata m => Identifier -> m [String]
94+getTags identifier = do
95+ metadata <- getMetadata identifier
96+ return $ maybe [] (map trim . splitAll ",") $ M.lookup "tags" metadata
9097
91−-- | Obtain categories from a page
92−--
93−getCategory :: Page a -> [String]
94−getCategory = return . getField "category"
98+--------------------------------------------------------------------------------
99+-- | Obtain categories from a page.
100+getCategory :: MonadMetadata m => Identifier -> m [String]
101+getCategory = return . return . takeBaseName . takeDirectory . toFilePath
95102
103+
104+--------------------------------------------------------------------------------
96105-- | Higher-level function to read tags
97−--
98−readTagsWith :: (Page a -> [String]) -- ^ Function extracting tags from a page
99− -> [Page a] -- ^ Pages
100− -> Tags a -- ^ Resulting tags
101−readTagsWith f pages = Tags
102− { tagsMap = M.toList $
103− foldl (M.unionWith (++)) M.empty (map readTagsWith' pages)
104− }
106+buildTagsWith :: MonadMetadata m
107+ => (Identifier -> m [String]) -> [Identifier] -> m Tags
108+buildTagsWith f ids = do
109+ tagMap <- foldM addTags M.empty ids
110+ return $ Tags $ M.toList tagMap
105111 where
106112 -- Create a tag map for one page
107− readTagsWith' page =
108− let tags = f page
109− in M.fromList $ zip tags $ repeat [page]
113+ addTags tagMap id' = do
114+ tags <- f id'
115+ let tagMap' = M.fromList $ zip tags $ repeat [id']
116+ return $ M.unionWith (++) tagMap tagMap'
110117
118+--------------------------------------------------------------------------------
111119-- | Read a tagmap using the @tags@ metadata field
112−--
113−readTags :: [Page a] -> Tags a
114−readTags = readTagsWith getTags
120+-- TODO: Should use pattern
121+buildTags :: MonadMetadata m => [Identifier] -> m Tags
122+buildTags = buildTagsWith getTags
123+
115124
125+--------------------------------------------------------------------------------
116126-- | Read a tagmap using the @category@ metadata field
117−--
118−readCategory :: [Page a] -> Tags a
119−readCategory = readTagsWith getCategory
127+-- TODO: Should use pattern
128+buildCategory :: MonadMetadata m => [Identifier] -> m Tags
129+buildCategory = buildTagsWith getCategory
130+
120131
132+--------------------------------------------------------------------------------
121133-- | Render tags in HTML
122−--
123−renderTags :: (String -> Identifier (Page a))
124− -- ^ Produce a link
134+renderTags :: (String -> Identifier)
135+ -- ^ Produce a tag page id
125136 -> (String -> String -> Int -> Int -> Int -> String)
126137 -- ^ Produce a tag item: tag, url, count, min count, max count
127138 -> ([String] -> String)
128139 -- ^ Join items
129− -> Compiler (Tags a) String
140+ -> Tags
130141 -- ^ Tag cloud renderer
131−renderTags makeUrl makeItem concatItems = proc (Tags tags) -> do
142+ -> Compiler String
143+renderTags makeTagId makeHtml concatHtml (Tags tags) = do
132144 -- 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)
134148
135149 let -- Absolute frequencies of the pages
136150 freqs = map snd tags'
@@ -138,27 +152,31 @@ renderTags makeUrl makeItem concatItems = proc (Tags tags) -> do
138152 -- The minimum and maximum count found
139153 (min', max')
140154 | null freqs = (0, 1)
141− | otherwise = (minimum &&& maximum) freqs
155+ | otherwise = (minimum &&& maximum) freqs
142156
143157 -- Create a link for one item
144− makeItem' ((tag, url), count) =
145− makeItem tag (toUrl $ fromMaybe "/" url) count min' max'
158+ makeHtml' ((tag, url), count) =
159+ makeHtml tag (toUrl $ fromMaybe "/" url) count min' max'
146160
147161 -- Render and return the HTML
148− returnA -< concatItems $ map makeItem' tags'
162+ return $ concatHtml $ map makeHtml' tags'
163+
149164
165+--------------------------------------------------------------------------------
150166-- | Render a tag cloud in HTML
151−--
152−renderTagCloud :: (String -> Identifier (Page a))
167+-- TODO: Maybe produce a Context here
168+renderTagCloud :: (String -> Identifier)
153169 -- ^ Produce a link for a tag
154170 -> Double
155171 -- ^ Smallest font size, in percent
156172 -> Double
157173 -- ^ Biggest font size, in percent
158− -> Compiler (Tags a) String
159− -- ^ Tag cloud renderer
160−renderTagCloud makeUrl minSize maxSize =
161− renderTags makeUrl makeLink (intercalate " ")
174+ -> Tags
175+ -- ^ Input tags
176+ -> Compiler String
177+ -- ^ Rendered cloud
178+renderTagCloud makeTagId minSize maxSize =
179+ renderTags makeTagId makeLink (intercalate " ")
162180 where
163181 makeLink tag url count min' max' = renderHtml $
164182 H.a ! A.style (toValue $ "font-size: " ++ size count min' max')
@@ -172,61 +190,67 @@ renderTagCloud makeUrl minSize maxSize =
172190 size' = floor $ minSize + relative * (maxSize - minSize)
173191 in show (size' :: Int) ++ "%"
174192
193+
194+--------------------------------------------------------------------------------
175195-- | Render a simple tag list in HTML, with the tag count next to the item
176−--
177−renderTagList :: (String -> Identifier (Page a)) -> Compiler (Tags a) (String)
178−renderTagList makeUrl = renderTags makeUrl makeLink (intercalate ", ")
196+-- TODO: Maybe produce a Context here
197+renderTagList :: (String -> Identifier) -> Tags -> Compiler (String)
198+renderTagList makeTagId = renderTags makeTagId makeLink (intercalate ", ")
179199 where
180200 makeLink tag url count _ _ = renderHtml $
181201 H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")")
182202
203+
204+--------------------------------------------------------------------------------
183205-- | Render tags with links with custom function to get tags. It is typically
184206-- together with 'getTags' like this:
185−--
207+--
186208-- > renderTagsFieldWith (customFunction . getTags)
187209-- > "tags" (fromCapture "tags/*")
188−--
189−renderTagsFieldWith :: (Page a -> [String]) -- ^ Function to get the tags
190− -> String -- ^ Destination key
191− -> (String -> Identifier a) -- ^ Create a link for a tag
192− -> Compiler (Page a) (Page a) -- ^ Resulting compiler
193−renderTagsFieldWith tags destination makeUrl =
194− id &&& arr tags >>> setFieldA destination renderTags'
195− where
196− -- Compiler creating a comma-separated HTML string for a list of tags
197− renderTags' :: Compiler [String] String
198− renderTags' = arr (map $ id &&& makeUrl)
199− >>> mapA (id *** getRouteFor)
200− >>> arr (map $ uncurry renderLink)
201− >>> arr (renderHtml . mconcat . intersperse ", " . catMaybes)
210+tagsFieldWith :: (Identifier -> Compiler [String]) -- ^ Get the tags
211+ -> String -- ^ Destination key
212+ -> (String -> Identifier) -- ^ Create a link for a tag
213+ -> Context a -- ^ Resulting context
214+tagsFieldWith getTags' key makeTagId = field key $ \item -> do
215+ tags <- getTags' $ itemIdentifier item
216+ links <- forM tags $ \tag -> do
217+ route <- getRoute $ makeTagId tag
218+ return $ renderLink tag route
202219
220+ return $ renderHtml $ mconcat $ intersperse ", " $ catMaybes $ links
221+ where
203222 -- Render one tag link
204223 renderLink _ Nothing = Nothing
205224 renderLink tag (Just filePath) = Just $
206225 H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag
207226
227+
228+--------------------------------------------------------------------------------
208229-- | Render tags with links
209−--
210−renderTagsField :: String -- ^ Destination key
211− -> (String -> Identifier a) -- ^ Create a link for a tag
212− -> Compiler (Page a) (Page a) -- ^ Resulting compiler
213−renderTagsField = renderTagsFieldWith getTags
230+tagsField :: String -- ^ Destination key
231+ -> (String -> Identifier) -- ^ Create a link for a tag
232+ -> Context a -- ^ Context
233+tagsField = tagsFieldWith getTags
214234
235+
236+--------------------------------------------------------------------------------
215237-- | Render the category in a link
216−--
217−renderCategoryField :: String -- ^ Destination key
218− -> (String -> Identifier a) -- ^ Create a category link
219− -> Compiler (Page a) (Page a) -- ^ Resulting compiler
220−renderCategoryField = renderTagsFieldWith getCategory
238+categoryField :: String -- ^ Destination key
239+ -> (String -> Identifier) -- ^ Create a category link
240+ -> Context a -- ^ Context
241+categoryField = tagsFieldWith getCategory
221242
243+
244+--------------------------------------------------------------------------------
222245-- | Sort tags using supplied function. First element of the tuple passed to
223246-- the comparing function is the actual tag name.
224−--
225−sortTagsBy :: ((String, [Page a]) -> (String, [Page a]) -> Ordering)
226− -> Compiler (Tags a) (Tags a)
227−sortTagsBy f = arr $ Tags . sortBy f . tagsMap
247+sortTagsBy :: ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)
248+ -> Tags -> Tags
249+sortTagsBy f = Tags . sortBy f . unTags
228250
251+
252+--------------------------------------------------------------------------------
229253-- | Sample sorting function that compares tags case insensitively.
230−--
231−caseInsensitiveTags :: (String, [Page a]) -> (String, [Page a]) -> Ordering
254+caseInsensitiveTags :: (String, [Identifier]) -> (String, [Identifier])
255+ -> Ordering
232256caseInsensitiveTags = comparing $ map toLower . fst