From 2c86856ca7784483a7cdd438763b2693a297908a Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sun, 24 May 2020 11:14:02 -0400 Subject: Add a new template system Add a parser, pretty-printer, and renderer for a new template system, which should eventually be a drop-in replacement for the current mustache-based template system, but also supports text filters (which will be used for things like pluralization and noun casing). Nothing currently uses it yet, though. --- src/Xanthous/Messages/Template.hs | 275 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 275 insertions(+) create mode 100644 src/Xanthous/Messages/Template.hs (limited to 'src/Xanthous') diff --git a/src/Xanthous/Messages/Template.hs b/src/Xanthous/Messages/Template.hs new file mode 100644 index 000000000000..0f47729d6871 --- /dev/null +++ b/src/Xanthous/Messages/Template.hs @@ -0,0 +1,275 @@ +{-# 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 . 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 -- cgit 1.4.1