{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.Vessel.Single where

import Data.These
import Data.Patch (Group(..), Additive)
import Data.Semigroup
import Data.Functor.Identity
import Data.Witherable
import Data.Functor.Compose
import Data.Functor.Const
import Data.Align
import Data.Aeson
import GHC.Generics (Generic)

import Data.Vessel.Class
import Data.Vessel.Selectable
import Data.Vessel.ViewMorphism

------- Simple structure components -------

-- | A functor-indexed container for a single deletable item.
newtype SingleV (a :: *) (g :: * -> *) = SingleV { SingleV a g -> g (First (Maybe a))
unSingleV :: g (First (Maybe a)) }
  deriving ((forall x. SingleV a g -> Rep (SingleV a g) x)
-> (forall x. Rep (SingleV a g) x -> SingleV a g)
-> Generic (SingleV a g)
forall x. Rep (SingleV a g) x -> SingleV a g
forall x. SingleV a g -> Rep (SingleV a g) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a (g :: * -> *) x. Rep (SingleV a g) x -> SingleV a g
forall a (g :: * -> *) x. SingleV a g -> Rep (SingleV a g) x
$cto :: forall a (g :: * -> *) x. Rep (SingleV a g) x -> SingleV a g
$cfrom :: forall a (g :: * -> *) x. SingleV a g -> Rep (SingleV a g) x
Generic)

deriving instance (Eq (g (First (Maybe a)))) => Eq (SingleV a g)
deriving instance (Ord (g (First (Maybe a)))) => Ord (SingleV a g)
deriving instance (Show (g (First (Maybe a)))) => Show (SingleV a g)
deriving instance (Read (g (First (Maybe a)))) => Read (SingleV a g)

instance (Semigroup (g (First (Maybe a)))) => Semigroup (SingleV a g) where
  (SingleV g (First (Maybe a))
x) <> :: SingleV a g -> SingleV a g -> SingleV a g
<> (SingleV g (First (Maybe a))
y) = g (First (Maybe a)) -> SingleV a g
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (g (First (Maybe a))
x g (First (Maybe a)) -> g (First (Maybe a)) -> g (First (Maybe a))
forall a. Semigroup a => a -> a -> a
<> g (First (Maybe a))
y)

instance (Monoid (g (First (Maybe a)))) => Monoid (SingleV a g) where
  mempty :: SingleV a g
mempty = g (First (Maybe a)) -> SingleV a g
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV g (First (Maybe a))
forall a. Monoid a => a
mempty
  mappend :: SingleV a g -> SingleV a g -> SingleV a g
mappend (SingleV g (First (Maybe a))
x) (SingleV g (First (Maybe a))
y) = g (First (Maybe a)) -> SingleV a g
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (g (First (Maybe a)) -> g (First (Maybe a)) -> g (First (Maybe a))
forall a. Monoid a => a -> a -> a
mappend g (First (Maybe a))
x g (First (Maybe a))
y)

instance (Group (g (First (Maybe a)))) => Group (SingleV a g) where
  negateG :: SingleV a g -> SingleV a g
negateG (SingleV g (First (Maybe a))
x) = g (First (Maybe a)) -> SingleV a g
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (g (First (Maybe a)) -> g (First (Maybe a))
forall q. Group q => q -> q
negateG g (First (Maybe a))
x)

instance (Additive (g (First (Maybe a)))) => Additive (SingleV a g)

instance View (SingleV a) where
  cropV :: (forall a. s a -> i a -> r a)
-> SingleV a s -> SingleV a i -> Maybe (SingleV a r)
cropV forall a. s a -> i a -> r a
f (SingleV s (First (Maybe a))
s) (SingleV i (First (Maybe a))
i) = SingleV a r -> Maybe (SingleV a r)
forall a. a -> Maybe a
Just (SingleV a r -> Maybe (SingleV a r))
-> SingleV a r -> Maybe (SingleV a r)
forall a b. (a -> b) -> a -> b
$ r (First (Maybe a)) -> SingleV a r
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (r (First (Maybe a)) -> SingleV a r)
-> r (First (Maybe a)) -> SingleV a r
forall a b. (a -> b) -> a -> b
$ s (First (Maybe a)) -> i (First (Maybe a)) -> r (First (Maybe a))
forall a. s a -> i a -> r a
f s (First (Maybe a))
s i (First (Maybe a))
i
  nullV :: SingleV a i -> Bool
nullV (SingleV i (First (Maybe a))
_) = Bool
False
  condenseV :: (Foldable t, Filterable t, Functor t) => t (SingleV a g) -> SingleV a (Compose t g)
  condenseV :: t (SingleV a g) -> SingleV a (Compose t g)
condenseV t (SingleV a g)
m = Compose t g (First (Maybe a)) -> SingleV a (Compose t g)
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (Compose t g (First (Maybe a)) -> SingleV a (Compose t g))
-> (t (g (First (Maybe a))) -> Compose t g (First (Maybe a)))
-> t (g (First (Maybe a)))
-> SingleV a (Compose t g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (g (First (Maybe a))) -> Compose t g (First (Maybe a))
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (t (g (First (Maybe a))) -> SingleV a (Compose t g))
-> t (g (First (Maybe a))) -> SingleV a (Compose t g)
forall a b. (a -> b) -> a -> b
$ (SingleV a g -> g (First (Maybe a)))
-> t (SingleV a g) -> t (g (First (Maybe a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SingleV a g -> g (First (Maybe a))
forall a (g :: * -> *). SingleV a g -> g (First (Maybe a))
unSingleV t (SingleV a g)
m
  disperseV :: (Align t) => SingleV a (Compose t g) -> t (SingleV a g)
  disperseV :: SingleV a (Compose t g) -> t (SingleV a g)
disperseV (SingleV (Compose t (g (First (Maybe a)))
x)) = (g (First (Maybe a)) -> SingleV a g)
-> t (g (First (Maybe a))) -> t (SingleV a g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g (First (Maybe a)) -> SingleV a g
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV t (g (First (Maybe a)))
x
  mapV :: (forall x. f x -> g x) -> SingleV a f -> SingleV a g
  mapV :: (forall x. f x -> g x) -> SingleV a f -> SingleV a g
mapV forall x. f x -> g x
f (SingleV f (First (Maybe a))
x) = g (First (Maybe a)) -> SingleV a g
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (g (First (Maybe a)) -> SingleV a g)
-> g (First (Maybe a)) -> SingleV a g
forall a b. (a -> b) -> a -> b
$ f (First (Maybe a)) -> g (First (Maybe a))
forall x. f x -> g x
f f (First (Maybe a))
x
  traverseV :: (Applicative m) => (forall x. f x -> m (g x)) -> SingleV a f -> m (SingleV a g)
  traverseV :: (forall x. f x -> m (g x)) -> SingleV a f -> m (SingleV a g)
traverseV forall x. f x -> m (g x)
f (SingleV f (First (Maybe a))
x) = g (First (Maybe a)) -> SingleV a g
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (g (First (Maybe a)) -> SingleV a g)
-> m (g (First (Maybe a))) -> m (SingleV a g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (First (Maybe a)) -> m (g (First (Maybe a)))
forall x. f x -> m (g x)
f f (First (Maybe a))
x
  mapMaybeV :: (forall a. f a -> Maybe (g a))
-> SingleV a f -> Maybe (SingleV a g)
mapMaybeV forall a. f a -> Maybe (g a)
f (SingleV f (First (Maybe a))
x) = g (First (Maybe a)) -> SingleV a g
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (g (First (Maybe a)) -> SingleV a g)
-> Maybe (g (First (Maybe a))) -> Maybe (SingleV a g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (First (Maybe a)) -> Maybe (g (First (Maybe a)))
forall a. f a -> Maybe (g a)
f f (First (Maybe a))
x
  alignWithMaybeV :: (forall a. These (f a) (g a) -> Maybe (h a))
-> SingleV a f -> SingleV a g -> Maybe (SingleV a h)
alignWithMaybeV forall a. These (f a) (g a) -> Maybe (h a)
f (SingleV f (First (Maybe a))
x) (SingleV g (First (Maybe a))
y) = h (First (Maybe a)) -> SingleV a h
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (h (First (Maybe a)) -> SingleV a h)
-> Maybe (h (First (Maybe a))) -> Maybe (SingleV a h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> These (f (First (Maybe a))) (g (First (Maybe a)))
-> Maybe (h (First (Maybe a)))
forall a. These (f a) (g a) -> Maybe (h a)
f (f (First (Maybe a))
-> g (First (Maybe a))
-> These (f (First (Maybe a))) (g (First (Maybe a)))
forall a b. a -> b -> These a b
These f (First (Maybe a))
x g (First (Maybe a))
y)
  alignWithV :: (forall a. These (f a) (g a) -> h a)
-> SingleV a f -> SingleV a g -> SingleV a h
alignWithV forall a. These (f a) (g a) -> h a
f (SingleV f (First (Maybe a))
x) (SingleV g (First (Maybe a))
y) = h (First (Maybe a)) -> SingleV a h
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (h (First (Maybe a)) -> SingleV a h)
-> h (First (Maybe a)) -> SingleV a h
forall a b. (a -> b) -> a -> b
$ These (f (First (Maybe a))) (g (First (Maybe a)))
-> h (First (Maybe a))
forall a. These (f a) (g a) -> h a
f (These (f (First (Maybe a))) (g (First (Maybe a)))
 -> h (First (Maybe a)))
-> These (f (First (Maybe a))) (g (First (Maybe a)))
-> h (First (Maybe a))
forall a b. (a -> b) -> a -> b
$ f (First (Maybe a))
-> g (First (Maybe a))
-> These (f (First (Maybe a))) (g (First (Maybe a)))
forall a b. a -> b -> These a b
These f (First (Maybe a))
x g (First (Maybe a))
y

deriving instance ToJSON (g (First (Maybe a))) => ToJSON (SingleV a g)

deriving instance FromJSON (g (First (Maybe a))) => FromJSON (SingleV a g)

instance Selectable (SingleV a) () where
  type Selection (SingleV a) () = Maybe a
  selector :: (forall a. p a) -> () -> SingleV a p
selector forall a. p a
p () = p (First (Maybe a)) -> SingleV a p
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV p (First (Maybe a))
forall a. p a
p
  selection :: () -> SingleV a Identity -> Selection (SingleV a) ()
selection () (SingleV Identity (First (Maybe a))
x) = First (Maybe a) -> Maybe a
forall a. First a -> a
getFirst (First (Maybe a) -> Maybe a)
-> (Identity (First (Maybe a)) -> First (Maybe a))
-> Identity (First (Maybe a))
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (First (Maybe a)) -> First (Maybe a)
forall a. Identity a -> a
runIdentity (Identity (First (Maybe a)) -> Maybe a)
-> Identity (First (Maybe a)) -> Maybe a
forall a b. (a -> b) -> a -> b
$ Identity (First (Maybe a))
x

lookupSingleV :: SingleV a Identity -> Maybe a
lookupSingleV :: SingleV a Identity -> Maybe a
lookupSingleV = First (Maybe a) -> Maybe a
forall a. First a -> a
getFirst (First (Maybe a) -> Maybe a)
-> (SingleV a Identity -> First (Maybe a))
-> SingleV a Identity
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (First (Maybe a)) -> First (Maybe a)
forall a. Identity a -> a
runIdentity (Identity (First (Maybe a)) -> First (Maybe a))
-> (SingleV a Identity -> Identity (First (Maybe a)))
-> SingleV a Identity
-> First (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleV a Identity -> Identity (First (Maybe a))
forall a (g :: * -> *). SingleV a g -> g (First (Maybe a))
unSingleV

type instance ViewQueryResult (SingleV a (Const g)) = SingleV a Identity

-- Note.  the result functions always return Just;  a "Single" is always
-- present in the result, only that the value it may be is possibly a Nothing.
singleV :: (Applicative m, Applicative n) => ViewMorphism m n (Const g (Maybe a)) (SingleV a (Const g))
singleV :: ViewMorphism m n (Const g (Maybe a)) (SingleV a (Const g))
singleV = ViewHalfMorphism m n (Const g (Maybe a)) (SingleV a (Const g))
-> ViewHalfMorphism n m (SingleV a (Const g)) (Const g (Maybe a))
-> ViewMorphism m n (Const g (Maybe a)) (SingleV a (Const g))
forall (m :: * -> *) (n :: * -> *) p q.
ViewHalfMorphism m n p q
-> ViewHalfMorphism n m q p -> ViewMorphism m n p q
ViewMorphism ViewHalfMorphism m n (Const g (Maybe a)) (SingleV a (Const g))
forall (m :: * -> *) (n :: * -> *) g a.
(Applicative m, Applicative n) =>
ViewHalfMorphism m n (Const g (Maybe a)) (SingleV a (Const g))
toSingleV ViewHalfMorphism n m (SingleV a (Const g)) (Const g (Maybe a))
forall (m :: * -> *) (n :: * -> *) a g.
(Applicative m, Applicative n) =>
ViewHalfMorphism m n (SingleV a (Const g)) (Const g (Maybe a))
fromSingleV

toSingleV :: (Applicative m, Applicative n) => ViewHalfMorphism m n (Const g (Maybe a)) (SingleV a (Const g))
toSingleV :: ViewHalfMorphism m n (Const g (Maybe a)) (SingleV a (Const g))
toSingleV = ViewHalfMorphism :: forall (m :: * -> *) (n :: * -> *) p q.
(p -> m q)
-> (ViewQueryResult q -> n (ViewQueryResult p))
-> ViewHalfMorphism m n p q
ViewHalfMorphism
  { _viewMorphism_mapQuery :: Const g (Maybe a) -> m (SingleV a (Const g))
_viewMorphism_mapQuery = \(Const g
x) -> SingleV a (Const g) -> m (SingleV a (Const g))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SingleV a (Const g) -> m (SingleV a (Const g)))
-> (Const g (First (Maybe a)) -> SingleV a (Const g))
-> Const g (First (Maybe a))
-> m (SingleV a (Const g))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const g (First (Maybe a)) -> SingleV a (Const g)
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (Const g (First (Maybe a)) -> m (SingleV a (Const g)))
-> Const g (First (Maybe a)) -> m (SingleV a (Const g))
forall a b. (a -> b) -> a -> b
$ g -> Const g (First (Maybe a))
forall k a (b :: k). a -> Const a b
Const g
x
  , _viewMorphism_mapQueryResult :: ViewQueryResult (SingleV a (Const g))
-> n (ViewQueryResult (Const g (Maybe a)))
_viewMorphism_mapQueryResult = \(SingleV (Identity (First x))) -> Identity (Maybe a) -> n (Identity (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Identity (Maybe a)
forall a. a -> Identity a
Identity Maybe a
x)
  }

fromSingleV :: (Applicative m, Applicative n) => ViewHalfMorphism m n (SingleV a (Const g)) (Const g (Maybe a))
fromSingleV :: ViewHalfMorphism m n (SingleV a (Const g)) (Const g (Maybe a))
fromSingleV = ViewHalfMorphism :: forall (m :: * -> *) (n :: * -> *) p q.
(p -> m q)
-> (ViewQueryResult q -> n (ViewQueryResult p))
-> ViewHalfMorphism m n p q
ViewHalfMorphism
  { _viewMorphism_mapQuery :: SingleV a (Const g) -> m (Const g (Maybe a))
_viewMorphism_mapQuery = \(SingleV (Const g
g)) -> Const g (Maybe a) -> m (Const g (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Const g (Maybe a) -> m (Const g (Maybe a)))
-> Const g (Maybe a) -> m (Const g (Maybe a))
forall a b. (a -> b) -> a -> b
$ g -> Const g (Maybe a)
forall k a (b :: k). a -> Const a b
Const g
g
  , _viewMorphism_mapQueryResult :: ViewQueryResult (Const g (Maybe a))
-> n (ViewQueryResult (SingleV a (Const g)))
_viewMorphism_mapQueryResult = SingleV a Identity -> n (SingleV a Identity)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SingleV a Identity -> n (SingleV a Identity))
-> (Identity (Maybe a) -> SingleV a Identity)
-> Identity (Maybe a)
-> n (SingleV a Identity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (First (Maybe a)) -> SingleV a Identity
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (Identity (First (Maybe a)) -> SingleV a Identity)
-> (Identity (Maybe a) -> Identity (First (Maybe a)))
-> Identity (Maybe a)
-> SingleV a Identity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> First (Maybe a))
-> Identity (Maybe a) -> Identity (First (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe a -> First (Maybe a)
forall a. a -> First a
First
  }
-- | A gadget to "traverse" over a SingleV
handleSingleVSelector
  :: forall a f g m. Functor m
  => (forall x. x -> f x -> g x)
  -> m (First (Maybe a))
  ->    SingleV a f
  -> m (SingleV a g)
handleSingleVSelector :: (forall x. x -> f x -> g x)
-> m (First (Maybe a)) -> SingleV a f -> m (SingleV a g)
handleSingleVSelector forall x. x -> f x -> g x
k m (First (Maybe a))
f (SingleV f (First (Maybe a))
xs) = (\First (Maybe a)
y -> g (First (Maybe a)) -> SingleV a g
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (g (First (Maybe a)) -> SingleV a g)
-> g (First (Maybe a)) -> SingleV a g
forall a b. (a -> b) -> a -> b
$ First (Maybe a) -> f (First (Maybe a)) -> g (First (Maybe a))
forall x. x -> f x -> g x
k First (Maybe a)
y f (First (Maybe a))
xs) (First (Maybe a) -> SingleV a g)
-> m (First (Maybe a)) -> m (SingleV a g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (First (Maybe a))
f

-- | Non-existentialized mapV; since the contained value is known
mapSingleV :: (f (First (Maybe a)) -> g (First (Maybe a))) -> SingleV a f -> SingleV a g
mapSingleV :: (f (First (Maybe a)) -> g (First (Maybe a)))
-> SingleV a f -> SingleV a g
mapSingleV f (First (Maybe a)) -> g (First (Maybe a))
f (SingleV f (First (Maybe a))
xs) = g (First (Maybe a)) -> SingleV a g
forall a (g :: * -> *). g (First (Maybe a)) -> SingleV a g
SingleV (f (First (Maybe a)) -> g (First (Maybe a))
f f (First (Maybe a))
xs)