hablo/src/Blog/Wording.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Blog.Wording (
      Wording(..)
    , build
    , render
  ) where

import Arguments (Arguments(..))
import Control.Monad (foldM)
import Data.Aeson (ToJSON(..))
import Data.List (intercalate)
import Data.Map (Map, (!))
import qualified Data.Map as Map (empty, fromList, insert, keys, map, union)
import Data.Text (Text)
import qualified Data.Text as Text (pack, unpack)
import Data.Text.Lazy (toStrict)
import Data.Text.Template (Template, renderA, showTemplate, templateSafe)
import qualified Data.Text.Template as Template (render)
import Paths_hablo (getDataFileName)
import Text.ParserCombinators.Parsec (
      Parser
    , (<|>)
    , char, choice, endBy, eof, many, many1, noneOf, optional, parse, string, try
  )
import System.Exit (die)

newtype Wording = Wording (Map String Template)

variables :: Map String [Text]
variables = Map.fromList [
      ("allLink", [])
    , ("allPage", [])
    , ("allTaggedPage", ["tag"])
    , ("commentsLink", [])
    , ("commentsSection", [])
    , ("dateFormat", [])
    , ("latestLink", [])
    , ("latestPage", [])
    , ("latestTaggedPage", ["tag"])
    , ("metadata", ["author", "date", "tags"])
    , ("tagsList", [])
  ]


instance ToJSON Wording where
  toJSON (Wording m) = toJSON (showTemplate <$> m)
  toEncoding (Wording m) = toEncoding (showTemplate <$> m)

render :: String -> [(Text, Text)] -> Wording -> Text
render key env (Wording wMap) =
  toStrict $ Template.render (wMap ! key) (Map.fromList env !)

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 skip *> line `endBy` (many1 skip) <* eof)
  where
    restOfLine = many $ noneOf "\r\n"
    eol = try (string "\r\n") <|> string "\r" <|> string "\n"
    skip = optional (char '#' *> restOfLine) *> eol
    line = (,) <$> (choice (try . string <$> Map.keys variables) <* equal) <*> restOfLine
    equal = many (char ' ') *> char '=' *> many (char ' ')

makeTemplate :: String -> Map String Text -> IO Template
makeTemplate key wording =
  let templateText = wording ! key in
  let testEnvironment = flip lookup [(s, "") | s <- availableVariables] 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 = variables ! key
    variablesMessage =
      " (available variables: " ++ intercalate ", " (Text.unpack <$> availableVariables) ++ ")"
    syntaxError row col =
      "Syntax error in template for variable " ++ key ++ "at l." ++ row ++ ", c." ++ col 
    badTemplate = "Invalid template for variable " ++ key ++ variablesMessage

build :: Arguments -> IO Wording
build arguments = do
  defaultWording <- getDataFileName "defaultWording.conf"
  let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording]
  wordindMap <- foldM addWording Map.empty wordingFiles
  Wording <$> foldM (
      \templated key -> flip (Map.insert key) templated <$> makeTemplate key wordindMap
    ) Map.empty (Map.keys variables)