{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.Sequence.KV
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Sequences of key value pairs.
--
--------------------------------------------------------------------------------
module HGeometry.Sequence.KV
  ( KV(..)
  , assocs
  , empty
  ) where

import Control.Lens
import Data.Bifoldable
import Data.Bitraversable
import Data.Foldable1
import Data.Functor.Classes

-----------------------------------------------------------------------------------------

-- | An 'f' of key value pairs
newtype KV f k v = KV (f (k,v))

-- | Get the data as an 'f' of (k,v) pairs.
assocs          :: Foldable f => KV f k v -> f (k,v)
assocs :: forall (f :: * -> *) k v. Foldable f => KV f k v -> f (k, v)
assocs (KV f (k, v)
xs) = f (k, v)
xs


deriving instance (Show k, Show v, Show1 f) => Show (KV f k v)
deriving instance (Eq k, Eq v, Eq1 f)       => Eq (KV f k v)
deriving instance (Ord k, Ord v, Ord1 f)    => Ord (KV f k v)

deriving instance Functor f     => Functor (KV f k)
deriving instance Foldable f    => Foldable (KV f k)
deriving instance Traversable f => Traversable (KV f k)

-- instance (Show1 f, Show k) => Show1 (KV f k)
-- instance Show1 f           => Show2 (KV f) where
--   liftShowsPrec2

instance (Eq1 f, Eq k) => Eq1 (KV f k)
instance Eq1 f         => Eq2 (KV f) where
  liftEq2 :: forall a b c d.
(a -> b -> Bool)
-> (c -> d -> Bool) -> KV f a c -> KV f b d -> Bool
liftEq2 a -> b -> Bool
eqK c -> d -> Bool
eqV (KV f (a, c)
xs) (KV f (b, d)
ys) = ((a, c) -> (b, d) -> Bool) -> f (a, c) -> f (b, d) -> Bool
forall a b. (a -> b -> Bool) -> f a -> f b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (\(a
k,c
v) (b
k',d
v') -> a -> b -> Bool
eqK a
k b
k' Bool -> Bool -> Bool
&& c -> d -> Bool
eqV c
v d
v') f (a, c)
xs f (b, d)
ys

instance (Ord1 f, Ord k) => Ord1 (KV f k)
instance Ord1 f         => Ord2 (KV f) where
  liftCompare2 :: forall a b c d.
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> KV f a c -> KV f b d -> Ordering
liftCompare2 a -> b -> Ordering
cmpK c -> d -> Ordering
cmpV (KV f (a, c)
xs) (KV f (b, d)
ys) =
    ((a, c) -> (b, d) -> Ordering) -> f (a, c) -> f (b, d) -> Ordering
forall a b. (a -> b -> Ordering) -> f a -> f b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (\(a
k,c
v) (b
k',d
v') -> a -> b -> Ordering
cmpK a
k b
k' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> c -> d -> Ordering
cmpV c
v d
v') f (a, c)
xs f (b, d)
ys


instance (Show1 f, Show k) => Show1 (KV f k)
instance Show1 f => Show2 (KV f) where
  liftShowsPrec2 :: forall a b.
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> KV f a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
sp1 [a] -> ShowS
sl1 Int -> b -> ShowS
sp2 [b] -> ShowS
sl2 Int
d (KV f (a, b)
xs) = (Int -> f (a, b) -> ShowS) -> String -> Int -> f (a, b) -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith ((Int -> (a, b) -> ShowS)
-> ([(a, b)] -> ShowS) -> Int -> f (a, b) -> ShowS
forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> (a, b) -> ShowS
sp [(a, b)] -> ShowS
forall {a}. a
sl) String
"KV" Int
d f (a, b)
xs
    where
      sp :: Int -> (a, b) -> ShowS
sp = (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> (a, b)
-> ShowS
forall a b.
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> (a, b)
-> ShowS
forall (f :: * -> * -> *) a b.
Show2 f =>
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> f a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
sp1 [a] -> ShowS
sl1 Int -> b -> ShowS
sp2 [b] -> ShowS
sl2
      sl :: a
sl = a
forall a. HasCallStack => a
undefined


--   liftShowsPrec2 sp1 _ sp2 _ _ (x, y) =
--         showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'

-- instance Eq1 f   => Eq2   (KV f)
-- instance Ord1 f  => Ord2  (KV f)


instance Foldable1 f    => Foldable1 (KV f e) where
  foldMap1 :: forall m a. Semigroup m => (a -> m) -> KV f e a -> m
foldMap1 a -> m
f (KV f (e, a)
xs) = ((e, a) -> m) -> f (e, a) -> m
forall m a. Semigroup m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 ((a -> m) -> (e, a) -> m
forall m a. Semigroup m => (a -> m) -> (e, a) -> m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 a -> m
f) f (e, a)
xs

instance Traversable1 f => Traversable1 (KV f e) where
  traverse1 :: forall (f :: * -> *) a b.
Apply f =>
(a -> f b) -> KV f e a -> f (KV f e b)
traverse1 a -> f b
f (KV f (e, a)
xs) = f (e, b) -> KV f e b
forall (f :: * -> *) k v. f (k, v) -> KV f k v
KV (f (e, b) -> KV f e b) -> f (f (e, b)) -> f (KV f e b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((e, a) -> f (e, b)) -> f (e, a) -> f (f (e, b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable1 t, Apply f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b. Apply f => (a -> f b) -> f a -> f (f b)
traverse1 ((a -> f b) -> (e, a) -> f (e, b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable1 t, Apply f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Apply f =>
(a -> f b) -> (e, a) -> f (e, b)
traverse1 a -> f b
f) f (e, a)
xs

instance Functor f => Bifunctor (KV f) where
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> KV f a c -> KV f b d
bimap a -> b
f c -> d
g (KV f (a, c)
xs) = f (b, d) -> KV f b d
forall (f :: * -> *) k v. f (k, v) -> KV f k v
KV (f (b, d) -> KV f b d) -> f (b, d) -> KV f b d
forall a b. (a -> b) -> a -> b
$ ((a, c) -> (b, d)) -> f (a, c) -> f (b, d)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> d
g) f (a, c)
xs

instance Foldable f => Bifoldable (KV f) where
  bifoldMap :: forall m a b. Monoid m => (a -> m) -> (b -> m) -> KV f a b -> m
bifoldMap a -> m
f b -> m
g (KV f (a, b)
xs) = ((a, b) -> m) -> f (a, b) -> m
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> (b -> m) -> (a, b) -> m
forall m a b. Monoid m => (a -> m) -> (b -> m) -> (a, b) -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap a -> m
f b -> m
g) f (a, b)
xs

instance Traversable f => Bitraversable (KV f) where
  bitraverse :: forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> KV f a b -> f (KV f c d)
bitraverse a -> f c
f b -> f d
g (KV f (a, b)
xs) = f (c, d) -> KV f c d
forall (f :: * -> *) k v. f (k, v) -> KV f k v
KV (f (c, d) -> KV f c d) -> f (f (c, d)) -> f (KV f c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((a, b) -> f (c, d)) -> f (a, b) -> f (f (c, d))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f b)
traverse ((a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> f c
f b -> f d
g) f (a, b)
xs

instance Functor f => FunctorWithIndex k (KV f k) where
  imap :: forall a b. (k -> a -> b) -> KV f k a -> KV f k b
imap k -> a -> b
f (KV f (k, a)
xs) = f (k, b) -> KV f k b
forall (f :: * -> *) k v. f (k, v) -> KV f k v
KV (f (k, b) -> KV f k b) -> f (k, b) -> KV f k b
forall a b. (a -> b) -> a -> b
$ ((k, a) -> (k, b)) -> f (k, a) -> f (k, b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(k
k,a
v) -> (k
k,k -> a -> b
f k
k a
v)) f (k, a)
xs

instance Foldable f => FoldableWithIndex k (KV f k) where
  ifoldMap :: forall m a. Monoid m => (k -> a -> m) -> KV f k a -> m
ifoldMap k -> a -> m
f (KV f (k, a)
xs) = ((k, a) -> m) -> f (k, a) -> m
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((k -> a -> m) -> (k, a) -> m
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry k -> a -> m
f) f (k, a)
xs

instance Traversable f => TraversableWithIndex k (KV f k) where
  itraverse :: forall (f :: * -> *) a b.
Applicative f =>
(k -> a -> f b) -> KV f k a -> f (KV f k b)
itraverse k -> a -> f b
f (KV f (k, a)
xs) = f (k, b) -> KV f k b
forall (f :: * -> *) k v. f (k, v) -> KV f k v
KV (f (k, b) -> KV f k b) -> f (f (k, b)) -> f (KV f k b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((k, a) -> f (k, b)) -> f (k, a) -> f (f (k, b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f b)
traverse (\(k
k,a
v) -> (k
k,) (b -> (k, b)) -> f b -> f (k, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> a -> f b
f k
k a
v) f (k, a)
xs


instance Semigroup (f (k,v)) => Semigroup (KV f k v) where
  (KV f (k, v)
xs) <> :: KV f k v -> KV f k v -> KV f k v
<> (KV f (k, v)
ys) = f (k, v) -> KV f k v
forall (f :: * -> *) k v. f (k, v) -> KV f k v
KV (f (k, v) -> KV f k v) -> f (k, v) -> KV f k v
forall a b. (a -> b) -> a -> b
$ f (k, v)
xs f (k, v) -> f (k, v) -> f (k, v)
forall a. Semigroup a => a -> a -> a
<> f (k, v)
ys

instance Monoid (f (k,v)) => Monoid (KV f k v) where
  mempty :: KV f k v
mempty = KV f k v
forall (f :: * -> *) k v. Monoid (f (k, v)) => KV f k v
empty

-- | Produce an empty structure
empty :: Monoid (f (k,v)) => KV f k v
empty :: forall (f :: * -> *) k v. Monoid (f (k, v)) => KV f k v
empty = f (k, v) -> KV f k v
forall (f :: * -> *) k v. f (k, v) -> KV f k v
KV f (k, v)
forall a. Monoid a => a
mempty