{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Safe #-}
#else
-- Manual Typeable instances
{-# LANGUAGE Trustworthy #-}
#endif
#include "free-common.h"

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Alternative.Free
-- Copyright   :  (C) 2012 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  GADTs, Rank2Types
--
-- Left distributive 'Alternative' functors for free, based on a design
-- by Stijn van Drongelen.
----------------------------------------------------------------------------
module Control.Alternative.Free
  ( Alt(..)
  , AltF(..)
  , runAlt
  , liftAlt
  , hoistAlt
  ) where

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

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

infixl 3 `Ap`

data AltF f a where
  Ap     :: f a -> Alt f (a -> b) -> AltF f b
  Pure   :: a                     -> AltF f a
#if __GLASGOW_HASKELL__ >= 707
  deriving Typeable
#endif

newtype Alt f a = Alt { Alt f a -> [AltF f a]
alternatives :: [AltF f a] }
#if __GLASGOW_HASKELL__ >= 707
  deriving Typeable
#endif

instance Functor (AltF f) where
  fmap :: (a -> b) -> AltF f a -> AltF f b
fmap a -> b
f (Pure a
a) = b -> AltF f b
forall a (f :: * -> *). a -> AltF f a
Pure (b -> AltF f b) -> b -> AltF f b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
  fmap a -> b
f (Ap f a
x Alt f (a -> a)
g) = f a
x f a -> Alt f (a -> b) -> AltF f b
forall (f :: * -> *) a b. f a -> Alt f (a -> b) -> AltF f b
`Ap` ((a -> a) -> a -> b) -> Alt f (a -> a) -> Alt f (a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f (a -> b) -> (a -> a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) Alt f (a -> a)
g

instance Functor (Alt f) where
  fmap :: (a -> b) -> Alt f a -> Alt f b
fmap a -> b
f (Alt [AltF f a]
xs) = [AltF f b] -> Alt f b
forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt ([AltF f b] -> Alt f b) -> [AltF f b] -> Alt f b
forall a b. (a -> b) -> a -> b
$ (AltF f a -> AltF f b) -> [AltF f a] -> [AltF f b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> AltF f a -> AltF f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [AltF f a]
xs

instance Applicative (AltF f) where
  pure :: a -> AltF f a
pure = a -> AltF f a
forall a (f :: * -> *). a -> AltF f a
Pure
  {-# INLINE pure #-}
  (Pure a -> b
f)   <*> :: AltF f (a -> b) -> AltF f a -> AltF f b
<*> AltF f a
y         = (a -> b) -> AltF f a -> AltF f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f AltF f a
y      -- fmap
  AltF f (a -> b)
y          <*> (Pure a
a)  = ((a -> b) -> b) -> AltF f (a -> b) -> AltF f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
a) AltF f (a -> b)
y  -- interchange
  (Ap f a
a Alt f (a -> a -> b)
f)   <*> AltF f a
b         = f a
a f a -> Alt f (a -> b) -> AltF f b
forall (f :: * -> *) a b. f a -> Alt f (a -> b) -> AltF f b
`Ap` ((a -> a -> b) -> a -> a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> a -> b) -> a -> a -> b)
-> Alt f (a -> a -> b) -> Alt f (a -> a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Alt f (a -> a -> b)
f Alt f (a -> a -> b) -> Alt f a -> Alt f (a -> b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([AltF f a] -> Alt f a
forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt [AltF f a
b]))
  {-# INLINE (<*>) #-}

instance Applicative (Alt f) where
  pure :: a -> Alt f a
pure a
a = [AltF f a] -> Alt f a
forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt [a -> AltF f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a]
  {-# INLINE pure #-}

  (Alt [AltF f (a -> b)]
xs) <*> :: Alt f (a -> b) -> Alt f a -> Alt f b
<*> Alt f a
ys = [AltF f b] -> Alt f b
forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt ([AltF f (a -> b)]
xs [AltF f (a -> b)] -> (AltF f (a -> b) -> [AltF f b]) -> [AltF f b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Alt f b -> [AltF f b]
forall (f :: * -> *) a. Alt f a -> [AltF f a]
alternatives (Alt f b -> [AltF f b])
-> (AltF f (a -> b) -> Alt f b) -> AltF f (a -> b) -> [AltF f b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AltF f (a -> b) -> Alt f a -> Alt f b
forall a b. AltF f (a -> b) -> Alt f a -> Alt f b
`ap'` Alt f a
ys))
    where
      ap' :: AltF f (a -> b) -> Alt f a -> Alt f b

      Pure a -> b
f ap' :: AltF f (a -> b) -> Alt f a -> Alt f b
`ap'` Alt f a
u      = (a -> b) -> Alt f a -> Alt f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Alt f a
u
      (f a
u `Ap` Alt f (a -> a -> b)
f) `ap'` Alt f a
v  = [AltF f b] -> Alt f b
forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt [f a
u f a -> Alt f (a -> b) -> AltF f b
forall (f :: * -> *) a b. f a -> Alt f (a -> b) -> AltF f b
`Ap` ((a -> a -> b) -> a -> a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> a -> b) -> a -> a -> b)
-> Alt f (a -> a -> b) -> Alt f (a -> a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Alt f (a -> a -> b)
f) Alt f (a -> a -> b) -> Alt f a -> Alt f (a -> b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Alt f a
v]
  {-# INLINE (<*>) #-}

liftAltF :: f a -> AltF f a
liftAltF :: f a -> AltF f a
liftAltF f a
x = f a
x f a -> Alt f (a -> a) -> AltF f a
forall (f :: * -> *) a b. f a -> Alt f (a -> b) -> AltF f b
`Ap` (a -> a) -> Alt f (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id
{-# INLINE liftAltF #-}

-- | A version of 'lift' that can be used with any @f@.
liftAlt :: f a -> Alt f a
liftAlt :: f a -> Alt f a
liftAlt = [AltF f a] -> Alt f a
forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt ([AltF f a] -> Alt f a) -> (f a -> [AltF f a]) -> f a -> Alt f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AltF f a -> [AltF f a] -> [AltF f a]
forall a. a -> [a] -> [a]
:[]) (AltF f a -> [AltF f a]) -> (f a -> AltF f a) -> f a -> [AltF f a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> AltF f a
forall (f :: * -> *) a. f a -> AltF f a
liftAltF
{-# INLINE liftAlt #-}

-- | 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 x. f x -> g x) -> Alt f a -> g a
runAlt forall x. f x -> g x
u Alt f a
xs0 = Alt f a -> g a
forall b. Alt f b -> g b
go Alt f a
xs0 where

  go  :: Alt f b -> g b
  go :: Alt f b -> g b
go (Alt [AltF f b]
xs) = (AltF f b -> g b -> g b) -> g b -> [AltF f b] -> g b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\AltF f b
r g b
a -> (AltF f b -> g b
forall b. AltF f b -> g b
go2 AltF f b
r) g b -> g b -> g b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> g b
a) g b
forall (f :: * -> *) a. Alternative f => f a
empty [AltF f b]
xs

  go2 :: AltF f b -> g b
  go2 :: AltF f b -> g b
go2 (Pure b
a) = b -> g b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a
  go2 (Ap f a
x Alt f (a -> b)
f) = ((a -> b) -> a -> b) -> a -> (a -> b) -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> a -> b
forall a. a -> a
id (a -> (a -> b) -> b) -> g a -> g ((a -> b) -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> g a
forall x. f x -> g x
u f a
x g ((a -> b) -> b) -> g (a -> b) -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Alt f (a -> b) -> g (a -> b)
forall b. Alt f b -> g b
go Alt f (a -> b)
f
{-# INLINABLE runAlt #-}

instance Apply (Alt f) where
  <.> :: Alt f (a -> b) -> Alt f a -> Alt f b
(<.>) = Alt f (a -> b) -> Alt f a -> Alt f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
  {-# INLINE (<.>) #-}

instance Alt.Alt (Alt f) where
  <!> :: Alt f a -> Alt f a -> Alt f a
(<!>) = Alt f a -> Alt f a -> Alt f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
  {-# INLINE (<!>) #-}

instance Alternative (Alt f) where
  empty :: Alt f a
empty = [AltF f a] -> Alt f a
forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt []
  {-# INLINE empty #-}
  Alt [AltF f a]
as <|> :: Alt f a -> Alt f a -> Alt f a
<|> Alt [AltF f a]
bs = [AltF f a] -> Alt f a
forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt ([AltF f a]
as [AltF f a] -> [AltF f a] -> [AltF f a]
forall a. [a] -> [a] -> [a]
++ [AltF f a]
bs)
  {-# INLINE (<|>) #-}

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

instance Monoid (Alt f a) where
  mempty :: Alt f a
mempty = Alt f a
forall (f :: * -> *) a. Alternative f => f a
empty
  {-# INLINE mempty #-}
  mappend :: Alt f a -> Alt f a -> Alt f a
mappend = Alt f a -> Alt f a -> Alt f a
forall a. Semigroup a => a -> a -> a
(<>)
  {-# INLINE mappend #-}
  mconcat :: [Alt f a] -> Alt f a
mconcat [Alt f a]
as = [AltF f a] -> Alt f a
forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt ([Alt f a]
as [Alt f a] -> (Alt f a -> [AltF f a]) -> [AltF f a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Alt f a -> [AltF f a]
forall (f :: * -> *) a. Alt f a -> [AltF f a]
alternatives)
  {-# INLINE mconcat #-}

hoistAltF :: (forall a. f a -> g a) -> AltF f b -> AltF g b
hoistAltF :: (forall a. f a -> g a) -> AltF f b -> AltF g b
hoistAltF forall a. f a -> g a
_ (Pure b
a) = b -> AltF g b
forall a (f :: * -> *). a -> AltF f a
Pure b
a
hoistAltF forall a. f a -> g a
f (Ap f a
x Alt f (a -> b)
y) = g a -> Alt g (a -> b) -> AltF g b
forall (f :: * -> *) a b. f a -> Alt f (a -> b) -> AltF f b
Ap (f a -> g a
forall a. f a -> g a
f f a
x) ((forall a. f a -> g a) -> Alt f (a -> b) -> Alt g (a -> b)
forall (f :: * -> *) (g :: * -> *) b.
(forall a. f a -> g a) -> Alt f b -> Alt g b
hoistAlt forall a. f a -> g a
f Alt f (a -> b)
y)
{-# INLINE hoistAltF #-}

-- | 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 a. f a -> g a) -> Alt f b -> Alt g b
hoistAlt forall a. f a -> g a
f (Alt [AltF f b]
as) = [AltF g b] -> Alt g b
forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt ((AltF f b -> AltF g b) -> [AltF f b] -> [AltF g b]
forall a b. (a -> b) -> [a] -> [b]
map ((forall a. f a -> g a) -> AltF f b -> AltF g b
forall (f :: * -> *) (g :: * -> *) b.
(forall a. f a -> g a) -> AltF f b -> AltF g b
hoistAltF forall a. f a -> g a
f) [AltF f b]
as)
{-# INLINE hoistAlt #-}

#if __GLASGOW_HASKELL__ < 707
instance Typeable1 f => Typeable1 (Alt f) where
  typeOf1 t = mkTyConApp altTyCon [typeOf1 (f t)] where
    f :: Alt f a -> f a
    f = undefined

instance Typeable1 f => Typeable1 (AltF f) where
  typeOf1 t = mkTyConApp altFTyCon [typeOf1 (f t)] where
    f :: AltF f a -> f a
    f = undefined

altTyCon, altFTyCon :: TyCon
#if __GLASGOW_HASKELL__ < 704
altTyCon = mkTyCon "Control.Alternative.Free.Alt"
altFTyCon = mkTyCon "Control.Alternative.Free.AltF"
#else
altTyCon = mkTyCon3 "free" "Control.Alternative.Free" "Alt"
altFTyCon = mkTyCon3 "free" "Control.Alternative.Free" "AltF"
#endif
{-# NOINLINE altTyCon #-}
{-# NOINLINE altFTyCon #-}
#endif