From 82ecd61f5c699cf3af6c4eadf47a1c52b1d696c6 Mon Sep 17 00:00:00 2001 From: Aspen Smith Date: Sun, 11 Feb 2024 22:00:40 -0500 Subject: chore(users): grfn -> aspen Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9 Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809 Autosubmit: aspen Reviewed-by: sterni Tested-by: BuildkiteCI Reviewed-by: lukegb --- users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs | 227 --------------------- 1 file changed, 227 deletions(-) delete mode 100644 users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs (limited to 'users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs') diff --git a/users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs b/users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs deleted file mode 100644 index 1b875d448302..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# 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 -- cgit 1.4.1