module Text.Hakyll.Tags
( TagMap
, readTagMap
, readCategoryMap
, withTagMap
, renderTagCloud
, renderTagLinks
) where
import qualified Data.Map as M
import Data.List (intercalate)
import Data.Maybe (fromMaybe, maybeToList)
import Control.Arrow (second, (>>>))
import Control.Applicative ((<$>))
import System.FilePath
import Text.Hakyll.Context (Context (..))
import Text.Hakyll.ContextManipulations (changeValue)
import Text.Hakyll.CreateContext (createPage)
import Text.Hakyll.HakyllMonad (Hakyll)
import Text.Hakyll.Regex
import Text.Hakyll.HakyllAction
import Text.Hakyll.Util
import Text.Hakyll.Internal.Cache
import Text.Hakyll.Internal.Template
type TagMap = M.Map String [HakyllAction () Context]
readMap :: (Context -> [String])
-> String
-> [FilePath]
-> HakyllAction () TagMap
readMap getTagsFunction identifier paths = HakyllAction
{ actionDependencies = paths
, actionUrl = Right id
, actionFunction = actionFunction'
}
where
fileName = "tagmaps" </> identifier
actionFunction' _ = do
isCacheMoreRecent' <- isCacheMoreRecent fileName paths
assocMap <- if isCacheMoreRecent'
then M.fromAscList <$> getFromCache fileName
else do assocMap' <- readTagMap'
storeInCache (M.toAscList assocMap') fileName
return assocMap'
return $ M.map (map createPage) assocMap
readTagMap' :: Hakyll (M.Map String [FilePath])
readTagMap' = do
pairs' <- concat <$> mapM pairs paths
return $ M.fromListWith (flip (++)) pairs'
pairs :: FilePath -> Hakyll [(String, [FilePath])]
pairs path = do
context <- runHakyllAction $ createPage path
let tags = getTagsFunction context
return $ map (\tag -> (tag, [path])) tags
readTagMap :: String
-> [FilePath]
-> HakyllAction () TagMap
readTagMap = readMap getTagsFunction
where
getTagsFunction = map trim . splitRegex ","
. fromMaybe [] . M.lookup "tags" . unContext
readCategoryMap :: String
-> [FilePath]
-> HakyllAction () TagMap
readCategoryMap = readMap $ maybeToList . M.lookup "category" . unContext
withTagMap :: HakyllAction () TagMap
-> (String -> [HakyllAction () Context] -> Hakyll ())
-> Hakyll ()
withTagMap tagMap function = runHakyllAction (tagMap >>> action)
where
action = createHakyllAction (mapM_ (uncurry function) . M.toList)
renderTagCloud :: (String -> String)
-> Float
-> Float
-> HakyllAction TagMap String
renderTagCloud urlFunction minSize maxSize = createHakyllAction renderTagCloud'
where
renderTagCloud' tagMap =
return $ intercalate " " $ map (renderTag tagMap) (tagCount tagMap)
renderTag tagMap (tag, count) =
finalSubstitute linkTemplate $ Context $ M.fromList
[ ("size", sizeTag tagMap count)
, ("url", urlFunction tag)
, ("tag", tag)
]
linkTemplate =
fromString "<a style=\"font-size: $size\" href=\"$url\">$tag</a>"
sizeTag tagMap count = show (size' :: Int) ++ "%"
where
size' = floor $ minSize + relative tagMap count * (maxSize minSize)
minCount = minimum . map snd . tagCount
maxCount = maximum . map snd . tagCount
relative tagMap count = (count minCount tagMap) /
(maxCount tagMap minCount tagMap)
tagCount = map (second $ fromIntegral . length) . M.toList
renderTagLinks :: (String -> String)
-> HakyllAction Context Context
renderTagLinks urlFunction = changeValue "tags" renderTagLinks'
where
renderTagLinks' = intercalate ", "
. map ((\t -> link t $ urlFunction t) . trim)
. splitRegex ","