{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | @Alt F@ is the free 'Alternative' functor on @F@
module Env.Internal.Free
  ( Alt(..)
  , liftAlt
  , runAlt
  , foldAlt
  , hoistAlt
  -- * Debug
  , inspect
  ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..))
#endif
import Control.Applicative (Alternative(..))
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid(..))
#endif


data Alt f a where
  Nope :: Alt f a
  Pure :: a -> Alt f a
  Ap   :: Alt f (a -> b) -> Alt f a -> Alt f b
  Alt  :: Alt f a -> Alt f a -> Alt f a
  Lift :: f a -> Alt f a

-- | Print the free structure
inspect :: Alt f a -> String
inspect :: Alt f a -> String
inspect Alt f a
Nope      = String
"Nope"
inspect (Pure a
_)  = String
"Pure _"
inspect (Ap Alt f (a -> a)
f Alt f a
x)  = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"(", Alt f (a -> a) -> String
forall (f :: * -> *) a. Alt f a -> String
inspect Alt f (a -> a)
f, String
") <*> (", Alt f a -> String
forall (f :: * -> *) a. Alt f a -> String
inspect Alt f a
x, String
")"]
inspect (Alt Alt f a
x Alt f a
y) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"(", Alt f a -> String
forall (f :: * -> *) a. Alt f a -> String
inspect Alt f a
x, String
") <|> (", Alt f a -> String
forall (f :: * -> *) a. Alt f a -> String
inspect Alt f a
y, String
")"]
inspect (Lift f a
_)  = String
"Lift _"

instance Functor f => Functor (Alt f) where
  fmap :: (a -> b) -> Alt f a -> Alt f b
fmap a -> b
_ Alt f a
Nope      = Alt f b
forall (f :: * -> *) a. Alt f a
Nope
  fmap a -> b
f (Pure a
a)  = b -> Alt f b
forall a (f :: * -> *). a -> Alt f a
Pure (a -> b
f a
a)
  fmap a -> b
f (Ap Alt f (a -> a)
a Alt f a
v)  = Alt f (a -> b) -> Alt f a -> Alt f b
forall (f :: * -> *) a b. Alt f (a -> b) -> Alt f a -> Alt 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)
a) Alt f a
v
  fmap a -> b
f (Alt Alt f a
a Alt f a
b) = Alt f b -> Alt f b -> Alt f b
forall (f :: * -> *) a. Alt f a -> Alt f a -> Alt f a
Alt ((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
a) ((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
b)
  fmap a -> b
f (Lift f a
a)  = f b -> Alt f b
forall (f :: * -> *) a. f a -> Alt f a
Lift ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
a)

instance Functor f => Applicative (Alt f) where
  pure :: a -> Alt f a
pure = a -> Alt f a
forall a (f :: * -> *). a -> Alt f a
Pure
  <*> :: Alt f (a -> b) -> Alt f a -> Alt f b
(<*>) = Alt f (a -> b) -> Alt f a -> Alt f b
forall (f :: * -> *) a b. Alt f (a -> b) -> Alt f a -> Alt f b
Ap

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


liftAlt :: f a -> Alt f a
liftAlt :: f a -> Alt f a
liftAlt = f a -> Alt f a
forall (f :: * -> *) a. f a -> Alt f a
Lift

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 -> g a
forall b. Alt f b -> g b
go where
  go  :: Alt f b -> g b
  go :: Alt f b -> g b
go Alt f b
Nope      = g b
forall (f :: * -> *) a. Alternative f => f a
empty
  go (Pure b
a)  = b -> g b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a
  go (Ap Alt f (a -> b)
f Alt f a
x)  = Alt f (a -> b) -> g (a -> b)
forall b. Alt f b -> g b
go Alt f (a -> b)
f g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Alt f a -> g a
forall b. Alt f b -> g b
go Alt f a
x
  go (Alt Alt f b
s Alt f b
t) = Alt f b -> g b
forall b. Alt f b -> g b
go Alt f b
s g b -> g b -> g b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Alt f b -> g b
forall b. Alt f b -> g b
go Alt f b
t
  go (Lift f b
x)  = f b -> g b
forall x. f x -> g x
u f b
x

foldAlt :: Monoid p => (forall a. f a -> p) -> Alt f b -> p
foldAlt :: (forall a. f a -> p) -> Alt f b -> p
foldAlt forall a. f a -> p
f =
  Mon p b -> p
forall m a. Mon m a -> m
unMon (Mon p b -> p) -> (Alt f b -> Mon p b) -> Alt f b -> p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. f x -> Mon p x) -> Alt f b -> Mon p b
forall (f :: * -> *) (g :: * -> *) a.
Alternative g =>
(forall x. f x -> g x) -> Alt f a -> g a
runAlt (p -> Mon p x
forall m a. m -> Mon m a
Mon (p -> Mon p x) -> (f x -> p) -> f x -> Mon p x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> p
forall a. f a -> p
f)

hoistAlt :: forall f g b. Functor g => (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
nat =
  (forall x. f x -> Alt g x) -> Alt f b -> Alt g b
forall (f :: * -> *) (g :: * -> *) a.
Alternative g =>
(forall x. f x -> g x) -> Alt f a -> g a
runAlt (g x -> Alt g x
forall (f :: * -> *) a. f a -> Alt f a
Lift (g x -> Alt g x) -> (f x -> g x) -> f x -> Alt g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> g x
forall a. f a -> g a
nat)


-- | The 'Alternative' functor induced by the 'Monoid'
newtype Mon m a = Mon
  { Mon m a -> m
unMon :: m
  } deriving (Int -> Mon m a -> ShowS
[Mon m a] -> ShowS
Mon m a -> String
(Int -> Mon m a -> ShowS)
-> (Mon m a -> String) -> ([Mon m a] -> ShowS) -> Show (Mon m a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall m a. Show m => Int -> Mon m a -> ShowS
forall m a. Show m => [Mon m a] -> ShowS
forall m a. Show m => Mon m a -> String
showList :: [Mon m a] -> ShowS
$cshowList :: forall m a. Show m => [Mon m a] -> ShowS
show :: Mon m a -> String
$cshow :: forall m a. Show m => Mon m a -> String
showsPrec :: Int -> Mon m a -> ShowS
$cshowsPrec :: forall m a. Show m => Int -> Mon m a -> ShowS
Show, Mon m a -> Mon m a -> Bool
(Mon m a -> Mon m a -> Bool)
-> (Mon m a -> Mon m a -> Bool) -> Eq (Mon m a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall m a. Eq m => Mon m a -> Mon m a -> Bool
/= :: Mon m a -> Mon m a -> Bool
$c/= :: forall m a. Eq m => Mon m a -> Mon m a -> Bool
== :: Mon m a -> Mon m a -> Bool
$c== :: forall m a. Eq m => Mon m a -> Mon m a -> Bool
Eq)

instance Functor (Mon m) where
  fmap :: (a -> b) -> Mon m a -> Mon m b
fmap a -> b
_ (Mon m
a) = m -> Mon m b
forall m a. m -> Mon m a
Mon m
a

instance Monoid m => Applicative (Mon m) where
  pure :: a -> Mon m a
pure a
_ = m -> Mon m a
forall m a. m -> Mon m a
Mon m
forall a. Monoid a => a
mempty
  Mon m
x <*> :: Mon m (a -> b) -> Mon m a -> Mon m b
<*> Mon m
y = m -> Mon m b
forall m a. m -> Mon m a
Mon (m -> m -> m
forall a. Monoid a => a -> a -> a
mappend m
x m
y)

instance Monoid m => Alternative (Mon m) where
  empty :: Mon m a
empty = m -> Mon m a
forall m a. m -> Mon m a
Mon m
forall a. Monoid a => a
mempty
  Mon m
x <|> :: Mon m a -> Mon m a -> Mon m a
<|> Mon m
y = m -> Mon m a
forall m a. m -> Mon m a
Mon (m -> m -> m
forall a. Monoid a => a -> a -> a
mappend m
x m
y)