From 8b97683f6ef53605130542ea6de1e587b353aa5b Mon Sep 17 00:00:00 2001
From: Griffin Smith <grfn@gws.fyi>
Date: Sat, 19 Jun 2021 10:42:32 -0400
Subject: feat(xanthous): Track the volume and density of item types

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
---
 users/grfn/xanthous/test/Test/Prelude.hs         | 29 ++++++++++++++------
 users/grfn/xanthous/test/Xanthous/OrphansSpec.hs | 34 ++++++++++++++++++++++--
 2 files changed, 53 insertions(+), 10 deletions(-)

(limited to 'users/grfn/xanthous/test')

diff --git a/users/grfn/xanthous/test/Test/Prelude.hs b/users/grfn/xanthous/test/Test/Prelude.hs
index c423796184..2df0a6290a 100644
--- a/users/grfn/xanthous/test/Test/Prelude.hs
+++ b/users/grfn/xanthous/test/Test/Prelude.hs
@@ -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
diff --git a/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs b/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs
index 3740945877..0d800e8a91 100644
--- a/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs
+++ b/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs
@@ -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
-- 
cgit 1.4.1