Wording.hs

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

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

data Wording = Wording {
      allLink :: Text
    , allPage :: Text
    , allTaggedPage :: Template
    , commentsLink :: Text
    , commentsSection :: Text
    , dateFormat :: Text
    , latestLink :: Text
    , latestPage :: Text
    , latestTaggedPage :: Template
    , metadata :: Text
    , tagsList :: Text
  }

keys :: [String]
keys = [
      "allLink", "allPage", "allTaggedPage", "commentsLink", "commentsSection"
    , "dateFormat", "latestLink", "latestPage", "latestTaggedPage", "metadata"
    , "tagsList"
  ]

values :: [Wording -> Text]
values = [
      allLink, allPage, showTemplate . allTaggedPage, commentsLink, commentsSection
    , dateFormat, latestLink, latestPage, showTemplate . latestTaggedPage
    , metadata, tagsList
  ]

texts :: Wording -> [Text]
texts wording = ($ wording) <$> values

instance ToJSON Wording where
  toJSON = object . zipWith (.=) (Text.pack <$> keys) . texts
  toEncoding = pairs . foldl (<>) mempty . zipWith (.=) (Text.pack <$> keys) . texts

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 <$> keys) <* equal) <*> restOfLine
    equal = many (char ' ') *> char '=' *> many (char ' ')

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
      , commentsLink = wording ! "commentsLink"
      , commentsSection = wording ! "commentsSection"
      , dateFormat = wording ! "dateFormat"
      , latestLink = wording ! "latestLink"
      , latestPage = wording ! "latestPage"
      , latestTaggedPage
      , metadata = wording ! "metadata"
      , tagsList = wording ! "tagsList"
    }