module Hakyll.Web.Tags
( Tags (..)
, readTagsWith
, readTags
, readCategory
, renderTagCloud
, renderTagList
, renderTagsField
, renderCategoryField
, sortTagsBy
, caseInsensitiveTags
) where
import Prelude hiding (id)
import Control.Category (id)
import Control.Applicative ((<$>))
import Data.Char (toLower)
import Data.Ord (comparing)
import qualified Data.Map as M
import Data.List (intersperse, intercalate, sortBy)
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.Urls
import Hakyll.Core.Writable
import Hakyll.Core.Identifier
import Hakyll.Core.Compiler
import Hakyll.Core.Util.String
data Tags a = Tags
{ tagsMap :: [(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 = M.toList $
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
renderTags :: (String -> Identifier (Page a))
-> (String -> String -> Int -> Int -> Int -> String)
-> ([String] -> String)
-> Compiler (Tags a) String
renderTags makeUrl makeItem concatItems = proc (Tags tags) -> do
tags' <- mapCompiler ((id &&& (getRouteFor <<^ makeUrl)) *** arr length)
-< tags
let
freqs = map snd tags'
(min', max')
| null freqs = (0, 1)
| otherwise = (minimum &&& maximum) freqs
makeItem' ((tag, url), count) =
makeItem tag (toUrl $ fromMaybe "/" url) count min' max'
returnA -< concatItems $ map makeItem' tags'
renderTagCloud :: (String -> Identifier (Page a))
-> Double
-> Double
-> Compiler (Tags a) String
renderTagCloud makeUrl minSize maxSize =
renderTags makeUrl 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 :: (String -> Identifier (Page a)) -> Compiler (Tags a) (String)
renderTagList makeUrl = renderTags makeUrl makeLink (intercalate ", ")
where
makeLink tag url count _ _ = renderHtml $
H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")")
renderTagsFieldWith :: (Page a -> [String])
-> String
-> (String -> Identifier a)
-> 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 a)
-> Compiler (Page a) (Page a)
renderTagsField = renderTagsFieldWith getTags
renderCategoryField :: String
-> (String -> Identifier a)
-> Compiler (Page a) (Page a)
renderCategoryField = renderTagsFieldWith getCategory
sortTagsBy :: ((String, [Page a]) -> (String, [Page a]) -> Ordering)
-> Compiler (Tags a) (Tags a)
sortTagsBy f = arr $ Tags . sortBy f . tagsMap
caseInsensitiveTags :: (String, [Page a]) -> (String, [Page a]) -> Ordering
caseInsensitiveTags = comparing $ map toLower . fst