tvl-depot/users/aspen/xanthous/test/Xanthous/Messages/TemplateSpec.hs
Aspen Smith 82ecd61f5c chore(users): grfn -> aspen
Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9
Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809
Autosubmit: aspen <root@gws.fyi>
Reviewed-by: sterni <sternenseemann@systemli.org>
Tested-by: BuildkiteCI
Reviewed-by: lukegb <lukegb@tvl.fyi>
2024-02-14 19:37:41 +00:00

80 lines
3.2 KiB
Haskell

--------------------------------------------------------------------------------
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 = pack . 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
--