module Text.Hakyll.Tags
( readTagMap
, renderTagCloud
, renderTagLinks
) where
import qualified Data.Map as M
import Data.List (intercalate)
import Control.Monad (foldM)
import Control.Arrow (second)
import Control.Applicative ((<$>))
import System.FilePath ((</>))
import Text.Hakyll.Hakyll (Hakyll)
import Text.Hakyll.Context (ContextManipulation, changeValue)
import Text.Hakyll.Regex
import Text.Hakyll.Util
import Text.Hakyll.Page
import Text.Hakyll.Internal.Cache
import Text.Hakyll.Internal.Template
readTagMap :: String
-> [FilePath]
-> Hakyll (M.Map String [FilePath])
readTagMap identifier paths = do
isCacheMoreRecent' <- isCacheMoreRecent fileName paths
if isCacheMoreRecent' then M.fromAscList <$> getFromCache fileName
else do tagMap <- readTagMap'
storeInCache (M.toAscList tagMap) fileName
return tagMap
where
fileName = "tagmaps" </> identifier
readTagMap' = foldM addPaths M.empty paths
addPaths current path = do
page <- readPage path
let tags = map trim $ splitRegex "," $ getValue "tags" page
return $ foldr (flip (M.insertWith (++)) [path]) current tags
renderTagCloud :: M.Map String [FilePath]
-> (String -> String)
-> Float
-> Float
-> String
renderTagCloud tagMap urlFunction minSize maxSize =
intercalate " " $ map renderTag tagCount
where
renderTag :: (String, Float) -> String
renderTag (tag, count) =
finalSubstitute linkTemplate $ M.fromList [ ("size", sizeTag count)
, ("url", urlFunction tag)
, ("tag", tag)
]
linkTemplate =
fromString "<a style=\"font-size: $size\" href=\"$url\">$tag</a>"
sizeTag :: Float -> String
sizeTag count = show size' ++ "%"
where
size' :: Int
size' = floor $ minSize + relative count * (maxSize minSize)
minCount = minimum $ map snd tagCount
maxCount = maximum $ map snd tagCount
relative count = (count minCount) / (maxCount minCount)
tagCount :: [(String, Float)]
tagCount = map (second $ fromIntegral . length) $ M.toList tagMap
renderTagLinks :: (String -> String)
-> ContextManipulation
renderTagLinks urlFunction = changeValue "tags" renderTagLinks'
where
renderTagLinks' = intercalate ", "
. map ((\t -> link t $ urlFunction t) . trim)
. splitRegex ","