{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Alternative.Free.Final
-- Copyright   :  (C) 2012 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  GADTs, Rank2Types
--
-- Final encoding of free 'Alternative' functors.
----------------------------------------------------------------------------
module Control.Alternative.Free.Final
  ( Alt(..)
  , runAlt
  , liftAlt
  , hoistAlt
  ) where

import Control.Applicative
import Data.Functor.Apply
import Data.Functor.Alt ((<!>))
import qualified Data.Functor.Alt as Alt

#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup
#endif

-- | The free 'Alternative' for any @f@.
newtype Alt f a = Alt { forall (f :: * -> *) a.
Alt f a
-> forall (g :: * -> *).
   Alternative g =>
   (forall x. f x -> g x) -> g a
_runAlt :: forall g. Alternative g => (forall x. f x -> g x) -> g a }

instance Functor (Alt f) where
  fmap :: forall a b. (a -> b) -> Alt f a -> Alt f b
fmap a -> b
f (Alt forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
g) = forall (f :: * -> *) a.
(forall (g :: * -> *).
 Alternative g =>
 (forall x. f x -> g x) -> g a)
-> Alt f a
Alt (\forall x. f x -> g x
k -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
g forall x. f x -> g x
k))

instance Apply (Alt f) where
  Alt forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g (a -> b)
f <.> :: forall a b. Alt f (a -> b) -> Alt f a -> Alt f b
<.> Alt forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
x = forall (f :: * -> *) a.
(forall (g :: * -> *).
 Alternative g =>
 (forall x. f x -> g x) -> g a)
-> Alt f a
Alt (\forall x. f x -> g x
k -> forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g (a -> b)
f forall x. f x -> g x
k forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
x forall x. f x -> g x
k)

instance Applicative (Alt f) where
  pure :: forall a. a -> Alt f a
pure a
x = forall (f :: * -> *) a.
(forall (g :: * -> *).
 Alternative g =>
 (forall x. f x -> g x) -> g a)
-> Alt f a
Alt (\forall x. f x -> g x
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
  Alt forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g (a -> b)
f <*> :: forall a b. Alt f (a -> b) -> Alt f a -> Alt f b
<*> Alt forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
x = forall (f :: * -> *) a.
(forall (g :: * -> *).
 Alternative g =>
 (forall x. f x -> g x) -> g a)
-> Alt f a
Alt (\forall x. f x -> g x
k -> forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g (a -> b)
f forall x. f x -> g x
k forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
x forall x. f x -> g x
k)

instance Alt.Alt (Alt f) where
  Alt forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
x <!> :: forall a. Alt f a -> Alt f a -> Alt f a
<!> Alt forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
y = forall (f :: * -> *) a.
(forall (g :: * -> *).
 Alternative g =>
 (forall x. f x -> g x) -> g a)
-> Alt f a
Alt (\forall x. f x -> g x
k -> forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
x forall x. f x -> g x
k forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
y forall x. f x -> g x
k)

instance Alternative (Alt f) where
  empty :: forall a. Alt f a
empty = forall (f :: * -> *) a.
(forall (g :: * -> *).
 Alternative g =>
 (forall x. f x -> g x) -> g a)
-> Alt f a
Alt (\forall x. f x -> g x
_ -> forall (f :: * -> *) a. Alternative f => f a
empty)
  Alt forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
x <|> :: forall a. Alt f a -> Alt f a -> Alt f a
<|> Alt forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
y = forall (f :: * -> *) a.
(forall (g :: * -> *).
 Alternative g =>
 (forall x. f x -> g x) -> g a)
-> Alt f a
Alt (\forall x. f x -> g x
k -> forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
x forall x. f x -> g x
k forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
y forall x. f x -> g x
k)
  some :: forall a. Alt f a -> Alt f [a]
some (Alt forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
x) = forall (f :: * -> *) a.
(forall (g :: * -> *).
 Alternative g =>
 (forall x. f x -> g x) -> g a)
-> Alt f a
Alt forall a b. (a -> b) -> a -> b
$ \forall x. f x -> g x
k -> forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
x forall x. f x -> g x
k)
  many :: forall a. Alt f a -> Alt f [a]
many (Alt forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
x) = forall (f :: * -> *) a.
(forall (g :: * -> *).
 Alternative g =>
 (forall x. f x -> g x) -> g a)
-> Alt f a
Alt forall a b. (a -> b) -> a -> b
$ \forall x. f x -> g x
k -> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g a
x forall x. f x -> g x
k)

instance Semigroup (Alt f a) where
  <> :: Alt f a -> Alt f a -> Alt f a
(<>) = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance Monoid (Alt f a) where
  mempty :: Alt f a
mempty = forall (f :: * -> *) a. Alternative f => f a
empty
  mappend :: Alt f a -> Alt f a -> Alt f a
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- | A version of 'lift' that can be used with @f@.
liftAlt :: f a -> Alt f a
liftAlt :: forall (f :: * -> *) a. f a -> Alt f a
liftAlt f a
f = forall (f :: * -> *) a.
(forall (g :: * -> *).
 Alternative g =>
 (forall x. f x -> g x) -> g a)
-> Alt f a
Alt (\forall x. f x -> g x
k -> forall x. f x -> g x
k f a
f)

-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' f@ to @g@.
runAlt :: forall f g a. Alternative g => (forall x. f x -> g x) -> Alt f a -> g a
runAlt :: forall (f :: * -> *) (g :: * -> *) a.
Alternative g =>
(forall x. f x -> g x) -> Alt f a -> g a
runAlt forall x. f x -> g x
phi Alt f a
g = forall (f :: * -> *) a.
Alt f a
-> forall (g :: * -> *).
   Alternative g =>
   (forall x. f x -> g x) -> g a
_runAlt Alt f a
g forall x. f x -> g x
phi

-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Alt f@ to @Alt g@.
hoistAlt :: (forall a. f a -> g a) -> Alt f b -> Alt g b
hoistAlt :: forall (f :: * -> *) (g :: * -> *) b.
(forall a. f a -> g a) -> Alt f b -> Alt g b
hoistAlt forall a. f a -> g a
phi (Alt forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g b
g) = forall (f :: * -> *) a.
(forall (g :: * -> *).
 Alternative g =>
 (forall x. f x -> g x) -> g a)
-> Alt f a
Alt (\forall x. g x -> g x
k -> forall (g :: * -> *).
Alternative g =>
(forall x. f x -> g x) -> g b
g (forall x. g x -> g x
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. f a -> g a
phi))