{-# 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.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, many, many1, noneOf, parse, string, try
  )
import System.Exit (die)

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

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

values :: [Wording -> Text]
values = [
      allLink, allPage, showTemplate . allTaggedPage, commentsSection
    , latestLink, latestPage, showTemplate . latestTaggedPage, 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 eol *> line `endBy` (many1 eol))
  where
    line = (,) <$> (choice (try . string <$> 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
      , commentsSection = wording ! "commentsSection"
      , latestLink = wording ! "latestLink"
      , latestPage = wording ! "latestPage"
      , latestTaggedPage
      , tagsList = wording ! "tagsList"
    }