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.

5 files changed, 365 insertions, 1 deletions

diff --git a/package.yaml b/package.yaml
index b74a4df9e515..40e42a5b8a43 100644
--- a/package.yaml
+++ b/package.yaml
@@ -53,6 +53,7 @@ dependencies:
 - MonadRandom
 - mtl
 - optparse-applicative
+- parser-combinators
 - pointed
 - random
 - random-fu
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
diff --git a/test/Spec.hs b/test/Spec.hs
index 3790f3ce65ba..afe81d028c77 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -11,6 +11,7 @@ import qualified Xanthous.Entities.RawsSpec
 import qualified Xanthous.GameSpec
 import qualified Xanthous.Generators.UtilSpec
 import qualified Xanthous.MessageSpec
+import qualified Xanthous.Messages.TemplateSpec
 import qualified Xanthous.OrphansSpec
 import qualified Xanthous.Util.GraphicsSpec
 import qualified Xanthous.Util.GraphSpec
@@ -32,6 +33,7 @@ test = testGroup "Xanthous"
   , Xanthous.GameSpec.test
   , Xanthous.Generators.UtilSpec.test
   , Xanthous.MessageSpec.test
+  , Xanthous.Messages.TemplateSpec.test
   , Xanthous.OrphansSpec.test
   , Xanthous.DataSpec.test
   , Xanthous.UtilSpec.test
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
+
+--
diff --git a/xanthous.cabal b/xanthous.cabal
index 85b70c97f755..3c635a863020 100644
--- a/xanthous.cabal
+++ b/xanthous.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 61744d8e26bf309ee73e128a90af8badee98aedace39a756b6033f51711d3e2e
+-- hash: 4c80448c82dc61f97ea9809ad646f7ad66b0f57ca297e4d44ee596c7a1ef42fe
 
 name:           xanthous
 version:        0.1.0.0
@@ -67,6 +67,7 @@ library
       Xanthous.Generators.LevelContents
       Xanthous.Generators.Util
       Xanthous.Messages
+      Xanthous.Messages.Template
       Xanthous.Monad
       Xanthous.Orphans
       Xanthous.Prelude
@@ -122,6 +123,7 @@ library
     , monad-control
     , mtl
     , optparse-applicative
+    , parser-combinators
     , pointed
     , quickcheck-instances
     , quickcheck-text
@@ -184,6 +186,7 @@ executable xanthous
       Xanthous.Generators.LevelContents
       Xanthous.Generators.Util
       Xanthous.Messages
+      Xanthous.Messages.Template
       Xanthous.Monad
       Xanthous.Orphans
       Xanthous.Prelude
@@ -238,6 +241,7 @@ executable xanthous
     , monad-control
     , mtl
     , optparse-applicative
+    , parser-combinators
     , pointed
     , quickcheck-instances
     , quickcheck-text
@@ -274,6 +278,7 @@ test-suite test
       Xanthous.Entities.RawsSpec
       Xanthous.GameSpec
       Xanthous.Generators.UtilSpec
+      Xanthous.Messages.TemplateSpec
       Xanthous.MessageSpec
       Xanthous.OrphansSpec
       Xanthous.Util.GraphicsSpec
@@ -323,6 +328,7 @@ test-suite test
     , monad-control
     , mtl
     , optparse-applicative
+    , parser-combinators
     , pointed
     , quickcheck-instances
     , quickcheck-text