module Hakyll.Web.Tags
( Tags (..)
, readTagsWith
, readTags
, readCategory
, renderTagCloud
, renderTagsField
, renderCategoryField
) where
import Prelude hiding (id)
import Control.Category (id)
import Control.Applicative ((<$>))
import Data.Map (Map)
import qualified Data.Map as M
import Data.List (intersperse)
import Control.Arrow (arr, (&&&), (>>>), (***), (<<^), returnA)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid (mconcat)
import Data.Typeable (Typeable)
import Data.Binary (Binary, get, put)
import Text.Blaze.Renderer.String (renderHtml)
import Text.Blaze ((!), toHtml, toValue)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Hakyll.Web.Page
import Hakyll.Web.Page.Metadata
import Hakyll.Web.Util.Url
import Hakyll.Core.Writable
import Hakyll.Core.Identifier
import Hakyll.Core.Compiler
import Hakyll.Core.Util.String
data Tags a = Tags
{ tagsMap :: Map String [Page a]
} deriving (Show, Typeable)
instance Binary a => Binary (Tags a) where
get = Tags <$> get
put (Tags m) = put m
instance Writable (Tags a) where
write _ _ = return ()
getTags :: Page a -> [String]
getTags = map trim . splitAll "," . getField "tags"
getCategory :: Page a -> [String]
getCategory = return . getField "category"
readTagsWith :: (Page a -> [String])
-> [Page a]
-> Tags a
readTagsWith f pages = Tags
{ tagsMap = foldl (M.unionWith (++)) M.empty (map readTagsWith' pages)
}
where
readTagsWith' page =
let tags = f page
in M.fromList $ zip tags $ repeat [page]
readTags :: [Page a] -> Tags a
readTags = readTagsWith getTags
readCategory :: [Page a] -> Tags a
readCategory = readTagsWith getCategory
renderTagCloud :: (String -> Identifier)
-> Double
-> Double
-> Compiler (Tags a) String
renderTagCloud makeUrl minSize maxSize = proc (Tags tags) -> do
tags' <- mapCompiler ((id &&& (getRouteFor <<^ makeUrl)) *** arr length)
-< M.toList tags
let
freqs = map snd tags'
relative count = (fromIntegral count min') / (1 + max' min')
size count =
let size' = floor $ minSize + relative count * (maxSize minSize)
in show (size' :: Int) ++ "%"
(min', max')
| null freqs = (0, 1)
| otherwise = (minimum &&& maximum) $ map fromIntegral freqs
makeLink ((tag, url), count) =
H.a ! A.style (toValue $ "font-size: " ++ size count)
! A.href (toValue $ toUrl $ fromMaybe "/" url)
$ toHtml tag
returnA -< renderHtml $ mconcat $ intersperse " " $ map makeLink tags'
renderTagsFieldWith :: (Page a -> [String])
-> String
-> (String -> Identifier)
-> Compiler (Page a) (Page a)
renderTagsFieldWith tags destination makeUrl =
id &&& arr tags >>> setFieldA destination renderTags
where
renderTags :: Compiler [String] String
renderTags = arr (map $ id &&& makeUrl)
>>> mapCompiler (id *** getRouteFor)
>>> arr (map $ uncurry renderLink)
>>> arr (renderHtml . mconcat . intersperse ", " . catMaybes)
renderLink _ Nothing = Nothing
renderLink tag (Just filePath) = Just $
H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag
renderTagsField :: String
-> (String -> Identifier)
-> Compiler (Page a) (Page a)
renderTagsField = renderTagsFieldWith getTags
renderCategoryField :: String
-> (String -> Identifier)
-> Compiler (Page a) (Page a)
renderCategoryField = renderTagsFieldWith getCategory