-- |
-- Module      : Data.Functor.Invariant.Inplicative
-- Copyright   : (c) Justin Le 2021
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- Contains the classes 'Inply' and 'Inplicative', the invariant
-- counterparts to 'Apply'/'Divise' and 'Applicative'/'Divisible'.
--
-- @since 0.4.0.0
module Data.Functor.Invariant.Inplicative (
  -- * Typeclass
    Inply(..)
  , Inplicative(..)
  -- * Invariant 'Day'
  , runDay
  , dather
  -- * Assembling Helpers
  , 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

-- | The invariant counterpart of 'Apply' and 'Divise'.
--
-- Conceptually you can think of 'Apply' as, given a way to "combine" @a@ and
-- @b@ to @c@, lets you merge @f a@ (producer of @a@) and @f b@ (producer
-- of @b@) into a @f c@ (producer of @c@).  'Divise' can be thought of as,
-- given a way to "split" a @c@ into an @a@ and a @b@, lets you merge @f
-- a@ (consumer of @a@) and @f b@ (consumder of @b@) into a @f c@ (consumer
-- of @c@).
--
-- 'Inply', for 'gather', requires both a combining function and
-- a splitting function in order to merge @f b@ (producer and consumer of
-- @b@) and @f c@ (producer and consumer of @c@) into a @f a@.  You can
-- think of it as, for the @f a@, it "splits" the a into @b@ and @c@ with
-- the @a -> (b, c)@, feeds it to the original @f b@ and @f c@, and then
-- re-combines the output back into a @a@ with the @b -> c -> a@.
--
-- @since 0.4.0.0
class Invariant f => Inply f where
    -- | Like '<.>', '<*>', 'divise', or 'divide', but requires both
    -- a splitting and a recombining function.  '<.>' and '<*>' require
    -- only a combining function, and 'divise' and 'divide' require only
    -- a splitting function.
    --
    -- It is used to merge @f b@ (producer and consumer of @b@) and @f c@
    -- (producer and consumer of @c@) into a @f a@.  You can think of it
    -- as, for the @f a@, it "splits" the a into @b@ and @c@ with the @a ->
    -- (b, c)@, feeds it to the original @f b@ and @f c@, and then
    -- re-combines the output back into a @a@ with the @b -> c -> a@.
    --
    -- An important property is that it will always use @both@ of the
    -- ccomponents given in order to fulfil its job.  If you gather an @f
    -- a@ and an @f b@ into an @f c@, in order to consume/produdce the @c@,
    -- it will always use both the @f a@ or the @f b@ -- exactly one of
    -- them.
    --
    -- @since 0.4.0.0
    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)
    -- | A simplified version of 'gather' that combines into a tuple.  You
    -- can then use 'invmap' to reshape it into the proper shape.
    --
    -- @since 0.4.0.0
    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 #-}

-- | The invariant counterpart of 'Applicative' and 'Divisible'.
--
-- The main important action is described in 'Inply', but this adds 'knot',
-- which is the counterpart to 'pure' and 'conquer'.  It's the identity to
-- 'gather'; if combine two @f a@s with 'gather', and one of them is
-- 'knot', it will leave the structure unchanged.
--
-- Conceptually, if you think of 'gather' as "splitting and re-combining"
-- along multiple forks, then 'knot' introduces a fork that is never taken.
--
-- @since 0.4.0.0
class Inply f => Inplicative f where
    knot :: a -> f a

-- | Interpret out of a contravariant 'Day' into any instance of 'Inply' by
-- providing two interpreting functions.
--
-- This should go in "Data.Functor.Invariant.Day", but that module is in
-- a different package.
--
-- @since 0.4.0.0
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)

-- | Squash the two items in a 'Day' using their natural 'Inply'
-- instances.
--
-- This should go in "Data.Functor.Invariant.Day", but that module is in
-- a different package.
--
-- @since 0.4.0.0
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

-- | Convenient wrapper to build up an 'Inplicative' instance by providing
-- each component of it.  This makes it much easier to build up longer
-- chains because you would only need to write the splitting/joining
-- functions in one place.
--
-- For example, if you had a data type
--
-- @
-- data MyType = MT Int Bool String
-- @
--
-- and an invariant functor and 'Inplicative' instance @Prim@
-- (representing, say, a bidirectional parser, where @Prim Int@ is
-- a bidirectional parser for an 'Int'@), then you could assemble
-- a bidirectional parser for a @MyType@ using:
--
-- @
-- invmap (\(MyType x y z) -> I x :* I y :* I z :* Nil)
--        (\(I x :* I y :* I z :* Nil) -> MyType x y z) $
--   concatInplicative $ intPrim
--                    :* boolPrim
--                    :* stringPrim
--                    :* Nil
-- @
--
-- Some notes on usefulness depending on how many components you have:
--
-- *    If you have 0 components, use 'knot' directly.
-- *    If you have 1 component, use 'inject' directly.
-- *    If you have 2 components, use 'gather' directly.
-- *    If you have 3 or more components, these combinators may be useful;
--      otherwise you'd need to manually peel off tuples one-by-one.
--
-- @since 0.4.0.0
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)

-- | A version of 'concatInplicative' for non-empty 'NP', but only
-- requiring an 'Inply' instance.
--
-- @since 0.4.0.0
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)

-- | A version of 'concatInplicative' using 'V.XRec' from /vinyl/ instead of
-- 'NP' from /sop-core/.  This can be more convenient because it doesn't
-- require manual unwrapping/wrapping of components.
--
-- @since 0.4.0.0
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)

-- | A version of 'concatInply' using 'V.XRec' from /vinyl/ instead of
-- 'NP' from /sop-core/.  This can be more convenient because it doesn't
-- require manual unwrapping/wrapping of components.
--
-- @since 0.4.0.0
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)