summaryrefslogtreecommitdiff
path: root/src/Text
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text')
-rw-r--r--src/Text/Hakyll.hs34
-rw-r--r--src/Text/Hakyll/CompressCSS.hs1
-rw-r--r--src/Text/Hakyll/Context.hs4
-rw-r--r--src/Text/Hakyll/File.hs45
-rw-r--r--src/Text/Hakyll/Hakyll.hs25
-rw-r--r--src/Text/Hakyll/Page.hs59
-rw-r--r--src/Text/Hakyll/Render.hs79
-rw-r--r--src/Text/Hakyll/Render/Internal.hs24
-rw-r--r--src/Text/Hakyll/Renderable.hs4
-rw-r--r--src/Text/Hakyll/Renderables.hs13
-rw-r--r--src/Text/Hakyll/Tags.hs22
11 files changed, 202 insertions, 108 deletions
diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs
index e23e211..6718de6 100644
--- a/src/Text/Hakyll.hs
+++ b/src/Text/Hakyll.hs
@@ -1,28 +1,40 @@
module Text.Hakyll
- ( hakyll
+ ( defaultHakyllConfiguration
+ , hakyll
) where
-import Network.Hakyll.SimpleServer (simpleServer)
-
+import Control.Monad.Reader (runReaderT)
+import qualified Data.Map as M
import System.Environment (getArgs, getProgName)
import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
+import Network.Hakyll.SimpleServer (simpleServer)
+import Text.Hakyll.Hakyll
+
+-- | Default hakyll configuration.
+defaultHakyllConfiguration :: HakyllConfiguration
+defaultHakyllConfiguration = HakyllConfiguration
+ { additionalContext = M.empty
+ }
+
-- | Main function to run hakyll.
-hakyll :: IO () -> IO ()
-hakyll buildFunction = do
+hakyll :: HakyllConfiguration -> Hakyll () -> IO ()
+hakyll configuration buildFunction = do
args <- getArgs
- case args of ["build"] -> build buildFunction
+ case args of ["build"] -> build'
["clean"] -> clean
- ["preview", p] -> build buildFunction >> server (read p)
- ["preview"] -> build buildFunction >> server 8000
+ ["preview", p] -> build' >> server (read p)
+ ["preview"] -> build' >> server 8000
["server", p] -> server (read p)
["server"] -> server 8000
_ -> help
+ where
+ build' = build configuration buildFunction
-- | Build the site.
-build :: IO () -> IO ()
-build buildFunction = do putStrLn "Generating..."
- buildFunction
+build :: HakyllConfiguration -> Hakyll () -> IO ()
+build configuration buildFunction = do putStrLn "Generating..."
+ runReaderT buildFunction configuration
-- | Clean up directories.
clean :: IO ()
diff --git a/src/Text/Hakyll/CompressCSS.hs b/src/Text/Hakyll/CompressCSS.hs
index f9a062c..c6693b7 100644
--- a/src/Text/Hakyll/CompressCSS.hs
+++ b/src/Text/Hakyll/CompressCSS.hs
@@ -3,6 +3,7 @@ module Text.Hakyll.CompressCSS
) where
import Data.List (isPrefixOf)
+
import Text.Hakyll.Regex (substituteRegex)
-- | Compress CSS to speed up your site.
diff --git a/src/Text/Hakyll/Context.hs b/src/Text/Hakyll/Context.hs
index d2c6047..56adc49 100644
--- a/src/Text/Hakyll/Context.hs
+++ b/src/Text/Hakyll/Context.hs
@@ -8,12 +8,12 @@ module Text.Hakyll.Context
import qualified Data.Map as M
import Data.Map (Map)
-
import System.Locale (defaultTimeLocale)
import System.FilePath (takeFileName)
import Data.Time.Format (parseTime, formatTime)
import Data.Time.Clock (UTCTime)
import Data.Maybe (fromMaybe)
+
import Text.Hakyll.Regex (substituteRegex)
-- | Type for a context.
@@ -31,7 +31,7 @@ renderValue src dst f context = case M.lookup src context of
Nothing -> context
(Just value) -> M.insert dst (f value) context
--- | When the context has a key called `path` in a `yyyy-mm-dd-title.extension`
+-- | When the context has a key called @path@ in a @yyyy-mm-dd-title.extension@
-- format (default for pages), this function can render the date.
renderDate :: String -- ^ Key in which the rendered date should be placed.
-> String -- ^ Format to use on the date.
diff --git a/src/Text/Hakyll/File.hs b/src/Text/Hakyll/File.hs
index 81c4170..2a77707 100644
--- a/src/Text/Hakyll/File.hs
+++ b/src/Text/Hakyll/File.hs
@@ -17,6 +17,9 @@ import System.Directory
import System.FilePath
import Control.Monad
import Data.List (isPrefixOf)
+import Control.Monad.Reader (liftIO)
+
+import Text.Hakyll.Hakyll (Hakyll)
-- | Auxiliary function to remove pathSeparators form the start. We don't deal
-- with absolute paths here. We also remove $root from the start.
@@ -29,11 +32,11 @@ removeLeadingSeparator path
path' = if "$root" `isPrefixOf` path then drop 5 path
else path
--- | Convert a relative filepath to a filepath in the destination (_site).
+-- | Convert a relative filepath to a filepath in the destination (@_site@).
toDestination :: FilePath -> FilePath
toDestination path = "_site" </> (removeLeadingSeparator path)
--- | Convert a relative filepath to a filepath in the cache (_cache).
+-- | Convert a relative filepath to a filepath in the cache (@_cache@).
toCache :: FilePath -> FilePath
toCache path = "_cache" </> (removeLeadingSeparator path)
@@ -71,20 +74,20 @@ removeSpaces = map swap
-- | Given a path to a file, try to make the path writable by making
-- all directories on the path.
-makeDirectories :: FilePath -> IO ()
-makeDirectories path = createDirectoryIfMissing True dir
+makeDirectories :: FilePath -> Hakyll ()
+makeDirectories path = liftIO $ createDirectoryIfMissing True dir
where
dir = takeDirectory path
-- | Get all contents of a directory. Note that files starting with a dot (.)
-- will be ignored.
-getRecursiveContents :: FilePath -> IO [FilePath]
+getRecursiveContents :: FilePath -> Hakyll [FilePath]
getRecursiveContents topdir = do
- names <- getDirectoryContents topdir
+ names <- liftIO $ getDirectoryContents topdir
let properNames = filter isProper names
paths <- forM properNames $ \name -> do
let path = topdir </> name
- isDirectory <- doesDirectoryExist path
+ isDirectory <- liftIO $ doesDirectoryExist path
if isDirectory
then getRecursiveContents path
else return [path]
@@ -95,18 +98,26 @@ getRecursiveContents topdir = do
-- | A filter that takes all file names with a given extension. Prefix the
-- extension with a dot:
--
--- > havingExtension ".markdown" ["index.markdown", "style.css"] == ["index.markdown"]
+-- > havingExtension ".markdown" [ "index.markdown"
+-- > , "style.css"
+-- > ] == ["index.markdown"]
havingExtension :: String -> [FilePath] -> [FilePath]
havingExtension extension = filter ((==) extension . takeExtension)
--- | Perform an IO action on every file in a given directory.
-directory :: (FilePath -> IO ()) -> FilePath -> IO ()
-directory action dir = getRecursiveContents dir >>= mapM_ action
+-- | Perform a Hakyll action on every file in a given directory.
+directory :: (FilePath -> Hakyll ()) -> FilePath -> Hakyll ()
+directory action dir = do
+ contents <- getRecursiveContents dir
+ mapM_ action contents
-- | Check if a cache file is still valid.
-isCacheValid :: FilePath -> [FilePath] -> IO Bool
-isCacheValid cache depends = doesFileExist cache >>= \exists ->
- if not exists then return False
- else do dependsModified <- (mapM getModificationTime depends) >>= return . maximum
- cacheModified <- getModificationTime cache
- return (cacheModified >= dependsModified)
+isCacheValid :: FilePath -- ^ The cached file.
+ -> [FilePath] -- ^ Dependencies of the cached file.
+ -> Hakyll Bool
+isCacheValid cache depends = do
+ exists <- liftIO $ doesFileExist cache
+ if not exists
+ then return False
+ else do dependsModified <- liftIO $ mapM getModificationTime depends
+ cacheModified <- liftIO $ getModificationTime cache
+ return (cacheModified >= maximum dependsModified)
diff --git a/src/Text/Hakyll/Hakyll.hs b/src/Text/Hakyll/Hakyll.hs
new file mode 100644
index 0000000..af8c9c5
--- /dev/null
+++ b/src/Text/Hakyll/Hakyll.hs
@@ -0,0 +1,25 @@
+-- | Module describing the Hakyll monad stack.
+module Text.Hakyll.Hakyll
+ ( HakyllConfiguration (..)
+ , Hakyll
+ , askHakyll
+ ) where
+
+import Control.Monad.Reader (ReaderT, ask)
+import Control.Monad (liftM)
+
+import Text.Hakyll.Context (Context)
+
+-- | Hakyll global configuration type.
+data HakyllConfiguration = HakyllConfiguration
+ { -- | An additional context to use when rendering. This additional context
+ -- is used globally.
+ additionalContext :: Context
+ }
+
+-- | Our custom monad stack.
+type Hakyll = ReaderT HakyllConfiguration IO
+
+-- | Simplified @ask@ function for the Hakyll monad stack.
+askHakyll :: (HakyllConfiguration -> a) -> Hakyll a
+askHakyll = flip liftM ask
diff --git a/src/Text/Hakyll/Page.hs b/src/Text/Hakyll/Page.hs
index e807442..bae7fa6 100644
--- a/src/Text/Hakyll/Page.hs
+++ b/src/Text/Hakyll/Page.hs
@@ -9,18 +9,19 @@ module Text.Hakyll.Page
import qualified Data.Map as M
import qualified Data.List as L
import Data.Maybe (fromMaybe)
-
import Control.Parallel.Strategies (rdeepseq, ($|))
+import Control.Monad.Reader (liftIO)
+import System.FilePath (takeExtension)
+import System.IO (Handle, IOMode(..), openFile, hClose)
+import qualified System.IO.UTF8 as U
-import System.FilePath (FilePath, takeExtension)
-import System.IO
+import Text.Pandoc
+import Text.Hakyll.Hakyll (Hakyll)
import Text.Hakyll.File
import Text.Hakyll.Util (trim)
import Text.Hakyll.Context (Context)
import Text.Hakyll.Renderable
-import Text.Pandoc
-
-- | A Page is basically key-value mapping. Certain keys have special
-- meanings, like for example url, body and title.
@@ -65,9 +66,9 @@ renderFunction ext = writeHtmlString writerOptions
readFunction _ = readMarkdown
-- | Read metadata header from a file handle.
-readMetaData :: Handle -> IO [(String, String)]
+readMetaData :: Handle -> Hakyll [(String, String)]
readMetaData handle = do
- line <- hGetLine handle
+ line <- liftIO $ U.hGetLine handle
if isDelimiter line
then return []
else do others <- readMetaData handle
@@ -80,38 +81,48 @@ isDelimiter :: String -> Bool
isDelimiter = L.isPrefixOf "---"
-- | Used for caching of files.
-cachePage :: Page -> IO ()
+cachePage :: Page -> Hakyll ()
cachePage page@(Page mapping) = do
- let destination = toCache $ getURL page
makeDirectories destination
- handle <- openFile destination WriteMode
- hPutStrLn handle "---"
- mapM_ (writePair handle) $ M.toList $ M.delete "body" mapping
- hPutStrLn handle "---"
- hPutStr handle $ getBody page
- hClose handle
+ liftIO writePageToCache
where
- writePair h (k, v) = do hPutStr h $ k ++ ": " ++ v
- hPutStrLn h ""
+ (sectionMetaData, simpleMetaData) = M.partition (elem '\n')
+ (M.delete "body" mapping)
+
+ writePageToCache = do
+ handle <- openFile destination WriteMode
+ U.hPutStrLn handle "---"
+ mapM_ (writePair handle) $ M.toList simpleMetaData
+ mapM_ (writeSection handle) $ M.toList sectionMetaData
+ U.hPutStrLn handle "---"
+ U.hPutStrLn handle $ getBody page
+ hClose handle
+
+ writePair h (k, v) = do U.hPutStr h $ k ++ ": " ++ v
+ U.hPutStrLn h ""
+
+ writeSection h (k, v) = do U.hPutStrLn h $ "--- " ++ k
+ U.hPutStrLn h v
+
+ destination = toCache $ getURL page
-- | Read a page from a file. Metadata is supported, and if the filename
--- has a .markdown extension, it will be rendered using pandoc. Note that
--- pages are not templates, so they should not contain $identifiers.
-readPage :: FilePath -> IO Page
+-- has a @.markdown@ extension, it will be rendered using pandoc.
+readPage :: FilePath -> Hakyll Page
readPage pagePath = do
-- Check cache.
getFromCache <- isCacheValid cacheFile [pagePath]
let path = if getFromCache then cacheFile else pagePath
-- Read file.
- handle <- openFile path ReadMode
- line <- hGetLine handle
+ handle <- liftIO $ openFile path ReadMode
+ line <- liftIO $ U.hGetLine handle
(metaData, body) <-
if isDelimiter line
then do md <- readMetaData handle
- b <- hGetContents handle
+ b <- liftIO $ U.hGetContents handle
return (md, b)
- else do b <- hGetContents handle
+ else do b <- liftIO $ U.hGetContents handle
return ([], line ++ "\n" ++ b)
-- Render file
diff --git a/src/Text/Hakyll/Render.hs b/src/Text/Hakyll/Render.hs
index d8deea2..144c357 100644
--- a/src/Text/Hakyll/Render.hs
+++ b/src/Text/Hakyll/Render.hs
@@ -10,24 +10,23 @@ module Text.Hakyll.Render
, css
) where
-import Control.Monad (unless, mapM)
-
+import Control.Monad (unless)
+import Control.Monad.Reader (liftIO)
import System.Directory (copyFile)
-import System.IO
+import Text.Hakyll.Hakyll (Hakyll)
import Text.Hakyll.Context (ContextManipulation)
import Text.Hakyll.Page
import Text.Hakyll.Renderable
import Text.Hakyll.File
import Text.Hakyll.CompressCSS
-
import Text.Hakyll.Render.Internal
-- | Execute an IO action only when the cache is invalid.
depends :: FilePath -- ^ File to be rendered or created.
-> [FilePath] -- ^ Files the render depends on.
- -> IO () -- ^ IO action to execute when the file is out of date.
- -> IO ()
+ -> Hakyll () -- ^ IO action to execute when the file is out of date.
+ -> Hakyll ()
depends file dependencies action = do
valid <- isCacheValid (toDestination file) dependencies
unless valid action
@@ -36,7 +35,7 @@ depends file dependencies action = do
render :: Renderable a
=> FilePath -- ^ Template to use for rendering.
-> a -- ^ Renderable object to render with given template.
- -> IO Page -- ^ The body of the result will contain the render.
+ -> Hakyll Page -- ^ The body of the result will contain the render.
render = renderWith id
-- | Render to a Page. This function allows you to manipulate the context
@@ -45,61 +44,81 @@ renderWith :: Renderable a
=> ContextManipulation -- ^ Manipulation to apply on the context.
-> FilePath -- ^ Template to use for rendering.
-> a -- ^ Renderable object to render with given template.
- -> IO Page -- ^ The body of the result will contain the render.
+ -> Hakyll Page -- ^ The body of the result will contain the render.
renderWith manipulation templatePath renderable = do
- template <- readFile templatePath
+ template <- liftIO $ readFile templatePath
context <- toContext renderable
return $ fromContext $ pureRenderWith manipulation template context
--- | Render each renderable with the given template, then concatenate the
--- result.
-renderAndConcat :: Renderable a => FilePath -> [a] -> IO String
+-- | Render each renderable with the given templates, then concatenate the
+-- result. So, basically this function:
+--
+-- * Takes every renderable.
+--
+-- * Renders every renderable with all given templates. This is comparable
+-- with a renderChain action.
+--
+-- * Concatenates the result.
+--
+renderAndConcat :: Renderable a
+ => [FilePath] -- ^ Templates to apply on every renderable.
+ -> [a] -- ^ Renderables to render.
+ -> Hakyll String
renderAndConcat = renderAndConcatWith id
--- | Render each renderable with the given template, then concatenate the
+-- | Render each renderable with the given templates, then concatenate the
-- result. This function allows you to specify a "ContextManipulation" to
-- apply on every "Renderable".
renderAndConcatWith :: Renderable a
=> ContextManipulation
- -> FilePath
+ -> [FilePath]
-> [a]
- -> IO String
-renderAndConcatWith manipulation templatePath renderables = do
- template <- readFile templatePath
+ -> Hakyll String
+renderAndConcatWith manipulation templatePaths renderables = do
+ templates <- liftIO $ mapM readFile templatePaths
contexts <- mapM toContext renderables
- return $ pureRenderAndConcatWith manipulation template contexts
+ return $ pureRenderAndConcatWith manipulation templates contexts
-- | Chain a render action for a page with a number of templates. This will
-- also write the result to the site destination. This is the preferred way
-- to do general rendering.
-renderChain :: Renderable a => [FilePath] -> a -> IO ()
+--
+-- > renderChain [ "templates/notice.html"
+-- > , "templates/default.html"
+-- > ] $ createPagePath "warning.html"
+--
+-- This code will first render @warning.html@ using @templates/notice.html@,
+-- and will then render the result with @templates/default.html@.
+renderChain :: Renderable a => [FilePath] -> a -> Hakyll ()
renderChain = renderChainWith id
-- | A more custom render chain that allows you to specify a
-- "ContextManipulation" which to apply on the context when it is read first.
renderChainWith :: Renderable a
- => ContextManipulation -> [FilePath] -> a -> IO ()
+ => ContextManipulation -> [FilePath] -> a -> Hakyll ()
renderChainWith manipulation templatePaths renderable =
- depends (getURL renderable) (getDependencies renderable ++ templatePaths) $
- do templates <- mapM readFile templatePaths
- context <- toContext renderable
- let result = pureRenderChainWith manipulation templates context
- writePage $ fromContext result
+ depends (getURL renderable) dependencies render'
+ where
+ dependencies = (getDependencies renderable) ++ templatePaths
+ render' = do templates <- liftIO $ mapM readFile templatePaths
+ context <- toContext renderable
+ let result = pureRenderChainWith manipulation templates context
+ writePage $ fromContext result
-- | Mark a certain file as static, so it will just be copied when the site is
-- generated.
-static :: FilePath -> IO ()
+static :: FilePath -> Hakyll ()
static source = depends destination [source] action
where
destination = toDestination source
action = do makeDirectories destination
- copyFile source destination
+ liftIO $ copyFile source destination
-- | Render a css file, compressing it.
-css :: FilePath -> IO ()
+css :: FilePath -> Hakyll ()
css source = depends destination [source] css'
where
destination = toDestination source
- css' = do contents <- readFile source
+ css' = do contents <- liftIO $ readFile source
makeDirectories destination
- writeFile destination (compressCSS contents)
+ liftIO $ writeFile destination (compressCSS contents)
diff --git a/src/Text/Hakyll/Render/Internal.hs b/src/Text/Hakyll/Render/Internal.hs
index 8679dfb..b6810bb 100644
--- a/src/Text/Hakyll/Render/Internal.hs
+++ b/src/Text/Hakyll/Render/Internal.hs
@@ -11,17 +11,21 @@ module Text.Hakyll.Render.Internal
import qualified Data.Map as M
import Text.Hakyll.Context (Context, ContextManipulation)
+import Control.Monad.Reader (liftIO)
import Data.List (isPrefixOf, foldl')
import Data.Char (isAlpha)
import Data.Maybe (fromMaybe)
import Control.Parallel.Strategies (rdeepseq, ($|))
+import qualified System.IO.UTF8 as U
+
import Text.Hakyll.Renderable
import Text.Hakyll.Page
import Text.Hakyll.File
+import Text.Hakyll.Hakyll
--- | Substitutes `$identifiers` in the given string by values from the given
+-- | Substitutes @$identifiers@ in the given string by values from the given
-- "Context". When a key is not found, it is left as it is. You can here
--- specify the characters used to replace escaped dollars `$$`.
+-- specify the characters used to replace escaped dollars (@$$@).
substitute :: String -> String -> Context -> String
substitute _ [] _ = []
substitute escaper string context
@@ -58,14 +62,14 @@ pureRenderWith manipulation template context =
-- | A pure renderAndConcat function.
pureRenderAndConcatWith :: ContextManipulation
- -> String -- ^ Template to use.
+ -> [String] -- ^ Templates to use.
-> [Context] -- ^ Different renderables.
-> String
-pureRenderAndConcatWith manipulation template contexts =
+pureRenderAndConcatWith manipulation templates contexts =
foldl' renderAndConcat [] contexts
where
renderAndConcat chunk context =
- let rendered = pureRenderWith manipulation template context
+ let rendered = pureRenderChainWith manipulation templates context
in chunk ++ fromMaybe "" (M.lookup "body" rendered)
-- | A pure renderChain function.
@@ -79,13 +83,13 @@ pureRenderChainWith manipulation templates context =
-- | Write a page to the site destination. Final action after render
-- chains and such.
-writePage :: Page -> IO ()
+writePage :: Page -> Hakyll ()
writePage page = do
+ additionalContext' <- askHakyll additionalContext
let destination = toDestination url
+ context = additionalContext' `M.union` (M.singleton "root" $ toRoot url)
makeDirectories destination
- writeFile destination body
+    -- Substitute $root here, just before writing.
+ liftIO $ U.writeFile destination $ finalSubstitute (getBody page) context
where
url = getURL page
-    -- Substitute $root here, just before writing.
-    body = finalSubstitute (getBody page)
-                           (M.singleton "root" $ toRoot url)
diff --git a/src/Text/Hakyll/Renderable.hs b/src/Text/Hakyll/Renderable.hs
index c8e780e..bb4f71f 100644
--- a/src/Text/Hakyll/Renderable.hs
+++ b/src/Text/Hakyll/Renderable.hs
@@ -2,13 +2,13 @@ module Text.Hakyll.Renderable
( Renderable(toContext, getDependencies, getURL)
) where
-import System.FilePath (FilePath)
+import Text.Hakyll.Hakyll (Hakyll)
import Text.Hakyll.Context (Context)
-- | A class for datatypes that can be rendered to pages.
class Renderable a where
-- | Get a context to do substitutions with.
- toContext :: a -> IO Context
+ toContext :: a -> Hakyll Context
-- | Get the dependencies for the renderable. This is used for cache
-- invalidation.
diff --git a/src/Text/Hakyll/Renderables.hs b/src/Text/Hakyll/Renderables.hs
index 26d1e86..0151f10 100644
--- a/src/Text/Hakyll/Renderables.hs
+++ b/src/Text/Hakyll/Renderables.hs
@@ -5,8 +5,9 @@ module Text.Hakyll.Renderables
, createPagePath
) where
-import System.FilePath (FilePath)
import qualified Data.Map as M
+
+import Text.Hakyll.Hakyll (Hakyll)
import Text.Hakyll.Page
import Text.Hakyll.Renderable
import Text.Hakyll.File
@@ -15,13 +16,19 @@ import Text.Hakyll.File
data CustomPage = CustomPage
{ url :: String,
dependencies :: [FilePath],
- mapping :: [(String, Either String (IO String))]
+ mapping :: [(String, Either String (Hakyll String))]
}
-- | Create a custom page.
+--
+-- The association list given maps keys to values for substitution. Note
+-- that as value, you can either give a @String@ or a @Hakyll String@.
+-- A @Hakyll String@ is preferred for more complex data, since it allows
+-- dependency checking. A @String@ is obviously more simple to use in some
+-- cases.
createCustomPage :: String -- ^ Destination of the page, relative to _site.
-> [FilePath] -- ^ Dependencies of the page.
- -> [(String, Either String (IO String))] -- ^ Key - value mapping for rendering.
+ -> [(String, Either String (Hakyll String))] -- ^ Mapping.
-> CustomPage
createCustomPage = CustomPage
diff --git a/src/Text/Hakyll/Tags.hs b/src/Text/Hakyll/Tags.hs
index 625584e..e15a41f 100644
--- a/src/Text/Hakyll/Tags.hs
+++ b/src/Text/Hakyll/Tags.hs
@@ -9,17 +9,19 @@ module Text.Hakyll.Tags
import qualified Data.Map as M
import Data.List (intercalate)
import Control.Monad (foldM)
+import Control.Arrow (second)
+import Text.Hakyll.Hakyll (Hakyll)
import Text.Hakyll.Context (ContextManipulation, renderValue)
+import Text.Hakyll.Render.Internal (finalSubstitute)
import Text.Hakyll.Regex
import Text.Hakyll.Util
import Text.Hakyll.Page
-import Control.Arrow (second)
-- | Read a tag map. This creates a map from tags to page paths. This function
--- assumes the tags are located in the `tags` metadata field, separated by
+-- assumes the tags are located in the @tags@ metadata field, separated by
-- commas.
-readTagMap :: [FilePath] -> IO (M.Map String [FilePath])
+readTagMap :: [FilePath] -> Hakyll (M.Map String [FilePath])
readTagMap paths = foldM addPaths M.empty paths
where
addPaths current path = do
@@ -28,8 +30,8 @@ readTagMap paths = foldM addPaths M.empty paths
return $ foldr (\t -> M.insertWith (++) t [path]) current tags
-- | Render a tag cloud.
-renderTagCloud :: M.Map String [FilePath] -- ^ A tag map as produced by 'readTagMap'.
- -> (String -> String) -- ^ Function that produces an url for a tag.
+renderTagCloud :: M.Map String [FilePath] -- ^ Map as produced by "readTagMap".
+ -> (String -> String) -- ^ Function to produce an url for a tag.
-> Float -- ^ Smallest font size, in percent.
-> Float -- ^ Biggest font size, in percent.
-> String -- ^ Result of the render.
@@ -37,10 +39,12 @@ renderTagCloud tagMap urlFunction minSize maxSize =
intercalate " " $ map renderTag tagCount
where
renderTag :: (String, Float) -> String
- renderTag (tag, count) = "<a style=\"font-size: "
- ++ sizeTag count ++ "\" href=\""
- ++ urlFunction tag ++ "\">"
- ++ tag ++ "</a>"
+ renderTag (tag, count) =
+ finalSubstitute "<a style=\"font-size: $size\" href=\"$url\">$tag</a>" $
+ M.fromList [ ("size", sizeTag count)
+ , ("url", urlFunction tag)
+ , ("tag", tag)
+ ]
sizeTag :: Float -> String
sizeTag count = show size' ++ "%"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-09 04:31:58 +0000