{-# LANGUAGE DeriveDataTypeable #-}
--------------------------------------------------------------------------------
module Xanthous.Messages.Template
( -- * Template AST
Template(..)
, Substitution(..)
, Filter(..)
-- ** Template AST transformations
, reduceTemplate
-- * Template parser
, template
, runParser
, errorBundlePretty
-- * Template pretty-printer
, ppTemplate
-- * Rendering templates
, TemplateVar(..)
, nested
, TemplateVars(..)
, vars
, RenderError
, render
)
where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding
(many, concat, try, elements, some, parts)
--------------------------------------------------------------------------------
import Test.QuickCheck hiding (label)
import Test.QuickCheck.Instances.Text ()
import Test.QuickCheck.Instances.Semigroup ()
import Test.QuickCheck.Checkers (EqProp)
import Control.Monad.Combinators.NonEmpty
import Data.List.NonEmpty (NonEmpty(..))
import Data.Data
import Text.Megaparsec hiding (sepBy1, some)
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Data.Function (fix)
--------------------------------------------------------------------------------
import Xanthous.Util (EqEqProp(..))
--------------------------------------------------------------------------------
genIdentifier :: Gen Text
genIdentifier = pack <$> listOf1 (elements identifierChars)
identifierChars :: String
identifierChars = ['a'..'z'] <> ['A'..'Z'] <> ['-', '_']
newtype Filter = FilterName Text
deriving stock (Show, Eq, Ord, Generic, Data)
deriving anyclass (NFData)
deriving (IsString) via Text
instance Arbitrary Filter where
arbitrary = FilterName <$> genIdentifier
shrink (FilterName fn) = fmap FilterName . filter (not . null) $ shrink fn
data Substitution
= SubstPath (NonEmpty Text)
| SubstFilter Substitution Filter
deriving stock (Show, Eq, Ord, Generic, Data)
deriving anyclass (NFData)
instance Arbitrary Substitution where
arbitrary = sized . fix $ \gen n ->
let leaves =
[ SubstPath <$> ((:|) <$> genIdentifier <*> listOf genIdentifier)]
subtree = gen $ n `div` 2
in if n == 0
then oneof leaves
else oneof $ leaves <> [ SubstFilter <$> subtree <*> arbitrary ]
shrink (SubstPath pth) =
fmap SubstPath
. filter (not . any ((||) <$> null <*> any (`notElem` identifierChars)))
$ shrink pth
shrink (SubstFilter s f)
= shrink s
<> (uncurry SubstFilter <$> shrink (s, f))
data Template
= Literal Text
| Subst Substitution
| Concat Template Template
deriving stock (Show, Generic, Data)
deriving anyclass (NFData)
deriving EqProp via EqEqProp Template
instance Plated Template where
plate _ tpl@(Literal _) = pure tpl
plate _ tpl@(Subst _) = pure tpl
plate f (Concat tpl₁ tpl₂) = Concat <$> f tpl₁ <*> f tpl₂
reduceTemplate :: Template -> Template
reduceTemplate = transform $ \case
(Concat (Literal t₁) (Literal t₂)) -> Literal (t₁ <> t₂)
(Concat (Literal "") t) -> t
(Concat t (Literal "")) -> t
(Concat t₁ (Concat t₂ t₃)) -> Concat (Concat t₁ t₂) t₃
(Concat (Concat t₁ (Literal t₂)) (Literal t₃)) -> (Concat t₁ (Literal $ t₂ <> t₃))
t -> t
instance Eq Template where
tpl₁ == tpl₂ = case (reduceTemplate tpl₁, reduceTemplate tpl₂) of
(Literal t₁, Literal t₂) -> t₁ == t₂
(Subst s₁, Subst s₂) -> s₁ == s₂
(Concat ta₁ ta₂, Concat tb₁ tb₂) -> ta₁ == tb₁ && ta₂ == tb₂
_ -> False
instance Arbitrary Template where
arbitrary = sized . fix $ \gen n ->
let leaves = [ Literal . pack . filter (`notElem` ['\\', '{']) <$> arbitrary
, Subst <$> arbitrary
]
subtree = gen $ n `div` 2
genConcat = Concat <$> subtree <*> subtree
in if n == 0
then oneof leaves
else oneof $ genConcat : leaves
shrink (Literal t) = Literal <$> shrink t
shrink (Subst s) = Subst <$> shrink s
shrink (Concat t₁ t₂)
= shrink t₁
<> shrink t₂
<> (Concat <$> shrink t₁ <*> shrink t₂)
instance Semigroup Template where
(<>) = Concat
instance Monoid Template where
mempty = Literal ""
--------------------------------------------------------------------------------
type Parser = Parsec Void Text
sc :: Parser ()
sc = L.space space1 empty empty
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc
symbol :: Text -> Parser Text
symbol = L.symbol sc
identifier :: Parser Text
identifier = lexeme . label "identifier" $ do
firstChar <- letterChar <|> oneOf ['-', '_']
restChars <- many $ alphaNumChar <|> oneOf ['-', '_']
pure $ firstChar <| pack restChars
filterName :: Parser Filter
filterName = FilterName <$> identifier
substitutionPath :: Parser Substitution
substitutionPath = SubstPath <$> sepBy1 identifier (char '.')
substitutionFilter :: Parser Substitution
substitutionFilter = do
path <- substitutionPath
fs <- some $ symbol "|" *> filterName
pure $ foldl' SubstFilter path fs
-- pure $ SubstFilter path f
substitutionContents :: Parser Substitution
substitutionContents
= try substitutionFilter
<|> substitutionPath
substitution :: Parser Substitution
substitution = between (string "{{") (string "}}") substitutionContents
literal :: Parser Template
literal = Literal <$>
( (string "\\{" $> "{")
<|> takeWhile1P Nothing (`notElem` ['\\', '{'])
)
subst :: Parser Template
subst = Subst <$> substitution
template' :: Parser Template
template' = do
parts <- many $ literal <|> subst
pure $ foldr Concat (Literal "") parts
template :: Parser Template
template = reduceTemplate <$> template' <* eof
--------------------------------------------------------------------------------
ppSubstitution :: Substitution -> Text
ppSubstitution (SubstPath substParts) = intercalate "." substParts
ppSubstitution (SubstFilter s (FilterName f)) = ppSubstitution s <> " | " <> f
ppTemplate :: Template -> Text
ppTemplate (Literal txt) = txt
ppTemplate (Subst s) = "{{" <> ppSubstitution s <> "}}"
ppTemplate (Concat tpl₁ tpl₂) = ppTemplate tpl₁ <> ppTemplate tpl₂
--------------------------------------------------------------------------------
data TemplateVar
= Val Text
| Nested (Map Text TemplateVar)
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData)
nested :: [(Text, TemplateVar)] -> TemplateVar
nested = Nested . mapFromList
instance Arbitrary TemplateVar where
arbitrary = sized . fix $ \gen n ->
let nst = fmap mapFromList . listOf $ (,) <$> arbitrary <*> gen (n `div` 2)
in if n == 0
then Val <$> arbitrary
else oneof [ Val <$> arbitrary
, Nested <$> nst]
newtype TemplateVars = Vars { getTemplateVars :: Map Text TemplateVar }
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData)
deriving (Arbitrary) via (Map Text TemplateVar)
type instance Index TemplateVars = Text
type instance IxValue TemplateVars = TemplateVar
instance Ixed TemplateVars where
ix k f (Vars vs) = Vars <$> ix k f vs
instance At TemplateVars where
at k f (Vars vs) = Vars <$> at k f vs
vars :: [(Text, TemplateVar)] -> TemplateVars
vars = Vars . mapFromList
lookupVar :: TemplateVars -> NonEmpty Text -> Maybe TemplateVar
lookupVar vs (p :| []) = vs ^. at p
lookupVar vs (p :| (p₁ : ps)) = vs ^. at p >>= \case
(Val _) -> Nothing
(Nested vs') -> lookupVar (Vars vs') $ p₁ :| ps
data RenderError
= NoSuchVariable (NonEmpty Text)
| NestedFurther (NonEmpty Text)
| NoSuchFilter Filter
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData)
renderSubst
:: Map Filter (Text -> Text) -- ^ Filters
-> TemplateVars
-> Substitution
-> Either RenderError Text
renderSubst _ vs (SubstPath pth) =
case lookupVar vs pth of
Just (Val v) -> Right v
Just (Nested _) -> Left $ NestedFurther pth
Nothing -> Left $ NoSuchVariable pth
renderSubst fs vs (SubstFilter s fn) =
case fs ^. at fn of
Just filterFn -> filterFn <$> renderSubst fs vs s
Nothing -> Left $ NoSuchFilter fn
render
:: Map Filter (Text -> Text) -- ^ Filters
-> TemplateVars -- ^ Template variables
-> Template -- ^ Template
-> Either RenderError Text
render _ _ (Literal s) = pure s
render fs vs (Concat t₁ t₂) = (<>) <$> render fs vs t₁ <*> render fs vs t₂
render fs vs (Subst s) = renderSubst fs vs s
