--------------------------------------------------------------------------------
-- | This module containing some specialized functions to deal with tags. It
-- assumes you follow some conventions.
--
-- We support two types of tags: tags and categories.
--
-- To use default tags, use 'buildTags'. Tags are placed in a comma-separated
-- metadata field like this:
--
-- > ---
-- > author: Philip K. Dick
-- > title: Do androids dream of electric sheep?
-- > tags: future, science fiction, humanoid
-- > ---
-- > The novel is set in a post-apocalyptic near future, where the Earth and
-- > its populations have been damaged greatly by Nuclear...
--
-- To use categories, use the 'buildCategories' function. Categories are
-- determined by the directory a page is in, for example, the post
--
-- > posts/coding/2010-01-28-hakyll-categories.markdown
--
-- will receive the @coding@ category.
--
-- Advanced users may implement custom systems using 'buildTagsWith' if desired.
--
-- In the above example, we would want to create a page which lists all pages in
-- the @coding@ category, for example, with the 'Identifier':
--
-- > tags/coding.html
--
-- This is where the first parameter of 'buildTags' and 'buildCategories' comes
-- in. In the above case, we used the function:
--
-- > fromCapture "tags/*.html" :: String -> Identifier
--
-- The 'tagsRules' function lets you generate such a page for each tag in the
-- 'Rules' monad.
{-# LANGUAGE Arrows                     #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
module Hakyll.Web.Tags
    ( Tags (..)
    , getTags
    , getTagsByField
    , getCategory
    , buildTagsWith
    , buildTags
    , buildCategories
    , tagsRules
    , renderTags
    , renderTagCloud
    , renderTagCloudWith
    , tagCloudField
    , tagCloudFieldWith
    , renderTagList
    , tagsField
    , tagsFieldWith
    , categoryField
    , sortTagsBy
    , caseInsensitiveTags
    ) where


--------------------------------------------------------------------------------
import           Control.Arrow                   ((&&&))
import           Control.Monad                   (foldM, forM, forM_, mplus)
import           Data.Char                       (toLower)
import           Data.List                       (intercalate, intersperse,
                                                  sortBy)
import qualified Data.Map                        as M
import           Data.Maybe                      (catMaybes, fromMaybe)
import           Data.Ord                        (comparing)
import qualified Data.Set                        as S
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.Html
import           Hakyll.Web.Template.Context


--------------------------------------------------------------------------------
-- | Data about tags
data Tags = Tags
    { Tags -> [(String, [Identifier])]
tagsMap        :: [(String, [Identifier])]
    , Tags -> String -> Identifier
tagsMakeId     :: String -> Identifier
    , Tags -> Dependency
tagsDependency :: Dependency
    }


--------------------------------------------------------------------------------
-- | Obtain tags from a page in the default way: parse them from the @tags@
-- metadata field. This can either be a list or a comma-separated string.
getTags :: MonadMetadata m => Identifier -> m [String]
getTags :: Identifier -> m [String]
getTags = String -> Identifier -> m [String]
forall (m :: * -> *).
MonadMetadata m =>
String -> Identifier -> m [String]
getTagsByField String
"tags"

-- | Obtain tags from a page by name of the metadata field. These can be a list
-- or a comma-separated string
getTagsByField :: MonadMetadata m => String -> Identifier -> m [String]
getTagsByField :: String -> Identifier -> m [String]
getTagsByField String
fieldName Identifier
identifier = do
    Metadata
metadata <- Identifier -> m Metadata
forall (m :: * -> *). MonadMetadata m => Identifier -> m Metadata
getMetadata Identifier
identifier
    [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [String] -> [String]) -> Maybe [String] -> [String]
forall a b. (a -> b) -> a -> b
$
        (String -> Metadata -> Maybe [String]
lookupStringList String
fieldName Metadata
metadata) Maybe [String] -> Maybe [String] -> Maybe [String]
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
        ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
trim ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
splitAll String
"," (String -> [String]) -> Maybe String -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Metadata -> Maybe String
lookupString String
fieldName Metadata
metadata)


--------------------------------------------------------------------------------
-- | Obtain category from a page.
getCategory :: MonadMetadata m => Identifier -> m [String]
getCategory :: Identifier -> m [String]
getCategory = [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> m [String])
-> (Identifier -> [String]) -> Identifier -> m [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String])
-> (Identifier -> String) -> Identifier -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeBaseName (String -> String)
-> (Identifier -> String) -> Identifier -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeDirectory (String -> String)
-> (Identifier -> String) -> Identifier -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> String
toFilePath


--------------------------------------------------------------------------------
-- | Higher-order function to read tags
buildTagsWith :: MonadMetadata m
              => (Identifier -> m [String])
              -> Pattern
              -> (String -> Identifier)
              -> m Tags
buildTagsWith :: (Identifier -> m [String])
-> Pattern -> (String -> Identifier) -> m Tags
buildTagsWith Identifier -> m [String]
f Pattern
pattern String -> Identifier
makeId = do
    [Identifier]
ids    <- Pattern -> m [Identifier]
forall (m :: * -> *). MonadMetadata m => Pattern -> m [Identifier]
getMatches Pattern
pattern
    Map String [Identifier]
tagMap <- (Map String [Identifier]
 -> Identifier -> m (Map String [Identifier]))
-> Map String [Identifier]
-> [Identifier]
-> m (Map String [Identifier])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map String [Identifier]
-> Identifier -> m (Map String [Identifier])
addTags Map String [Identifier]
forall k a. Map k a
M.empty [Identifier]
ids
    let set' :: Set Identifier
set' = [Identifier] -> Set Identifier
forall a. Ord a => [a] -> Set a
S.fromList [Identifier]
ids
    Tags -> m Tags
forall (m :: * -> *) a. Monad m => a -> m a
return (Tags -> m Tags) -> Tags -> m Tags
forall a b. (a -> b) -> a -> b
$ [(String, [Identifier])]
-> (String -> Identifier) -> Dependency -> Tags
Tags (Map String [Identifier] -> [(String, [Identifier])]
forall k a. Map k a -> [(k, a)]
M.toList Map String [Identifier]
tagMap) String -> Identifier
makeId (Pattern -> Set Identifier -> Dependency
PatternDependency Pattern
pattern Set Identifier
set')
  where
    -- Create a tag map for one page
    addTags :: Map String [Identifier]
-> Identifier -> m (Map String [Identifier])
addTags Map String [Identifier]
tagMap Identifier
id' = do
        [String]
tags <- Identifier -> m [String]
f Identifier
id'
        let tagMap' :: Map String [Identifier]
tagMap' = [(String, [Identifier])] -> Map String [Identifier]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, [Identifier])] -> Map String [Identifier])
-> [(String, [Identifier])] -> Map String [Identifier]
forall a b. (a -> b) -> a -> b
$ [String] -> [[Identifier]] -> [(String, [Identifier])]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
tags ([[Identifier]] -> [(String, [Identifier])])
-> [[Identifier]] -> [(String, [Identifier])]
forall a b. (a -> b) -> a -> b
$ [Identifier] -> [[Identifier]]
forall a. a -> [a]
repeat [Identifier
id']
        Map String [Identifier] -> m (Map String [Identifier])
forall (m :: * -> *) a. Monad m => a -> m a
return (Map String [Identifier] -> m (Map String [Identifier]))
-> Map String [Identifier] -> m (Map String [Identifier])
forall a b. (a -> b) -> a -> b
$ ([Identifier] -> [Identifier] -> [Identifier])
-> Map String [Identifier]
-> Map String [Identifier]
-> Map String [Identifier]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith [Identifier] -> [Identifier] -> [Identifier]
forall a. [a] -> [a] -> [a]
(++) Map String [Identifier]
tagMap Map String [Identifier]
tagMap'


--------------------------------------------------------------------------------
buildTags :: MonadMetadata m => Pattern -> (String -> Identifier) -> m Tags
buildTags :: Pattern -> (String -> Identifier) -> m Tags
buildTags = (Identifier -> m [String])
-> Pattern -> (String -> Identifier) -> m Tags
forall (m :: * -> *).
MonadMetadata m =>
(Identifier -> m [String])
-> Pattern -> (String -> Identifier) -> m Tags
buildTagsWith Identifier -> m [String]
forall (m :: * -> *). MonadMetadata m => Identifier -> m [String]
getTags


--------------------------------------------------------------------------------
buildCategories :: MonadMetadata m => Pattern -> (String -> Identifier)
                -> m Tags
buildCategories :: Pattern -> (String -> Identifier) -> m Tags
buildCategories = (Identifier -> m [String])
-> Pattern -> (String -> Identifier) -> m Tags
forall (m :: * -> *).
MonadMetadata m =>
(Identifier -> m [String])
-> Pattern -> (String -> Identifier) -> m Tags
buildTagsWith Identifier -> m [String]
forall (m :: * -> *). MonadMetadata m => Identifier -> m [String]
getCategory


--------------------------------------------------------------------------------
tagsRules :: Tags -> (String -> Pattern -> Rules ()) -> Rules ()
tagsRules :: Tags -> (String -> Pattern -> Rules ()) -> Rules ()
tagsRules Tags
tags String -> Pattern -> Rules ()
rules =
    [(String, [Identifier])]
-> ((String, [Identifier]) -> Rules ()) -> Rules ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Tags -> [(String, [Identifier])]
tagsMap Tags
tags) (((String, [Identifier]) -> Rules ()) -> Rules ())
-> ((String, [Identifier]) -> Rules ()) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \(String
tag, [Identifier]
identifiers) ->
        [Dependency] -> Rules () -> Rules ()
forall a. [Dependency] -> Rules a -> Rules a
rulesExtraDependencies [Tags -> Dependency
tagsDependency Tags
tags] (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$
            [Identifier] -> Rules () -> Rules ()
create [Tags -> String -> Identifier
tagsMakeId Tags
tags String
tag] (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$
                String -> Pattern -> Rules ()
rules String
tag (Pattern -> Rules ()) -> Pattern -> Rules ()
forall a b. (a -> b) -> a -> b
$ [Identifier] -> Pattern
fromList [Identifier]
identifiers


--------------------------------------------------------------------------------
-- | Render tags in HTML (the flexible higher-order function)
renderTags :: (String -> String -> Int -> Int -> Int -> String)
           -- ^ Produce a tag item: tag, url, count, min count, max count
           -> ([String] -> String)
           -- ^ Join items
           -> Tags
           -- ^ Tag cloud renderer
           -> Compiler String
renderTags :: (String -> String -> Int -> Int -> Int -> String)
-> ([String] -> String) -> Tags -> Compiler String
renderTags String -> String -> Int -> Int -> Int -> String
makeHtml [String] -> String
concatHtml Tags
tags = do
    -- In tags' we create a list: [((tag, route), count)]
    [((String, Maybe String), Int)]
tags' <- [(String, [Identifier])]
-> ((String, [Identifier])
    -> Compiler ((String, Maybe String), Int))
-> Compiler [((String, Maybe String), Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Tags -> [(String, [Identifier])]
tagsMap Tags
tags) (((String, [Identifier]) -> Compiler ((String, Maybe String), Int))
 -> Compiler [((String, Maybe String), Int)])
-> ((String, [Identifier])
    -> Compiler ((String, Maybe String), Int))
-> Compiler [((String, Maybe String), Int)]
forall a b. (a -> b) -> a -> b
$ \(String
tag, [Identifier]
ids) -> do
        Maybe String
route' <- Identifier -> Compiler (Maybe String)
getRoute (Identifier -> Compiler (Maybe String))
-> Identifier -> Compiler (Maybe String)
forall a b. (a -> b) -> a -> b
$ Tags -> String -> Identifier
tagsMakeId Tags
tags String
tag
        ((String, Maybe String), Int)
-> Compiler ((String, Maybe String), Int)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String
tag, Maybe String
route'), [Identifier] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Identifier]
ids)

    -- TODO: We actually need to tell a dependency here!

    let -- Absolute frequencies of the pages
        freqs :: [Int]
freqs = (((String, Maybe String), Int) -> Int)
-> [((String, Maybe String), Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((String, Maybe String), Int) -> Int
forall a b. (a, b) -> b
snd [((String, Maybe String), Int)]
tags'

        -- The minimum and maximum count found
        (Int
min', Int
max')
            | [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
freqs = (Int
0, Int
1)
            | Bool
otherwise  = ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> ([Int] -> Int) -> [Int] -> (Int, Int)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum) [Int]
freqs

        -- Create a link for one item
        makeHtml' :: ((String, Maybe String), Int) -> String
makeHtml' ((String
tag, Maybe String
url), Int
count) =
            String -> String -> Int -> Int -> Int -> String
makeHtml String
tag (String -> String
toUrl (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"/" Maybe String
url) Int
count Int
min' Int
max'

    -- Render and return the HTML
    String -> Compiler String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ [String] -> String
concatHtml ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (((String, Maybe String), Int) -> String)
-> [((String, Maybe String), Int)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String, Maybe String), Int) -> String
makeHtml' [((String, Maybe String), Int)]
tags'


--------------------------------------------------------------------------------
-- | Render a tag cloud in HTML
renderTagCloud :: Double
               -- ^ Smallest font size, in percent
               -> Double
               -- ^ Biggest font size, in percent
               -> Tags
               -- ^ Input tags
               -> Compiler String
               -- ^ Rendered cloud
renderTagCloud :: Double -> Double -> Tags -> Compiler String
renderTagCloud = (Double
 -> Double -> String -> String -> Int -> Int -> Int -> String)
-> ([String] -> String)
-> Double
-> Double
-> Tags
-> Compiler String
renderTagCloudWith Double -> Double -> String -> String -> Int -> Int -> Int -> String
forall a a a a a a.
(ToValue a, ToMarkup a, Integral a, Integral a, Integral a,
 RealFrac a) =>
a -> a -> a -> a -> a -> a -> a -> String
makeLink (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" ")
  where
    makeLink :: a -> a -> a -> a -> a -> a -> a -> String
makeLink a
minSize a
maxSize a
tag a
url a
count a
min' a
max' =
        -- Show the relative size of one 'count' in percent
        let diff :: a
diff     = a
1 a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
max' a -> a -> a
forall a. Num a => a -> a -> a
- a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
min'
            relative :: a
relative = (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
count a -> a -> a
forall a. Num a => a -> a -> a
- a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
min') a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
diff
            size :: Int
size     = a -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (a -> Int) -> a -> Int
forall a b. (a -> b) -> a -> b
$ a
minSize a -> a -> a
forall a. Num a => a -> a -> a
+ a
relative a -> a -> a
forall a. Num a => a -> a -> a
* (a
maxSize a -> a -> a
forall a. Num a => a -> a -> a
- a
minSize) :: Int
        in Html -> String
renderHtml (Html -> String) -> Html -> String
forall a b. (a -> b) -> a -> b
$
            Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.style (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ String
"font-size: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
size String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"%")
                (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (a -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue a
url)
                (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ a -> Html
forall a. ToMarkup a => a -> Html
toHtml a
tag


--------------------------------------------------------------------------------
-- | Render a tag cloud in HTML
renderTagCloudWith :: (Double -> Double ->
                       String -> String -> Int -> Int -> Int -> String)
                   -- ^ Render a single tag link
                   -> ([String] -> String)
                   -- ^ Concatenate links
                   -> Double
                   -- ^ Smallest font size, in percent
                   -> Double
                   -- ^ Biggest font size, in percent
                   -> Tags
                   -- ^ Input tags
                   -> Compiler String
                   -- ^ Rendered cloud
renderTagCloudWith :: (Double
 -> Double -> String -> String -> Int -> Int -> Int -> String)
-> ([String] -> String)
-> Double
-> Double
-> Tags
-> Compiler String
renderTagCloudWith Double -> Double -> String -> String -> Int -> Int -> Int -> String
makeLink [String] -> String
cat Double
minSize Double
maxSize =
  (String -> String -> Int -> Int -> Int -> String)
-> ([String] -> String) -> Tags -> Compiler String
renderTags (Double -> Double -> String -> String -> Int -> Int -> Int -> String
makeLink Double
minSize Double
maxSize) [String] -> String
cat


--------------------------------------------------------------------------------
-- | Render a tag cloud in HTML as a context
tagCloudField :: String
               -- ^ Destination key
               -> Double
               -- ^ Smallest font size, in percent
               -> Double
               -- ^ Biggest font size, in percent
               -> Tags
               -- ^ Input tags
               -> Context a
               -- ^ Context
tagCloudField :: String -> Double -> Double -> Tags -> Context a
tagCloudField String
key Double
minSize Double
maxSize Tags
tags =
  String -> (Item a -> Compiler String) -> Context a
forall a. String -> (Item a -> Compiler String) -> Context a
field String
key ((Item a -> Compiler String) -> Context a)
-> (Item a -> Compiler String) -> Context a
forall a b. (a -> b) -> a -> b
$ \Item a
_ -> Double -> Double -> Tags -> Compiler String
renderTagCloud Double
minSize Double
maxSize Tags
tags


--------------------------------------------------------------------------------
-- | Render a tag cloud in HTML as a context
tagCloudFieldWith :: String
                  -- ^ Destination key
                  -> (Double -> Double ->
                      String -> String -> Int -> Int -> Int -> String)
                  -- ^ Render a single tag link
                  -> ([String] -> String)
                  -- ^ Concatenate links
                  -> Double
                  -- ^ Smallest font size, in percent
                  -> Double
                  -- ^ Biggest font size, in percent
                  -> Tags
                  -- ^ Input tags
                  -> Context a
                  -- ^ Context
tagCloudFieldWith :: String
-> (Double
    -> Double -> String -> String -> Int -> Int -> Int -> String)
-> ([String] -> String)
-> Double
-> Double
-> Tags
-> Context a
tagCloudFieldWith String
key Double -> Double -> String -> String -> Int -> Int -> Int -> String
makeLink [String] -> String
cat Double
minSize Double
maxSize Tags
tags =
  String -> (Item a -> Compiler String) -> Context a
forall a. String -> (Item a -> Compiler String) -> Context a
field String
key ((Item a -> Compiler String) -> Context a)
-> (Item a -> Compiler String) -> Context a
forall a b. (a -> b) -> a -> b
$ \Item a
_ -> (Double
 -> Double -> String -> String -> Int -> Int -> Int -> String)
-> ([String] -> String)
-> Double
-> Double
-> Tags
-> Compiler String
renderTagCloudWith Double -> Double -> String -> String -> Int -> Int -> Int -> String
makeLink [String] -> String
cat Double
minSize Double
maxSize Tags
tags


--------------------------------------------------------------------------------
-- | Render a simple tag list in HTML, with the tag count next to the item
-- TODO: Maybe produce a Context here
renderTagList :: Tags -> Compiler (String)
renderTagList :: Tags -> Compiler String
renderTagList = (String -> String -> Int -> Int -> Int -> String)
-> ([String] -> String) -> Tags -> Compiler String
renderTags String -> String -> Int -> Int -> Int -> String
forall a a p p.
(ToValue a, Show a) =>
String -> a -> a -> p -> p -> String
makeLink (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", ")
  where
    makeLink :: String -> a -> a -> p -> p -> String
makeLink String
tag a
url a
count p
_ p
_ = Html -> String
renderHtml (Html -> String) -> Html -> String
forall a b. (a -> b) -> a -> b
$
        Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (a -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue a
url) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
toHtml (String
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
count String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")


--------------------------------------------------------------------------------
-- | Render tags with links with custom functions to get tags and to
-- render links
tagsFieldWith :: (Identifier -> Compiler [String])
              -- ^ Get the tags
              -> (String -> (Maybe FilePath) -> Maybe H.Html)
              -- ^ Render link for one tag
              -> ([H.Html] -> H.Html)
              -- ^ Concatenate tag links
              -> String
              -- ^ Destination field
              -> Tags
              -- ^ Tags structure
              -> Context a
              -- ^ Resulting context
tagsFieldWith :: (Identifier -> Compiler [String])
-> (String -> Maybe String -> Maybe Html)
-> ([Html] -> Html)
-> String
-> Tags
-> Context a
tagsFieldWith Identifier -> Compiler [String]
getTags' String -> Maybe String -> Maybe Html
renderLink [Html] -> Html
cat String
key Tags
tags = String -> (Item a -> Compiler String) -> Context a
forall a. String -> (Item a -> Compiler String) -> Context a
field String
key ((Item a -> Compiler String) -> Context a)
-> (Item a -> Compiler String) -> Context a
forall a b. (a -> b) -> a -> b
$ \Item a
item -> do
    [String]
tags' <- Identifier -> Compiler [String]
getTags' (Identifier -> Compiler [String])
-> Identifier -> Compiler [String]
forall a b. (a -> b) -> a -> b
$ Item a -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item a
item
    [Maybe Html]
links <- [String]
-> (String -> Compiler (Maybe Html)) -> Compiler [Maybe Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
tags' ((String -> Compiler (Maybe Html)) -> Compiler [Maybe Html])
-> (String -> Compiler (Maybe Html)) -> Compiler [Maybe Html]
forall a b. (a -> b) -> a -> b
$ \String
tag -> do
        Maybe String
route' <- Identifier -> Compiler (Maybe String)
getRoute (Identifier -> Compiler (Maybe String))
-> Identifier -> Compiler (Maybe String)
forall a b. (a -> b) -> a -> b
$ Tags -> String -> Identifier
tagsMakeId Tags
tags String
tag
        Maybe Html -> Compiler (Maybe Html)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Html -> Compiler (Maybe Html))
-> Maybe Html -> Compiler (Maybe Html)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> Maybe Html
renderLink String
tag Maybe String
route'

    String -> Compiler String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ Html -> String
renderHtml (Html -> String) -> Html -> String
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
cat ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$ [Maybe Html] -> [Html]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Html] -> [Html]) -> [Maybe Html] -> [Html]
forall a b. (a -> b) -> a -> b
$ [Maybe Html]
links


--------------------------------------------------------------------------------
-- | Render tags with links
tagsField :: String     -- ^ Destination key
          -> Tags       -- ^ Tags
          -> Context a  -- ^ Context
tagsField :: String -> Tags -> Context a
tagsField =
  (Identifier -> Compiler [String])
-> (String -> Maybe String -> Maybe Html)
-> ([Html] -> Html)
-> String
-> Tags
-> Context a
forall a.
(Identifier -> Compiler [String])
-> (String -> Maybe String -> Maybe Html)
-> ([Html] -> Html)
-> String
-> Tags
-> Context a
tagsFieldWith Identifier -> Compiler [String]
forall (m :: * -> *). MonadMetadata m => Identifier -> m [String]
getTags String -> Maybe String -> Maybe Html
simpleRenderLink ([Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> ([Html] -> [Html]) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
intersperse Html
", ")


--------------------------------------------------------------------------------
-- | Render the category in a link
categoryField :: String     -- ^ Destination key
              -> Tags       -- ^ Tags
              -> Context a  -- ^ Context
categoryField :: String -> Tags -> Context a
categoryField =
  (Identifier -> Compiler [String])
-> (String -> Maybe String -> Maybe Html)
-> ([Html] -> Html)
-> String
-> Tags
-> Context a
forall a.
(Identifier -> Compiler [String])
-> (String -> Maybe String -> Maybe Html)
-> ([Html] -> Html)
-> String
-> Tags
-> Context a
tagsFieldWith Identifier -> Compiler [String]
forall (m :: * -> *). MonadMetadata m => Identifier -> m [String]
getCategory String -> Maybe String -> Maybe Html
simpleRenderLink ([Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> ([Html] -> [Html]) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
intersperse Html
", ")


--------------------------------------------------------------------------------
-- | Render one tag link
simpleRenderLink :: String -> (Maybe FilePath) -> Maybe H.Html
simpleRenderLink :: String -> Maybe String -> Maybe Html
simpleRenderLink String
_   Maybe String
Nothing         = Maybe Html
forall a. Maybe a
Nothing
simpleRenderLink String
tag (Just String
filePath) = Html -> Maybe Html
forall a. a -> Maybe a
Just (Html -> Maybe Html) -> Html -> Maybe Html
forall a b. (a -> b) -> a -> b
$
    Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.title (String -> AttributeValue
H.stringValue (String
"All pages tagged '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
tagString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'."))
        (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ String -> String
toUrl String
filePath)
        (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
toHtml String
tag


--------------------------------------------------------------------------------
-- | Sort tags using supplied function. First element of the tuple passed to
-- the comparing function is the actual tag name.
sortTagsBy :: ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)
           -> Tags -> Tags
sortTagsBy :: ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)
-> Tags -> Tags
sortTagsBy (String, [Identifier]) -> (String, [Identifier]) -> Ordering
f Tags
t = Tags
t {tagsMap :: [(String, [Identifier])]
tagsMap = ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)
-> [(String, [Identifier])] -> [(String, [Identifier])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (String, [Identifier]) -> (String, [Identifier]) -> Ordering
f (Tags -> [(String, [Identifier])]
tagsMap Tags
t)}


--------------------------------------------------------------------------------
-- | Sample sorting function that compares tags case insensitively.
caseInsensitiveTags :: (String, [Identifier]) -> (String, [Identifier])
                    -> Ordering
caseInsensitiveTags :: (String, [Identifier]) -> (String, [Identifier]) -> Ordering
caseInsensitiveTags = ((String, [Identifier]) -> String)
-> (String, [Identifier]) -> (String, [Identifier]) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (((String, [Identifier]) -> String)
 -> (String, [Identifier]) -> (String, [Identifier]) -> Ordering)
-> ((String, [Identifier]) -> String)
-> (String, [Identifier])
-> (String, [Identifier])
-> Ordering
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String)
-> ((String, [Identifier]) -> String)
-> (String, [Identifier])
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [Identifier]) -> String
forall a b. (a, b) -> a
fst