Implement customizable texts

hablo.cabal

@@ -18,6 +18,7 @@ extra-source-files:  CHANGELOG.md
 build-type:          Simple
 data-dir:            share
 data-files:          js/*.js
+                     defaultWording.conf
 
 executable hablo
   main-is:             Main.hs
@@ -27,6 +28,7 @@ executable hablo
                      , Blog
                      , Blog.Path
                      , Blog.Skin
+                     , Blog.Wording
                      , Dom
                      , Files
                      , HTML
@@ -45,6 +47,7 @@ executable hablo
                      , mtl
                      , optparse-applicative
                      , parsec
+                     , template
                      , text
                      , time
                      , unix

share/defaultWording.conf

@@ -0,0 +1,7 @@
+allLink = See all
+allPage = All articles
+allTaggedPage = All articles tagged ${tag}
+latestLink = See only latest
+latestPage = Latest articles
+latestTaggedPage = Latest articles tagged ${tag}
+tagsList = Tags

share/js/domRenderer.js

@@ -64,7 +64,12 @@ function DomRenderer(modules) {
 	}
 
 	function pageTitle(tag, all) {
-		return (all ? 'All' : 'Latest') + ' articles' + (tag != undefined ? ' tagged ' + tag : '');
+		if(tag != undefined) {
+			var template = blog.wording[all ? 'allTaggedPage' : 'latestTaggedPage'];
+			return template.replace(/([^$]|^)\$(?:{tag}|tag([^a-zA-Z]|$))/, '$1' + tag + '$2');
+		} else {
+			return blog.wording[all ? 'allPage' : 'latestPage'];
+		}
 	}
 
 	function otherUrl(tag, all) {
@@ -78,7 +83,7 @@ function DomRenderer(modules) {
 				modules.dom.make('h2', {innerText: pageTitle(tag, all)}),
 				modules.dom.make('a', {
 					class: 'navigation',
-					innerText: all ? 'See only latest' : 'See all',
+					innerText: all ? blog.wording.latestLink : blog.wording.allLink,
 					href: otherUrl(tag, all)
 				}),
 				modules.dom.make('div', {class: 'articles'}, articlePreviews.filter(modules.fun.defined))

src/Arguments.hs

@@ -25,6 +25,7 @@ data Arguments = BlogConfig {
     , pagesPath :: Maybe FilePath
     , previewArticlesCount :: Int
     , previewLinesCount :: Int
+    , wording :: Maybe FilePath
   }
   | Version
 
@@ -70,6 +71,7 @@ blogConfig = BlogConfig
         <> long "preview-lines"
         <> help "number of lines to display in articles preview"
       )
+  <*> option filePath 'w' "wording" "WORDING" "path to the file containing the wording to use"
 
 version :: Parser Arguments
 version = flag' Version (

src/ArticlesList.hs

@@ -1,12 +1,19 @@
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 module ArticlesList (
       ArticlesList(..)
-    , otherLink
     , otherUrl
     , pageTitle
   ) where
 
 import Article (Article)
+import Blog (Blog(..), Wording(..), get)
+import Control.Monad.Reader (MonadReader)
+import Data.Text (Text, pack)
+import Data.Text.Lazy (toStrict)
+import Data.Text.Template (render)
+import Pretty ((.$))
 import System.FilePath.Posix ((</>))
 
 data ArticlesList = ArticlesList {
@@ -23,12 +30,11 @@ otherUrl (ArticlesList {full, tagged}) =
   where
     url = maybe "/" ("/" </>)
 
-otherLink :: ArticlesList -> String
+pageTitle :: (MonadReader Blog m) => ArticlesList -> m Text
-otherLink (ArticlesList {full}) =
+pageTitle (ArticlesList {full, tagged}) = do
-  if full
+  template <- Blog.get $wording.$(if full then allTaggedPage else latestTaggedPage)
-    then "See only latest"
+  untagged <- Blog.get $wording.$(if full then allPage else latestPage)
-    else "See all"
+  return $ maybe untagged (toStrict . render template . tag) tagged
-
+  where
-pageTitle :: ArticlesList -> String
+    tag :: String -> Text -> Text
-pageTitle (ArticlesList {full, tagged}) =
+    tag t = \"tag"  -> pack t
-  (if full then "All" else "Latest") ++ " articles" ++ maybe "" (" tagged " ++) tagged

src/Blog.hs

@@ -4,6 +4,7 @@ module Blog (
       Blog(..)
     , Path(..)
     , Skin(..)
+    , Wording(..)
     , build
     , get
   ) where
@@ -16,11 +17,13 @@ import Blog.Path (Path(..))
 import qualified Blog.Path as Path (build)
 import Blog.Skin (Skin(..))
 import qualified Blog.Skin as Skin (build)
+import Blog.Wording (Wording(..))
+import qualified Blog.Wording as Wording (build)
 import Control.Monad ((>=>), filterM, forM)
 import Control.Monad.Reader (MonadReader, ask)
 import Data.Either (rights)
-import Data.Map (Map)
+import Data.Map (Map, (!?))
-import qualified Data.Map as Map (fromList, member)
+import qualified Data.Map as Map (fromList)
 import Data.Set (Set)
 import qualified Data.Set as Set (empty, null, singleton, union)
 import qualified Files (find)
@@ -35,6 +38,7 @@ data Blog = Blog {
     , path :: Path
     , skin :: Skin
     , tags :: Map String (Set String)
+    , wording :: Wording
   }
 
 get :: MonadReader Blog m => (Blog -> a) -> m a
@@ -58,17 +62,18 @@ tagged collection path = do
     fileExists <- doesFileExist link
     return $ if fileExists
       then let articleKey = Article.getKey link in
-        if Map.member articleKey collection then Set.singleton articleKey else Set.empty
+        maybe Set.empty (\_ -> Set.singleton articleKey) (collection !? articleKey)
       else Set.empty
   return (takeFileName path, foldl Set.union Set.empty keys)
 
 build :: Arguments -> IO Blog
 build arguments = withCurrentDirectory (root path) $ do
   skin <- Skin.build name arguments
+  wording <- Wording.build arguments
   articles <- findArticles $ articlesPath path
   tags <- Map.fromList . filter (not . Set.null . snd)
     <$> (Files.find (articlesPath path </> "tags") >>= mapM (articles `tagged`))
-  return $ Blog {articles, name, path, skin, tags}
+  return $ Blog {articles, name, path, skin, tags, wording}
   where
     path = Path.build arguments
     name = maybe (takeFileName . dropTrailingPathSeparator $ root path) id

src/Blog/Wording.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Blog.Wording (
+      Wording(..)
+    , build
+  ) where
+
+import Arguments (Arguments(..))
+import Control.Monad (foldM)
+import Data.List (intercalate)
+import Data.Map (Map, (!))
+import qualified Data.Map as Map (empty, fromList, map, union)
+import Data.Text (Text)
+import qualified Data.Text as Text (pack, unpack)
+import Data.Text.Template (Template, renderA, templateSafe)
+import Paths_hablo (getDataFileName)
+import Text.ParserCombinators.Parsec (
+      Parser
+    , (<|>)
+    , char, choice, endBy, many, many1, noneOf, parse, string, try
+  )
+import System.Exit (die)
+
+data Wording = Wording {
+      allLink :: Text
+    , allPage :: Text
+    , allTaggedPage :: Template
+    , latestLink :: Text
+    , latestPage :: Text
+    , latestTaggedPage :: Template
+    , tagsList :: Text
+  }
+
+keys :: [Parser String]
+keys = try . string <$> [
+      "allLink"
+    , "allPage"
+    , "allTaggedPage"
+    , "latestLink"
+    , "latestPage"
+    , "latestTaggedPage"
+    , "tagsList"
+  ]
+
+addWording :: Map String Text -> FilePath -> IO (Map String Text)
+addWording currentWording wordingFile = do
+  parsed <- parse wordingP wordingFile <$> readFile wordingFile
+  case parsed of
+    Left errorMessage -> die $ show errorMessage
+    Right newWording -> return $ Map.union currentWording newWording
+
+wordingP :: Parser (Map String Text)
+wordingP = Map.map Text.pack . Map.fromList <$> (many eol *> line `endBy` (many1 eol))
+  where
+    line = (,) <$> (choice keys <* equal) <*> many (noneOf "\r\n")
+    equal = many (char ' ') *> char '=' *> many (char ' ')
+    eol = try (string "\r\n") <|> string "\r" <|> string "\n"
+
+checkTemplateWith :: [Text] -> String -> Map String Text -> IO Template
+checkTemplateWith variables key wording =
+  let templateText = wording ! key in
+  let testEnvironment = flip lookup [(s, "") | s <- variables] in
+  case templateSafe templateText of
+    Left (row, col) -> die $ syntaxError (show row) (show col)
+    Right template ->
+      maybe (die badTemplate) (return . const template) (renderA template testEnvironment)
+  where
+    availableVariables =
+      " (available variables: " ++ intercalate ", " (Text.unpack <$> variables) ++ ")"
+    syntaxError row col =
+      "Syntax error in template for variable " ++ key ++ "at l." ++ row ++ ", c." ++ col 
+    badTemplate = "Invalid template for variable " ++ key ++ availableVariables
+
+build :: Arguments -> IO Wording
+build arguments = do
+  defaultWording <- getDataFileName "defaultWording.conf"
+  let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording]
+  wording <- foldM addWording Map.empty wordingFiles
+  allTaggedPage <- checkTemplateWith ["tag"] "allTaggedPage" wording
+  latestTaggedPage <- checkTemplateWith ["tag"] "latestTaggedPage" wording
+  return Wording {
+        allLink = wording ! "allLink"
+      , allPage = wording ! "allPage"
+      , allTaggedPage
+      , latestLink = wording ! "latestLink"
+      , latestPage = wording ! "latestPage"
+      , latestTaggedPage
+      , tagsList = wording ! "tagsList"
+    }

src/Dom.hs

@@ -6,13 +6,13 @@ module Dom (
 
 import Article (Article(..))
 import qualified Article (preview)
-import ArticlesList (ArticlesList(..), otherLink, otherUrl, pageTitle)
+import ArticlesList (ArticlesList(..), otherUrl, pageTitle)
-import Blog (Blog(..), Path(..), Skin(..))
+import Blog (Blog(..), Path(..), Skin(..), Wording(..))
 import qualified Blog (get)
 import Control.Monad.Reader (ReaderT)
 import qualified Data.Map as Map (keys)
 import Data.Monoid ((<>))
-import Data.Text (pack, empty)
+import Data.Text (Text, pack, empty)
 import Lucid
 import Lucid.Base (makeAttribute)
 import Prelude hiding (head)
@@ -27,23 +27,24 @@ class Page a where
 
 instance Page Article where
   card (Article {title}) =
-    ("A new article on " <>) <$> Blog.get name
+    makeCard title =<< (Blog.get $name.$("A new article on " <>).$pack)
-    >>= makeCard title
 
   content = article True
 
 instance Page ArticlesList where
   card al = do
     blogName <- Blog.get name
-    makeCard (maybe blogName ((blogName ++ " - ") ++) $ tagged al) (pageTitle al)
+    makeCard (maybe blogName ((blogName ++ " - ") ++) $ tagged al) =<< pageTitle al
 
-  content al@(ArticlesList {featured}) = do
+  content al@(ArticlesList {featured, full}) = do
     preview <- Article.preview <$> (Blog.get $skin.$previewLinesCount)
-    h2_ . toHtml . pack $ pageTitle al
+    h2_ . toHtml =<< pageTitle al
-    navigationA [href_ . pack $ otherUrl al] . toHtml . pack $ otherLink al
+    navigationA [href_ . pack $ otherUrl al] . toHtml =<< otherLink
     div_ [class_ "articles"] (
         mapM_ (article False . preview) featured
       )
+    where
+      otherLink = Blog.get $wording.$(if full then latestLink else allLink)
 
 article :: Bool -> Article -> HtmlGenerator ()
 article raw (Article {key, body, title}) = do
@@ -57,14 +58,14 @@ article raw (Article {key, body, title}) = do
   where
     (aElem, extension) = if raw then (a_, "md") else (navigationA, "html")
 
-makeCard :: String -> String -> HtmlGenerator ()
+makeCard :: String -> Text -> HtmlGenerator ()
 makeCard title description = do
-  og "title" title
+  og "title" $ pack title
   og "description" description
-  og "image" =<< (Blog.get $skin.$cardImage)
+  og "image" =<< (Blog.get $skin.$cardImage.$pack)
-  og "site_name" =<< Blog.get name
+  og "site_name" =<< (Blog.get $name.$pack)
   where
-    og attribute value = meta_ [makeAttribute "property" $ "og:" <> attribute , content_ $ pack value]
+    og attribute value = meta_ [makeAttribute "property" $ "og:" <> attribute , content_ value]
 
 navigationA :: Term arg result => arg -> result
 navigationA = "a" `termWith` [class_ "navigation"]
@@ -97,9 +98,9 @@ page aPage =
           (Blog.get $skin.$head) >>= maybe (toHtml empty) toHtmlRaw
         )
       body_ (do
-          (Blog.get $skin.$banner) >>= maybe defaultBanner toHtmlRaw
+          maybe defaultBanner toHtmlRaw =<< (Blog.get $skin.$banner)
           div_ [id_ "navigator"] (do
-              h2_ "Tags"
+              h2_ =<< (Blog.get $wording.$tagsList.$toHtml)
               ul_ . mapM_ tag . Map.keys =<< Blog.get tags
             )
           div_ [id_ "contents"] $ content aPage

src/JSON.hs

@@ -7,13 +7,15 @@ module JSON (
 import Article (Article)
 import qualified Article (Article(..))
 import Blog (Blog)
-import qualified Blog (Blog(..), Path(..), Skin(..))
+import qualified Blog (Blog(..), Path(..), Skin(..), Wording(..))
 import Control.Monad.Reader (ReaderT, ask)
 import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions, encode)
 import Data.ByteString.Lazy (ByteString)
 import Data.Map (Map, mapWithKey)
 import qualified Data.Map as Map (filter, keys)
 import qualified Data.Set as Set (elems, member)
+import Data.Text (Text)
+import Data.Text.Template (showTemplate)
 import GHC.Generics
 
 data ArticleExport = ArticleExport {
@@ -43,11 +45,25 @@ data SkinExport = SkinExport {
 instance ToJSON SkinExport where
   toEncoding = genericToEncoding defaultOptions
 
+data WordingExport = WordingExport {
+      allLink :: Text
+    , allPage :: Text
+    , allTaggedPage :: Text
+    , latestLink :: Text
+    , latestPage :: Text
+    , latestTaggedPage :: Text
+    , tagsList :: Text
+  } deriving (Generic)
+
+instance ToJSON WordingExport where
+  toEncoding = genericToEncoding defaultOptions
+
 data BlogDB = BlogDB {
       articles :: Map String ArticleExport
     , path :: PathExport
     , skin :: SkinExport
     , tags :: Map String [String]
+    , wording :: WordingExport
   } deriving (Generic)
 
 instance ToJSON BlogDB where
@@ -76,4 +92,13 @@ exportBlog = do
             , previewLinesCount = Blog.previewLinesCount $ Blog.skin blog
           }
       , tags = Set.elems <$> Blog.tags blog
+      , wording = WordingExport {
+              allLink = Blog.allLink $ Blog.wording blog
+            , allPage = Blog.allPage $ Blog.wording blog
+            , allTaggedPage = showTemplate . Blog.allTaggedPage $ Blog.wording blog
+            , latestLink = Blog.latestLink $ Blog.wording blog
+            , latestPage = Blog.latestPage $ Blog.wording blog
+            , latestTaggedPage = showTemplate . Blog.latestTaggedPage $ Blog.wording blog
+            , tagsList = Blog.tagsList $ Blog.wording blog
+          }
     }