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.

1 files changed, 80 insertions, 0 deletions

diff --git a/test/Xanthous/Messages/TemplateSpec.hs b/test/Xanthous/Messages/TemplateSpec.hs
new file mode 100644
index 000000000000..8ea5186c5050
--- /dev/null
+++ b/test/Xanthous/Messages/TemplateSpec.hs
@@ -0,0 +1,80 @@
+--------------------------------------------------------------------------------
+module Xanthous.Messages.TemplateSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude
+import Test.QuickCheck.Instances.Text ()
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Function (fix)
+--------------------------------------------------------------------------------
+import Xanthous.Messages.Template
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Messages.Template"
+  [ testGroup "parsing"
+    [ testProperty "literals" $ forAll genLiteral $ \s ->
+        testParse template s === Right (Literal s)
+    , parseCase "escaped curlies"
+      "foo\\{"
+      $ Literal "foo{"
+    , parseCase "simple substitution"
+      "foo {{bar}}"
+      $ Literal "foo " `Concat` Subst (SubstPath $ "bar" :| [])
+    , parseCase "substitution with filters"
+      "foo {{bar | baz}}"
+      $ Literal "foo "
+      `Concat` Subst (SubstFilter (SubstPath $ "bar" :| [])
+                                  (FilterName "baz"))
+    , parseCase "substitution with multiple filters"
+      "foo {{bar | baz | qux}}"
+      $ Literal "foo "
+      `Concat` Subst (SubstFilter (SubstFilter (SubstPath $ "bar" :| [])
+                                                (FilterName "baz"))
+                                  (FilterName "qux"))
+    , parseCase "two substitutions and a literal"
+      "{{a}}{{b}}c"
+      $ Subst (SubstPath $ "a" :| [])
+      `Concat` Subst (SubstPath $ "b" :| [])
+      `Concat` Literal "c"
+    , localOption (QuickCheckTests 10)
+    $ testProperty "round-trips with ppTemplate" $ \tpl ->
+        testParse template (ppTemplate tpl) === Right tpl
+    ]
+  , testBatch $ monoid @Template mempty
+  , testGroup "rendering"
+    [ testProperty "rendering literals renders literally"
+      $ forAll genLiteral $ \s fs vs ->
+        render fs vs (Literal s) === Right s
+    , testProperty "rendering substitutions renders substitutions"
+      $ forAll genPath $ \ident val fs ->
+        let tpl = Subst (SubstPath ident)
+            tvs = varsWith ident val
+        in render fs tvs tpl === Right val
+    , testProperty "filters filter" $ forAll genPath
+      $ \ident filterName filterFn val ->
+        let tpl = Subst (SubstFilter (SubstPath ident) filterName)
+            fs = mapFromList [(filterName, filterFn)]
+            vs = varsWith ident val
+        in render fs vs tpl === Right (filterFn val)
+    ]
+  ]
+  where
+    genLiteral = filter (`notElem` ['\\', '{']) <$> arbitrary
+    parseCase name input expected =
+      testCase name $ testParse template input @?= Right expected
+    testParse p = over _Left errorBundlePretty . runParser p "<test>"
+    genIdentifier = pack @Text <$> listOf1 (elements identifierChars)
+    identifierChars = ['a'..'z'] <> ['A'..'Z'] <> ['-', '_']
+
+    varsWith (p :| []) val = vars [(p, Val val)]
+    varsWith (phead :| ps) val = vars . pure . (phead ,) . flip fix ps $
+      \next pth -> case pth of
+          [] -> Val val
+          p : ps' -> nested [(p, next ps')]
+
+    genPath = (:|) <$> genIdentifier <*> listOf genIdentifier
+
+--