about summary refs log tree commit diff
path: root/users/grfn
diff options
context:
space:
mode:
Diffstat (limited to 'users/grfn')
-rw-r--r--users/grfn/xanthous/package.yaml1
-rw-r--r--users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs3
-rw-r--r--users/grfn/xanthous/src/Xanthous/App.hs3
-rw-r--r--users/grfn/xanthous/src/Xanthous/App/Autocommands.hs2
-rw-r--r--users/grfn/xanthous/src/Xanthous/Data.hs68
-rw-r--r--users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs21
-rw-r--r--users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml2
-rw-r--r--users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml4
-rw-r--r--users/grfn/xanthous/src/Xanthous/Orphans.hs115
-rw-r--r--users/grfn/xanthous/test/Test/Prelude.hs29
-rw-r--r--users/grfn/xanthous/test/Xanthous/OrphansSpec.hs34
-rw-r--r--users/grfn/xanthous/xanthous.cabal6
12 files changed, 255 insertions, 33 deletions
diff --git a/users/grfn/xanthous/package.yaml b/users/grfn/xanthous/package.yaml
index 3939d52a51..fa217f80dc 100644
--- a/users/grfn/xanthous/package.yaml
+++ b/users/grfn/xanthous/package.yaml
@@ -94,6 +94,7 @@ default-extensions:
 - GADTSyntax
 - GeneralizedNewtypeDeriving
 - KindSignatures
+- StandaloneKindSignatures
 - LambdaCase
 - MultiWayIf
 - NoImplicitPrelude
diff --git a/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs b/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs
index 34f2a94038..e89fcd6211 100644
--- a/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs
+++ b/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs
@@ -89,7 +89,8 @@ type TagSingleConstructors  = 'TagSingleConstructors
 class Demotable (a :: k) where
   demote :: proxy a -> Demoted k
 
-type family All (p :: Type -> Constraint) (xs :: [k]) :: Constraint where
+type All :: (Type -> Constraint) -> [Type] -> Constraint
+type family All p xs where
   All p '[] = ()
   All p (x ': xs) = (p x, All p xs)
 
diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs
index 1e915a03fe..6ed545e3aa 100644
--- a/users/grfn/xanthous/src/Xanthous/App.hs
+++ b/users/grfn/xanthous/src/Xanthous/App.hs
@@ -32,6 +32,7 @@ import           Xanthous.Data
                  , position
                  , Position
                  , (|*|)
+                 , Tiles(..)
                  )
 import           Xanthous.Data.App (ResourceName, Panel(..), AppEvent(..))
 import qualified Xanthous.Data.EntityMap as EntityMap
@@ -127,7 +128,7 @@ handleCommand (Move dir) = do
   collisionAt newPos >>= \case
     Nothing -> do
       characterPosition .= newPos
-      stepGameBy =<< uses (character . speed) (|*| 1)
+      stepGameBy =<< uses (character . speed) (|*| Tiles 1)
       describeEntitiesAt newPos
     Just Combat -> attackAt newPos
     Just Stop -> pure ()
diff --git a/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs b/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs
index 5892536137..5d4db1a474 100644
--- a/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs
+++ b/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs
@@ -30,7 +30,7 @@ autoStep (AutoMove dir) = do
   collisionAt newPos >>= \case
     Nothing -> do
       characterPosition .= newPos
-      stepGameBy =<< uses (character . speed) (|*| 1)
+      stepGameBy =<< uses (character . speed) (|*| (1 :: Tiles))
       describeEntitiesAt newPos
       cancelIfDanger
     Just _ -> cancelAutocommand
diff --git a/users/grfn/xanthous/src/Xanthous/Data.hs b/users/grfn/xanthous/src/Xanthous/Data.hs
index c9c11b553b..89d0993b4e 100644
--- a/users/grfn/xanthous/src/Xanthous/Data.hs
+++ b/users/grfn/xanthous/src/Xanthous/Data.hs
@@ -3,8 +3,6 @@
 {-# LANGUAGE RoleAnnotations        #-}
 {-# LANGUAGE RecordWildCards        #-}
 {-# LANGUAGE DeriveTraversable      #-}
-{-# LANGUAGE DeriveFoldable         #-}
-{-# LANGUAGE DeriveFunctor          #-}
 {-# LANGUAGE TemplateHaskell        #-}
 {-# LANGUAGE NoTypeSynonymInstances #-}
 {-# LANGUAGE DuplicateRecordFields  #-}
@@ -56,6 +54,10 @@ module Xanthous.Data
   , TicksPerTile
   , TilesPerTick
   , timesTiles
+  , Square(..)
+  , Cubic(..)
+  , Grams
+  , Meters
 
     -- *
   , Dimensions'(..)
@@ -490,9 +492,9 @@ rotations orig@(Neighbors tl t tr l r bl b br) = V4
 newtype Per a b = Rate Double
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
-  deriving (Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) via Double
+  deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON)
+       via Double
   deriving (Semigroup, Monoid) via Product Double
-instance Arbitrary (Per a b) where arbitrary = genericArbitrary
 
 invertRate :: a `Per` b -> b `Per` a
 invertRate (Rate p) = Rate $ 1 / p
@@ -500,9 +502,42 @@ invertRate (Rate p) = Rate $ 1 / p
 invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b')
 invertedRate = iso invertRate invertRate
 
+type (:*:) :: Type -> Type -> Type
+type family (:*:) a b where
+  (a `Per` b) :*: b = a
+  (Square a) :*: a = Cubic a
+  a :*: a = Square a
+
 infixl 7 |*|
-(|*|) :: (Scalar a, Scalar b) => a `Per` b -> b -> a
-(|*|) (Rate rate) b = fromScalar $ rate * scalar b
+class MulUnit a b where
+  (|*|) :: a -> b -> a :*: b
+
+instance (Scalar a, Scalar b) => MulUnit (a `Per` b) b where
+  (Rate rate) |*| b = fromScalar $ rate * scalar b
+
+instance forall a. (Scalar a, a :*: a ~ Square a) => MulUnit a a where
+  x' |*| y' = Square @a . fromScalar $ scalar x' * scalar y'
+
+instance forall a. (Scalar a) => MulUnit (Square a) a where
+  x' |*| y' = Cubic @a . fromScalar $ scalar x' * scalar y'
+
+newtype Square a = Square a
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON
+           , Scalar
+           )
+       via a
+
+newtype Cubic a = Cubic a
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON
+           , Scalar
+           )
+       via a
+
+--------------------------------------------------------------------------------
 
 newtype Ticks = Ticks Word
   deriving stock (Show, Eq, Generic)
@@ -510,14 +545,14 @@ newtype Ticks = Ticks Word
   deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word
   deriving (Semigroup, Monoid) via (Sum Word)
   deriving Scalar via ScalarIntegral Ticks
-instance Arbitrary Ticks where arbitrary = genericArbitrary
+  deriving Arbitrary via GenericArbitrary Ticks
 
 newtype Tiles = Tiles Double
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
   deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double
   deriving (Semigroup, Monoid) via (Sum Double)
-instance Arbitrary Tiles where arbitrary = genericArbitrary
+  deriving Arbitrary via GenericArbitrary Tiles
 
 type TicksPerTile = Ticks `Per` Tiles
 type TilesPerTick = Tiles `Per` Ticks
@@ -536,6 +571,23 @@ newtype Hitpoints = Hitpoints Word
 
 --------------------------------------------------------------------------------
 
+-- | Grams, the fundamental measure of weight in Xanthous.
+newtype Grams = Grams Double
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving ( Arbitrary, Num, Ord, Enum, Real, Floating, Fractional, RealFloat
+           , RealFrac, Scalar, ToJSON, FromJSON
+           )
+       via Double
+  deriving (Semigroup, Monoid) via Sum Double
+
+-- | Every tile is 1 meter
+type Meters = Tiles
+
+
+
+--------------------------------------------------------------------------------
+
 data Box a = Box
   { _topLeftCorner :: V2 a
   , _dimensions    :: V2 a
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
index b7c5fe31c9..88070ed7b8 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
+++ b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
@@ -51,11 +51,12 @@ import Data.Aeson.Generic.DerivingVia
 import Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
 import Xanthous.Messages (Message(..))
-import Xanthous.Data (TicksPerTile, Hitpoints)
+import Xanthous.Data (TicksPerTile, Hitpoints, Per, Grams, Cubic, Meters)
 import Xanthous.Data.EntityChar
 import Xanthous.Util.QuickCheck
 import Xanthous.Generators.Speech (Language, gormlak, english)
 import Xanthous.Orphans ()
+import Data.Interval (Interval, lowerBound', upperBound')
 --------------------------------------------------------------------------------
 
 -- | Identifiers for languages that creatures can speak.
@@ -153,10 +154,12 @@ data ItemType = ItemType
   , _description     :: !Text
   , _longDescription :: !Text
   , _char            :: !EntityChar
+  , _density         :: !(Interval (Grams `Per` Cubic Meters))
+  , _volume          :: !(Interval (Cubic Meters))
   , _edible          :: !(Maybe EdibleItem)
   , _wieldable       :: !(Maybe WieldableItem)
   }
-  deriving stock (Show, Eq, Ord, Generic)
+  deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
   deriving Arbitrary via GenericArbitrary ItemType
   deriving (ToJSON, FromJSON)
@@ -164,6 +167,20 @@ data ItemType = ItemType
                        ItemType
 makeFieldsNoPrefix ''ItemType
 
+instance Ord ItemType where
+  compare x y
+    = compareOf name x y
+    <> compareOf description x y
+    <> compareOf longDescription x y
+    <> compareOf char x y
+    <> compareOf (density . to extractInterval) x y
+    <> compareOf (volume . to extractInterval) x y
+    <> compareOf edible x y
+    <> compareOf wieldable x y
+    where
+      compareOf l = comparing (view l)
+      extractInterval = lowerBound' &&& upperBound'
+
 -- | Can this item be eaten?
 isEdible :: ItemType -> Bool
 isEdible = has $ edible . _Just
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml
index c3f19dce91..c0501a18a8 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml
@@ -10,3 +10,5 @@ Item:
     hitpointsHealed: 2
     eatMessage:
       - You slurp up the noodles. Yumm!
+  density: 500000
+  volume: 0.001
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml
index bc7fde4d8b..4100808ca0 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml
@@ -12,3 +12,7 @@ Item:
       - You bonk the {{creature.creatureType.name}} over the head with your stick.
       - You bash the {{creature.creatureType.name}} on the noggin with your stick.
       - You whack the {{creature.creatureType.name}} with your stick.
+  # https://www.sciencedirect.com/topics/agricultural-and-biological-sciences/wood-density
+  # it's a hard stick. so it's dense wood.
+  density: 890000 # g/m³
+  volume: [ 0.003, 0.006 ] # ≈3.5 cm radius × ≈1m length
diff --git a/users/grfn/xanthous/src/Xanthous/Orphans.hs b/users/grfn/xanthous/src/Xanthous/Orphans.hs
index e6ea131031..0b282af44c 100644
--- a/users/grfn/xanthous/src/Xanthous/Orphans.hs
+++ b/users/grfn/xanthous/src/Xanthous/Orphans.hs
@@ -1,10 +1,10 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE PackageImports #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE PackageImports        #-}
+{-# OPTIONS_GHC -Wno-orphans       #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
 --------------------------------------------------------------------------------
-{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
 module Xanthous.Orphans
   ( ppTemplate
   ) where
@@ -28,11 +28,15 @@ import           Text.Mustache
 import           Text.Mustache.Type ( showKey )
 import           Control.Monad.State
 import           Linear
+import qualified Data.Interval as Interval
+import           Data.Interval ( Interval, Extended (..), Boundary (..)
+                               , lowerBound', upperBound', (<=..<), (<=..<=)
+                               , interval)
+import           Test.QuickCheck.Checkers (EqProp ((=-=)))
 --------------------------------------------------------------------------------
 import           Xanthous.Util.JSON
 import           Xanthous.Util.QuickCheck
-import qualified Data.Interval as Interval
-import Data.Interval (Interval, Extended (..))
+import           Xanthous.Util (EqEqProp(EqEqProp))
 --------------------------------------------------------------------------------
 
 instance forall s a.
@@ -241,6 +245,8 @@ instance CoArbitrary a => CoArbitrary (MaybeDefault a) where
 instance (Eq a, Show a, Read a, Function a) => Function (MaybeDefault a) where
   function = functionShow
 
+deriving via (EqEqProp Attr) instance EqProp Attr
+
 instance Arbitrary Attr where
   arbitrary = do
     attrStyle <- arbitrary
@@ -367,12 +373,46 @@ instance Function a => Function (V2 a)
 
 --------------------------------------------------------------------------------
 
-instance Arbitrary r => Arbitrary (Extended r) where
+instance CoArbitrary Boundary
+instance Function Boundary
+
+instance Arbitrary a => Arbitrary (Extended a) where
   arbitrary = oneof [ pure NegInf
                     , pure PosInf
                     , Finite <$> arbitrary
                     ]
 
+instance CoArbitrary a => CoArbitrary (Extended a) where
+  coarbitrary NegInf = variant 1
+  coarbitrary PosInf = variant 2
+  coarbitrary (Finite x) = variant 3 . coarbitrary x
+
+instance (Function a) => Function (Extended a) where
+  function = functionMap g h
+    where
+     g NegInf = Left True
+     g (Finite a) = Right a
+     g PosInf = Left False
+     h (Left False) = PosInf
+     h (Left True) = NegInf
+     h (Right a) = Finite a
+
+instance ToJSON a => ToJSON (Extended a) where
+  toJSON NegInf = String "NegInf"
+  toJSON PosInf = String "PosInf"
+  toJSON (Finite x) = toJSON x
+
+instance FromJSON a => FromJSON (Extended a) where
+  parseJSON (String "NegInf") = pure NegInf
+  parseJSON (String "PosInf") = pure PosInf
+  parseJSON val               = Finite <$> parseJSON val
+
+instance (EqProp a, Show a) => EqProp (Extended a) where
+  NegInf =-= NegInf = property True
+  PosInf =-= PosInf = property True
+  (Finite x) =-= (Finite y) = x =-= y
+  x =-= y = counterexample (show x <> " /= " <> show y) False
+
 instance Arbitrary Interval.Boundary where
   arbitrary = elements [ Interval.Open , Interval.Closed ]
 
@@ -384,3 +424,60 @@ instance (Ord r, Arbitrary r) => Arbitrary (Interval r) where
       Interval.interval
       lower
       upper
+
+instance CoArbitrary a => CoArbitrary (Interval a) where
+  coarbitrary int = coarbitrary (lowerBound' int) . coarbitrary (upperBound' int)
+
+instance (Function a, Ord a) => Function (Interval a) where
+  function = functionMap g h
+    where
+      g = lowerBound' &&& upperBound'
+      h = uncurry interval
+
+deriving via (EqEqProp (Interval a)) instance Eq a => (EqProp (Interval a))
+
+instance ToJSON a => ToJSON (Interval a) where
+  toJSON x = Array . fromList $
+    [ object [ lowerKey .= lowerVal ]
+    , object [ upperKey .= upperVal ]
+    ]
+    where
+      (lowerVal, lowerBoundary) = lowerBound' x
+      (upperVal, upperBoundary) = upperBound' x
+      upperKey = boundaryToKey upperBoundary
+      lowerKey = boundaryToKey lowerBoundary
+      boundaryToKey Open = "Excluded"
+      boundaryToKey Closed = "Included"
+
+instance forall a. (FromJSON a, Ord a) => FromJSON (Interval a) where
+  parseJSON x =
+    boundPairWithBoundary x
+      <|> boundPairWithoutBoundary x
+      <|> singleVal x
+    where
+      boundPairWithBoundary = withArray "Bound pair" $ \arr -> do
+        checkLength arr
+        lower <- parseBound $ arr ^?! ix 0
+        upper <- parseBound $ arr ^?! ix 1
+        pure $ interval lower upper
+      parseBound = withObject "Bound" $ \obj -> do
+        when (length obj /= 1) $ fail "Expected an object with a single key"
+        let [(k, v)] = obj ^@.. ifolded
+        boundary <- case k of
+          "Excluded" -> pure Open
+          "Open"     -> pure Open
+          "Included" -> pure Closed
+          "Closed"   -> pure Closed
+          _          -> fail "Invalid boundary specification"
+        val <- parseJSON v
+        pure (val, boundary)
+      boundPairWithoutBoundary = withArray "Bound pair" $ \arr -> do
+        checkLength arr
+        lower <- parseJSON $ arr ^?! ix 0
+        upper <- parseJSON $ arr ^?! ix 1
+        pure $ lower <=..< upper
+      singleVal v = do
+        val <- parseJSON v
+        pure $ val <=..<= val
+      checkLength arr =
+        when (length arr /= 2) $ fail "Expected array of length 2"
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
diff --git a/users/grfn/xanthous/xanthous.cabal b/users/grfn/xanthous/xanthous.cabal
index 4cbabdb58e..baa09fab3e 100644
--- a/users/grfn/xanthous/xanthous.cabal
+++ b/users/grfn/xanthous/xanthous.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: b39d4dd906804ca42f8965c2dbe519434e80622fef7fafce1dca0d211a1c6663
+-- hash: fdfa821ad291b11a2d7a7ee9cc38d7980a9b1f494b77216b141d3424168d621d
 
 name:           xanthous
 version:        0.1.0.0
@@ -104,6 +104,7 @@ library
       GADTSyntax
       GeneralizedNewtypeDeriving
       KindSignatures
+      StandaloneKindSignatures
       LambdaCase
       MultiWayIf
       NoImplicitPrelude
@@ -261,6 +262,7 @@ executable xanthous
       GADTSyntax
       GeneralizedNewtypeDeriving
       KindSignatures
+      StandaloneKindSignatures
       LambdaCase
       MultiWayIf
       NoImplicitPrelude
@@ -385,6 +387,7 @@ test-suite test
       GADTSyntax
       GeneralizedNewtypeDeriving
       KindSignatures
+      StandaloneKindSignatures
       LambdaCase
       MultiWayIf
       NoImplicitPrelude
@@ -494,6 +497,7 @@ benchmark benchmark
       GADTSyntax
       GeneralizedNewtypeDeriving
       KindSignatures
+      StandaloneKindSignatures
       LambdaCase
       MultiWayIf
       NoImplicitPrelude
generated by cgit-pink 1.4.1 (git 2.44.1) at 2024-06-28T02·58+0000