#if __GLASGOW_HASKELL__ >= 707
#endif
module Control.Alternative.Free
( Alt(..)
, runAlt
, liftAlt
, hoistAlt
) where
import Control.Applicative
import Data.Functor.Apply
import Data.Semigroup
#ifdef GHC_TYPEABLE
import Data.Typeable
#endif
data Alt f a where
Pure :: a -> Alt f a
Ap :: f a -> Alt f (a -> b) -> Alt f b
Alt :: [Alt f a] -> Alt f a
#if __GLASGOW_HASKELL__ >= 707
deriving (Typeable)
#endif
runAlt :: Alternative g => (forall x. f x -> g x) -> Alt f a -> g a
runAlt _ (Pure x) = pure x
runAlt u (Ap f x) = flip id <$> u f <*> runAlt u x
runAlt u (Alt as) = foldr (\a r -> runAlt u a <|> r) empty as
instance Functor (Alt f) where
fmap f (Pure a) = Pure (f a)
fmap f (Ap x y) = Ap x ((f .) <$> y)
fmap f (Alt as) = Alt (fmap f <$> as)
instance Apply (Alt f) where
Pure f <.> y = fmap f y
Ap x y <.> z = Ap x (flip <$> y <.> z)
Alt as <.> z = Alt (map (<.> z) as)
instance Applicative (Alt f) where
pure = Pure
Pure f <*> y = fmap f y
Ap x y <*> z = Ap x (flip <$> y <*> z)
Alt as <*> z = Alt (map (<*> z) as)
instance Alternative (Alt f) where
empty = Alt []
Alt [] <|> r = r
l <|> Alt [] = l
Alt as <|> Alt bs = Alt (as ++ bs)
l <|> r = Alt [l, r]
instance Semigroup (Alt f a) where
(<>) = (<|>)
instance Monoid (Alt f a) where
mempty = empty
mappend = (<|>)
mconcat as = fromList (as >>= toList)
where
toList (Alt xs) = xs
toList x = [x]
fromList [x] = x
fromList xs = Alt xs
liftAlt :: f a -> Alt f a
liftAlt x = Ap x (Pure id)
hoistAlt :: (forall a. f a -> g a) -> Alt f b -> Alt g b
hoistAlt _ (Pure a) = Pure a
hoistAlt f (Ap x y) = Ap (f x) (hoistAlt f y)
hoistAlt f (Alt as) = Alt (map (hoistAlt f) as)
#if defined(GHC_TYPEABLE) && __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
altTyCon :: TyCon
#if __GLASGOW_HASKELL__ < 704
altTyCon = mkTyCon "Control.Alternative.Free.Alt"
#else
altTyCon = mkTyCon3 "free" "Control.Alternative.Free" "Alt"
#endif
#endif