Wording.hs

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

import Arguments (Arguments(..))
import Control.Monad (foldM)
import Data.Aeson (ToJSON(..))
import Data.Map (Map)
import qualified Data.Map as Map (empty, fromList, keys, map, union)
import Data.Text (Text)
import qualified Data.Text as Text (pack)
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 Text)

variables :: Map String [Text]
variables = Map.fromList [
      ("allLink", [])
    , ("allPage", ["tag"])
    , ("articleDescription", ["name"])
    , ("commentsLink", [])
    , ("commentsSection", [])
    , ("dateFormat", [])
    , ("latestLink", [])
    , ("latestPage", ["tag"])
    , ("metadata", ["author", "date", "tags"])
    , ("pageDescription", ["name"])
    , ("pagesList", [])
    , ("rssLink", [])
    , ("rssTitle", ["tag"])
    , ("tagsList", [])
  ]

instance ToJSON Wording where
  toJSON (Wording m) = toJSON m
  toEncoding (Wording m) = toEncoding m

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
    varEqual = choice (try . string <$> Map.keys variables) <* equal
    line = (,) <$> varEqual <*> restOfLine
    equal = many (char ' ') *> char '=' *> many (char ' ')

build :: Arguments -> IO Wording
build arguments = do
  defaultWording <- getDataFileName "defaultWording.conf"
  let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording]
  Wording <$> foldM addWording Map.empty wordingFiles