module Data.Functor.Invariant.Inplicative (
Inply(..)
, Inplicative(..)
, runDay
, dather
, concatInplicative
, concatInply
, concatInplicativeRec
, concatInplyRec
) where
import Control.Natural
import Data.Functor.Invariant
import Data.Functor.Invariant.Day
import Data.SOP hiding (hmap)
import qualified Data.Vinyl as V
import qualified Data.Vinyl.Functor as V
class Invariant f => Inply f where
gather
:: (b -> c -> a)
-> (a -> (b, c))
-> f b
-> f c
-> f a
gather b -> c -> a
f a -> (b, c)
g f b
x f c
y = ((b, c) -> a) -> (a -> (b, c)) -> f (b, c) -> f a
forall (f :: * -> *) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap ((b -> c -> a) -> (b, c) -> a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry b -> c -> a
f) a -> (b, c)
g (f b -> f c -> f (b, c)
forall (f :: * -> *) a b. Inply f => f a -> f b -> f (a, b)
gathered f b
x f c
y)
gathered
:: f a
-> f b
-> f (a, b)
gathered = (a -> b -> (a, b)) -> ((a, b) -> (a, b)) -> f a -> f b -> f (a, b)
forall (f :: * -> *) b c a.
Inply f =>
(b -> c -> a) -> (a -> (b, c)) -> f b -> f c -> f a
gather (,) (a, b) -> (a, b)
forall a. a -> a
id
{-# MINIMAL gather | gathered #-}
class Inply f => Inplicative f where
knot :: a -> f a
runDay
:: Inply h
=> (f ~> h)
-> (g ~> h)
-> Day f g ~> h
runDay :: (f ~> h) -> (g ~> h) -> Day f g ~> h
runDay f ~> h
f g ~> h
g (Day f b
x g c
y b -> c -> x
a x -> (b, c)
b) = (b -> c -> x) -> (x -> (b, c)) -> h b -> h c -> h x
forall (f :: * -> *) b c a.
Inply f =>
(b -> c -> a) -> (a -> (b, c)) -> f b -> f c -> f a
gather b -> c -> x
a x -> (b, c)
b (f b -> h b
f ~> h
f f b
x) (g c -> h c
g ~> h
g g c
y)
dather
:: Inply f
=> Day f f ~> f
dather :: Day f f ~> f
dather (Day f b
x f c
y b -> c -> x
a x -> (b, c)
b) = (b -> c -> x) -> (x -> (b, c)) -> f b -> f c -> f x
forall (f :: * -> *) b c a.
Inply f =>
(b -> c -> a) -> (a -> (b, c)) -> f b -> f c -> f a
gather b -> c -> x
a x -> (b, c)
b f b
x f c
y
concatInplicative
:: Inplicative f
=> NP f as
-> f (NP I as)
concatInplicative :: NP f as -> f (NP I as)
concatInplicative = \case
NP f as
Nil -> NP I '[] -> f (NP I '[])
forall (f :: * -> *) a. Inplicative f => a -> f a
knot NP I '[]
forall k (a :: k -> *). NP a '[]
Nil
f x
x :* NP f xs
xs -> (x -> NP I xs -> NP I (x : xs))
-> (NP I (x : xs) -> (x, NP I xs))
-> f x
-> f (NP I xs)
-> f (NP I (x : xs))
forall (f :: * -> *) b c a.
Inply f =>
(b -> c -> a) -> (a -> (b, c)) -> f b -> f c -> f a
gather
(\x
y NP I xs
ys -> x -> I x
forall a. a -> I a
I x
y I x -> NP I xs -> NP I (x : xs)
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I xs
ys)
(\case I x
y :* NP I xs
ys -> (x
x
y, NP I xs
NP I xs
ys))
f x
x
(NP f xs -> f (NP I xs)
forall (f :: * -> *) (as :: [*]).
Inplicative f =>
NP f as -> f (NP I as)
concatInplicative NP f xs
xs)
concatInply
:: Inply f
=> NP f (a ': as)
-> f (NP I (a ': as))
concatInply :: NP f (a : as) -> f (NP I (a : as))
concatInply (f x
x :* NP f xs
xs) = case NP f xs
xs of
NP f xs
Nil -> (x -> NP I '[x]) -> (NP I '[x] -> x) -> f x -> f (NP I '[x])
forall (f :: * -> *) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap ((I x -> NP I '[] -> NP I '[x]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I '[]
forall k (a :: k -> *). NP a '[]
Nil) (I x -> NP I '[x]) -> (x -> I x) -> x -> NP I '[x]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> I x
forall a. a -> I a
I) (\case I x
y :* NP I xs
_ -> x
x
y) f x
x
f x
_ :* NP f xs
_ -> (x -> NP I (x : xs) -> NP I (x : x : xs))
-> (NP I (x : x : xs) -> (x, NP I (x : xs)))
-> f x
-> f (NP I (x : xs))
-> f (NP I (x : x : xs))
forall (f :: * -> *) b c a.
Inply f =>
(b -> c -> a) -> (a -> (b, c)) -> f b -> f c -> f a
gather
(\x
y NP I (x : xs)
ys -> x -> I x
forall a. a -> I a
I x
y I x -> NP I (x : xs) -> NP I (x : x : xs)
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I (x : xs)
ys)
(\case I x
y :* NP I xs
ys -> (x
x
y, NP I xs
NP I (x : xs)
ys))
f x
x
(NP f (x : xs) -> f (NP I (x : xs))
forall (f :: * -> *) a (as :: [*]).
Inply f =>
NP f (a : as) -> f (NP I (a : as))
concatInply NP f xs
NP f (x : xs)
xs)
concatInplicativeRec
:: Inplicative f
=> V.Rec f as
-> f (V.XRec V.Identity as)
concatInplicativeRec :: Rec f as -> f (XRec Identity as)
concatInplicativeRec = \case
Rec f as
V.RNil -> Rec (XData Identity) '[] -> f (Rec (XData Identity) '[])
forall (f :: * -> *) a. Inplicative f => a -> f a
knot Rec (XData Identity) '[]
forall u (a :: u -> *). Rec a '[]
V.RNil
f r
x V.:& Rec f rs
xs -> (r -> XRec Identity rs -> XRec Identity (r : rs))
-> (XRec Identity (r : rs) -> (r, XRec Identity rs))
-> f r
-> f (XRec Identity rs)
-> f (XRec Identity (r : rs))
forall (f :: * -> *) b c a.
Inply f =>
(b -> c -> a) -> (a -> (b, c)) -> f b -> f c -> f a
gather
r -> XRec Identity rs -> XRec Identity (r : rs)
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
(V.::&)
(\case HKD Identity r
y V.::& XRec Identity rs
ys -> (r
HKD Identity r
y, XRec Identity rs
ys))
f r
x
(Rec f rs -> f (XRec Identity rs)
forall (f :: * -> *) (as :: [*]).
Inplicative f =>
Rec f as -> f (XRec Identity as)
concatInplicativeRec Rec f rs
xs)
concatInplyRec
:: Inply f
=> V.Rec f (a ': as)
-> f (V.XRec V.Identity (a ': as))
concatInplyRec :: Rec f (a : as) -> f (XRec Identity (a : as))
concatInplyRec (f r
x V.:& Rec f rs
xs) = case Rec f rs
xs of
Rec f rs
V.RNil -> (r -> XRec Identity '[a])
-> (XRec Identity '[a] -> r) -> f r -> f (XRec Identity '[a])
forall (f :: * -> *) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap (HKD Identity a -> Rec (XData Identity) '[] -> XRec Identity '[a]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
V.::& Rec (XData Identity) '[]
forall u (a :: u -> *). Rec a '[]
V.RNil) (\case HKD Identity a
z V.::& Rec (XData Identity) '[]
_ -> r
HKD Identity a
z) f r
x
f r
_ V.:& Rec f rs
_ -> (r -> XRec Identity (r : rs) -> XRec Identity (a : r : rs))
-> (XRec Identity (a : r : rs) -> (r, XRec Identity (r : rs)))
-> f r
-> f (XRec Identity (r : rs))
-> f (XRec Identity (a : r : rs))
forall (f :: * -> *) b c a.
Inply f =>
(b -> c -> a) -> (a -> (b, c)) -> f b -> f c -> f a
gather
r -> XRec Identity (r : rs) -> XRec Identity (a : r : rs)
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
(V.::&)
(\case HKD Identity a
y V.::& XRec Identity (r : rs)
ys -> (r
HKD Identity a
y, XRec Identity (r : rs)
ys))
f r
x
(Rec f (r : rs) -> f (XRec Identity (r : rs))
forall (f :: * -> *) a (as :: [*]).
Inply f =>
Rec f (a : as) -> f (XRec Identity (a : as))
concatInplyRec Rec f rs
Rec f (r : rs)
xs)