mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
tvl-depot/test/Xanthous/OrphansSpec.hs

43 lines
1.7 KiB
Haskell
Raw Normal View History

Implement messages Implement messages almost the same as in the Rust version, only with YAML instead of TOML this time, and a regular old mustache template instead of something handrolled. Besides that, pretty much everything here is the same.
2019-09-01 19:54:27 +02:00
{-# LANGUAGE BlockArguments #-}
Implement saving+loading the game Implement ToJSON and FromJSON for all of the various pieces of the game state, and add a pair of functions saveGame/loadGame implementing a prism to save the game as zlib-compressed JSON. To test this, there's now Arbitrary, CoArbitrary, and Function instances for all the parts of the game state - to get around circular imports with the concrete entities this unfortunately is happening via orphan instances, plus an hs-boot file to break a circular import that was just a little too hard to remove by moving things around. Ugh.
2019-11-29 20:33:52 +01:00
--------------------------------------------------------------------------------
Implement messages Implement messages almost the same as in the Rust version, only with YAML instead of TOML this time, and a regular old mustache template instead of something handrolled. Besides that, pretty much everything here is the same.
2019-09-01 19:54:27 +02:00
module Xanthous.OrphansSpec where
Implement saving+loading the game Implement ToJSON and FromJSON for all of the various pieces of the game state, and add a pair of functions saveGame/loadGame implementing a prism to save the game as zlib-compressed JSON. To test this, there's now Arbitrary, CoArbitrary, and Function instances for all the parts of the game state - to get around circular imports with the concrete entities this unfortunately is happening via orphan instances, plus an hs-boot file to break a circular import that was just a little too hard to remove by moving things around. Ugh.
2019-11-29 20:33:52 +01:00
--------------------------------------------------------------------------------
import Test.Prelude
--------------------------------------------------------------------------------
import Text.Mustache
import Text.Megaparsec (errorBundlePretty)
import Graphics.Vty.Attributes
import qualified Data.Aeson as JSON
--------------------------------------------------------------------------------
import Xanthous.Orphans
--------------------------------------------------------------------------------
Implement messages Implement messages almost the same as in the Rust version, only with YAML instead of TOML this time, and a regular old mustache template instead of something handrolled. Besides that, pretty much everything here is the same.
2019-09-01 19:54:27 +02:00
main :: IO ()
main = defaultMain test
test :: TestTree
test = testGroup "Xanthous.Orphans"
[ localOption (QuickCheckTests 50)
. localOption (QuickCheckMaxSize 10)
$ testGroup "Template"
[ testProperty "ppTemplate / compileMustacheText " \tpl ->
let src = ppTemplate tpl
res :: Either String Template
res = over _Left errorBundlePretty
$ compileMustacheText (templateActual tpl) src
expected = templateCache tpl ^?! at (templateActual tpl)
in
counterexample (unpack src)
$ Right expected === do
(Template actual cache) <- res
maybe (Left "Template not found") Right $ cache ^? at actual
Implement saving+loading the game Implement ToJSON and FromJSON for all of the various pieces of the game state, and add a pair of functions saveGame/loadGame implementing a prism to save the game as zlib-compressed JSON. To test this, there's now Arbitrary, CoArbitrary, and Function instances for all the parts of the game state - to get around circular imports with the concrete entities this unfortunately is happening via orphan instances, plus an hs-boot file to break a circular import that was just a little too hard to remove by moving things around. Ugh.
2019-11-29 20:33:52 +01:00
, testProperty "JSON round trip" $ \(tpl :: Template) ->
counterexample (unpack $ ppTemplate tpl)
$ JSON.decode (JSON.encode tpl) === Just tpl
]
, testGroup "Attr"
[ testProperty "JSON round trip" $ \(attr :: Attr) ->
JSON.decode (JSON.encode attr) === Just attr
Implement messages Implement messages almost the same as in the Rust version, only with YAML instead of TOML this time, and a regular old mustache template instead of something handrolled. Besides that, pretty much everything here is the same.
2019-09-01 19:54:27 +02:00
]
]
Reference in a new issue Copy permalink