maurice/snix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat(xanthous): Track the volume and density of item types

Browse source 
Allow the itemType raw to have density and volume fields, both of which
represent *intervals* of both density and volume (because both can
hypothetically vary a bit). The idea here is that when we're making
an *instance* of one of these items, we pick a random value in the
range.

Lots of stuff in this commit is datatype and typeclass instances to
support things like intervals being fields on datatypes that get
serialized to saved games - including a manual definition of Ord for
Item since Ord isn't well-defined for intervals

Change-Id: Ia088f2f75cdce9d00560297e5c269e3310b85bc3
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3225
Reviewed-by: grfn <grfn@gws.fyi>
Tested-by: BuildkiteCI
This commit is contained in:
Griffin Smith 2021-06-19 10:42:32 -04:00 • committed by grfn
parent 638b355aa6
commit 8b97683f6e
12 changed files with 255 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

29
users/grfn/xanthous/test/Test/Prelude.hs
View file

@ -1,3 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
--------------------------------------------------------------------------------
module Test.Prelude
( module Xanthous.Prelude
, module Test.Tasty
@ -5,15 +7,26 @@ module Test.Prelude
, module Test.Tasty.QuickCheck
, module Test.QuickCheck.Classes
, testBatch
, jsonRoundTrip
) where
import Xanthous.Prelude hiding (assert, elements)
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.HUnit
import Test.QuickCheck.Classes
import Test.QuickCheck.Checkers (TestBatch)
import Test.QuickCheck.Instances.ByteString ()
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (assert, elements)
--------------------------------------------------------------------------------
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.HUnit
import Test.QuickCheck.Classes
import Test.QuickCheck.Checkers (TestBatch, EqProp ((=-=)))
import Test.QuickCheck.Instances.ByteString ()
--------------------------------------------------------------------------------
import qualified Data.Aeson as JSON
import Data.Aeson (ToJSON, FromJSON)
--------------------------------------------------------------------------------
testBatch :: TestBatch -> TestTree
testBatch (name, tests) = testGroup name $ uncurry testProperty <$> tests
jsonRoundTrip
:: forall a. (ToJSON a, FromJSON a, EqProp a, Arbitrary a, Show a) => TestTree
jsonRoundTrip = testProperty "JSON round trip" $ \(x :: a) ->
JSON.decode (JSON.encode x) =-= Just x

34
users/grfn/xanthous/test/Xanthous/OrphansSpec.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedLists #-}
--------------------------------------------------------------------------------
module Xanthous.OrphansSpec where
--------------------------------------------------------------------------------
@ -8,6 +9,10 @@ import Text.Mustache
import Text.Megaparsec (errorBundlePretty)
import Graphics.Vty.Attributes
import qualified Data.Aeson as JSON
import Data.Interval (Interval, (<=..<=), (<=..<), (<..<=))
import Data.Aeson ( ToJSON(toJSON), object, Value(Array) )
import Data.Aeson.Types (fromJSON)
import Data.IntegerInterval (Extended(Finite))
--------------------------------------------------------------------------------
import Xanthous.Orphans
--------------------------------------------------------------------------------
@ -36,7 +41,32 @@ test = testGroup "Xanthous.Orphans"
$ JSON.decode (JSON.encode tpl) === Just tpl
]
, testGroup "Attr"
[ testProperty "JSON round trip" $ \(attr :: Attr) ->
JSON.decode (JSON.encode attr) === Just attr
[ jsonRoundTrip @Attr ]
, testGroup "Extended"
[ jsonRoundTrip @(Extended Int) ]
, testGroup "Interval"
[ testGroup "JSON"
[ jsonRoundTrip @(Interval Int)
, testCase "parses a single value as a length-1 interval" $
getSuccess (fromJSON $ toJSON (1 :: Int))
@?= Just (Finite (1 :: Int) <=..<= Finite 1)
, testCase "parses a pair of values as a single-ended interval" $
getSuccess (fromJSON $ toJSON ([1, 2] :: [Int]))
@?= Just (Finite (1 :: Int) <=..< Finite (2 :: Int))
, testCase "parses the full included/excluded syntax" $
getSuccess (fromJSON $ Array [ object [ "Excluded" JSON..= (1 :: Int) ]
, object [ "Included" JSON..= (4 :: Int) ]
])
@?= Just (Finite (1 :: Int) <..<= Finite (4 :: Int))
, testCase "parses open/closed as aliases" $
getSuccess (fromJSON $ Array [ object [ "Open" JSON..= (1 :: Int) ]
, object [ "Closed" JSON..= (4 :: Int) ]
])
@?= Just (Finite (1 :: Int) <..<= Finite (4 :: Int))
]
]
]
where
getSuccess :: JSON.Result a -> Maybe a
getSuccess (JSON.Error _) = Nothing
getSuccess (JSON.Success r) = Just r