diff options
| -rw-r--r-- | package.yaml | 1 | ||||
| -rw-r--r-- | src/Xanthous/Messages/Template.hs | 275 | ||||
| -rw-r--r-- | test/Spec.hs | 2 | ||||
| -rw-r--r-- | test/Xanthous/Messages/TemplateSpec.hs | 80 | ||||
| -rw-r--r-- | xanthous.cabal | 8 |
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 |