-- |
-- Module      : Data.Functor.Apply.Free
-- Copyright   : (c) Justin Le 2019
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- The free 'Apply'.  Provides 'Ap1' and various utility methods.  See
-- 'Ap1' for more details.
--
-- Ideally 'Ap1' would be in the /free/ package.  However, it is defined
-- here for now.
module Data.Functor.Apply.Free (
    Ap1(.., DayAp1, ap1Day)
  , toAp, fromAp
  , liftAp1
  , retractAp1
  , runAp1
  ) where

import           Control.Applicative.Free
import           Control.Natural
import           Data.Function
import           Data.Functor.Apply
import           Data.Functor.Day
import           Data.Functor.Identity
import           Data.Functor.Invariant
import           Data.HFunctor
import           Data.HFunctor.HTraversable
import           Data.HFunctor.Interpret
import           Data.Kind
import           GHC.Generics

-- | One or more @f@s convolved with itself.
--
-- Essentially:
--
-- @
-- 'Ap1' f
--     ~ f                            -- one f
--   ':+:' (f \`'Day'` f)          -- two f's
--   :+: (f \`Day\` f \`Day\` f)           -- three f's
--   :+: (f \`Day\` f \`Day\` f \`Day\` f)  -- four f's
--   :+: ...                          -- etc.
-- @
--
-- Useful if you want to promote an @f@ to a situation with "at least one
-- @f@ sequenced with itself".
--
-- Mostly useful for its 'HFunctor' and 'Interpret' instance, along with
-- its relationship with 'Ap' and 'Day'.
--
-- This is the free 'Apply' ---  Basically a "non-empty" 'Ap'.
--
-- The construction here is based on 'Ap', similar to now
-- 'Data.List.NonEmpty.NonEmpty' is built on list.
data Ap1 :: (Type -> Type) -> Type -> Type where
    Ap1 :: f a -> Ap f (a -> b) -> Ap1 f b

-- | An 'Ap1' is a "non-empty" 'Ap'; this function "forgets" the non-empty
-- property and turns it back into a normal 'Ap'.
toAp :: Ap1 f ~> Ap f
toAp :: forall (f :: * -> *). Ap1 f ~> Ap f
toAp (Ap1 f a
x Ap f (a -> x)
xs) = forall (f :: * -> *) a1 a. f a1 -> Ap f (a1 -> a) -> Ap f a
Ap f a
x Ap f (a -> x)
xs

-- | Convert an 'Ap' into an 'Ap1' if possible.  If the 'Ap' was "empty",
-- return the 'Pure' value instead.
fromAp :: Ap f ~> (Identity :+: Ap1 f)
fromAp :: forall (f :: * -> *). Ap f ~> (Identity :+: Ap1 f)
fromAp = \case
    Pure x
x  -> forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall a b. (a -> b) -> a -> b
$ forall a. a -> Identity a
Identity x
x
    Ap f a1
x Ap f (a1 -> x)
xs -> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 f a1
x Ap f (a1 -> x)
xs

-- | @since 0.3.0.0
instance Invariant (Ap1 f) where
    invmap :: forall a b. (a -> b) -> (b -> a) -> Ap1 f a -> Ap1 f b
invmap a -> b
f b -> a
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f

-- | An @'Ap1' f@ is just a @'Day' f ('Ap' f)@.  This bidirectional pattern
-- synonym lets you treat it as such.
pattern DayAp1 :: Day f (Ap f) a -> Ap1 f a
pattern $bDayAp1 :: forall (f :: * -> *) a. Day f (Ap f) a -> Ap1 f a
$mDayAp1 :: forall {r} {f :: * -> *} {a}.
Ap1 f a -> (Day f (Ap f) a -> r) -> ((# #) -> r) -> r
DayAp1 { forall (f :: * -> *) a. Ap1 f a -> Day f (Ap f) a
ap1Day } <- ((\case Ap1 f a
x Ap f (a -> a)
y -> forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> Day f g a
Day f a
x Ap f (a -> a)
y forall a b. a -> (a -> b) -> b
(&)) -> ap1Day)
  where
    DayAp1 (Day f b
x Ap f c
y b -> c -> a
f) = forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 f b
x (forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> c -> a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ap f c
y)
{-# COMPLETE DayAp1 #-}

deriving instance Functor (Ap1 f)

instance Apply (Ap1 f) where
    Ap1 f a
x Ap f (a -> a -> b)
xs <.> :: forall a b. Ap1 f (a -> b) -> Ap1 f a -> Ap1 f b
<.> Ap1 f a
ys = forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 f a
x (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ap f (a -> a -> b)
xs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *). Ap1 f ~> Ap f
toAp Ap1 f a
ys)

-- | Embed an @f@ into 'Ap1'.
liftAp1 :: f ~> Ap1 f
liftAp1 :: forall (f :: * -> *). f ~> Ap1 f
liftAp1 f x
x = forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 f x
x (forall a (f :: * -> *). a -> Ap f a
Pure forall a. a -> a
id)

-- | Extract the @f@ out of the 'Ap1'.
--
-- @
-- 'retractAp1' . 'liftAp1' == id
-- @
retractAp1 :: Apply f => Ap1 f ~> f
retractAp1 :: forall (f :: * -> *). Apply f => Ap1 f ~> f
retractAp1 (Ap1 f a
x Ap f (a -> x)
xs) = forall (f :: * -> *) a b. Apply f => f a -> Ap f (a -> b) -> f b
retractAp1_ f a
x Ap f (a -> x)
xs

-- | Interpret an @'Ap' f@ into some 'Apply' context @g@.
runAp1
    :: Apply g
    => (f ~> g)
    -> Ap1 f ~> g
runAp1 :: forall (g :: * -> *) (f :: * -> *).
Apply g =>
(f ~> g) -> Ap1 f ~> g
runAp1 f ~> g
f (Ap1 f a
x Ap f (a -> x)
xs) = forall (f :: * -> *) (g :: * -> *) a b.
Apply g =>
(f ~> g) -> f a -> Ap f (a -> b) -> g b
runAp1_ f ~> g
f f a
x Ap f (a -> x)
xs

instance HFunctor Ap1 where
    hmap :: forall (f :: * -> *) (g :: * -> *). (f ~> g) -> Ap1 f ~> Ap1 g
hmap f ~> g
f (Ap1 f a
x Ap f (a -> x)
xs) = forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 (f ~> g
f f a
x) (forall {k} {k1} (t :: (k -> *) -> k1 -> *) (f :: k -> *)
       (g :: k -> *).
HFunctor t =>
(f ~> g) -> t f ~> t g
hmap f ~> g
f Ap f (a -> x)
xs)

instance Inject Ap1 where
    inject :: forall (f :: * -> *). f ~> Ap1 f
inject = forall (f :: * -> *). f ~> Ap1 f
liftAp1

instance HBind Ap1 where
    hbind :: forall (f :: * -> *) (g :: * -> *). (f ~> Ap1 g) -> Ap1 f ~> Ap1 g
hbind = forall (g :: * -> *) (f :: * -> *).
Apply g =>
(f ~> g) -> Ap1 f ~> g
runAp1

instance HTraversable Ap1 where
    htraverse :: forall (h :: * -> *) (f :: * -> *) (g :: * -> *) a.
Applicative h =>
(forall x. f x -> h (g x)) -> Ap1 f a -> h (Ap1 g a)
htraverse forall x. f x -> h (g x)
f (Ap1 f a
x Ap f (a -> a)
xs) = forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall x. f x -> h (g x)
f f a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {k} {k1} (t :: (k -> *) -> k1 -> *) (h :: * -> *)
       (f :: k -> *) (g :: k -> *) (a :: k1).
(HTraversable t, Applicative h) =>
(forall (x :: k). f x -> h (g x)) -> t f a -> h (t g a)
htraverse forall x. f x -> h (g x)
f Ap f (a -> a)
xs

instance HTraversable1 Ap1 where
    htraverse1 :: forall (h :: * -> *) (f :: * -> *) (g :: * -> *) a.
Apply h =>
(forall x. f x -> h (g x)) -> Ap1 f a -> h (Ap1 g a)
htraverse1 forall x. f x -> h (g x)
f (Ap1 f a
x Ap f (a -> a)
xs) = forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a b.
Apply h =>
(forall x. f x -> h (g x)) -> f a -> Ap f (a -> b) -> h (Ap1 g b)
traverseAp1_ forall x. f x -> h (g x)
f f a
x Ap f (a -> a)
xs

traverseAp1_
    :: forall f g h a b. Apply h
    => (forall x. f x -> h (g x))
    -> f a
    -> Ap f (a -> b)
    -> h (Ap1 g b)
traverseAp1_ :: forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a b.
Apply h =>
(forall x. f x -> h (g x)) -> f a -> Ap f (a -> b) -> h (Ap1 g b)
traverseAp1_ forall x. f x -> h (g x)
f = forall x y. f x -> Ap f (x -> y) -> h (Ap1 g y)
go
  where
    go :: f x -> Ap f (x -> y) -> h (Ap1 g y)
    go :: forall x y. f x -> Ap f (x -> y) -> h (Ap1 g y)
go f x
x = \case
      Pure x -> y
y  -> (forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
`Ap1` forall a (f :: * -> *). a -> Ap f a
Pure x -> y
y) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall x. f x -> h (g x)
f f x
x
      Ap f a1
y Ap f (a1 -> x -> y)
ys -> forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall x. f x -> h (g x)
f f x
x forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> (forall (f :: * -> *). Ap1 f ~> Ap f
toAp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall x y. f x -> Ap f (x -> y) -> h (Ap1 g y)
go f a1
y Ap f (a1 -> x -> y)
ys)


instance Apply f => Interpret Ap1 f where
    retract :: Ap1 f ~> f
retract = forall (f :: * -> *). Apply f => Ap1 f ~> f
retractAp1
    interpret :: forall (g :: * -> *). (g ~> f) -> Ap1 g ~> f
interpret = forall (g :: * -> *) (f :: * -> *).
Apply g =>
(f ~> g) -> Ap1 f ~> g
runAp1

retractAp1_ :: Apply f => f a -> Ap f (a -> b) -> f b
retractAp1_ :: forall (f :: * -> *) a b. Apply f => f a -> Ap f (a -> b) -> f b
retractAp1_ f a
x = \case
    Pure a -> b
y  ->   a -> b
y forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x
    Ap f a1
y Ap f (a1 -> a -> b)
ys -> forall a b. a -> (a -> b) -> b
(&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> forall (f :: * -> *) a b. Apply f => f a -> Ap f (a -> b) -> f b
retractAp1_ f a1
y Ap f (a1 -> a -> b)
ys

runAp1_
    :: forall f g a b. Apply g
    => (f ~> g)
    -> f a
    -> Ap f (a -> b)
    -> g b
runAp1_ :: forall (f :: * -> *) (g :: * -> *) a b.
Apply g =>
(f ~> g) -> f a -> Ap f (a -> b) -> g b
runAp1_ f ~> g
f = forall x y. f x -> Ap f (x -> y) -> g y
go
  where
    go :: f x -> Ap f (x -> y) -> g y
    go :: forall x y. f x -> Ap f (x -> y) -> g y
go f x
x = \case
      Pure x -> y
y  ->   x -> y
y forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f ~> g
f f x
x
      Ap f a1
y Ap f (a1 -> x -> y)
ys -> forall a b. a -> (a -> b) -> b
(&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f ~> g
f f x
x forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> forall x y. f x -> Ap f (x -> y) -> g y
go f a1
y Ap f (a1 -> x -> y)
ys