module Hakyll.Web.Tags
( Tags (..)
, getTags
, buildTagsWith
, buildTags
, buildCategories
, tagsRules
, renderTags
, renderTagCloud
, renderTagList
, tagsField
, categoryField
, sortTagsBy
, caseInsensitiveTags
) where
import Control.Arrow ((&&&))
import Control.Monad (foldM, forM, forM_)
import Data.Char (toLower)
import Data.List (intercalate, intersperse,
sortBy)
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid (mconcat)
import Data.Ord (comparing)
import System.FilePath (takeBaseName, takeDirectory)
import Text.Blaze.Html (toHtml, toValue, (!))
import Text.Blaze.Html.Renderer.String (renderHtml)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Hakyll.Core.Compiler
import Hakyll.Core.Dependencies
import Hakyll.Core.Identifier
import Hakyll.Core.Identifier.Pattern
import Hakyll.Core.Item
import Hakyll.Core.Metadata
import Hakyll.Core.Rules
import Hakyll.Core.Util.String
import Hakyll.Web.Template.Context
import Hakyll.Web.Html
data Tags = Tags
{ tagsMap :: [(String, [Identifier])]
, tagsMakeId :: String -> Identifier
, tagsDependency :: Dependency
} deriving (Show)
getTags :: MonadMetadata m => Identifier -> m [String]
getTags identifier = do
metadata <- getMetadata identifier
return $ maybe [] (map trim . splitAll ",") $ M.lookup "tags" metadata
getCategory :: MonadMetadata m => Identifier -> m [String]
getCategory = return . return . takeBaseName . takeDirectory . toFilePath
buildTagsWith :: MonadMetadata m
=> (Identifier -> m [String])
-> Pattern
-> (String -> Identifier)
-> m Tags
buildTagsWith f pattern makeId = do
ids <- getMatches pattern
tagMap <- foldM addTags M.empty ids
return $ Tags (M.toList tagMap) makeId (PatternDependency pattern ids)
where
addTags tagMap id' = do
tags <- f id'
let tagMap' = M.fromList $ zip tags $ repeat [id']
return $ M.unionWith (++) tagMap tagMap'
buildTags :: MonadMetadata m => Pattern -> (String -> Identifier) -> m Tags
buildTags = buildTagsWith getTags
buildCategories :: MonadMetadata m => Pattern -> (String -> Identifier)
-> m Tags
buildCategories = buildTagsWith getCategory
tagsRules :: Tags -> (String -> Pattern -> Rules ()) -> Rules ()
tagsRules tags rules =
forM_ (tagsMap tags) $ \(tag, identifiers) ->
create [tagsMakeId tags tag] $
rulesExtraDependencies [tagsDependency tags] $
rules tag $ fromList identifiers
renderTags :: (String -> String -> Int -> Int -> Int -> String)
-> ([String] -> String)
-> Tags
-> Compiler String
renderTags makeHtml concatHtml tags = do
tags' <- forM (tagsMap tags) $ \(tag, ids) -> do
route' <- getRoute $ tagsMakeId tags tag
return ((tag, route'), length ids)
let
freqs = map snd tags'
(min', max')
| null freqs = (0, 1)
| otherwise = (minimum &&& maximum) freqs
makeHtml' ((tag, url), count) =
makeHtml tag (toUrl $ fromMaybe "/" url) count min' max'
return $ concatHtml $ map makeHtml' tags'
renderTagCloud :: Double
-> Double
-> Tags
-> Compiler String
renderTagCloud minSize maxSize = renderTags makeLink (intercalate " ")
where
makeLink tag url count min' max' = renderHtml $
H.a ! A.style (toValue $ "font-size: " ++ size count min' max')
! A.href (toValue url)
$ toHtml tag
size count min' max' =
let diff = 1 + fromIntegral max' fromIntegral min'
relative = (fromIntegral count fromIntegral min') / diff
size' = floor $ minSize + relative * (maxSize minSize)
in show (size' :: Int) ++ "%"
renderTagList :: Tags -> Compiler (String)
renderTagList = renderTags makeLink (intercalate ", ")
where
makeLink tag url count _ _ = renderHtml $
H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")")
tagsFieldWith :: (Identifier -> Compiler [String])
-> String
-> Tags
-> Context a
tagsFieldWith getTags' key tags = field key $ \item -> do
tags' <- getTags' $ itemIdentifier item
links <- forM tags' $ \tag -> do
route' <- getRoute $ tagsMakeId tags tag
return $ renderLink tag route'
return $ renderHtml $ mconcat $ intersperse ", " $ catMaybes $ links
where
renderLink _ Nothing = Nothing
renderLink tag (Just filePath) = Just $
H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag
tagsField :: String
-> Tags
-> Context a
tagsField = tagsFieldWith getTags
categoryField :: String
-> Tags
-> Context a
categoryField = tagsFieldWith getCategory
sortTagsBy :: ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)
-> Tags -> Tags
sortTagsBy f t = t {tagsMap = sortBy f (tagsMap t)}
caseInsensitiveTags :: (String, [Identifier]) -> (String, [Identifier])
-> Ordering
caseInsensitiveTags = comparing $ map toLower . fst