-- |
-- 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 :: * -> *) x. Ap1 f x -> Ap f x
toAp (Ap1 f a
x Ap f (a -> x)
xs) = f a -> Ap f (a -> x) -> Ap f x
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 :: * -> *) x. Ap f x -> (:+:) Identity (Ap1 f) x
fromAp = \case
    Pure x
x  -> Identity x -> (:+:) Identity (Ap1 f) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (Identity x -> (:+:) Identity (Ap1 f) x)
-> Identity x -> (:+:) Identity (Ap1 f) x
forall a b. (a -> b) -> a -> b
$ x -> Identity x
forall a. a -> Identity a
Identity x
x
    Ap f a1
x Ap f (a1 -> x)
xs -> Ap1 f x -> (:+:) Identity (Ap1 f) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Ap1 f x -> (:+:) Identity (Ap1 f) x)
-> Ap1 f x -> (:+:) Identity (Ap1 f) x
forall a b. (a -> b) -> a -> b
$ f a1 -> Ap f (a1 -> x) -> Ap1 f x
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
_ = (a -> b) -> Ap1 f a -> Ap1 f b
forall a b. (a -> b) -> Ap1 f a -> Ap1 f b
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 $mDayAp1 :: forall {r} {f :: * -> *} {a}.
Ap1 f a -> (Day f (Ap f) a -> r) -> ((# #) -> r) -> r
$bDayAp1 :: forall (f :: * -> *) a. Day f (Ap f) a -> Ap1 f a
DayAp1 { forall (f :: * -> *) a. Ap1 f a -> Day f (Ap f) a
ap1Day } <- ((\case Ap1 f a
x Ap f (a -> a)
y -> f a -> Ap f (a -> a) -> (a -> (a -> a) -> a) -> Day f (Ap f) a
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 a -> (a -> a) -> a
forall a b. a -> (a -> b) -> b
(&)) -> ap1Day)
  where
    DayAp1 (Day f b
x Ap f c
y b -> c -> a
f) = f b -> Ap f (b -> a) -> Ap1 f a
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 f b
x ((b -> c -> a) -> c -> b -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> c -> a
f (c -> b -> a) -> Ap f c -> Ap f (b -> a)
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 = f a -> Ap f (a -> b) -> Ap1 f b
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 f a
x ((a -> a -> b) -> a -> a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> a -> b) -> a -> a -> b)
-> Ap f (a -> a -> b) -> Ap f (a -> a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ap f (a -> a -> b)
xs Ap f (a -> a -> b) -> Ap f a -> Ap f (a -> b)
forall a b. Ap f (a -> b) -> Ap f a -> Ap f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ap1 f a -> Ap f a
forall (f :: * -> *) x. Ap1 f x -> Ap f x
toAp Ap1 f a
ys)

-- | Embed an @f@ into 'Ap1'.
liftAp1 :: f ~> Ap1 f
liftAp1 :: forall (f :: * -> *) x. f x -> Ap1 f x
liftAp1 f x
x = f x -> Ap f (x -> x) -> Ap1 f x
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 f x
x ((x -> x) -> Ap f (x -> x)
forall a (f :: * -> *). a -> Ap f a
Pure x -> x
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) = f a -> Ap f (a -> x) -> f x
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) = (f ~> g) -> f a -> Ap f (a -> x) -> g x
forall (f :: * -> *) (g :: * -> *) a b.
Apply g =>
(f ~> g) -> f a -> Ap f (a -> b) -> g b
runAp1_ f x -> g x
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) = g a -> Ap g (a -> x) -> Ap1 g x
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 (f a -> g a
f ~> g
f f a
x) ((f ~> g) -> Ap f ~> Ap g
forall {k} {k1} (t :: (k -> *) -> k1 -> *) (f :: k -> *)
       (g :: k -> *).
HFunctor t =>
(f ~> g) -> t f ~> t g
forall (f :: * -> *) (g :: * -> *). (f ~> g) -> Ap f ~> Ap g
hmap f x -> g x
f ~> g
f Ap f (a -> x)
xs)

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

instance HBind Ap1 where
    hbind :: forall (f :: * -> *) (g :: * -> *). (f ~> Ap1 g) -> Ap1 f ~> Ap1 g
hbind = (f ~> Ap1 g) -> Ap1 f x -> Ap1 g x
(f ~> Ap1 g) -> Ap1 f ~> Ap1 g
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) = g a -> Ap g (a -> a) -> Ap1 g a
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 (g a -> Ap g (a -> a) -> Ap1 g a)
-> h (g a) -> h (Ap g (a -> a) -> Ap1 g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> h (g a)
forall x. f x -> h (g x)
f f a
x h (Ap g (a -> a) -> Ap1 g a) -> h (Ap g (a -> a)) -> h (Ap1 g a)
forall a b. h (a -> b) -> h a -> h b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall x. f x -> h (g x)) -> Ap f (a -> a) -> h (Ap g (a -> a))
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)
forall (h :: * -> *) (f :: * -> *) (g :: * -> *) a.
Applicative h =>
(forall x. f x -> h (g x)) -> Ap f a -> h (Ap g a)
htraverse f x -> h (g x)
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 x. f x -> h (g x)) -> f a -> Ap f (a -> a) -> h (Ap1 g a)
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_ f x -> h (g x)
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 = f a -> Ap f (a -> b) -> h (Ap1 g b)
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  -> (g x -> Ap g (x -> y) -> Ap1 g y
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
`Ap1` (x -> y) -> Ap g (x -> y)
forall a (f :: * -> *). a -> Ap f a
Pure x -> y
y) (g x -> Ap1 g y) -> h (g x) -> h (Ap1 g y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x -> h (g x)
forall x. f x -> h (g x)
f f x
x
      Ap f a1
y Ap f (a1 -> x -> y)
ys -> g x -> Ap g (x -> y) -> Ap1 g y
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 (g x -> Ap g (x -> y) -> Ap1 g y)
-> h (g x) -> h (Ap g (x -> y) -> Ap1 g y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x -> h (g x)
forall x. f x -> h (g x)
f f x
x h (Ap g (x -> y) -> Ap1 g y) -> h (Ap g (x -> y)) -> h (Ap1 g y)
forall a b. h (a -> b) -> h a -> h b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> (Ap1 g (x -> y) -> Ap g (x -> y)
forall (f :: * -> *) x. Ap1 f x -> Ap f x
toAp (Ap1 g (x -> y) -> Ap g (x -> y))
-> h (Ap1 g (x -> y)) -> h (Ap g (x -> y))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a1 -> Ap f (a1 -> x -> y) -> h (Ap1 g (x -> y))
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 = Ap1 f x -> f x
Ap1 f ~> f
forall (f :: * -> *). Apply f => Ap1 f ~> f
retractAp1
    interpret :: forall (g :: * -> *). (g ~> f) -> Ap1 g ~> f
interpret = (g ~> f) -> Ap1 g x -> f x
(g ~> f) -> Ap1 g ~> f
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 (a -> b) -> f a -> f b
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 -> a -> (a -> b) -> b
forall a b. a -> (a -> b) -> b
(&) (a -> (a -> b) -> b) -> f a -> f ((a -> b) -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x f ((a -> b) -> b) -> f (a -> b) -> f b
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> f a1 -> Ap f (a1 -> a -> b) -> f (a -> 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 = f a -> Ap f (a -> b) -> g b
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 (x -> y) -> g x -> g y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x -> g x
f ~> g
f f x
x
      Ap f a1
y Ap f (a1 -> x -> y)
ys -> x -> (x -> y) -> y
forall a b. a -> (a -> b) -> b
(&) (x -> (x -> y) -> y) -> g x -> g ((x -> y) -> y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x -> g x
f ~> g
f f x
x g ((x -> y) -> y) -> g (x -> y) -> g y
forall a b. g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> f a1 -> Ap f (a1 -> x -> y) -> g (x -> y)
forall x y. f x -> Ap f (x -> y) -> g y
go f a1
y Ap f (a1 -> x -> y)
ys