diff --git a/haggis.cabal b/haggis.cabal --- a/haggis.cabal +++ b/haggis.cabal @@ -1,5 +1,5 @@ name: haggis -version: 0.1.1.1 +version: 0.1.1.2 synopsis: A static site generator with blogging/comments support homepage: http://github.com/tych0/haggis license: MIT diff --git a/src/Text/Haggis.hs b/src/Text/Haggis.hs --- a/src/Text/Haggis.hs +++ b/src/Text/Haggis.hs @@ -18,7 +18,6 @@ import Text.XmlHtml -import Text.Haggis.Binders import Text.Haggis.Comments import Text.Haggis.Config import Text.Haggis.Parse @@ -47,7 +46,7 @@ sequence_ $ map writePage ps sequence_ $ map writeMultiPage mps where - wrapper = bindSpecial config mps $ root (siteTemplates config) + wrapper = getBindSpecial config mps $ root (siteTemplates config) writeThing fp title ns = do let xform = hq "#content *" (Group ns) . hq "title *" title html = xform $ wrapper @@ -56,21 +55,21 @@ BS.writeFile path $ renderHtml html writePage :: Page -> IO () writePage p = - let content = bindPage config p $ single (siteTemplates config) + let content = getBindPage config p $ single (siteTemplates config) in writeThing (pagePath p) (pageTitle p) content writeMultiPage :: MultiPage -> IO () writeMultiPage mp = - let xform = hq ".page *" $ map (bindPage config) $ singlePages mp + let xform = hq ".page *" $ map (getBindPage config) $ singlePages mp content = xform $ multiple (siteTemplates config) path = mpTypeToPath $ multiPageType mp - in writeThing path (mpTypeToTitle $ multiPageType mp) content + in writeThing path (mpTypeToTitle config $ multiPageType mp) content ensureDirExists :: FilePath -> IO () ensureDirExists = createDirectoryIfMissing True . dropFileName generateSpecial :: HaggisConfig -> [MultiPage] -> [Page] generateSpecial config mps = - let bind = bindSpecial config mps + let bind = getBindSpecial config mps archivesContent = bind (archivesTemplate $ siteTemplates config) archives = plainPage "Archives" "./archives/index.html" archivesContent tagsContent = bind (tagsTemplate $ siteTemplates config) diff --git a/src/Text/Haggis/Binders.hs b/src/Text/Haggis/Binders.hs --- a/src/Text/Haggis/Binders.hs +++ b/src/Text/Haggis/Binders.hs @@ -15,7 +15,7 @@ import Text.Pandoc.Readers.Markdown import Text.Pandoc.Options -import Text.Haggis.Types +import Text.Haggis.Types hiding (bindPage, bindComment, bindTag, bindSpecial) import Text.Haggis.Utils import Text.Hquery import Text.XmlHtml @@ -31,7 +31,7 @@ } = let bindTags = if null tags then hq ".tags" nothing - else hq ".tag *" (map (bindTag config) tags) + else hq ".tag *" $ addCommas (map (bindTag config) tags) auth = maybe (defaultAuthor config) Just author in hq ".title *" title . bindTags . @@ -52,8 +52,14 @@ nameBind Nothing = hq ".name" (commenterName c) bindTag :: HaggisConfig -> String -> [Node] -> [Node] bindTag config t = hq "a [href]" (sitePath config (mpTypeToPath $ Tag t)) . - hq "a *" (t ++ ", ") + hq "a *" (t) +addCommas :: [[Node] -> [Node]] -> [[Node] -> [Node]] +addCommas ns | not (null ns) = let l = last ns + is = init ns + in map (hq "* +" ", " .) is ++ [l] +addCommas ns = ns + bindSpecial :: HaggisConfig -> [MultiPage] -> [Node] -> [Node] bindSpecial config mps = let (archives, tags) = bindAggregates in hq ".tag" tags . hq ".archive *" archives @@ -64,7 +70,8 @@ hq "a *" (show y ++ " - " ++ show m) bind (MultiPage xs typ@(Tag t)) = Right $ hq ".tag [href]" (sitePath config mpTypeToPath typ) . - hq ".tag *" (t ++ " (" ++ show (length xs) ++ "), ") + hq ".tag *" (t ++ " (" ++ show (length xs) ++ ")") bind _ = Left $ hq "*" nothing - in partitionEithers $ map bind mps + (archives, tags) = partitionEithers $ map bind mps + in (archives, addCommas tags) diff --git a/src/Text/Haggis/Comments.hs b/src/Text/Haggis/Comments.hs --- a/src/Text/Haggis/Comments.hs +++ b/src/Text/Haggis/Comments.hs @@ -16,8 +16,6 @@ import qualified Data.Traversable as T import Data.Typeable -import Prelude hiding (catch) - import System.FilePath import Text.Haggis.Types diff --git a/src/Text/Haggis/Config.hs b/src/Text/Haggis/Config.hs --- a/src/Text/Haggis/Config.hs +++ b/src/Text/Haggis/Config.hs @@ -1,11 +1,15 @@ module Text.Haggis.Config ( parseConfig, rootUri, - readTemplates + readTemplates, + getBindPage, + getBindTag, + getBindComment, + getBindSpecial, ) where import Control.Applicative -import Control.Exception +import qualified Control.Exception as E import qualified Data.Map.Lazy as M import Data.Maybe @@ -13,25 +17,27 @@ import Network.URI -import Prelude hiding (catch) - import System.FilePath import System.IO import Text.Haggis.Parse import Text.Haggis.Types +import qualified Text.Haggis.Binders as Bind import Text.Parsec +import Text.XmlHtml parseConfig :: FilePath -> SiteTemplates -> IO HaggisConfig parseConfig fp ts = do - inp <- catch (readFile fp) - (\e -> do let err = show (e :: IOException) + inp <- E.catch (readFile fp) + (\e -> do let err = show (e :: E.IOException) hPutStr stderr ("Problem reading: " ++ err) return "") let kvs = dieOnParseError fp $ parse keyValueParser "" inp return $ buildConfig (M.fromList kvs) ts -buildConfig :: M.Map String String -> SiteTemplates -> HaggisConfig +buildConfig :: M.Map String String + -> SiteTemplates + -> HaggisConfig buildConfig kvs = let get = (flip M.lookup) kvs in HaggisConfig (fromMaybe "/" $ get "sitePath") (get "defaultAuthor") @@ -39,6 +45,12 @@ (get "rssTitle") (get "rssDescription") (get "sqlite3File") + (get "indexTitle") + -- binders + Nothing + Nothing + Nothing + Nothing rootUri :: HaggisConfig -> Maybe URI rootUri c = siteHost c >>= \h -> parseURI $ "http://" ++ pappend h (sitePath c) @@ -56,3 +68,14 @@ <*> readTemplate (fp "tags.html") <*> readTemplate (fp "archives.html") +getBindPage :: HaggisConfig -> Page -> [Node] -> [Node] +getBindPage c = fromMaybe (Bind.bindPage c) (bindPage c) + +getBindTag :: HaggisConfig -> String -> [Node] -> [Node] +getBindTag c = fromMaybe (Bind.bindTag c) (bindTag c) + +getBindComment :: HaggisConfig -> Comment -> [Node] -> [Node] +getBindComment c = fromMaybe Bind.bindComment (bindComment c) + +getBindSpecial :: HaggisConfig -> [MultiPage] -> [Node] -> [Node] +getBindSpecial c = fromMaybe (Bind.bindSpecial c) (bindSpecial c) diff --git a/src/Text/Haggis/Types.hs b/src/Text/Haggis/Types.hs --- a/src/Text/Haggis/Types.hs +++ b/src/Text/Haggis/Types.hs @@ -60,10 +60,10 @@ let month = fromMaybe "index" $ fmap show m in "archives" show y month <.> "html" -mpTypeToTitle :: MultiPageType -> String -mpTypeToTitle (Tag t) = "Tagged: " ++ t -mpTypeToTitle (DirIndex d) = "Filed under: " ++ d -mpTypeToTitle (Archive y m) = +mpTypeToTitle :: HaggisConfig -> MultiPageType -> String +mpTypeToTitle _ (Tag t) = "Tagged: " ++ t +mpTypeToTitle conf (DirIndex d) = fromMaybe ("Filed under: " ++ d) (indexTitle conf) +mpTypeToTitle _ (Archive y m) = let month = fromMaybe "" $ fmap ((" - " ++) . show) m in "Posts from: " ++ (show y) ++ month @@ -82,7 +82,7 @@ defaultAuthor :: Maybe String, -- | Hostname where the blog is hosted, used for generating RSS feed links. - -- E.g. blog.example.com + -- E.g. blog.example.com, blog.example.com:8080 siteHost :: Maybe String, rssTitle :: Maybe String, rssDescription :: Maybe String, @@ -90,8 +90,17 @@ -- | Sqlite3 file name, for comments. sqlite3File :: Maybe FilePath, + -- | Index page title. + indexTitle :: Maybe String, + + -- * Custom binders for pages. See "Text.Haggis.Binders" for the defaults. + bindPage :: Maybe (Page -> [Node] -> [Node]), + bindTag :: Maybe (String -> [Node] -> [Node]), + bindComment :: Maybe (Comment -> [Node] -> [Node]), + bindSpecial :: Maybe ([MultiPage] -> [Node] -> [Node]), + siteTemplates :: SiteTemplates -} deriving (Show) +} data Comment = Comment { commenterName :: String,