{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Hakyll.Web.Template.DirList
(
Configuration (..)
, defaultConfiguration
, metadataConfiguration
, dirListField
) where
import Control.Monad (liftM)
import Data.List (sortBy)
import Data.Ord (comparing)
import Hakyll ( MonadMetadata, Identifier
, Item, itemIdentifier, field
, getMetadata, lookupString, listField
, toFilePath, Metadata, Compiler, Context
, splitAll)
import System.FilePath ( dropExtensions
, splitDirectories
, takeBaseName)
import Data.Maybe ( fromMaybe)
import qualified Data.Map as M
import Data.Default (Default (..))
data Configuration = Configuration
{
beginItemTag :: Int -> String
, endItemTag :: Int -> String
, beginCollectionTag :: Int -> String
, endCollectionTag :: Int -> String
}
instance Default Configuration where
def = defaultConfiguration
defaultConfiguration :: Configuration
defaultConfiguration = Configuration
{ beginItemTag = \_ -> "<li>"
, endItemTag = \_ -> "</li>"
, beginCollectionTag = \_ -> "<ul>"
, endCollectionTag = \_ -> "</ul>"
}
metadataConfiguration :: Metadata -> Configuration -> Configuration
metadataConfiguration md default' =
Configuration
( f "beginItemTag" ( beginItemTag default' ) )
( f "endItemTag" ( endItemTag default' ) )
( f "beginCollectionTag" ( beginCollectionTag default' ) )
( f "endCollectionTag" ( endCollectionTag default' ) )
where
del = fromMaybe "," (lookupString "tagDelimiter" md)
f :: String -> ( Int -> String ) -> ( Int -> String )
f tag df =
case lookupString tag md of
Nothing -> df
Just s -> g ( splitAll del s )
g :: [String] -> Int -> String
g (x:[]) _ = t x
g (x:_) 0 = t x
g (_:xs) l = g xs (l - 1)
g [] _ = "<???>"
t :: String -> String
t x = if x == "--" then "" else x
alphabetical :: MonadMetadata m => [Item a] -> m [Item a]
alphabetical =
sortByM $ getItemPath . itemIdentifier
where
sortByM :: (Monad m, Ord k) => (a -> m k) -> [a] -> m [a]
sortByM f xs = liftM (map fst . sortBy (comparing snd)) $
mapM (\x -> liftM (x,) (f x)) xs
getItemPath :: MonadMetadata m
=> Identifier
-> m FilePath
getItemPath id' = return $ toFilePath id'
data ItemTree a = ItemTree (Item a) [ItemTree a] String String
type ItemPath a = ( Item a, [FilePath])
itemPath :: [ Item a] -> [ ItemPath a]
itemPath =
map (\i -> ( i, splitDirectories
. dropExtensions . toFilePath . itemIdentifier $ i) )
getTreeFiles :: [ ItemPath a] -> ( [ItemPath a], [ItemPath a])
getTreeFiles [] = ( [], [])
getTreeFiles (p:ps)
| (length $ snd p) > 1 = getTreeFiles ps
| otherwise = getTreeFiles' ( head . snd $ p ) ([],p:ps)
getTreeFiles' :: FilePath -> ([ItemPath a], [ItemPath a])
-> ( [ItemPath a], [ItemPath a])
getTreeFiles' _ ( ts, [] ) = ( ts, [])
getTreeFiles' a ( ts, p:ps )
| (head $ snd p ) == a = getTreeFiles' a ( ts ++ [p] , ps)
| otherwise = ( ts, p:ps )
buildTree :: MonadMetadata m => String -> [ItemPath a] -> m (ItemTree a)
buildTree parentPid (p:ps) = do
pid <- getItemPageId id'
ord <- getItemPageOrder id'
tl <- buildOrderedTreeList (parentPid' ++ pid) ( map (\x->(fst x, tail $ snd x)) ps)
return $ ItemTree (fst p) tl (parentPid' ++ pid) ord
where
id' = itemIdentifier $ fst p
parentPid' = if parentPid == "" then "" else parentPid ++ "-"
buildTree _ [] = error "buildTree: empty file list"
buildTreeList :: MonadMetadata m => String -> [ItemPath a] -> m [ItemTree a]
buildTreeList _ [] = return []
buildTreeList parentPid ps = do
t <- buildTree parentPid ts
tl <- buildTreeList parentPid rs
return $ t : tl
where ( ts, rs) = getTreeFiles ps
buildOrderedTreeList :: MonadMetadata m => String -> [ItemPath a] -> m [ItemTree a]
buildOrderedTreeList _ [] = return []
buildOrderedTreeList parentPid ps = do
tl <- buildTreeList parentPid ps
return $ sortBy (comparing (\( ItemTree _ _ _ o)-> o)) tl
data TreeContext = TreeContext String String String deriving Show
getItemTreeAList :: Configuration -> ItemTree a -> Int
-> String -> String -> [(Item a, TreeContext)]
getItemTreeAList cfg ( ItemTree i [] pid _ ) level btags etags =
[( i, TreeContext pid (btags ++ (beginItemTag cfg) level)
((endItemTag cfg) level ++ etags))]
getItemTreeAList cfg ( ItemTree i ts pid _ ) level btags etags =
( i, TreeContext pid (btags ++ (beginItemTag cfg) level) "")
: (getItemTreeListAList cfg (level+1) ((endItemTag cfg) level ++ etags) ts)
callGetItemTreeListAList :: Configuration -> [ ItemTree a ]
-> [(Item a, TreeContext)]
callGetItemTreeListAList cfg = getItemTreeListAList cfg 0 ""
getItemTreeListAList :: Configuration -> Int -> String
-> [ ItemTree a ] -> [(Item a, TreeContext)]
getItemTreeListAList _ _ _ [] = []
getItemTreeListAList cfg level etags (t:[]) =
getItemTreeAList cfg t level
((beginCollectionTag cfg) level)
((endCollectionTag cfg) level ++ etags)
getItemTreeListAList cfg level etags (t:ts) =
(getItemTreeAList cfg t level ((beginCollectionTag cfg) level) "")
++ (getItemTreeListAList' cfg level
((endCollectionTag cfg) level ++ etags) ts)
getItemTreeListAList' :: Configuration -> Int -> String
-> [ ItemTree a ] -> [(Item a, TreeContext)]
getItemTreeListAList' _ _ _ [] = []
getItemTreeListAList' cfg level etags (t:[]) =
getItemTreeAList cfg t level "" etags
getItemTreeListAList' cfg level etags (t:ts) =
( getItemTreeAList cfg t level "" "")
++ ( getItemTreeListAList' cfg level etags ts)
getItemPageId :: MonadMetadata m => Identifier -> m String
getItemPageId id' = do
metadata <- getMetadata id'
return $ fromMaybe
( takeBaseName $ toFilePath id' )
( lookupString "page-id" metadata )
getItemPageOrder :: MonadMetadata m => Identifier -> m String
getItemPageOrder id' = do
metadata <- getMetadata id'
pageId <- getItemPageId id'
return $ fromMaybe pageId ( lookupString "page-order" metadata)
dirListField :: Configuration -> String -> Context a
-> Compiler [Item a] -> Context b
dirListField cfg key c xs = listField key ( c' `mappend` c) pages'
where
pages = alphabetical =<< xs
treeList = (buildOrderedTreeList "") =<<
map (\ip-> (fst ip, tail . snd $ ip)) <$> itemPath <$> pages
aList = callGetItemTreeListAList cfg <$> treeList
pages' = (map fst) <$> aList
aList' = map (\(item,ct)->(itemIdentifier item,ct)) <$> aList
idMap = M.fromList <$> aList'
c' =
( field "full-page-id"
( \i -> ( (\(Just (TreeContext pid _ _))->pid)
. ( M.lookup (itemIdentifier i) ) ) <$> idMap ) ) `mappend`
( field "begin-tags"
( \i -> ( (\(Just (TreeContext _ b _))->b)
. ( M.lookup (itemIdentifier i) ) ) <$> idMap ) ) `mappend`
( field "end-tags"
( \i -> ( (\(Just (TreeContext _ _ e))->e)
. ( M.lookup (itemIdentifier i) ) ) <$> idMap ) )