{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Module      : Data.Functor.Invariant.Inplicative.Free
-- Copyright   : (c) Justin Le 2019
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- Provide an invariant functor combinator sequencer, like a combination of
-- 'Ap' and 'Div'.
--
-- This module was named 'Data.Functor.Invariant.DecAlt' before v0.4.0.0
--
-- @since 0.4.0.0
module Data.Functor.Invariant.Inplicative.Free (
  -- * Chain
    DivAp(.., Gather, Knot)
  , runCoDivAp
  , runContraDivAp
  , divApAp
  , divApDiv
  , foldDivAp
  , assembleDivAp
  , assembleDivApRec
  -- * Nonempty Chain
  , DivAp1(.., DivAp1)
  , runCoDivAp1
  , runContraDivAp1
  , divApAp1
  , divApDiv1
  , foldDivAp1
  , assembleDivAp1
  , assembleDivAp1Rec
  ) where

import           Control.Applicative
import           Control.Applicative.Free                  (Ap(..))
import           Control.Applicative.ListF                 (MaybeF(..))
import           Control.Natural
import           Data.Coerce
import           Data.Functor.Apply
import           Data.Functor.Apply.Free                   (Ap1(..))
import           Data.Functor.Contravariant.Divise
import           Data.Functor.Contravariant.Divisible
import           Data.Functor.Contravariant.Divisible.Free (Div(..), Div1)
import           Data.Functor.Identity
import           Data.Functor.Invariant
import           Data.Functor.Invariant.Day
import           Data.Functor.Invariant.Inplicative
import           Data.HBifunctor.Tensor hiding             (elim1, elim2, intro1, intro2)
import           Data.HFunctor
import           Data.HFunctor.Chain
import           Data.HFunctor.Chain.Internal
import           Data.HFunctor.Interpret
import           Data.SOP hiding                           (hmap)
import qualified Data.Vinyl                                as V
import qualified Data.Vinyl.Functor                        as V

-- | In the covariant direction, we can interpret into any 'Apply'.
--
-- In theory, this shouldn't never be necessary, because you should just be
-- able to use 'interpret', since any instance of 'Apply' is also an instance
-- of 'Inply'.  However, this can be handy if you are using an instance of
-- 'Apply' that has no 'Inply' instance.  Consider also 'unsafeInplyCo' if
-- you are using a specific, concrete type for @g@.
runCoDivAp1
    :: forall f g. Apply g
    => f ~> g
    -> DivAp1 f ~> g
runCoDivAp1 :: forall (f :: * -> *) (g :: * -> *).
Apply g =>
(f ~> g) -> DivAp1 f ~> g
runCoDivAp1 f ~> g
f = (f ~> g) -> (Day f g ~> g) -> DivAp1 f ~> g
forall (f :: * -> *) (g :: * -> *).
(f ~> g) -> (Day f g ~> g) -> DivAp1 f ~> g
foldDivAp1 f x -> g x
f ~> g
f ((f ~> g) -> (g ~> g) -> Day f g ~> g
forall (f :: * -> *) (g :: * -> *) (h :: * -> *).
Apply h =>
(f ~> h) -> (g ~> h) -> Day f g ~> h
runDayApply f x -> g x
f ~> g
f g x -> g x
forall a. a -> a
g ~> g
id)

-- | In the contravariant direction, we can interpret into any 'Divise'.
--
-- In theory, this shouldn't never be necessary, because you should just be
-- able to use 'interpret', since any instance of 'Divise' is also an instance
-- of 'Inply'.  However, this can be handy if you are using an instance of
-- 'Divise' that has no 'Inply' instance.  Consider also
-- 'unsafeInplyContra' if you are using a specific, concrete type for @g@.
runContraDivAp1
    :: forall f g. Divise g
    => f ~> g
    -> DivAp1 f ~> g
runContraDivAp1 :: forall (f :: * -> *) (g :: * -> *).
Divise g =>
(f ~> g) -> DivAp1 f ~> g
runContraDivAp1 f ~> g
f = (f ~> g) -> (Day f g ~> g) -> DivAp1 f ~> g
forall (f :: * -> *) (g :: * -> *).
(f ~> g) -> (Day f g ~> g) -> DivAp1 f ~> g
foldDivAp1 f x -> g x
f ~> g
f ((f ~> g) -> (g ~> g) -> Day f g ~> g
forall (f :: * -> *) (g :: * -> *) (h :: * -> *).
Divise h =>
(f ~> h) -> (g ~> h) -> Day f g ~> h
runDayDivise f x -> g x
f ~> g
f g x -> g x
forall a. a -> a
g ~> g
id)

-- | In the covariant direction, we can interpret into any 'Applicative'.
--
-- In theory, this shouldn't never be necessary, because you should just be
-- able to use 'interpret', since any instance of 'Applicative' is also an
-- instance of 'Inplicative'.  However, this can be handy if you are using
-- an instance of 'Applicative' that has no 'Inplicative' instance.
-- Consider also 'unsafeInplicativeCo' if you are using a specific,
-- concrete type for @g@.
runCoDivAp
    :: forall f g. Applicative g
    => f ~> g
    -> DivAp f ~> g
runCoDivAp :: forall (f :: * -> *) (g :: * -> *).
Applicative g =>
(f ~> g) -> DivAp f ~> g
runCoDivAp f ~> g
f = (forall x. x -> g x) -> (Day f g ~> g) -> DivAp f ~> g
forall (g :: * -> *) (f :: * -> *).
(forall x. x -> g x) -> (Day f g ~> g) -> DivAp f ~> g
foldDivAp x -> g x
forall x. x -> g x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\case Day f b
x g c
y b -> c -> x
h x -> (b, c)
_ -> (b -> c -> x) -> g b -> g c -> g x
forall a b c. (a -> b -> c) -> g a -> g b -> g c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> c -> x
h (f b -> g b
f ~> g
f f b
x) g c
y)

-- | In the covariant direction, we can interpret into any 'Divisible'.
--
-- In theory, this shouldn't never be necessary, because you should just be
-- able to use 'interpret', since any instance of 'Divisible' is also an
-- instance of 'Inplicative'.  However, this can be handy if you are using
-- an instance of 'Divisible' that has no 'Inplicative' instance.  Consider
-- also 'unsafeInplicativeContra' if you are using a specific, concrete
-- type for @g@.
runContraDivAp
    :: forall f g. Divisible g
    => f ~> g
    -> DivAp f ~> g
runContraDivAp :: forall (f :: * -> *) (g :: * -> *).
Divisible g =>
(f ~> g) -> DivAp f ~> g
runContraDivAp f ~> g
f = (forall x. x -> g x) -> (Day f g ~> g) -> DivAp f ~> g
forall (g :: * -> *) (f :: * -> *).
(forall x. x -> g x) -> (Day f g ~> g) -> DivAp f ~> g
foldDivAp (g x -> x -> g x
forall a b. a -> b -> a
const g x
forall a. g a
forall (f :: * -> *) a. Divisible f => f a
conquer) (\case Day f b
x g c
y b -> c -> x
_ x -> (b, c)
g -> (x -> (b, c)) -> g b -> g c -> g x
forall a b c. (a -> (b, c)) -> g b -> g c -> g a
forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide x -> (b, c)
g (f b -> g b
f ~> g
f f b
x) g c
y)

-- | General-purpose folder of 'DivAp'.  Provide a way to handle the
-- identity ('pure'/'conquer'/'Knot') and a way to handle a cons
-- ('liftA2'/'divide'/'Gather').
--
-- @since 0.3.5.0
foldDivAp
    :: (forall x. x -> g x)
    -> (Day f g ~> g)
    -> DivAp f ~> g
foldDivAp :: forall (g :: * -> *) (f :: * -> *).
(forall x. x -> g x) -> (Day f g ~> g) -> DivAp f ~> g
foldDivAp forall x. x -> g x
f Day f g ~> g
g = (Identity ~> g) -> (Day f g ~> g) -> Chain Day Identity f ~> g
forall {k} (t :: (k -> *) -> (k -> *) -> k -> *) (i :: k -> *)
       (f :: k -> *) (g :: k -> *).
HBifunctor t =>
(i ~> g) -> (t f g ~> g) -> Chain t i f ~> g
foldChain (x -> g x
forall x. x -> g x
f (x -> g x) -> (Identity x -> x) -> Identity x -> g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity x -> x
forall a. Identity a -> a
runIdentity) Day f g x -> g x
Day f g ~> g
g (Chain Day Identity f x -> g x)
-> (DivAp f x -> Chain Day Identity f x) -> DivAp f x -> g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DivAp f x -> Chain Day Identity f x
forall (f :: * -> *) a. DivAp f a -> Chain Day Identity f a
unDivAp

-- | General-purpose folder of 'DivAp1'.  Provide a way to handle the
-- individual leaves and a way to handle a cons ('liftF2/'divise'/'Gather').
--
-- @since 0.3.5.0
foldDivAp1
    :: (f ~> g)
    -> (Day f g ~> g)
    -> DivAp1 f ~> g
foldDivAp1 :: forall (f :: * -> *) (g :: * -> *).
(f ~> g) -> (Day f g ~> g) -> DivAp1 f ~> g
foldDivAp1 f ~> g
f Day f g ~> g
g = (f ~> g) -> (Day f g ~> g) -> Chain1 Day f ~> g
forall {k} (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (g :: k -> *).
HBifunctor t =>
(f ~> g) -> (t f g ~> g) -> Chain1 t f ~> g
foldChain1 f x -> g x
f ~> g
f Day f g x -> g x
Day f g ~> g
g (Chain1 Day f x -> g x)
-> (DivAp1 f x -> Chain1 Day f x) -> DivAp1 f x -> g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DivAp1 f x -> Chain1 Day f x
forall (f :: * -> *) a. DivAp1 f a -> Chain1 Day f a
unDivAp1





-- | Extract the 'Ap' part out of a 'DivAp', shedding the
-- contravariant bits.
--
-- @since 0.3.2.0
divApAp :: DivAp f ~> Ap f
divApAp :: forall (f :: * -> *) x. DivAp f x -> Ap f x
divApAp = (f ~> Ap f) -> DivAp f ~> Ap f
forall (f :: * -> *) (g :: * -> *).
Applicative g =>
(f ~> g) -> DivAp f ~> g
runCoDivAp f x -> Ap f x
f ~> Ap f
forall {k} (t :: (k -> *) -> k -> *) (f :: k -> *).
Inject t =>
f ~> t f
forall (f :: * -> *). f ~> Ap f
inject

-- | Extract the 'Ap1' part out of a 'DivAp1', shedding the
-- contravariant bits.
--
-- @since 0.3.2.0
divApAp1 :: DivAp1 f ~> Ap1 f
divApAp1 :: forall (f :: * -> *) x. DivAp1 f x -> Ap1 f x
divApAp1 = (f ~> Ap1 f) -> DivAp1 f ~> Ap1 f
forall (f :: * -> *) (g :: * -> *).
Apply g =>
(f ~> g) -> DivAp1 f ~> g
runCoDivAp1 f x -> Ap1 f x
f ~> Ap1 f
forall {k} (t :: (k -> *) -> k -> *) (f :: k -> *).
Inject t =>
f ~> t f
forall (f :: * -> *). f ~> Ap1 f
inject

-- | Extract the 'Div' part out of a 'DivAp', shedding the
-- covariant bits.
--
-- @since 0.3.2.0
divApDiv :: DivAp f ~> Div f
divApDiv :: forall (f :: * -> *) x. DivAp f x -> Div f x
divApDiv = (f ~> Div f) -> DivAp f ~> Div f
forall (f :: * -> *) (g :: * -> *).
Divisible g =>
(f ~> g) -> DivAp f ~> g
runContraDivAp f x -> Div f x
f ~> Div f
forall {k} (t :: (k -> *) -> k -> *) (f :: k -> *).
Inject t =>
f ~> t f
forall (f :: * -> *). f ~> Div f
inject

-- | Extract the 'Div1' part out of a 'DivAp1', shedding the
-- covariant bits.
--
-- @since 0.3.2.0
divApDiv1 :: DivAp1 f ~> Div1 f
divApDiv1 :: forall (f :: * -> *) x. DivAp1 f x -> Div1 f x
divApDiv1 = (f ~> Div1 f) -> DivAp1 f ~> Div1 f
forall (f :: * -> *) (g :: * -> *).
Divise g =>
(f ~> g) -> DivAp1 f ~> g
runContraDivAp1 f x -> Div1 f x
f ~> Div1 f
forall {k} (t :: (k -> *) -> k -> *) (f :: k -> *).
Inject t =>
f ~> t f
forall (f :: * -> *). f ~> Div1 f
inject

-- | Match on a non-empty 'DivAp'; contains no @f@s, but only the
-- terminal value.  Analogous to the 'Control.Applicative.Free.Ap'
-- constructor.
--
-- Note that the order of the first two arguments has swapped as of
-- v0.4.0.0
pattern Gather :: (b -> c -> a) -> (a -> (b, c)) -> f b -> DivAp f c -> DivAp f a
pattern $mGather :: forall {r} {a} {f :: * -> *}.
DivAp f a
-> (forall {b} {c}.
    (b -> c -> a) -> (a -> (b, c)) -> f b -> DivAp f c -> r)
-> ((# #) -> r)
-> r
$bGather :: forall a (f :: * -> *) b c.
(b -> c -> a) -> (a -> (b, c)) -> f b -> DivAp f c -> DivAp f a
Gather f g x xs <- (unGather_->MaybeF (Just (Day x xs f g)))
  where
    Gather b -> c -> a
f a -> (b, c)
g f b
x DivAp f c
xs = Chain Day Identity f a -> DivAp f a
forall (f :: * -> *) a. Chain Day Identity f a -> DivAp f a
DivAp (Chain Day Identity f a -> DivAp f a)
-> Chain Day Identity f a -> DivAp f a
forall a b. (a -> b) -> a -> b
$ Day f (Chain Day Identity f) a -> Chain Day Identity f a
forall {k} {k1} (t :: k -> (k1 -> *) -> k1 -> *) (i :: k1 -> *)
       (f :: k) (a :: k1).
t f (Chain t i f) a -> Chain t i f a
More (Day f (Chain Day Identity f) a -> Chain Day Identity f a)
-> Day f (Chain Day Identity f) a -> Chain Day Identity f a
forall a b. (a -> b) -> a -> b
$ f b
-> Chain Day Identity f c
-> (b -> c -> a)
-> (a -> (b, c))
-> Day f (Chain Day Identity f) a
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> (a -> (b, c)) -> Day f g a
Day f b
x (DivAp f c -> Chain Day Identity f c
forall (f :: * -> *) a. DivAp f a -> Chain Day Identity f a
unDivAp DivAp f c
xs) b -> c -> a
f a -> (b, c)
g

unGather_ :: DivAp f ~> MaybeF (Day f (DivAp f))
unGather_ :: forall (f :: * -> *) x. DivAp f x -> MaybeF (Day f (DivAp f)) x
unGather_ = \case
  DivAp (More (Day f b
x Chain Day Identity f c
xs b -> c -> x
g x -> (b, c)
f)) -> Maybe (Day f (DivAp f) x) -> MaybeF (Day f (DivAp f)) x
forall {k} (f :: k -> *) (a :: k). Maybe (f a) -> MaybeF f a
MaybeF (Maybe (Day f (DivAp f) x) -> MaybeF (Day f (DivAp f)) x)
-> (Day f (DivAp f) x -> Maybe (Day f (DivAp f) x))
-> Day f (DivAp f) x
-> MaybeF (Day f (DivAp f)) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day f (DivAp f) x -> Maybe (Day f (DivAp f) x)
forall a. a -> Maybe a
Just (Day f (DivAp f) x -> MaybeF (Day f (DivAp f)) x)
-> Day f (DivAp f) x -> MaybeF (Day f (DivAp f)) x
forall a b. (a -> b) -> a -> b
$ f b
-> DivAp f c -> (b -> c -> x) -> (x -> (b, c)) -> Day f (DivAp f) x
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> (a -> (b, c)) -> Day f g a
Day f b
x (Chain Day Identity f c -> DivAp f c
forall (f :: * -> *) a. Chain Day Identity f a -> DivAp f a
DivAp Chain Day Identity f c
xs) b -> c -> x
g x -> (b, c)
f
  DivAp (Done Identity x
_             ) -> Maybe (Day f (DivAp f) x) -> MaybeF (Day f (DivAp f)) x
forall {k} (f :: k -> *) (a :: k). Maybe (f a) -> MaybeF f a
MaybeF Maybe (Day f (DivAp f) x)
forall a. Maybe a
Nothing

-- | Match on an "empty" 'DivAp'; contains no @f@s, but only the
-- terminal value.  Analogous to 'Control.Applicative.Free.Pure'.
pattern Knot :: a -> DivAp f a
pattern $mKnot :: forall {r} {a} {f :: * -> *}.
DivAp f a -> (a -> r) -> ((# #) -> r) -> r
$bKnot :: forall a (f :: * -> *). a -> DivAp f a
Knot x = DivAp (Done (Identity x))
{-# COMPLETE Gather, Knot #-}

instance Inply (DivAp f) where
    gather :: forall b c a.
(b -> c -> a)
-> (a -> (b, c)) -> DivAp f b -> DivAp f c -> DivAp f a
gather = ((b -> c -> a)
 -> (a -> (b, c))
 -> Chain Day Identity f b
 -> Chain Day Identity f c
 -> Chain Day Identity f a)
-> (b -> c -> a)
-> (a -> (b, c))
-> DivAp f b
-> DivAp f c
-> DivAp f a
forall a b. Coercible a b => a -> b
coerce (forall (f :: * -> *) b c a.
Inply f =>
(b -> c -> a) -> (a -> (b, c)) -> f b -> f c -> f a
gather @(Chain Day Identity _))

-- | The free 'Inplicative'
instance Inplicative (DivAp f) where
    knot :: forall a. a -> DivAp f a
knot = (a -> Chain Day Identity f a) -> a -> DivAp f a
forall a b. Coercible a b => a -> b
coerce (forall (f :: * -> *) a. Inplicative f => a -> f a
knot @(Chain Day Identity _))

-- | Match on a 'DivAp1' to get the head and the rest of the items.
-- Analogous to the 'Data.Functor.Apply.Free.Ap1' constructor.
--
-- Note that the order of the first two arguments has swapped as of
-- v0.4.0.0
pattern DivAp1 :: Invariant f => (b -> c -> a) -> (a -> (b, c)) -> f b -> DivAp f c -> DivAp1 f a
pattern $mDivAp1 :: forall {r} {f :: * -> *} {a}.
Invariant f =>
DivAp1 f a
-> (forall {b} {c}.
    (b -> c -> a) -> (a -> (b, c)) -> f b -> DivAp f c -> r)
-> ((# #) -> r)
-> r
$bDivAp1 :: forall (f :: * -> *) a b c.
Invariant f =>
(b -> c -> a) -> (a -> (b, c)) -> f b -> DivAp f c -> DivAp1 f a
DivAp1 f g x xs <- (coerce splitChain1->Day x xs f g)
  where
    DivAp1 b -> c -> a
f a -> (b, c)
g f b
x DivAp f c
xs = Day f (ListBy Day f) a -> NonEmptyBy Day f a
Day f (ListBy Day f) ~> NonEmptyBy Day f
forall (f :: * -> *).
FunctorBy Day f =>
Day f (ListBy Day f) ~> NonEmptyBy Day f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
(Matchable t i, FunctorBy t f) =>
t f (ListBy t f) ~> NonEmptyBy t f
unsplitNE (Day f (ListBy Day f) a -> NonEmptyBy Day f a)
-> Day f (ListBy Day f) a -> NonEmptyBy Day f a
forall a b. (a -> b) -> a -> b
$ f b
-> DivAp f c -> (b -> c -> a) -> (a -> (b, c)) -> Day f (DivAp f) a
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> (a -> (b, c)) -> Day f g a
Day f b
x DivAp f c
xs b -> c -> a
f a -> (b, c)
g
{-# COMPLETE DivAp1 #-}

-- | The free 'Inplicative'
instance Invariant f => Inply (DivAp1 f) where
    gather :: forall b c a.
(b -> c -> a)
-> (a -> (b, c)) -> DivAp1 f b -> DivAp1 f c -> DivAp1 f a
gather = ((b -> c -> a)
 -> (a -> (b, c))
 -> Chain1 Day f b
 -> Chain1 Day f c
 -> Chain1 Day f a)
-> (b -> c -> a)
-> (a -> (b, c))
-> DivAp1 f b
-> DivAp1 f c
-> DivAp1 f a
forall a b. Coercible a b => a -> b
coerce (forall (f :: * -> *) b c a.
Inply f =>
(b -> c -> a) -> (a -> (b, c)) -> f b -> f c -> f a
gather @(Chain1 Day _))

-- | Convenient wrapper to build up a 'DivAp' 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 @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) $
--   assembleDivAp $ 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' or 'injectChain' directly.
-- *    If you have 2 components, use 'toListBy' or 'toChain'.
-- *    If you have 3 or more components, these combinators may be useful;
--      otherwise you'd need to manually peel off tuples one-by-one.
--
-- If each component is itself a @'DivAp' f@ (instead of @f@), you can use
-- 'concatInplicative'.
assembleDivAp
    :: NP f as
    -> DivAp f (NP I as)
assembleDivAp :: forall (f :: * -> *) (as :: [*]). NP f as -> DivAp f (NP I as)
assembleDivAp = \case
    NP f as
Nil     -> Chain Day Identity f (NP I as) -> DivAp f (NP I as)
forall (f :: * -> *) a. Chain Day Identity f a -> DivAp f a
DivAp (Chain Day Identity f (NP I as) -> DivAp f (NP I as))
-> Chain Day Identity f (NP I as) -> DivAp f (NP I as)
forall a b. (a -> b) -> a -> b
$ Identity (NP I as) -> Chain Day Identity f (NP I as)
forall {k} {k1} (t :: k -> (k1 -> *) -> k1 -> *) (i :: k1 -> *)
       (f :: k) (a :: k1).
i a -> Chain t i f a
Done (Identity (NP I as) -> Chain Day Identity f (NP I as))
-> Identity (NP I as) -> Chain Day Identity f (NP I as)
forall a b. (a -> b) -> a -> b
$ NP I as -> Identity (NP I as)
forall a. a -> Identity a
Identity NP I as
NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil
    f x
x :* NP f xs
xs -> Chain Day Identity f (NP I as) -> DivAp f (NP I as)
forall (f :: * -> *) a. Chain Day Identity f a -> DivAp f a
DivAp (Chain Day Identity f (NP I as) -> DivAp f (NP I as))
-> Chain Day Identity f (NP I as) -> DivAp f (NP I as)
forall a b. (a -> b) -> a -> b
$ Day f (Chain Day Identity f) (NP I as)
-> Chain Day Identity f (NP I as)
forall {k} {k1} (t :: k -> (k1 -> *) -> k1 -> *) (i :: k1 -> *)
       (f :: k) (a :: k1).
t f (Chain t i f) a -> Chain t i f a
More (Day f (Chain Day Identity f) (NP I as)
 -> Chain Day Identity f (NP I as))
-> Day f (Chain Day Identity f) (NP I as)
-> Chain Day Identity f (NP I as)
forall a b. (a -> b) -> a -> b
$ f x
-> Chain Day Identity f (NP I xs)
-> (x -> NP I xs -> NP I as)
-> (NP I as -> (x, NP I xs))
-> Day f (Chain Day Identity f) (NP I as)
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> (a -> (b, c)) -> Day f g a
Day
      f x
x
      (DivAp f (NP I xs) -> Chain Day Identity f (NP I xs)
forall (f :: * -> *) a. DivAp f a -> Chain Day Identity f a
unDivAp (NP f xs -> DivAp f (NP I xs)
forall (f :: * -> *) (as :: [*]). NP f as -> DivAp f (NP I as)
assembleDivAp NP f xs
xs))
      (\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))

-- | A version of 'assembleDivAp' but for 'DivAp1' instead.  Can be
-- useful if you intend on interpreting it into something with only
-- a 'Divise' or 'Apply' instance, but no 'Divisible' or 'Applicative'.
--
-- If each component is itself a @'DivAp1' f@ (instead of @f@), you can use
-- 'concatInply'.
assembleDivAp1
    :: Invariant f
    => NP f (a ': as)
    -> DivAp1 f (NP I (a ': as))
assembleDivAp1 :: forall (f :: * -> *) a (as :: [*]).
Invariant f =>
NP f (a : as) -> DivAp1 f (NP I (a : as))
assembleDivAp1 (f x
x :* NP f xs
xs) = Chain1 Day f (NP I (a : as)) -> DivAp1 f (NP I (a : as))
forall (f :: * -> *) a. Chain1 Day f a -> DivAp1 f a
DivAp1_ (Chain1 Day f (NP I (a : as)) -> DivAp1 f (NP I (a : as)))
-> Chain1 Day f (NP I (a : as)) -> DivAp1 f (NP I (a : as))
forall a b. (a -> b) -> a -> b
$ case NP f xs
xs of
    NP f xs
Nil    -> f (NP I (a : as)) -> Chain1 Day f (NP I (a : as))
forall {k} (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
f a -> Chain1 t f a
Done1 (f (NP I (a : as)) -> Chain1 Day f (NP I (a : as)))
-> f (NP I (a : as)) -> Chain1 Day f (NP I (a : as))
forall a b. (a -> b) -> a -> b
$ (a -> NP I (a : as))
-> (NP I (a : as) -> a) -> f a -> f (NP I (a : as))
forall a b. (a -> b) -> (b -> a) -> f a -> f b
forall (f :: * -> *) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap ((I a -> NP I as -> NP I (a : as)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I as
NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil) (I a -> NP I (a : as)) -> (a -> I a) -> a -> NP I (a : as)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> I a
forall a. a -> I a
I) (I a -> a
forall a. I a -> a
unI (I a -> a) -> (NP I (a : as) -> I a) -> NP I (a : as) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP I (a : as) -> I a
forall {k} (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x
hd) f a
f x
x
    f x
_ :* NP f xs
_ -> Day f (Chain1 Day f) (NP I (a : as))
-> Chain1 Day f (NP I (a : as))
forall {k} (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
t f (Chain1 t f) a -> Chain1 t f a
More1 (Day f (Chain1 Day f) (NP I (a : as))
 -> Chain1 Day f (NP I (a : as)))
-> Day f (Chain1 Day f) (NP I (a : as))
-> Chain1 Day f (NP I (a : as))
forall a b. (a -> b) -> a -> b
$ f x
-> Chain1 Day f (NP I (x : xs))
-> (x -> NP I (x : xs) -> NP I (a : as))
-> (NP I (a : as) -> (x, NP I (x : xs)))
-> Day f (Chain1 Day f) (NP I (a : as))
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> (a -> (b, c)) -> Day f g a
Day
      f x
x
      (DivAp1 f (NP I (x : xs)) -> Chain1 Day f (NP I (x : xs))
forall (f :: * -> *) a. DivAp1 f a -> Chain1 Day f a
unDivAp1 (NP f (x : xs) -> DivAp1 f (NP I (x : xs))
forall (f :: * -> *) a (as :: [*]).
Invariant f =>
NP f (a : as) -> DivAp1 f (NP I (a : as))
assembleDivAp1 NP f xs
NP f (x : xs)
xs))
      (\x
y NP I (x : xs)
ys -> a -> I a
forall a. a -> I a
I a
x
y I a -> NP I as -> NP I (a : as)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I as
NP I (x : xs)
ys)
      (\case I x
y :* NP I xs
ys -> (x
x
y, NP I xs
NP I (x : xs)
ys))

-- | A version of 'assembleDivAp' 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.
--
-- @
-- data MyType = MT Int Bool String
--
-- invmap (\(MyType x y z) -> x ::& y ::& z ::& RNil)
--        (\(x ::& y ::& z ::& RNil) -> MyType x y z) $
--   assembleDivApRec $ intPrim
--                      :& boolPrim
--                      :& stringPrim
--                      :& Nil
-- @
--
-- If each component is itself a @'DivAp' f@ (instead of @f@), you can use
-- 'concatDivApRec'.
assembleDivApRec
    :: V.Rec f as
    -> DivAp f (V.XRec V.Identity as)
assembleDivApRec :: forall (f :: * -> *) (as :: [*]).
Rec f as -> DivAp f (XRec Identity as)
assembleDivApRec = \case
    Rec f as
V.RNil    -> Chain Day Identity f (XRec Identity as)
-> DivAp f (XRec Identity as)
forall (f :: * -> *) a. Chain Day Identity f a -> DivAp f a
DivAp (Chain Day Identity f (XRec Identity as)
 -> DivAp f (XRec Identity as))
-> Chain Day Identity f (XRec Identity as)
-> DivAp f (XRec Identity as)
forall a b. (a -> b) -> a -> b
$ Identity (XRec Identity as)
-> Chain Day Identity f (XRec Identity as)
forall {k} {k1} (t :: k -> (k1 -> *) -> k1 -> *) (i :: k1 -> *)
       (f :: k) (a :: k1).
i a -> Chain t i f a
Done (Identity (XRec Identity as)
 -> Chain Day Identity f (XRec Identity as))
-> Identity (XRec Identity as)
-> Chain Day Identity f (XRec Identity as)
forall a b. (a -> b) -> a -> b
$ XRec Identity as -> Identity (XRec Identity as)
forall a. a -> Identity a
Identity XRec Identity as
Rec (XData Identity) '[]
forall {u} (a :: u -> *). Rec a '[]
V.RNil
    f r
x V.:& Rec f rs
xs -> Chain Day Identity f (XRec Identity as)
-> DivAp f (XRec Identity as)
forall (f :: * -> *) a. Chain Day Identity f a -> DivAp f a
DivAp (Chain Day Identity f (XRec Identity as)
 -> DivAp f (XRec Identity as))
-> Chain Day Identity f (XRec Identity as)
-> DivAp f (XRec Identity as)
forall a b. (a -> b) -> a -> b
$ Day f (Chain Day Identity f) (XRec Identity as)
-> Chain Day Identity f (XRec Identity as)
forall {k} {k1} (t :: k -> (k1 -> *) -> k1 -> *) (i :: k1 -> *)
       (f :: k) (a :: k1).
t f (Chain t i f) a -> Chain t i f a
More (Day f (Chain Day Identity f) (XRec Identity as)
 -> Chain Day Identity f (XRec Identity as))
-> Day f (Chain Day Identity f) (XRec Identity as)
-> Chain Day Identity f (XRec Identity as)
forall a b. (a -> b) -> a -> b
$ f r
-> Chain Day Identity f (XRec Identity rs)
-> (r -> XRec Identity rs -> XRec Identity as)
-> (XRec Identity as -> (r, XRec Identity rs))
-> Day f (Chain Day Identity f) (XRec Identity as)
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> (a -> (b, c)) -> Day f g a
Day
      f r
x
      (DivAp f (XRec Identity rs)
-> Chain Day Identity f (XRec Identity rs)
forall (f :: * -> *) a. DivAp f a -> Chain Day Identity f a
unDivAp (Rec f rs -> DivAp f (XRec Identity rs)
forall (f :: * -> *) (as :: [*]).
Rec f as -> DivAp f (XRec Identity as)
assembleDivApRec Rec f rs
xs))
      r -> XRec Identity rs -> XRec Identity as
HKD Identity 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.::&)
      XRec Identity as -> (r, XRec Identity rs)
XRec Identity (r : rs) -> (r, XRec Identity rs)
forall a (as :: [*]).
XRec Identity (a : as) -> (a, XRec Identity as)
unconsRec

-- | A version of 'assembleDivAp1' 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.
--
-- If each component is itself a @'DivAp1' f@ (instead of @f@), you can use
-- 'concatDivAp1Rec'.
assembleDivAp1Rec
    :: Invariant f
    => V.Rec f (a ': as)
    -> DivAp1 f (V.XRec V.Identity (a ': as))
assembleDivAp1Rec :: forall (f :: * -> *) a (as :: [*]).
Invariant f =>
Rec f (a : as) -> DivAp1 f (XRec Identity (a : as))
assembleDivAp1Rec (f r
x V.:& Rec f rs
xs) = case Rec f rs
xs of
    Rec f rs
V.RNil   -> Chain1 Day f (XRec Identity (a : as))
-> DivAp1 f (XRec Identity (a : as))
forall (f :: * -> *) a. Chain1 Day f a -> DivAp1 f a
DivAp1_ (Chain1 Day f (XRec Identity (a : as))
 -> DivAp1 f (XRec Identity (a : as)))
-> Chain1 Day f (XRec Identity (a : as))
-> DivAp1 f (XRec Identity (a : as))
forall a b. (a -> b) -> a -> b
$ f (XRec Identity (a : as)) -> Chain1 Day f (XRec Identity (a : as))
forall {k} (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
f a -> Chain1 t f a
Done1 (f (XRec Identity (a : as))
 -> Chain1 Day f (XRec Identity (a : as)))
-> f (XRec Identity (a : as))
-> Chain1 Day f (XRec Identity (a : as))
forall a b. (a -> b) -> a -> b
$ (r -> XRec Identity (a : as))
-> (XRec Identity (a : as) -> r)
-> f r
-> f (XRec Identity (a : as))
forall a b. (a -> b) -> (b -> a) -> f a -> f b
forall (f :: * -> *) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap (HKD Identity a -> XRec Identity as -> XRec Identity (a : as)
forall {a} (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
V.::& XRec Identity as
Rec (XData Identity) '[]
forall {u} (a :: u -> *). Rec a '[]
V.RNil) (\case HKD Identity a
z V.::& XRec Identity as
_ -> r
HKD Identity a
z) f r
x
    f r
_ V.:& Rec f rs
_ -> Chain1 Day f (XRec Identity (a : as))
-> DivAp1 f (XRec Identity (a : as))
forall (f :: * -> *) a. Chain1 Day f a -> DivAp1 f a
DivAp1_ (Chain1 Day f (XRec Identity (a : as))
 -> DivAp1 f (XRec Identity (a : as)))
-> Chain1 Day f (XRec Identity (a : as))
-> DivAp1 f (XRec Identity (a : as))
forall a b. (a -> b) -> a -> b
$ Day f (Chain1 Day f) (XRec Identity (a : as))
-> Chain1 Day f (XRec Identity (a : as))
forall {k} (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
t f (Chain1 t f) a -> Chain1 t f a
More1 (Day f (Chain1 Day f) (XRec Identity (a : as))
 -> Chain1 Day f (XRec Identity (a : as)))
-> Day f (Chain1 Day f) (XRec Identity (a : as))
-> Chain1 Day f (XRec Identity (a : as))
forall a b. (a -> b) -> a -> b
$ f r
-> Chain1 Day f (XRec Identity (r : rs))
-> (r -> XRec Identity (r : rs) -> XRec Identity (a : as))
-> (XRec Identity (a : as) -> (r, XRec Identity (r : rs)))
-> Day f (Chain1 Day f) (XRec Identity (a : as))
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> (a -> (b, c)) -> Day f g a
Day
      f r
x
      (DivAp1 f (XRec Identity (r : rs))
-> Chain1 Day f (XRec Identity (r : rs))
forall (f :: * -> *) a. DivAp1 f a -> Chain1 Day f a
unDivAp1 (Rec f (r : rs) -> DivAp1 f (XRec Identity (r : rs))
forall (f :: * -> *) a (as :: [*]).
Invariant f =>
Rec f (a : as) -> DivAp1 f (XRec Identity (a : as))
assembleDivAp1Rec Rec f rs
Rec f (r : rs)
xs))
      r -> XRec Identity (r : rs) -> XRec Identity (a : as)
HKD Identity a
-> 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.::&)
      XRec Identity (a : as) -> (a, XRec Identity as)
XRec Identity (a : as) -> (r, XRec Identity (r : rs))
forall a (as :: [*]).
XRec Identity (a : as) -> (a, XRec Identity as)
unconsRec

unconsRec :: V.XRec V.Identity (a ': as) -> (a, V.XRec V.Identity as)
unconsRec :: forall a (as :: [*]).
XRec Identity (a : as) -> (a, XRec Identity as)
unconsRec (HKD Identity a
y V.::& XRec Identity as
ys) = (a
HKD Identity a
y, XRec Identity as
ys)

-- | A free 'Inply'
instance Inply f => Interpret DivAp1 f where
    interpret :: forall (g :: * -> *). (g ~> f) -> DivAp1 g ~> f
interpret g ~> f
f (DivAp1_ Chain1 Day g x
x) = (g ~> f) -> (Day g f ~> f) -> Chain1 Day g ~> f
forall {k} (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (g :: k -> *).
HBifunctor t =>
(f ~> g) -> (t f g ~> g) -> Chain1 t f ~> g
foldChain1 g x -> f x
g ~> f
f ((g ~> f) -> (f ~> f) -> Day g f ~> f
forall (h :: * -> *) (f :: * -> *) (g :: * -> *).
Inply h =>
(f ~> h) -> (g ~> h) -> Day f g ~> h
runDay g x -> f x
g ~> f
f f x -> f x
forall a. a -> a
f ~> f
id) Chain1 Day g x
x

-- | A free 'Inplicative'
instance Inplicative f => Interpret DivAp f where
    interpret :: forall (g :: * -> *). (g ~> f) -> DivAp g ~> f
interpret g ~> f
f (DivAp Chain Day Identity g x
x) = (Identity ~> f) -> (Day g f ~> f) -> Chain Day Identity g ~> f
forall {k} (t :: (k -> *) -> (k -> *) -> k -> *) (i :: k -> *)
       (f :: k -> *) (g :: k -> *).
HBifunctor t =>
(i ~> g) -> (t f g ~> g) -> Chain t i f ~> g
foldChain (x -> f x
forall a. a -> f a
forall (f :: * -> *) a. Inplicative f => a -> f a
knot (x -> f x) -> (Identity x -> x) -> Identity x -> f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity x -> x
forall a. Identity a -> a
runIdentity) ((g ~> f) -> (f ~> f) -> Day g f ~> f
forall (h :: * -> *) (f :: * -> *) (g :: * -> *).
Inply h =>
(f ~> h) -> (g ~> h) -> Day f g ~> h
runDay g x -> f x
g ~> f
f f x -> f x
forall a. a -> a
f ~> f
id) Chain Day Identity g x
x