{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Data.Functor.Logistic
  ( Logistic(..)
  , setters
  ) where

import Data.Distributive
import Data.Functor.Identity
import Data.Functor.Contravariant
import Data.Functor.Compose
import Data.Functor.Product
import Data.Proxy
import Data.Complex
import GHC.Generics

class Functor t => Logistic t where
  deliver :: Contravariant f => f (t a -> t a) -> t (f (a -> a))
  default deliver :: (Generic1 t, Logistic (Rep1 t), Contravariant f) => f (t a -> t a) -> t (f (a -> a))
  deliver f (t a -> t a)
f = Rep1 t (f (a -> a)) -> t (f (a -> a))
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 t (f (a -> a)) -> t (f (a -> a)))
-> Rep1 t (f (a -> a)) -> t (f (a -> a))
forall a b. (a -> b) -> a -> b
$ f (Rep1 t a -> Rep1 t a) -> Rep1 t (f (a -> a))
forall (t :: * -> *) (f :: * -> *) a.
(Logistic t, Contravariant f) =>
f (t a -> t a) -> t (f (a -> a))
deliver (f (Rep1 t a -> Rep1 t a) -> Rep1 t (f (a -> a)))
-> f (Rep1 t a -> Rep1 t a) -> Rep1 t (f (a -> a))
forall a b. (a -> b) -> a -> b
$ ((Rep1 t a -> Rep1 t a) -> t a -> t a)
-> f (t a -> t a) -> f (Rep1 t a -> Rep1 t a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\Rep1 t a -> Rep1 t a
g -> Rep1 t a -> t a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 t a -> t a) -> (t a -> Rep1 t a) -> t a -> t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep1 t a -> Rep1 t a
g (Rep1 t a -> Rep1 t a) -> (t a -> Rep1 t a) -> t a -> Rep1 t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t a -> Rep1 t a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1) f (t a -> t a)
f

instance Logistic Identity where
  deliver :: f (Identity a -> Identity a) -> Identity (f (a -> a))
deliver f (Identity a -> Identity a)
f = f (a -> a) -> Identity (f (a -> a))
forall a. a -> Identity a
Identity (((a -> a) -> Identity a -> Identity a)
-> f (Identity a -> Identity a) -> f (a -> a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (a -> a) -> Identity a -> Identity a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (Identity a -> Identity a)
f)

instance Logistic Par1 where
  deliver :: f (Par1 a -> Par1 a) -> Par1 (f (a -> a))
deliver f (Par1 a -> Par1 a)
f = f (a -> a) -> Par1 (f (a -> a))
forall p. p -> Par1 p
Par1 (((a -> a) -> Par1 a -> Par1 a)
-> f (Par1 a -> Par1 a) -> f (a -> a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (a -> a) -> Par1 a -> Par1 a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (Par1 a -> Par1 a)
f)

instance Logistic f => Logistic (M1 i c f) where
  deliver :: f (M1 i c f a -> M1 i c f a) -> M1 i c f (f (a -> a))
deliver f (M1 i c f a -> M1 i c f a)
f = f (f (a -> a)) -> M1 i c f (f (a -> a))
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f (f (a -> a)) -> M1 i c f (f (a -> a)))
-> f (f (a -> a)) -> M1 i c f (f (a -> a))
forall a b. (a -> b) -> a -> b
$ f (f a -> f a) -> f (f (a -> a))
forall (t :: * -> *) (f :: * -> *) a.
(Logistic t, Contravariant f) =>
f (t a -> t a) -> t (f (a -> a))
deliver (f (f a -> f a) -> f (f (a -> a)))
-> f (f a -> f a) -> f (f (a -> a))
forall a b. (a -> b) -> a -> b
$ ((f a -> f a) -> M1 i c f a -> M1 i c f a)
-> f (M1 i c f a -> M1 i c f a) -> f (f a -> f a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\f a -> f a
g -> f a -> M1 i c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 i c f a)
-> (M1 i c f a -> f a) -> M1 i c f a -> M1 i c f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> f a
g (f a -> f a) -> (M1 i c f a -> f a) -> M1 i c f a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i c f a -> f a
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1) f (M1 i c f a -> M1 i c f a)
f

instance Logistic f => Logistic (Rec1 f) where
  deliver :: f (Rec1 f a -> Rec1 f a) -> Rec1 f (f (a -> a))
deliver f (Rec1 f a -> Rec1 f a)
f = f (f (a -> a)) -> Rec1 f (f (a -> a))
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (f (f (a -> a)) -> Rec1 f (f (a -> a)))
-> f (f (a -> a)) -> Rec1 f (f (a -> a))
forall a b. (a -> b) -> a -> b
$ f (f a -> f a) -> f (f (a -> a))
forall (t :: * -> *) (f :: * -> *) a.
(Logistic t, Contravariant f) =>
f (t a -> t a) -> t (f (a -> a))
deliver (f (f a -> f a) -> f (f (a -> a)))
-> f (f a -> f a) -> f (f (a -> a))
forall a b. (a -> b) -> a -> b
$ ((f a -> f a) -> Rec1 f a -> Rec1 f a)
-> f (Rec1 f a -> Rec1 f a) -> f (f a -> f a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\f a -> f a
g -> f a -> Rec1 f a
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (f a -> Rec1 f a) -> (Rec1 f a -> f a) -> Rec1 f a -> Rec1 f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> f a
g (f a -> f a) -> (Rec1 f a -> f a) -> Rec1 f a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec1 f a -> f a
forall k (f :: k -> *) (p :: k). Rec1 f p -> f p
unRec1) f (Rec1 f a -> Rec1 f a)
f

instance Logistic Proxy where
  deliver :: f (Proxy a -> Proxy a) -> Proxy (f (a -> a))
deliver f (Proxy a -> Proxy a)
_ = Proxy (f (a -> a))
forall k (t :: k). Proxy t
Proxy

instance Logistic U1 where
  deliver :: f (U1 a -> U1 a) -> U1 (f (a -> a))
deliver f (U1 a -> U1 a)
_ = U1 (f (a -> a))
forall k (p :: k). U1 p
U1

-- | Update only if the argument matches
instance Eq r => Logistic ((->) r) where
  deliver :: f ((r -> a) -> r -> a) -> r -> f (a -> a)
deliver f ((r -> a) -> r -> a)
f r
x = ((a -> a) -> (r -> a) -> r -> a)
-> f ((r -> a) -> r -> a) -> f (a -> a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\a -> a
u r -> a
g r
r -> if r
r r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
x then a -> a
u (r -> a
g r
r) else r -> a
g r
r) f ((r -> a) -> r -> a)
f

instance (Logistic f, Logistic g) => Logistic (Product f g) where
  deliver :: f (Product f g a -> Product f g a) -> Product f g (f (a -> a))
deliver f (Product f g a -> Product f g a)
f = f (f (a -> a)) -> g (f (a -> a)) -> Product f g (f (a -> a))
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair
    (f (f a -> f a) -> f (f (a -> a))
forall (t :: * -> *) (f :: * -> *) a.
(Logistic t, Contravariant f) =>
f (t a -> t a) -> t (f (a -> a))
deliver (((f a -> f a) -> Product f g a -> Product f g a)
-> f (Product f g a -> Product f g a) -> f (f a -> f a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\f a -> f a
u (Pair f a
a g a
b) -> f a -> g a -> Product f g a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (f a -> f a
u f a
a) g a
b) f (Product f g a -> Product f g a)
f))
    (f (g a -> g a) -> g (f (a -> a))
forall (t :: * -> *) (f :: * -> *) a.
(Logistic t, Contravariant f) =>
f (t a -> t a) -> t (f (a -> a))
deliver (((g a -> g a) -> Product f g a -> Product f g a)
-> f (Product f g a -> Product f g a) -> f (g a -> g a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\g a -> g a
u (Pair f a
a g a
b) -> f a -> g a -> Product f g a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f a
a (g a -> g a
u g a
b)) f (Product f g a -> Product f g a)
f))

instance (Logistic f, Logistic g) => Logistic (f :*: g) where
  deliver :: f ((:*:) f g a -> (:*:) f g a) -> (:*:) f g (f (a -> a))
deliver f ((:*:) f g a -> (:*:) f g a)
f
    = f (f a -> f a) -> f (f (a -> a))
forall (t :: * -> *) (f :: * -> *) a.
(Logistic t, Contravariant f) =>
f (t a -> t a) -> t (f (a -> a))
deliver (((f a -> f a) -> (:*:) f g a -> (:*:) f g a)
-> f ((:*:) f g a -> (:*:) f g a) -> f (f a -> f a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\f a -> f a
u (f a
a :*: g a
b) -> f a -> f a
u f a
a f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
b) f ((:*:) f g a -> (:*:) f g a)
f)
    f (f (a -> a)) -> g (f (a -> a)) -> (:*:) f g (f (a -> a))
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: f (g a -> g a) -> g (f (a -> a))
forall (t :: * -> *) (f :: * -> *) a.
(Logistic t, Contravariant f) =>
f (t a -> t a) -> t (f (a -> a))
deliver (((g a -> g a) -> (:*:) f g a -> (:*:) f g a)
-> f ((:*:) f g a -> (:*:) f g a) -> f (g a -> g a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\g a -> g a
u (f a
a :*: g a
b) -> f a
a f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a -> g a
u g a
b) f ((:*:) f g a -> (:*:) f g a)
f)

instance (Logistic f, Logistic g, Applicative f, Traversable g, Distributive g) => Logistic (Compose f g) where
  deliver :: f (Compose f g a -> Compose f g a) -> Compose f g (f (a -> a))
deliver f (Compose f g a -> Compose f g a)
f = f (g (f (a -> a))) -> Compose f g (f (a -> a))
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose
    (f (g (f (a -> a))) -> Compose f g (f (a -> a)))
-> f (g (f (a -> a))) -> Compose f g (f (a -> a))
forall a b. (a -> b) -> a -> b
$ (Compose g f (a -> a) -> g (f (a -> a)))
-> f (Compose g f (a -> a)) -> f (g (f (a -> a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Compose g f (a -> a) -> g (f (a -> a))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose
    (f (Compose g f (a -> a)) -> f (g (f (a -> a))))
-> f (Compose g f (a -> a)) -> f (g (f (a -> a)))
forall a b. (a -> b) -> a -> b
$ Compose g f (f a -> f a) -> f (Compose g f (a -> a))
forall (t :: * -> *) (f :: * -> *) a.
(Logistic t, Contravariant f) =>
f (t a -> t a) -> t (f (a -> a))
deliver
    (Compose g f (f a -> f a) -> f (Compose g f (a -> a)))
-> Compose g f (f a -> f a) -> f (Compose g f (a -> a))
forall a b. (a -> b) -> a -> b
$ g (f (f a -> f a)) -> Compose g f (f a -> f a)
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose
    (g (f (f a -> f a)) -> Compose g f (f a -> f a))
-> g (f (f a -> f a)) -> Compose g f (f a -> f a)
forall a b. (a -> b) -> a -> b
$ f (g (f a) -> g (f a)) -> g (f (f a -> f a))
forall (t :: * -> *) (f :: * -> *) a.
(Logistic t, Contravariant f) =>
f (t a -> t a) -> t (f (a -> a))
deliver
    (f (g (f a) -> g (f a)) -> g (f (f a -> f a)))
-> f (g (f a) -> g (f a)) -> g (f (f a -> f a))
forall a b. (a -> b) -> a -> b
$ ((g (f a) -> g (f a)) -> Compose f g a -> Compose f g a)
-> f (Compose f g a -> Compose f g a) -> f (g (f a) -> g (f a))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (g (f a) -> g (f a)) -> Compose f g a -> Compose f g a
forall (g :: * -> *) (f :: * -> *) (g :: * -> *) (f :: * -> *) a a.
(Traversable g, Applicative f, Distributive g, Functor f) =>
(g (f a) -> g (f a)) -> Compose f g a -> Compose f g a
go f (Compose f g a -> Compose f g a)
f
    where
      go :: (g (f a) -> g (f a)) -> Compose f g a -> Compose f g a
go g (f a) -> g (f a)
p = f (g a) -> Compose f g a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (f (g a) -> Compose f g a)
-> (Compose f g a -> f (g a)) -> Compose f g a -> Compose f g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g (f a) -> f (g a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (g (f a) -> f (g a))
-> (Compose f g a -> g (f a)) -> Compose f g a -> f (g a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g (f a) -> g (f a)
p (g (f a) -> g (f a))
-> (Compose f g a -> g (f a)) -> Compose f g a -> g (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (g a) -> g (f a)
forall (g :: * -> *) (f :: * -> *) a.
(Distributive g, Functor f) =>
f (g a) -> g (f a)
distribute (f (g a) -> g (f a))
-> (Compose f g a -> f (g a)) -> Compose f g a -> g (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose f g a -> f (g a)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose

instance (Logistic f, Logistic g, Applicative f, Traversable g, Distributive g) => Logistic (f :.: g) where
  deliver :: f ((:.:) f g a -> (:.:) f g a) -> (:.:) f g (f (a -> a))
deliver f ((:.:) f g a -> (:.:) f g a)
f = f (g (f (a -> a))) -> (:.:) f g (f (a -> a))
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (f (g (f (a -> a))) -> (:.:) f g (f (a -> a)))
-> f (g (f (a -> a))) -> (:.:) f g (f (a -> a))
forall a b. (a -> b) -> a -> b
$ ((:.:) g f (a -> a) -> g (f (a -> a)))
-> f ((:.:) g f (a -> a)) -> f (g (f (a -> a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (:.:) g f (a -> a) -> g (f (a -> a))
forall k2 (f :: k2 -> *) k1 (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1 (f ((:.:) g f (a -> a)) -> f (g (f (a -> a))))
-> f ((:.:) g f (a -> a)) -> f (g (f (a -> a)))
forall a b. (a -> b) -> a -> b
$ (:.:) g f (f a -> f a) -> f ((:.:) g f (a -> a))
forall (t :: * -> *) (f :: * -> *) a.
(Logistic t, Contravariant f) =>
f (t a -> t a) -> t (f (a -> a))
deliver ((:.:) g f (f a -> f a) -> f ((:.:) g f (a -> a)))
-> (:.:) g f (f a -> f a) -> f ((:.:) g f (a -> a))
forall a b. (a -> b) -> a -> b
$ g (f (f a -> f a)) -> (:.:) g f (f a -> f a)
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (g (f (f a -> f a)) -> (:.:) g f (f a -> f a))
-> g (f (f a -> f a)) -> (:.:) g f (f a -> f a)
forall a b. (a -> b) -> a -> b
$ f (g (f a) -> g (f a)) -> g (f (f a -> f a))
forall (t :: * -> *) (f :: * -> *) a.
(Logistic t, Contravariant f) =>
f (t a -> t a) -> t (f (a -> a))
deliver (f (g (f a) -> g (f a)) -> g (f (f a -> f a)))
-> f (g (f a) -> g (f a)) -> g (f (f a -> f a))
forall a b. (a -> b) -> a -> b
$ ((g (f a) -> g (f a)) -> (:.:) f g a -> (:.:) f g a)
-> f ((:.:) f g a -> (:.:) f g a) -> f (g (f a) -> g (f a))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (g (f a) -> g (f a)) -> (:.:) f g a -> (:.:) f g a
forall (g :: * -> *) (f :: * -> *) (g :: * -> *) (f :: * -> *) a p.
(Traversable g, Applicative f, Distributive g, Functor f) =>
(g (f a) -> g (f p)) -> (:.:) f g a -> (:.:) f g p
go f ((:.:) f g a -> (:.:) f g a)
f
    where
      go :: (g (f a) -> g (f p)) -> (:.:) f g a -> (:.:) f g p
go g (f a) -> g (f p)
p = f (g p) -> (:.:) f g p
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (f (g p) -> (:.:) f g p)
-> ((:.:) f g a -> f (g p)) -> (:.:) f g a -> (:.:) f g p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g (f p) -> f (g p)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (g (f p) -> f (g p))
-> ((:.:) f g a -> g (f p)) -> (:.:) f g a -> f (g p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g (f a) -> g (f p)
p (g (f a) -> g (f p))
-> ((:.:) f g a -> g (f a)) -> (:.:) f g a -> g (f p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (g a) -> g (f a)
forall (g :: * -> *) (f :: * -> *) a.
(Distributive g, Functor f) =>
f (g a) -> g (f a)
distribute (f (g a) -> g (f a))
-> ((:.:) f g a -> f (g a)) -> (:.:) f g a -> g (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.:) f g a -> f (g a)
forall k2 (f :: k2 -> *) k1 (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1

instance Logistic Complex where
  deliver :: f (Complex a -> Complex a) -> Complex (f (a -> a))
deliver f (Complex a -> Complex a)
f
    = ((a -> a) -> Complex a -> Complex a)
-> f (Complex a -> Complex a) -> f (a -> a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\a -> a
g (a
a :+ a
b) -> a -> a
g a
a a -> a -> Complex a
forall a. a -> a -> Complex a
:+ a
b) f (Complex a -> Complex a)
f
    f (a -> a) -> f (a -> a) -> Complex (f (a -> a))
forall a. a -> a -> Complex a
:+ ((a -> a) -> Complex a -> Complex a)
-> f (Complex a -> Complex a) -> f (a -> a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\a -> a
g (a
a :+ a
b) -> a
a a -> a -> Complex a
forall a. a -> a -> Complex a
:+ a -> a
g a
b) f (Complex a -> Complex a)
f

setters :: Logistic t => t ((a -> a) -> t a -> t a)
setters :: t ((a -> a) -> t a -> t a)
setters = Op (t a -> t a) (a -> a) -> (a -> a) -> t a -> t a
forall a b. Op a b -> b -> a
getOp (Op (t a -> t a) (a -> a) -> (a -> a) -> t a -> t a)
-> t (Op (t a -> t a) (a -> a)) -> t ((a -> a) -> t a -> t a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Op (t a -> t a) (t a -> t a) -> t (Op (t a -> t a) (a -> a))
forall (t :: * -> *) (f :: * -> *) a.
(Logistic t, Contravariant f) =>
f (t a -> t a) -> t (f (a -> a))
deliver (((t a -> t a) -> t a -> t a) -> Op (t a -> t a) (t a -> t a)
forall a b. (b -> a) -> Op a b
Op (t a -> t a) -> t a -> t a
forall a. a -> a
id)
{-# INLINE setters #-}