70 lines
2.8 KiB
Haskell
70 lines
2.8 KiB
Haskell
{-# 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
|