{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTSyntax #-}
{-# LANGUAGE RankNTypes #-}

-- | An applicative with left zero @f@ is an 'Applicative'
-- with polymorphic zero action which stops
-- all actions right to zero.
--
-- @
-- -- Type of zero action
-- zero :: forall a. f a
-- 
-- -- Left zero law
-- zero \<*\> x === zero
-- @
-- 
-- This module provides the free @Applicative@ with zero, 'ApZ',
-- like the free applicative 'Control.Applicative.ApZ.Ap'.
module Control.Applicative.Free.Zero(
  ApZ(..),
  liftApZ, hoistApZ, trap,
  
  foldApZ, foldMaybeT, retract
) where

import Control.Applicative (Alternative(..), (<**>))
import FFunctor
import FMonad

-- | Free (applicative with left zero).
data ApZ f a where
  Pure :: a -> ApZ f a
  Zero :: ApZ f a
  Ap :: f a -> ApZ f (a -> b) -> ApZ f b

instance Functor (ApZ f) where
  fmap :: forall a b. (a -> b) -> ApZ f a -> ApZ f b
fmap a -> b
f (Pure a
r) = b -> ApZ f b
forall a (f :: * -> *). a -> ApZ f a
Pure (a -> b
f a
r)
  fmap a -> b
_ ApZ f a
Zero = ApZ f b
forall (f :: * -> *) a. ApZ f a
Zero
  fmap a -> b
f (Ap f a
fa ApZ f (a -> a)
mk) = f a -> ApZ f (a -> b) -> ApZ f b
forall (f :: * -> *) a b. f a -> ApZ f (a -> b) -> ApZ f b
Ap f a
fa ((a -> b
f (a -> b) -> (a -> a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((a -> a) -> a -> b) -> ApZ f (a -> a) -> ApZ f (a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ApZ f (a -> a)
mk)

instance Applicative (ApZ f) where
  pure :: forall a. a -> ApZ f a
pure = a -> ApZ f a
forall a (f :: * -> *). a -> ApZ f a
Pure

  liftA2 :: forall a b c. (a -> b -> c) -> ApZ f a -> ApZ f b -> ApZ f c
liftA2 a -> b -> c
op (Pure a
x) ApZ f b
y = a -> b -> c
op a
x (b -> c) -> ApZ f b -> ApZ f c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ApZ f b
y
  liftA2 a -> b -> c
_ ApZ f a
Zero ApZ f b
_ = ApZ f c
forall (f :: * -> *) a. ApZ f a
Zero
  liftA2 a -> b -> c
op (Ap f a
fa ApZ f (a -> a)
mk) ApZ f b
y = f a -> ApZ f (a -> c) -> ApZ f c
forall (f :: * -> *) a b. f a -> ApZ f (a -> b) -> ApZ f b
Ap f a
fa (((a -> a) -> b -> a -> c)
-> ApZ f (a -> a) -> ApZ f b -> ApZ f (a -> c)
forall a b c. (a -> b -> c) -> ApZ f a -> ApZ f b -> ApZ f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\a -> a
g b
b a
a -> a -> b -> c
op (a -> a
g a
a) b
b) ApZ f (a -> a)
mk ApZ f b
y)

-- | /Left zero/ + /Left catch/
instance Alternative (ApZ f) where
  empty :: forall a. ApZ f a
empty = ApZ f a
forall (f :: * -> *) a. ApZ f a
Zero
  <|> :: forall a. ApZ f a -> ApZ f a -> ApZ f a
(<|>) = ApZ f a -> ApZ f a -> ApZ f a
forall (f :: * -> *) a. ApZ f a -> ApZ f a -> ApZ f a
trap

liftApZ :: f a -> ApZ f a
liftApZ :: forall (f :: * -> *) a. f a -> ApZ f a
liftApZ f a
fa = f a -> ApZ f (a -> a) -> ApZ f a
forall (f :: * -> *) a b. f a -> ApZ f (a -> b) -> ApZ f b
Ap f a
fa ((a -> a) -> ApZ f (a -> a)
forall a (f :: * -> *). a -> ApZ f a
Pure a -> a
forall a. a -> a
id)

hoistApZ :: (forall x. f x -> g x) -> ApZ f a -> ApZ g a
hoistApZ :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> ApZ f a -> ApZ g a
hoistApZ forall x. f x -> g x
_ (Pure a
a) = a -> ApZ g a
forall a (f :: * -> *). a -> ApZ f a
Pure a
a
hoistApZ forall x. f x -> g x
_ ApZ f a
Zero = ApZ g a
forall (f :: * -> *) a. ApZ f a
Zero
hoistApZ forall x. f x -> g x
fg (Ap f a
fa ApZ f (a -> a)
mk) = g a -> ApZ g (a -> a) -> ApZ g a
forall (f :: * -> *) a b. f a -> ApZ f (a -> b) -> ApZ f b
Ap (f a -> g a
forall x. f x -> g x
fg f a
fa) ((forall x. f x -> g x) -> ApZ f (a -> a) -> ApZ g (a -> a)
forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> ApZ f a -> ApZ g a
hoistApZ f x -> g x
forall x. f x -> g x
fg ApZ f (a -> a)
mk)

instance FFunctor ApZ where
  ffmap :: forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> ApZ g x -> ApZ h x
ffmap = (forall x. g x -> h x) -> ApZ g x -> ApZ h x
forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> ApZ f a -> ApZ g a
hoistApZ

instance FMonad ApZ where
  fpure :: forall (g :: * -> *). Functor g => g ~> ApZ g
fpure = g x -> ApZ g x
forall (f :: * -> *) a. f a -> ApZ f a
liftApZ
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> ApZ h) -> ApZ g a -> ApZ h a
fbind g ~> ApZ h
k = (g ~> ApZ h) -> (forall r. ApZ h r) -> ApZ g a -> ApZ h a
forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall r. f r -> g r) -> (forall r. g r) -> ApZ f a -> g a
foldApZ g r -> ApZ h r
g ~> ApZ h
k ApZ h r
forall r. ApZ h r
forall (f :: * -> *) a. ApZ f a
Zero

-- | Recovery from 'Zero'.
--
-- @'trap' x y@ first look at @x@ if it ends with @Zero@ constructor.
-- If @x@ ends with @Pure@, return @x@ itself.
-- Otherwise, it replaces @Zero@ in x with @y@.
--
-- @
-- 'trap' (Ap f1 (Ap f2 ... Zero)) y === Ap f1 (Ap f2 ... y)
-- @
trap :: ApZ f a -> ApZ f a -> ApZ f a
trap :: forall (f :: * -> *) a. ApZ f a -> ApZ f a -> ApZ f a
trap = (a -> a) -> ApZ f a -> ApZ f a -> ApZ f a
forall b a (f :: * -> *). (b -> a) -> ApZ f a -> ApZ f b -> ApZ f a
go a -> a
forall a. a -> a
id
  where
    go :: (b -> a) -> ApZ f a -> ApZ f b -> ApZ f a
    go :: forall b a (f :: * -> *). (b -> a) -> ApZ f a -> ApZ f b -> ApZ f a
go b -> a
_ (Pure a
a) ApZ f b
_ = a -> ApZ f a
forall a (f :: * -> *). a -> ApZ f a
Pure a
a
    go b -> a
p ApZ f a
Zero ApZ f b
y = b -> a
p (b -> a) -> ApZ f b -> ApZ f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ApZ f b
y
    go b -> a
p (Ap f a
fa ApZ f (a -> a)
mk) ApZ f b
y = f a -> ApZ f (a -> a) -> ApZ f a
forall (f :: * -> *) a b. f a -> ApZ f (a -> b) -> ApZ f b
Ap f a
fa ((b -> a -> a) -> ApZ f (a -> a) -> ApZ f b -> ApZ f (a -> a)
forall b a (f :: * -> *). (b -> a) -> ApZ f a -> ApZ f b -> ApZ f a
go (a -> a -> a
forall a b. a -> b -> a
const (a -> a -> a) -> (b -> a) -> b -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
p) ApZ f (a -> a)
mk ApZ f b
y)

-- * Interpreting

foldApZ :: Applicative g => (forall r. f r -> g r) -> (forall r. g r) -> ApZ f a -> g a
foldApZ :: forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall r. f r -> g r) -> (forall r. g r) -> ApZ f a -> g a
foldApZ forall r. f r -> g r
handle forall r. g r
z ApZ f a
e = case ApZ f a
e of
  Pure a
a -> a -> g a
forall a. a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  ApZ f a
Zero -> g a
forall r. g r
z
  Ap f a
fa ApZ f (a -> a)
mk -> f a -> g a
forall r. f r -> g r
handle f a
fa g a -> g (a -> a) -> g a
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> (forall r. f r -> g r)
-> (forall r. g r) -> ApZ f (a -> a) -> g (a -> a)
forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall r. f r -> g r) -> (forall r. g r) -> ApZ f a -> g a
foldApZ f r -> g r
forall r. f r -> g r
handle g r
forall r. g r
z ApZ f (a -> a)
mk

foldMaybeT :: Monad g => (forall r. f r -> g r) -> ApZ f a -> g (Maybe a)
foldMaybeT :: forall (g :: * -> *) (f :: * -> *) a.
Monad g =>
(forall r. f r -> g r) -> ApZ f a -> g (Maybe a)
foldMaybeT forall r. f r -> g r
_ (Pure a
a) = Maybe a -> g (Maybe a)
forall a. a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
foldMaybeT forall r. f r -> g r
_ ApZ f a
Zero = Maybe a -> g (Maybe a)
forall a. a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
foldMaybeT forall r. f r -> g r
h (Ap f a
fa ApZ f (a -> a)
mk) = f a -> g a
forall r. f r -> g r
h f a
fa g a -> (a -> g (Maybe a)) -> g (Maybe a)
forall a b. g a -> (a -> g b) -> g b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> ((a -> a) -> a) -> Maybe (a -> a) -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
a) (Maybe (a -> a) -> Maybe a) -> g (Maybe (a -> a)) -> g (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall r. f r -> g r) -> ApZ f (a -> a) -> g (Maybe (a -> a))
forall (g :: * -> *) (f :: * -> *) a.
Monad g =>
(forall r. f r -> g r) -> ApZ f a -> g (Maybe a)
foldMaybeT f r -> g r
forall r. f r -> g r
h ApZ f (a -> a)
mk 

retract :: Alternative f => ApZ f a -> f a
retract :: forall (f :: * -> *) a. Alternative f => ApZ f a -> f a
retract = (forall r. f r -> f r) -> (forall r. f r) -> ApZ f a -> f a
forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall r. f r -> g r) -> (forall r. g r) -> ApZ f a -> g a
foldApZ f r -> f r
forall a. a -> a
forall r. f r -> f r
id f r
forall r. f r
forall (f :: * -> *) a. Alternative f => f a
empty