{-# LANGUAGE
  GADTs #-}

-- |
-- The definition of 'Aps'.
-- Most of this is reexported by "ApNormalize".

module ApNormalize.Aps
  ( -- * Normalizing applicative functors
    Aps(..)
  , (<$>^)
  , (<*>^)
  , liftAps
  , lowerAps
  , liftA2Aps
  , apsToApDList
  ) where

import Control.Applicative (liftA2, liftA3)
import ApNormalize.DList

-- | An applicative functor transformer which accumulates @f@-actions (things of type @f x@)
-- in a normal form.
--
-- It constructs a value of type @f a@ with the following syntactic invariant.
-- It depends on the number of @f@-actions @a1 ... an@ composing it,
-- which are delimited using 'liftAps':
--
-- - Zero action: @pure x@
-- - One action: @f \<$> a1@
-- - Two or more actions: @liftA2 f a1 a2 \<*> a3 \<*> ... \<*> an@
data Aps f a where
  Pure :: a -> Aps f a
  FmapLift :: (x -> a) -> f x -> Aps f a
  LiftA2Aps :: (x -> y -> z -> a) -> f x -> f y -> ApDList f z -> Aps f a

infixl 4 <$>^, <*>^

-- | @f \<$>^ u :: Aps f b@ is a delayed representation of @f \<$> u :: f b@,
-- so that it can be fused with other applicative operations.
--
-- @f \<$>^ u@ is a shorthand for @f \<$> 'liftAps' u@.
(<$>^) :: (a -> b) -> f a -> Aps f b
<$>^ :: (a -> b) -> f a -> Aps f b
(<$>^) = (a -> b) -> f a -> Aps f b
forall x a (f :: * -> *). (x -> a) -> f x -> Aps f a
FmapLift
{-# INLINE (<$>^) #-}

-- | @u \<*>^ v@ appends an @f@-action @v@ to the right of an @('Aps' f)@-action @u@.
--
-- @u \<*>^ v@ is a shorthand for @u \<*> 'liftAps' v@.
(<*>^) :: Applicative f => Aps f (a -> b) -> f a -> Aps f b
Aps f (a -> b)
u <*>^ :: Aps f (a -> b) -> f a -> Aps f b
<*>^ f a
v = Aps f (a -> b)
u Aps f (a -> b) -> Aps f a -> Aps f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a -> Aps f a
forall (f :: * -> *) a. f a -> Aps f a
liftAps f a
v
{-# INLINE (<*>^) #-}

-- | Lift an @f@-action into @'Aps' f@.
liftAps :: f a -> Aps f a
liftAps :: f a -> Aps f a
liftAps = (a -> a) -> f a -> Aps f a
forall x a (f :: * -> *). (x -> a) -> f x -> Aps f a
FmapLift a -> a
forall a. a -> a
id
{-# INLINE liftAps #-}

-- | Lower an @f@-action from @'Aps' f@.
lowerAps :: Applicative f => Aps f a -> f a
lowerAps :: Aps f a -> f a
lowerAps (Pure a
x) = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
lowerAps (FmapLift x -> a
f f x
u) = (x -> a) -> f x -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap x -> a
f f x
u
lowerAps (LiftA2Aps x -> y -> z -> a
f f x
u f y
v ApDList f z
w) =
   Yoneda f (z -> a) -> ApDList f z -> f a
forall (f :: * -> *) b c. Yoneda f (b -> c) -> ApDList f b -> f c
lowerApDList ((forall x. ((z -> a) -> x) -> f x) -> Yoneda f (z -> a)
forall (f :: * -> *) a. (forall x. (a -> x) -> f x) -> Yoneda f a
Yoneda (\(z -> a) -> x
k -> (x -> y -> x) -> f x -> f y -> f x
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\x
x y
y -> (z -> a) -> x
k (x -> y -> z -> a
f x
x y
y)) f x
u f y
v)) ApDList f z
w
{-# INLINE lowerAps #-}

instance Functor (Aps f) where
  fmap :: (a -> b) -> Aps f a -> Aps f b
fmap a -> b
f (Pure a
x) = b -> Aps f b
forall a (f :: * -> *). a -> Aps f a
Pure (a -> b
f a
x)
  fmap a -> b
f (FmapLift x -> a
g f x
u) = (x -> b) -> f x -> Aps f b
forall x a (f :: * -> *). (x -> a) -> f x -> Aps f a
FmapLift (a -> b
f (a -> b) -> (x -> a) -> x -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> a
g) f x
u
  fmap a -> b
f (LiftA2Aps x -> y -> z -> a
g f x
u f y
v ApDList f z
w) = (x -> y -> z -> b) -> f x -> f y -> ApDList f z -> Aps f b
forall x y z a (f :: * -> *).
(x -> y -> z -> a) -> f x -> f y -> ApDList f z -> Aps f a
LiftA2Aps ((((y -> z -> a) -> y -> z -> b)
-> (x -> y -> z -> a) -> x -> y -> z -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((y -> z -> a) -> y -> z -> b)
 -> (x -> y -> z -> a) -> x -> y -> z -> b)
-> ((a -> b) -> (y -> z -> a) -> y -> z -> b)
-> (a -> b)
-> (x -> y -> z -> a)
-> x
-> y
-> z
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((z -> a) -> z -> b) -> (y -> z -> a) -> y -> z -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((z -> a) -> z -> b) -> (y -> z -> a) -> y -> z -> b)
-> ((a -> b) -> (z -> a) -> z -> b)
-> (a -> b)
-> (y -> z -> a)
-> y
-> z
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> (z -> a) -> z -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f x -> y -> z -> a
g) f x
u f y
v ApDList f z
w
  {-# INLINE fmap #-}

instance Applicative f => Applicative (Aps f) where
  pure :: a -> Aps f a
pure = a -> Aps f a
forall a (f :: * -> *). a -> Aps f a
Pure
  Pure a -> b
f <*> :: Aps f (a -> b) -> Aps f a -> Aps f b
<*> Aps f a
uy = (a -> b) -> Aps f a -> Aps f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Aps f a
uy
  FmapLift x -> a -> b
f f x
ux <*> Aps f a
uy = (x -> a -> b) -> f x -> Aps f a -> Aps f b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> Aps f b -> Aps f c
liftA2Aps x -> a -> b
f f x
ux Aps f a
uy
  LiftA2Aps x -> y -> z -> a -> b
f f x
u f y
v ApDList f z
w <*> Aps f a
ww =
    (x -> y -> (z, a) -> b)
-> f x -> f y -> ApDList f (z, a) -> Aps f b
forall x y z a (f :: * -> *).
(x -> y -> z -> a) -> f x -> f y -> ApDList f z -> Aps f a
LiftA2Aps (\x
x y
y (z
z, a
zz) -> x -> y -> z -> a -> b
f x
x y
y z
z a
zz) f x
u f y
v ((z -> a -> (z, a))
-> ApDList f z -> ApDList f a -> ApDList f (z, a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) ApDList f z
w (Aps f a -> ApDList f a
forall (f :: * -> *) a. Applicative f => Aps f a -> ApDList f a
apsToApDList Aps f a
ww))
  {-# INLINE pure #-}
  {-# INLINE (<*>) #-}

-- | Append an action to the left of an 'Aps'.
liftA2Aps :: Applicative f => (a -> b -> c) -> f a -> Aps f b -> Aps f c
liftA2Aps :: (a -> b -> c) -> f a -> Aps f b -> Aps f c
liftA2Aps a -> b -> c
f f a
ux (Pure b
y) = (a -> c) -> f a -> Aps f c
forall x a (f :: * -> *). (x -> a) -> f x -> Aps f a
FmapLift (\a
x -> a -> b -> c
f a
x b
y) f a
ux
liftA2Aps a -> b -> c
f f a
ux (FmapLift x -> b
g f x
uy) = (a -> x -> () -> c) -> f a -> f x -> ApDList f () -> Aps f c
forall x y z a (f :: * -> *).
(x -> y -> z -> a) -> f x -> f y -> ApDList f z -> Aps f a
LiftA2Aps (\a
x x
y ()
_ -> a -> b -> c
f a
x (x -> b
g x
y)) f a
ux f x
uy (() -> ApDList f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
liftA2Aps a -> b -> c
f f a
ux (LiftA2Aps x -> y -> z -> b
g f x
u f y
v ApDList f z
w) =
  (a -> x -> (y, z) -> c)
-> f a -> f x -> ApDList f (y, z) -> Aps f c
forall x y z a (f :: * -> *).
(x -> y -> z -> a) -> f x -> f y -> ApDList f z -> Aps f a
LiftA2Aps (\a
x x
y (y
z, z
zz) -> a -> b -> c
f a
x (x -> y -> z -> b
g x
y y
z z
zz)) f a
ux f x
u ((y -> z -> (y, z))
-> ApDList f y -> ApDList f z -> ApDList f (y, z)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (f y -> ApDList f y
forall (f :: * -> *) a. Applicative f => f a -> ApDList f a
liftApDList f y
v) ApDList f z
w)
{-# INLINE liftA2Aps #-}

-- | Conversion from 'Aps' to 'ApDList'.
apsToApDList :: Applicative f => Aps f a -> ApDList f a
apsToApDList :: Aps f a -> ApDList f a
apsToApDList (Pure a
x) = a -> ApDList f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
apsToApDList (FmapLift x -> a
f f x
u) = (x -> a) -> ApDList f x -> ApDList f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap x -> a
f (f x -> ApDList f x
forall (f :: * -> *) a. Applicative f => f a -> ApDList f a
liftApDList f x
u)
apsToApDList (LiftA2Aps x -> y -> z -> a
f f x
u f y
v ApDList f z
w) = (x -> y -> z -> a)
-> ApDList f x -> ApDList f y -> ApDList f z -> ApDList f a
forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 x -> y -> z -> a
f (f x -> ApDList f x
forall (f :: * -> *) a. Applicative f => f a -> ApDList f a
liftApDList f x
u) (f y -> ApDList f y
forall (f :: * -> *) a. Applicative f => f a -> ApDList f a
liftApDList f y
v) ApDList f z
w
{-# INLINE apsToApDList #-}