{-# 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 :: String -> Environment -> Templates -> m Text
render String
key Environment
environment (Templates Map String HabloTemplate
templates) =
  ([Text] -> Text
Text.concat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
toStrict) ([Text] -> Text) -> m [Text] -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TemplateChunk -> m Text) -> [TemplateChunk] -> m [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TemplateChunk -> m Text
forall (m :: * -> *). MonadIO m => TemplateChunk -> m Text
renderChunk [TemplateChunk]
templateChunks
  where
    HabloTemplate [TemplateChunk]
templateChunks = Map String HabloTemplate
templates Map String HabloTemplate -> String -> HabloTemplate
forall k a. Ord k => Map k a -> k -> a
! String
key
    renderer :: Template -> Maybe Text
renderer Template
template = Template -> ContextA Maybe -> Maybe Text
forall (f :: * -> *).
Applicative f =>
Template -> ContextA f -> f Text
renderA Template
template ((Text -> Environment -> Maybe Text)
-> Environment -> ContextA Maybe
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Environment -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Environment
environment)
    renderChunk :: TemplateChunk -> m Text
renderChunk (Top Template
template) =
      let err :: String
err = String
"Could not template " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack (Template -> Text
showTemplate Template
template) in
      m Text -> (Text -> m Text) -> Maybe Text -> m Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
forall a. String -> IO a
die String
err) Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> m Text) -> Maybe Text -> m Text
forall a b. (a -> b) -> a -> b
$ Template -> Maybe Text
renderer Template
template
    renderChunk (Sub Template
template) = Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> (Maybe Text -> Text) -> Maybe Text -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Text -> Text
forall a. a -> a
id (Maybe Text -> m Text) -> Maybe Text -> m Text
forall a b. (a -> b) -> a -> b
$ Template -> Maybe Text
renderer Template
template

makeTemplate :: String -> Text -> IO Template
makeTemplate :: String -> Text -> IO Template
makeTemplate String
key Text
templateText =
  let testEnvironment :: ContextA Maybe
testEnvironment = (Text -> Environment -> Maybe Text)
-> Environment -> ContextA Maybe
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Environment -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(Text
s, Text
"") | Text
s <- [Text]
availableVariables] in
  case Text -> Either (Int, Int) Template
templateSafe Text
templateText of
    Left (Int
row, Int
col) -> String -> IO Template
forall a. String -> IO a
die (String -> IO Template) -> String -> IO Template
forall a b. (a -> b) -> a -> b
$ String -> String -> String
syntaxError (Int -> String
forall a. Show a => a -> String
show Int
row) (Int -> String
forall a. Show a => a -> String
show Int
col)
    Right Template
template ->
      IO Template -> (Text -> IO Template) -> Maybe Text -> IO Template
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO Template
forall a. String -> IO a
die String
badTemplate) (Template -> IO Template
forall (m :: * -> *) a. Monad m => a -> m a
return (Template -> IO Template)
-> (Text -> Template) -> Text -> IO Template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Template -> Text -> Template
forall a b. a -> b -> a
const Template
template) (Template -> ContextA Maybe -> Maybe Text
forall (f :: * -> *).
Applicative f =>
Template -> ContextA f -> f Text
renderA Template
template ContextA Maybe
testEnvironment)
  where
    availableVariables :: [Text]
availableVariables = Map String [Text]
variables Map String [Text] -> String -> [Text]
forall k a. Ord k => Map k a -> k -> a
! String
key
    variablesMessage :: String
variablesMessage =
      String
" (available variables: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Text -> String
Text.unpack (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
availableVariables) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    syntaxError :: String -> String -> String
syntaxError String
row String
col =
      String
"Syntax error in template for variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"at l." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
row String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", c." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
col 
    badTemplate :: String
badTemplate = String
"Invalid template for variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
variablesMessage

makeHabloTemplate :: String -> Map String Text -> IO HabloTemplate
makeHabloTemplate :: String -> Map String Text -> IO HabloTemplate
makeHabloTemplate String
key Map String Text
wording = [TemplateChunk] -> HabloTemplate
HabloTemplate ([TemplateChunk] -> HabloTemplate)
-> IO [TemplateChunk] -> IO HabloTemplate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Text -> IO [TemplateChunk]
toHablo Bool
True (Map String Text
wording Map String Text -> String -> Text
forall k a. Ord k => Map k a -> k -> a
! String
key)
  where
    toHablo :: Bool -> Text -> IO [TemplateChunk]
toHablo Bool
_ Text
"" = [TemplateChunk] -> IO [TemplateChunk]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    toHablo Bool
atTop Text
template = do
      let (Text
start, Text
rest) = (Int -> Text -> Text
Text.drop Int
2) (Text -> Text) -> (Text, Text) -> (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> (Text, Text)
breakOn (Bool -> Text
forall p. IsString p => Bool -> p
delimiter Bool
atTop) Text
template
      Bool -> Text -> IO ([TemplateChunk] -> [TemplateChunk])
push Bool
atTop Text
start IO ([TemplateChunk] -> [TemplateChunk])
-> IO [TemplateChunk] -> IO [TemplateChunk]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Text -> IO [TemplateChunk]
toHablo (Bool -> Bool
not Bool
atTop) Text
rest
    delimiter :: Bool -> p
delimiter Bool
atTop = if Bool
atTop then p
"{?" else p
"?}"
    push :: Bool -> Text -> IO ([TemplateChunk] -> [TemplateChunk])
push Bool
atTop Text
t
      | Text -> Bool
Text.null Text
t = ([TemplateChunk] -> [TemplateChunk])
-> IO ([TemplateChunk] -> [TemplateChunk])
forall (m :: * -> *) a. Monad m => a -> m a
return [TemplateChunk] -> [TemplateChunk]
forall a. a -> a
id
      | Bool
otherwise = (:) (TemplateChunk -> [TemplateChunk] -> [TemplateChunk])
-> (Template -> TemplateChunk)
-> Template
-> [TemplateChunk]
-> [TemplateChunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
atTop then Template -> TemplateChunk
Top else Template -> TemplateChunk
Sub) (Template -> [TemplateChunk] -> [TemplateChunk])
-> IO Template -> IO ([TemplateChunk] -> [TemplateChunk])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Text -> IO Template
makeTemplate String
key Text
t

build :: Wording -> IO Templates
build :: Wording -> IO Templates
build (Wording Map String Text
wordingMap) =
  Map String HabloTemplate -> Templates
Templates (Map String HabloTemplate -> Templates)
-> IO (Map String HabloTemplate) -> IO Templates
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map String HabloTemplate
 -> String -> IO (Map String HabloTemplate))
-> Map String HabloTemplate
-> [String]
-> IO (Map String HabloTemplate)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map String HabloTemplate -> String -> IO (Map String HabloTemplate)
templateWording Map String HabloTemplate
forall k a. Map k a
Map.empty (Map String [Text] -> [String]
forall k a. Map k a -> [k]
Map.keys Map String [Text]
variables)
  where
    templateWording :: Map String HabloTemplate -> String -> IO (Map String HabloTemplate)
templateWording Map String HabloTemplate
templated String
key =
      (HabloTemplate
 -> Map String HabloTemplate -> Map String HabloTemplate)
-> Map String HabloTemplate
-> HabloTemplate
-> Map String HabloTemplate
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> HabloTemplate
-> Map String HabloTemplate
-> Map String HabloTemplate
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
key) Map String HabloTemplate
templated (HabloTemplate -> Map String HabloTemplate)
-> IO HabloTemplate -> IO (Map String HabloTemplate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Map String Text -> IO HabloTemplate
makeHabloTemplate String
key Map String Text
wordingMap