{-# 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 { forall (f :: * -> *) a. Alt f a -> [AltF f a]
alternatives :: [AltF f a] }
#if __GLASGOW_HASKELL__ >= 707
  deriving Typeable
#endif

instance Functor (AltF f) where
  fmap :: forall a b. (a -> b) -> AltF f a -> AltF f b
fmap a -> b
f (Pure a
a) = forall a (f :: * -> *). a -> AltF f a
Pure 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 forall (f :: * -> *) a b. f a -> Alt f (a -> b) -> AltF f b
`Ap` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
.) Alt f (a -> a)
g

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

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

  (Alt [AltF f (a -> b)]
xs) <*> :: forall a b. Alt f (a -> b) -> Alt f a -> Alt f b
<*> Alt f a
ys = forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt ([AltF f (a -> b)]
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Alt f a -> [AltF f a]
alternatives forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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' :: forall a b. AltF f (a -> b) -> Alt f a -> Alt f b
`ap'` Alt f a
u      = 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  = forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt [f a
u forall (f :: * -> *) a b. f a -> Alt f (a -> b) -> AltF f b
`Ap` (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Alt f (a -> a -> b)
f) 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 :: forall (f :: * -> *) a. f a -> AltF f a
liftAltF f a
x = f a
x forall (f :: * -> *) a b. f a -> Alt f (a -> b) -> AltF f b
`Ap` forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: forall (f :: * -> *) a. f a -> Alt f a
liftAlt = forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (f :: * -> *) (g :: * -> *) a.
Alternative g =>
(forall x. f x -> g x) -> Alt f a -> g a
runAlt forall x. f x -> g x
u Alt f a
xs0 = forall b. Alt f b -> g b
go Alt f a
xs0 where

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

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

instance Apply (Alt f) where
  <.> :: forall a 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
  <!> :: forall 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 :: forall a. Alt f a
empty = forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt []
  {-# INLINE empty #-}
  Alt [AltF f a]
as <|> :: forall a. Alt f a -> Alt f a -> Alt f a
<|> Alt [AltF f a]
bs = forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt ([AltF f a]
as 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
(<>) = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
  {-# INLINE (<>) #-}

instance Monoid (Alt f a) where
  mempty :: Alt f a
mempty = forall (f :: * -> *) a. Alternative f => f a
empty
  {-# INLINE mempty #-}
  mappend :: Alt f a -> Alt f a -> Alt f a
mappend = forall a. Semigroup a => a -> a -> a
(<>)
  {-# INLINE mappend #-}
  mconcat :: [Alt f a] -> Alt f a
mconcat [Alt f a]
as = forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt ([Alt f a]
as forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 (f :: * -> *) (g :: * -> *) b.
(forall a. f a -> g a) -> AltF f b -> AltF g b
hoistAltF forall a. f a -> g a
_ (Pure b
a) = 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) = forall (f :: * -> *) a b. f a -> Alt f (a -> b) -> AltF f b
Ap (forall a. f a -> g a
f f a
x) (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 (f :: * -> *) (g :: * -> *) b.
(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) = forall (f :: * -> *) a. [AltF f a] -> Alt f a
Alt (forall a b. (a -> b) -> [a] -> [b]
map (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