Begin a broken-out NestedMap type
Begin breaking out a NestedMap data structure, which existed in both the variables for the new template system and the structure that stored messages.
This commit is contained in:
Griffin Smith
parent
2c86856ca7
commit
db6ea02581
5 changed files with 258 additions and 2 deletions
|
|
@ -24,6 +24,7 @@ dependencies:
|
|||
- quickcheck-text
|
||||
- quickcheck-instances
|
||||
- brick
|
||||
- bifunctors
|
||||
- checkers
|
||||
- classy-prelude
|
||||
- comonad
|
||||
|
|
|
|||
227
src/Xanthous/Data/NestedMap.hs
Normal file
227
src/Xanthous/Data/NestedMap.hs
Normal file
|
|
@ -0,0 +1,227 @@
|
|||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE QuantifiedConstraints #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Data.NestedMap
|
||||
( NestedMapVal(..)
|
||||
, NestedMap(..)
|
||||
, lookup
|
||||
, lookupVal
|
||||
, insert
|
||||
|
||||
-- *
|
||||
, (:->)
|
||||
, BifunctorFunctor'(..)
|
||||
, BifunctorMonad'(..)
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude hiding (lookup, foldMap)
|
||||
import qualified Xanthous.Prelude as P
|
||||
--------------------------------------------------------------------------------
|
||||
import Test.QuickCheck
|
||||
import Data.Aeson
|
||||
import Data.Function (fix)
|
||||
import Data.Foldable (Foldable(..))
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Natural transformations on bifunctors
|
||||
type (:->) p q = forall a b. p a b -> q a b
|
||||
infixr 0 :->
|
||||
|
||||
class (forall b. Bifunctor b => Bifunctor (t b)) => BifunctorFunctor' t where
|
||||
bifmap' :: (Bifunctor p, Bifunctor q) => (p :-> q) -> t p :-> t q
|
||||
|
||||
class BifunctorFunctor' t => BifunctorMonad' t where
|
||||
bireturn' :: (Bifunctor p) => p :-> t p
|
||||
|
||||
bibind' :: (Bifunctor p, Bifunctor q) => (p :-> t q) -> t p :-> t q
|
||||
bibind' f = bijoin' . bifmap' f
|
||||
|
||||
bijoin' :: (Bifunctor p) => t (t p) :-> t p
|
||||
bijoin' = bibind' id
|
||||
|
||||
{-# MINIMAL bireturn', (bibind' | bijoin') #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data NestedMapVal m k v = Val v | Nested (NestedMap m k v)
|
||||
|
||||
deriving stock instance
|
||||
( forall k' v'. (Show k', Show v') => Show (m k' v')
|
||||
, Show k
|
||||
, Show v
|
||||
) => Show (NestedMapVal m k v)
|
||||
|
||||
deriving stock instance
|
||||
( forall k' v'. (Eq k', Eq v') => Eq (m k' v')
|
||||
, Eq k
|
||||
, Eq v
|
||||
) => Eq (NestedMapVal m k v)
|
||||
|
||||
instance
|
||||
forall m k v.
|
||||
( Arbitrary (m k v)
|
||||
, Arbitrary (m k (NestedMapVal m k v))
|
||||
, Arbitrary k
|
||||
, Arbitrary v
|
||||
, IsMap (m k (NestedMapVal m k v))
|
||||
, MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v)
|
||||
, ContainerKey (m k (NestedMapVal m k v)) ~ k
|
||||
) => Arbitrary (NestedMapVal m k v) where
|
||||
arbitrary = sized . fix $ \gen n ->
|
||||
let nst = fmap (NestedMap . mapFromList)
|
||||
. listOf
|
||||
$ (,) <$> arbitrary @k <*> gen (n `div` 2)
|
||||
in if n == 0
|
||||
then Val <$> arbitrary
|
||||
else oneof [ Val <$> arbitrary
|
||||
, Nested <$> nst]
|
||||
shrink (Val v) = Val <$> shrink v
|
||||
shrink (Nested mkv) = Nested <$> shrink mkv
|
||||
|
||||
instance Functor (m k) => Functor (NestedMapVal m k) where
|
||||
fmap f (Val v) = Val $ f v
|
||||
fmap f (Nested m) = Nested $ fmap f m
|
||||
|
||||
instance Bifunctor m => Bifunctor (NestedMapVal m) where
|
||||
bimap _ g (Val v) = Val $ g v
|
||||
bimap f g (Nested m) = Nested $ bimap f g m
|
||||
|
||||
instance BifunctorFunctor' NestedMapVal where
|
||||
bifmap' _ (Val v) = Val v
|
||||
bifmap' f (Nested m) = Nested $ bifmap' f m
|
||||
|
||||
instance (ToJSONKey k, ToJSON v, ToJSON (m k (NestedMapVal m k v)))
|
||||
=> ToJSON (NestedMapVal m k v) where
|
||||
toJSON (Val v) = toJSON v
|
||||
toJSON (Nested m) = toJSON m
|
||||
|
||||
instance Foldable (m k) => Foldable (NestedMapVal m k) where
|
||||
foldMap f (Val v) = f v
|
||||
foldMap f (Nested m) = foldMap f m
|
||||
|
||||
-- _NestedMapVal
|
||||
-- :: forall m k v m' k' v'.
|
||||
-- ( IsMap (m k v), IsMap (m' k' v')
|
||||
-- , IsMap (m [k] v), IsMap (m' [k'] v')
|
||||
-- , ContainerKey (m k v) ~ k, ContainerKey (m' k' v') ~ k'
|
||||
-- , ContainerKey (m [k] v) ~ [k], ContainerKey (m' [k'] v') ~ [k']
|
||||
-- , MapValue (m k v) ~ v, MapValue (m' k' v') ~ v'
|
||||
-- , MapValue (m [k] v) ~ v, MapValue (m' [k'] v') ~ v'
|
||||
-- )
|
||||
-- => Iso (NestedMapVal m k v)
|
||||
-- (NestedMapVal m' k' v')
|
||||
-- (m [k] v)
|
||||
-- (m' [k'] v')
|
||||
-- _NestedMapVal = iso hither yon
|
||||
-- where
|
||||
-- hither :: NestedMapVal m k v -> m [k] v
|
||||
-- hither (Val v) = singletonMap [] v
|
||||
-- hither (Nested m) = bimap _ _ $ m ^. _NestedMap
|
||||
-- yon = _
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newtype NestedMap m k v = NestedMap (m k (NestedMapVal m k v))
|
||||
|
||||
deriving stock instance
|
||||
( forall k' v'. (Eq k', Eq v') => Eq (m k' v')
|
||||
, Eq k
|
||||
, Eq v
|
||||
) => Eq (NestedMap m k v)
|
||||
|
||||
deriving stock instance
|
||||
( forall k' v'. (Show k', Show v') => Show (m k' v')
|
||||
, Show k
|
||||
, Show v
|
||||
) => Show (NestedMap m k v)
|
||||
|
||||
instance Arbitrary (m k (NestedMapVal m k v))
|
||||
=> Arbitrary (NestedMap m k v) where
|
||||
arbitrary = NestedMap <$> arbitrary
|
||||
shrink (NestedMap m) = NestedMap <$> shrink m
|
||||
|
||||
instance Functor (m k) => Functor (NestedMap m k) where
|
||||
fmap f (NestedMap m) = NestedMap $ fmap (fmap f) m
|
||||
|
||||
instance Bifunctor m => Bifunctor (NestedMap m) where
|
||||
bimap f g (NestedMap m) = NestedMap $ bimap f (bimap f g) m
|
||||
|
||||
instance BifunctorFunctor' NestedMap where
|
||||
bifmap' f (NestedMap m) = NestedMap . f $ bimap id (bifmap' f) m
|
||||
|
||||
instance (ToJSONKey k, ToJSON v, ToJSON (m k (NestedMapVal m k v)))
|
||||
=> ToJSON (NestedMap m k v) where
|
||||
toJSON (NestedMap m) = toJSON m
|
||||
|
||||
instance Foldable (m k) => Foldable (NestedMap m k) where
|
||||
foldMap f (NestedMap m) = foldMap (foldMap f) m
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
lookup
|
||||
:: ( IsMap (m k (NestedMapVal m k v))
|
||||
, MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v)
|
||||
, ContainerKey (m k (NestedMapVal m k v)) ~ k
|
||||
)
|
||||
=> NonEmpty k
|
||||
-> NestedMap m k v
|
||||
-> Maybe (NestedMapVal m k v)
|
||||
lookup (p :| []) (NestedMap vs) = P.lookup p vs
|
||||
lookup (p :| (p₁ : ps)) (NestedMap vs) = P.lookup p vs >>= \case
|
||||
(Val _) -> Nothing
|
||||
(Nested vs') -> lookup (p₁ :| ps) vs'
|
||||
|
||||
lookupVal
|
||||
:: ( IsMap (m k (NestedMapVal m k v))
|
||||
, MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v)
|
||||
, ContainerKey (m k (NestedMapVal m k v)) ~ k
|
||||
)
|
||||
=> NonEmpty k
|
||||
-> NestedMap m k v
|
||||
-> Maybe v
|
||||
lookupVal ks m
|
||||
| Just (Val v) <- lookup ks m = Just v
|
||||
| otherwise = Nothing
|
||||
|
||||
insert
|
||||
:: ( IsMap (m k (NestedMapVal m k v))
|
||||
, MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v)
|
||||
, ContainerKey (m k (NestedMapVal m k v)) ~ k
|
||||
)
|
||||
=> NonEmpty k
|
||||
-> v
|
||||
-> NestedMap m k v
|
||||
-> NestedMap m k v
|
||||
insert (k :| []) v (NestedMap m) = NestedMap $ P.insertMap k (Val v) m
|
||||
insert (k₁ :| (k₂ : ks)) v (NestedMap m) = NestedMap $ alterMap upd k₁ m
|
||||
where
|
||||
upd (Just (Nested nm)) = Just . Nested $ insert (k₂ :| ks) v nm
|
||||
upd _ = Just $
|
||||
let (kΩ :| ks') = NE.reverse (k₂ :| ks)
|
||||
in P.foldl'
|
||||
(\m' k -> Nested . NestedMap . singletonMap k $ m')
|
||||
(Nested . NestedMap . singletonMap kΩ $ Val v)
|
||||
ks'
|
||||
|
||||
-- _NestedMap
|
||||
-- :: ( IsMap (m k v), IsMap (m' k' v')
|
||||
-- , IsMap (m (NonEmpty k) v), IsMap (m' (NonEmpty k') v')
|
||||
-- , ContainerKey (m k v) ~ k, ContainerKey (m' k' v') ~ k'
|
||||
-- , ContainerKey (m (NonEmpty k) v) ~ (NonEmpty k)
|
||||
-- , ContainerKey (m' (NonEmpty k') v') ~ (NonEmpty k')
|
||||
-- , MapValue (m k v) ~ v, MapValue (m' k' v') ~ v'
|
||||
-- , MapValue (m (NonEmpty k) v) ~ v, MapValue (m' (NonEmpty k') v') ~ v'
|
||||
-- )
|
||||
-- => Iso (NestedMap m k v)
|
||||
-- (NestedMap m' k' v')
|
||||
-- (m (NonEmpty k) v)
|
||||
-- (m' (NonEmpty k') v')
|
||||
-- _NestedMap = iso undefined yon
|
||||
-- where
|
||||
-- hither (NestedMap m) = undefined . mapToList $ m
|
||||
-- yon mkv = undefined
|
||||
|
|
@ -6,6 +6,7 @@ import qualified Xanthous.Data.EntityMapSpec
|
|||
import qualified Xanthous.Data.EntityMap.GraphicsSpec
|
||||
import qualified Xanthous.Data.LevelsSpec
|
||||
import qualified Xanthous.Data.EntitiesSpec
|
||||
import qualified Xanthous.Data.NestedMapSpec
|
||||
import qualified Xanthous.DataSpec
|
||||
import qualified Xanthous.Entities.RawsSpec
|
||||
import qualified Xanthous.GameSpec
|
||||
|
|
@ -27,8 +28,9 @@ test = testGroup "Xanthous"
|
|||
[ Xanthous.Data.EntityCharSpec.test
|
||||
, Xanthous.Data.EntityMapSpec.test
|
||||
, Xanthous.Data.EntityMap.GraphicsSpec.test
|
||||
, Xanthous.Data.LevelsSpec.test
|
||||
, Xanthous.Data.EntitiesSpec.test
|
||||
, Xanthous.Data.LevelsSpec.test
|
||||
, Xanthous.Data.NestedMapSpec.test
|
||||
, Xanthous.Entities.RawsSpec.test
|
||||
, Xanthous.GameSpec.test
|
||||
, Xanthous.Generators.UtilSpec.test
|
||||
|
|
|
|||
20
test/Xanthous/Data/NestedMapSpec.hs
Normal file
20
test/Xanthous/Data/NestedMapSpec.hs
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Data.NestedMapSpec (main, test) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Test.Prelude
|
||||
--------------------------------------------------------------------------------
|
||||
import Test.QuickCheck.Instances.Semigroup ()
|
||||
--------------------------------------------------------------------------------
|
||||
import qualified Xanthous.Data.NestedMap as NM
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain test
|
||||
|
||||
test :: TestTree
|
||||
test = testGroup "Xanthous.Data.NestedMap"
|
||||
[ testProperty "insert/lookup" $ \nm ks v ->
|
||||
let nm' = NM.insert ks v nm
|
||||
in counterexample ("inserted: " <> show nm')
|
||||
$ NM.lookup @Map @Int @Int ks nm' === Just (NM.Val v)
|
||||
]
|
||||
|
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 4c80448c82dc61f97ea9809ad646f7ad66b0f57ca297e4d44ee596c7a1ef42fe
|
||||
-- hash: 0486cac7957fae1f9badffdd082f0c5eb5910eb8c066569123b0f57bc6fa0d8b
|
||||
|
||||
name: xanthous
|
||||
version: 0.1.0.0
|
||||
|
|
@ -44,6 +44,7 @@ library
|
|||
Xanthous.Data.EntityMap
|
||||
Xanthous.Data.EntityMap.Graphics
|
||||
Xanthous.Data.Levels
|
||||
Xanthous.Data.NestedMap
|
||||
Xanthous.Data.VectorBag
|
||||
Xanthous.Entities.Character
|
||||
Xanthous.Entities.Creature
|
||||
|
|
@ -95,6 +96,7 @@ library
|
|||
, array
|
||||
, async
|
||||
, base
|
||||
, bifunctors
|
||||
, brick
|
||||
, checkers
|
||||
, classy-prelude
|
||||
|
|
@ -163,6 +165,7 @@ executable xanthous
|
|||
Xanthous.Data.EntityMap
|
||||
Xanthous.Data.EntityMap.Graphics
|
||||
Xanthous.Data.Levels
|
||||
Xanthous.Data.NestedMap
|
||||
Xanthous.Data.VectorBag
|
||||
Xanthous.Entities.Character
|
||||
Xanthous.Entities.Creature
|
||||
|
|
@ -213,6 +216,7 @@ executable xanthous
|
|||
, array
|
||||
, async
|
||||
, base
|
||||
, bifunctors
|
||||
, brick
|
||||
, checkers
|
||||
, classy-prelude
|
||||
|
|
@ -274,6 +278,7 @@ test-suite test
|
|||
Xanthous.Data.EntityMap.GraphicsSpec
|
||||
Xanthous.Data.EntityMapSpec
|
||||
Xanthous.Data.LevelsSpec
|
||||
Xanthous.Data.NestedMapSpec
|
||||
Xanthous.DataSpec
|
||||
Xanthous.Entities.RawsSpec
|
||||
Xanthous.GameSpec
|
||||
|
|
@ -299,6 +304,7 @@ test-suite test
|
|||
, array
|
||||
, async
|
||||
, base
|
||||
, bifunctors
|
||||
, brick
|
||||
, checkers
|
||||
, classy-prelude
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue