{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE Trustworthy #-}
#endif
#include "free-common.h"
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
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
(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 #-}
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 #-}
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 #-}
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