From c54c7a05b1b5a949dc50c37b05300ef21ce22042 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <m@jaspervdj.be>
Date: Thu, 22 Nov 2012 14:37:04 +0100
Subject: Port tags module to hakyll4 (WIP)
---
src/Hakyll.hs | 4 +-
src/Hakyll/Web/Tags.hs | 260 ++++++++++++++++++++-----------------
src/Hakyll/Web/Template/Context.hs | 7 -
3 files changed, 144 insertions(+), 127 deletions(-)
(limited to 'src')
diff --git a/src/Hakyll.hs b/src/Hakyll.hs
index 12d5eb3..0deca0f 100644
--- a/src/Hakyll.hs
+++ b/src/Hakyll.hs
@@ -26,7 +26,7 @@ module Hakyll
, module Hakyll.Web.Pandoc.FileType
, module Hakyll.Web.Urls
, module Hakyll.Web.Urls.Relativize
- -- , module Hakyll.Web.Tags
+ , module Hakyll.Web.Tags
, module Hakyll.Web.Template
, module Hakyll.Web.Template.Context
, module Hakyll.Web.Template.List
@@ -58,7 +58,7 @@ import Hakyll.Web.Pandoc.Biblio
import Hakyll.Web.Pandoc.FileType
import Hakyll.Web.Urls
import Hakyll.Web.Urls.Relativize
--- import Hakyll.Web.Tags
+import Hakyll.Web.Tags
import Hakyll.Web.Template
import Hakyll.Web.Template.Context
import Hakyll.Web.Template.List
diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs
index af3c3ba..e10af56 100644
--- a/src/Hakyll/Web/Tags.hs
+++ b/src/Hakyll/Web/Tags.hs
@@ -1,4 +1,4 @@
--- TODO: port
+--------------------------------------------------------------------------------
-- | Module containing some specialized functions to deal with tags.
-- This Module follows certain conventions. My advice is to stick with them if
-- possible.
@@ -20,117 +20,131 @@
-- is to place pages in subdirectories.
--
-- An example, the page @posts\/coding\/2010-01-28-hakyll-categories.markdown@
--- Tags or categories are read using the @readTags@ and @readCategory@
+-- Tags or categories are read using the @buildTags@ and @buildCategory@
-- functions. This module only provides functions to work with tags:
-- categories are represented as tags. This is perfectly possible: categories
-- only have an additional restriction that a page can only have one category
-- (instead of multiple tags).
---
-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, Arrows #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
module Hakyll.Web.Tags
( Tags (..)
, getTags
- , readTagsWith
- , readTags
- , readCategory
+ , buildTagsWith
+ , buildTags
+ , buildCategory
, renderTagCloud
, renderTagList
- , renderTagsField
- , renderTagsFieldWith
- , renderCategoryField
+ , tagsField
+ , categoryField
, 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.Html.Renderer.String (renderHtml)
-import Text.Blaze.Html ((!), 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.Arrow
-import Hakyll.Core.Util.String
+--------------------------------------------------------------------------------
+import Control.Arrow ((&&&))
+import Control.Monad (foldM, forM)
+import Data.Binary (Binary)
+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 Data.Typeable (Typeable)
+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.Identifier
+import Hakyll.Core.Item
+import Hakyll.Core.Metadata
+import Hakyll.Core.Util.String
+import Hakyll.Core.Writable
+import Hakyll.Web.Template.Context
+import Hakyll.Web.Urls
+
+
+--------------------------------------------------------------------------------
-- | Data about tags
---
-data Tags a = Tags
- { tagsMap :: [(String, [Page a])]
- } deriving (Show, Typeable)
+-- TODO Make this a map instead of a list?
+newtype Tags = Tags
+ { unTags :: [(String, [Identifier])]
+ } deriving (Binary, Show, Typeable)
-instance Binary a => Binary (Tags a) where
- get = Tags <$> get
- put (Tags m) = put m
-instance Writable (Tags a) where
+--------------------------------------------------------------------------------
+instance Writable Tags where
write _ _ = return ()
+
+--------------------------------------------------------------------------------
-- | Obtain tags from a page in the default way: parse them from the @tags@
-- metadata field.
---
-getTags :: Page a -> [String]
-getTags = map trim . splitAll "," . getField "tags"
+getTags :: MonadMetadata m => Identifier -> m [String]
+getTags identifier = do
+ metadata <- getMetadata identifier
+ return $ maybe [] (map trim . splitAll ",") $ M.lookup "tags" metadata
--- | Obtain categories from a page
---
-getCategory :: Page a -> [String]
-getCategory = return . getField "category"
+--------------------------------------------------------------------------------
+-- | Obtain categories from a page.
+getCategory :: MonadMetadata m => Identifier -> m [String]
+getCategory = return . return . takeBaseName . takeDirectory . toFilePath
+
+--------------------------------------------------------------------------------
-- | Higher-level function to read tags
---
-readTagsWith :: (Page a -> [String]) -- ^ Function extracting tags from a page
- -> [Page a] -- ^ Pages
- -> Tags a -- ^ Resulting tags
-readTagsWith f pages = Tags
- { tagsMap = M.toList $
- foldl (M.unionWith (++)) M.empty (map readTagsWith' pages)
- }
+buildTagsWith :: MonadMetadata m
+ => (Identifier -> m [String]) -> [Identifier] -> m Tags
+buildTagsWith f ids = do
+ tagMap <- foldM addTags M.empty ids
+ return $ Tags $ M.toList tagMap
where
-- Create a tag map for one page
- readTagsWith' page =
- let tags = f page
- in M.fromList $ zip tags $ repeat [page]
+ addTags tagMap id' = do
+ tags <- f id'
+ let tagMap' = M.fromList $ zip tags $ repeat [id']
+ return $ M.unionWith (++) tagMap tagMap'
+--------------------------------------------------------------------------------
-- | Read a tagmap using the @tags@ metadata field
---
-readTags :: [Page a] -> Tags a
-readTags = readTagsWith getTags
+-- TODO: Should use pattern
+buildTags :: MonadMetadata m => [Identifier] -> m Tags
+buildTags = buildTagsWith getTags
+
+--------------------------------------------------------------------------------
-- | Read a tagmap using the @category@ metadata field
---
-readCategory :: [Page a] -> Tags a
-readCategory = readTagsWith getCategory
+-- TODO: Should use pattern
+buildCategory :: MonadMetadata m => [Identifier] -> m Tags
+buildCategory = buildTagsWith getCategory
+
+--------------------------------------------------------------------------------
-- | Render tags in HTML
---
-renderTags :: (String -> Identifier (Page a))
- -- ^ Produce a link
+renderTags :: (String -> Identifier)
+ -- ^ Produce a tag page id
-> (String -> String -> Int -> Int -> Int -> String)
-- ^ Produce a tag item: tag, url, count, min count, max count
-> ([String] -> String)
-- ^ Join items
- -> Compiler (Tags a) String
+ -> Tags
-- ^ Tag cloud renderer
-renderTags makeUrl makeItem concatItems = proc (Tags tags) -> do
+ -> Compiler String
+renderTags makeTagId makeHtml concatHtml (Tags tags) = do
-- In tags' we create a list: [((tag, route), count)]
- tags' <- mapA ((id &&& (getRouteFor <<^ makeUrl)) *** arr length) -< tags
+ tags' <- forM tags $ \(tag, ids) -> do
+ route <- getRoute $ makeTagId tag
+ return ((tag, route), length ids)
let -- Absolute frequencies of the pages
freqs = map snd tags'
@@ -138,27 +152,31 @@ renderTags makeUrl makeItem concatItems = proc (Tags tags) -> do
-- The minimum and maximum count found
(min', max')
| null freqs = (0, 1)
- | otherwise = (minimum &&& maximum) freqs
+ | otherwise = (minimum &&& maximum) freqs
-- Create a link for one item
- makeItem' ((tag, url), count) =
- makeItem tag (toUrl $ fromMaybe "/" url) count min' max'
+ makeHtml' ((tag, url), count) =
+ makeHtml tag (toUrl $ fromMaybe "/" url) count min' max'
-- Render and return the HTML
- returnA -< concatItems $ map makeItem' tags'
+ return $ concatHtml $ map makeHtml' tags'
+
+--------------------------------------------------------------------------------
-- | Render a tag cloud in HTML
---
-renderTagCloud :: (String -> Identifier (Page a))
+-- TODO: Maybe produce a Context here
+renderTagCloud :: (String -> Identifier)
-- ^ Produce a link for a tag
-> Double
-- ^ Smallest font size, in percent
-> Double
-- ^ Biggest font size, in percent
- -> Compiler (Tags a) String
- -- ^ Tag cloud renderer
-renderTagCloud makeUrl minSize maxSize =
- renderTags makeUrl makeLink (intercalate " ")
+ -> Tags
+ -- ^ Input tags
+ -> Compiler String
+ -- ^ Rendered cloud
+renderTagCloud makeTagId minSize maxSize =
+ renderTags makeTagId makeLink (intercalate " ")
where
makeLink tag url count min' max' = renderHtml $
H.a ! A.style (toValue $ "font-size: " ++ size count min' max')
@@ -172,61 +190,67 @@ renderTagCloud makeUrl minSize maxSize =
size' = floor $ minSize + relative * (maxSize - minSize)
in show (size' :: Int) ++ "%"
+
+--------------------------------------------------------------------------------
-- | Render a simple tag list in HTML, with the tag count next to the item
---
-renderTagList :: (String -> Identifier (Page a)) -> Compiler (Tags a) (String)
-renderTagList makeUrl = renderTags makeUrl makeLink (intercalate ", ")
+-- TODO: Maybe produce a Context here
+renderTagList :: (String -> Identifier) -> Tags -> Compiler (String)
+renderTagList makeTagId = renderTags makeTagId makeLink (intercalate ", ")
where
makeLink tag url count _ _ = renderHtml $
H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")")
+
+--------------------------------------------------------------------------------
-- | Render tags with links with custom function to get tags. It is typically
-- together with 'getTags' like this:
---
+--
-- > renderTagsFieldWith (customFunction . getTags)
-- > "tags" (fromCapture "tags/*")
---
-renderTagsFieldWith :: (Page a -> [String]) -- ^ Function to get the tags
- -> String -- ^ Destination key
- -> (String -> Identifier a) -- ^ Create a link for a tag
- -> Compiler (Page a) (Page a) -- ^ Resulting compiler
-renderTagsFieldWith tags destination makeUrl =
- id &&& arr tags >>> setFieldA destination renderTags'
- where
- -- Compiler creating a comma-separated HTML string for a list of tags
- renderTags' :: Compiler [String] String
- renderTags' = arr (map $ id &&& makeUrl)
- >>> mapA (id *** getRouteFor)
- >>> arr (map $ uncurry renderLink)
- >>> arr (renderHtml . mconcat . intersperse ", " . catMaybes)
+tagsFieldWith :: (Identifier -> Compiler [String]) -- ^ Get the tags
+ -> String -- ^ Destination key
+ -> (String -> Identifier) -- ^ Create a link for a tag
+ -> Context a -- ^ Resulting context
+tagsFieldWith getTags' key makeTagId = field key $ \item -> do
+ tags <- getTags' $ itemIdentifier item
+ links <- forM tags $ \tag -> do
+ route <- getRoute $ makeTagId tag
+ return $ renderLink tag route
+ return $ renderHtml $ mconcat $ intersperse ", " $ catMaybes $ links
+ where
-- Render one tag link
renderLink _ Nothing = Nothing
renderLink tag (Just filePath) = Just $
H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag
+
+--------------------------------------------------------------------------------
-- | Render tags with links
---
-renderTagsField :: String -- ^ Destination key
- -> (String -> Identifier a) -- ^ Create a link for a tag
- -> Compiler (Page a) (Page a) -- ^ Resulting compiler
-renderTagsField = renderTagsFieldWith getTags
+tagsField :: String -- ^ Destination key
+ -> (String -> Identifier) -- ^ Create a link for a tag
+ -> Context a -- ^ Context
+tagsField = tagsFieldWith getTags
+
+--------------------------------------------------------------------------------
-- | Render the category in a link
---
-renderCategoryField :: String -- ^ Destination key
- -> (String -> Identifier a) -- ^ Create a category link
- -> Compiler (Page a) (Page a) -- ^ Resulting compiler
-renderCategoryField = renderTagsFieldWith getCategory
+categoryField :: String -- ^ Destination key
+ -> (String -> Identifier) -- ^ Create a category link
+ -> Context a -- ^ Context
+categoryField = tagsFieldWith getCategory
+
+--------------------------------------------------------------------------------
-- | Sort tags using supplied function. First element of the tuple passed to
-- the comparing function is the actual tag name.
---
-sortTagsBy :: ((String, [Page a]) -> (String, [Page a]) -> Ordering)
- -> Compiler (Tags a) (Tags a)
-sortTagsBy f = arr $ Tags . sortBy f . tagsMap
+sortTagsBy :: ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)
+ -> Tags -> Tags
+sortTagsBy f = Tags . sortBy f . unTags
+
+--------------------------------------------------------------------------------
-- | Sample sorting function that compares tags case insensitively.
---
-caseInsensitiveTags :: (String, [Page a]) -> (String, [Page a]) -> Ordering
+caseInsensitiveTags :: (String, [Identifier]) -> (String, [Identifier])
+ -> Ordering
caseInsensitiveTags = comparing $ map toLower . fst
diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs
index 11491bf..3b98ea3 100644
--- a/src/Hakyll/Web/Template/Context.hs
+++ b/src/Hakyll/Web/Template/Context.hs
@@ -11,7 +11,6 @@ module Hakyll.Web.Template.Context
, metadataField
, urlField
, pathField
- , categoryField
, titleField
, dateField
, dateFieldWith
@@ -88,7 +87,6 @@ defaultContext =
metadataField `mappend`
urlField "url" `mappend`
pathField "path" `mappend`
- categoryField "category" `mappend`
titleField "title" `mappend`
missingField
@@ -116,11 +114,6 @@ pathField :: String -> Context a
pathField key = field key $ return . toFilePath . itemIdentifier
---------------------------------------------------------------------------------
-categoryField :: String -> Context a
-categoryField key = mapContext (takeBaseName . takeDirectory) $ pathField key
-
-
--------------------------------------------------------------------------------
titleField :: String -> Context a
titleField key = mapContext takeBaseName $ pathField key
--
cgit v1.2.3