module Text.Domplate.Replace (Template, parseTemplate, replace) where
import Prelude hiding (lookup)
import qualified Prelude as P
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Control.Applicative hiding (empty)
import Data.Maybe (catMaybes)
import Text.HTML.TagSoup
import Text.Domplate.Context
import Data.Yaml
import Data.ByteString (ByteString)
newtype Template = Template [Tag T.Text]
parseTemplate :: ByteString -> Template
parseTemplate = Template . parseTags . decodeUtf8
data InternalKey = Weak [Key] | Strong [Key]
replace :: Template -> Context -> Either String ByteString
replace = genericReplace encodeUtf8
replaceText :: Template -> Context -> Either String T.Text
replaceText = genericReplace id
genericReplace :: (T.Text -> a) -> Template -> Context -> Either String a
genericReplace conv (Template template) context =
conv . renderTagsOptions opts . reverse <$> replace' template context
where
opts = renderOptions {optEscape = id}
replace' ts ctx =
step [] ts
where
step acc (TagOpen name attrs : tags) = do
attrs' <- catMaybes <$> mapM replaceAttr attrs
substTag acc (TagOpen name attrs' : tags)
step acc t = do
substTag acc t
substTag acc (tag@(TagOpen _ attrs):tags)
| Just key <- P.lookup "insert" attrs =
handleInsert acc (stripAttr "insert" tag) (mkKey key) tags
| Just key <- P.lookup "replace" attrs =
handleReplace acc tag (mkKey key) tags
| Just key <- P.lookup "forall" attrs =
handleForall acc (stripAttr "forall" tag) (mkKey key) tags
| Just key <- P.lookup "when" attrs =
handleWhen acc (stripAttr "when" tag) (mkKey key) tags
| Just key <- P.lookup "unless" attrs =
handleUnless acc (stripAttr "unless" tag) (mkKey key) tags
substTag acc (tag:tags) = step (tag : acc) tags
substTag acc [] = return acc
replaceAttr a@(k, val) =
case T.splitOn ":" k of
["when", key, attr] -> do
v <- nestedLookup (Bool False) (mkKey key) ctx
case truthOf v of
Just True -> return (Just (attr, val))
Just False -> return Nothing
_ -> typeError (mkKey key) "bool" (typeOf v)
["unless", key, attr] -> do
v <- nestedLookup (Bool False) (mkKey key) ctx
case truthOf v of
Just True -> return Nothing
Just False -> return (Just (attr, val))
_ -> typeError (mkKey key) "bool" (typeOf v)
["insert", key, attr] -> do
v <- nestedLookup (String "") (mkKey key) ctx
case stringOf v of
Just s -> return (Just (attr, s))
_ -> typeError (mkKey key) "string" (typeOf v)
_ -> do
return $ Just a
mkKey k
| T.head k == '?' = Weak $ T.splitOn "." $ T.tail k
| otherwise = Strong $ T.splitOn "." k
stripAttr s (TagOpen t as) = TagOpen t [a | a <- as, fst a /= s]
handleInsert acc tag@(TagOpen nm _) key tags = do
v <- nestedLookup (String "") key ctx
case (dropUntilClose nm tags, stringOf v) of
(ts', Just val) -> step (TagClose nm:TagText val:tag:acc) ts'
_ -> typeError key "string" (typeOf v)
handleReplace acc tag@(TagOpen name _) key tags = do
v <- nestedLookup (String "") key ctx
case stringOf v of
Just s -> step (TagText s : acc) (dropUntilClose name tags)
_ -> typeError key "string" (typeOf v)
handleWhen acc tag@(TagOpen name _) key tags = do
v <- nestedLookup (Bool False) key ctx
case truthOf v of
Just True -> step (tag : acc) tags
Just False -> step acc (dropUntilClose name tags)
_ -> typeError key "bool" (typeOf v)
handleUnless acc tag@(TagOpen name _) key tags = do
v <- nestedLookup (Bool False) key ctx
case truthOf v of
Just False -> step (tag : acc) tags
Just True -> step acc (dropUntilClose name tags)
_ -> typeError key "bool" (typeOf v)
handleForall acc tag@(TagOpen name _) key tags = do
let t = tag:takeUntilClose name tags ++ [TagClose name]
rest = dropUntilClose name tags
k = case key of
Strong k -> k
Weak k -> k
v <- nestedLookup (Array V.empty) key ctx
case v of
Array l -> do
outs <- mapM (forallIter t k (V.length l1))
(zip [0..] (V.toList l))
step (concat (reverse (outs)) ++ acc) rest
_ -> do
typeError key "array" (typeOf v)
forallIter t k lastIx (ix, v) = do
ctx' <- nestedAdd k v ctx
ctx'' <- if ix == 0
then nestedAdd ["_first"] (Bool True) ctx'
else nestedAdd ["_first"] (Bool False) ctx'
ctx''' <- if ix == lastIx
then nestedAdd ["_last"] (Bool True) ctx''
else nestedAdd ["_last"] (Bool False) ctx''
replace' t ctx'''
truthOf :: Value -> Maybe Bool
truthOf (Bool b) = Just b
truthOf (Array a) = Just $ V.null a
truthOf _ = Nothing
stringOf :: Value -> Maybe T.Text
stringOf (String s) = Just s
stringOf (Bool True) = Just "true"
stringOf (Bool False) = Just "false"
stringOf (Number n) = Just $ T.pack $ show n
stringOf _ = Nothing
nestedAdd :: [Key] -> Value -> Context -> Either String Context
nestedAdd key val ctx = go key ctx
where
go [k] m = do
return $ add k val m
go (k:ks) m = do
case lookup k m of
Just (Object ctx') -> do
Ctx ctx'' <- go ks (Ctx ctx')
return $ add k (Object ctx'') m
_ -> do
Ctx ctx' <- go ks empty
return $ add k (Object ctx') m
go _ _ = do
notFoundError (Strong key)
nestedLookup :: Value -> InternalKey -> Context -> Either String Value
nestedLookup def key = go key'
where
(key', notFound) = case key of
Weak k -> (k, return def)
Strong k -> (k, notFoundError key)
go [k] m =
case lookup k m of
Just v -> return v
_ -> notFound
go (k:ks) m =
case lookup k m of
Just (Object m') -> go ks (Ctx m')
_ -> notFound
go _ _ =
notFound
takeUntilClose :: T.Text -> [Tag T.Text] -> [Tag T.Text]
takeUntilClose str = go 0
where
go n (tag:tags) =
case tag of
TagOpen name _
| voidTag name -> tag:go n tags
| otherwise -> tag:go (n+1) tags
TagClose name
| name == str && n == 0 -> []
| otherwise -> tag:go (n1) tags
_ -> tag:go n tags
go _ tags =
[]
dropUntilClose :: T.Text -> [Tag T.Text] -> [Tag T.Text]
dropUntilClose str tags
| voidTag str = tags
| otherwise = go 0 tags
where
go n (tag:tags) =
case tag of
TagOpen name _
| voidTag name -> go n tags
| otherwise -> go (n+1) tags
TagClose name
| name == str && n == 0 -> tags
| otherwise -> go (n1) tags
_ -> go n tags
go _ tags =
tags
voidTag :: T.Text -> Bool
voidTag t = t `elem` [
"area", "base", "br", "col", "command", "embed", "hr", "img", "input",
"keygen", "link", "meta", "param", "source", "track", "wbr"
]
typeError :: InternalKey -> String -> String -> Either String a
typeError k tTemplate tCtx =
Left $ unwords [
T.unpack k', "was used as a", tTemplate, "by template,",
"but declared", tCtx, "by context!"
]
where
k' = case k of
Weak k' -> T.intercalate (T.singleton '.') k'
Strong k' -> T.intercalate (T.singleton '.') k'
notFoundError :: InternalKey -> Either String a
notFoundError k = Left $ T.unpack k' ++ " was not found in the context!"
where
k' = case k of
Weak k' -> T.intercalate (T.singleton '.') k'
Strong k' -> T.intercalate (T.singleton '.') k'