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

Ignoring revisions in .git-blame-ignore-revs. Click here to bypass and see the normal blame view.

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