Template.hs

{-# LANGUAGE OverloadedStrings #-}
module Blog.Template (
      Environment
    , Templates(..)
    , build
    , render
  ) where

import Blog.Wording (Wording(..), variables)
import Control.Monad (foldM)
import Control.Monad.IO.Class (MonadIO(..))
import Data.List (intercalate)
import Data.Map (Map, (!))
import qualified Data.Map as Map (empty, insert, keys)
import Data.Text (Text, breakOn)
import qualified Data.Text as Text (concat, drop, null, unpack)
import Data.Text.Lazy (toStrict)
import Data.Text.Template (Template, renderA, showTemplate, templateSafe)
import System.Exit (die)

data TemplateChunk = Top Template | Sub Template
newtype HabloTemplate = HabloTemplate [TemplateChunk]
newtype Templates = Templates (Map String HabloTemplate)
type Environment = [(Text, Text)]

render :: MonadIO m => String -> Environment -> Templates -> m Text
render key environment (Templates templates) =
  (Text.concat . fmap toStrict) <$> mapM renderChunk templateChunks
  where
    HabloTemplate templateChunks = templates ! key
    renderer template = renderA template (flip lookup environment)
    renderChunk (Top template) =
      let err = "Could not template " ++ Text.unpack (showTemplate template) in
      maybe (liftIO $ die err) return $ renderer template
    renderChunk (Sub template) = return . maybe "" id $ renderer template

makeTemplate :: String -> Text -> IO Template
makeTemplate key templateText =
  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

makeHabloTemplate :: String -> Map String Text -> IO HabloTemplate
makeHabloTemplate key wording = HabloTemplate <$> toHablo True (wording ! key)
  where
    toHablo _ "" = return []
    toHablo atTop template = do
      let (start, rest) = (Text.drop 2) <$> breakOn (delimiter atTop) template
      push atTop start <*> toHablo (not atTop) rest
    delimiter atTop = if atTop then "{?" else "?}"
    push atTop t
      | Text.null t = return id
      | otherwise = (:) . (if atTop then Top else Sub) <$> makeTemplate key t

build :: Wording -> IO Templates
build (Wording wordingMap) =
  Templates <$> foldM templateWording Map.empty (Map.keys variables)
  where
    templateWording templated key =
      flip (Map.insert key) templated <$> makeHabloTemplate key wordingMap