{-# LANGUAGE RankNTypes
, DeriveFunctor
#-}
module Church where
true = \t f -> t
false = \t f -> f
toBool b = b True False
iff = \b t f -> id
and = \x y t f -> x (y t f) f
or = \x y t f -> x t (y t f)
not = flip
newtype ChurchMaybe a = ChurchMaybe { runChurchMaybe :: forall r. r -> (a -> r) -> r }
nothing :: ChurchMaybe a
nothing = ChurchMaybe $ \n _ -> n
just :: a -> ChurchMaybe a
just x = ChurchMaybe $ \_ j -> j x
isNothing :: ChurchMaybe a -> Bool
isNothing (ChurchMaybe m) = m True (const False)
isJust :: ChurchMaybe a -> Bool
isJust (ChurchMaybe m) = m False (const True)
fromJust :: ChurchMaybe a -> a
fromJust (ChurchMaybe m) = m (error "fromJust") id
maybe :: b -> (a -> b) -> ChurchMaybe a -> b
maybe d f (ChurchMaybe m) = m d f
instance Eq a => Eq (ChurchMaybe a) where
(ChurchMaybe x) == (ChurchMaybe y) = x (y True (const False)) (y False . (==))
instance Ord a => Ord (ChurchMaybe a) where
compare (ChurchMaybe x) (ChurchMaybe y) = x (y EQ (const LT)) (y GT . compare)
instance Show a => Show (ChurchMaybe a) where
show (ChurchMaybe m) = m "Nothing" (("Just " ++) . show)
instance Functor ChurchMaybe where
fmap f (ChurchMaybe x) = ChurchMaybe $ \n j -> x n (j . f)
instance Applicative ChurchMaybe where
pure x = ChurchMaybe $ \_ j -> j x
(ChurchMaybe f) <*> (ChurchMaybe x) = f nothing (x nothing . (just .))
instance Monad ChurchMaybe where
return = pure
(ChurchMaybe x) >>= f = x nothing f
instance Foldable ChurchMaybe where
foldMap f (ChurchMaybe x) = x mempty f
instance Traversable ChurchMaybe where
traverse f (ChurchMaybe x) = x (pure nothing) ((just <$>) . f)
instance Monoid a => Monoid (ChurchMaybe a) where
mempty = nothing
mappend (ChurchMaybe x) (ChurchMaybe y) = x (y mempty just)
(y <$> just <*> ((just .) . mappend ))
data Free f a = Pure a
| Free (f (Free f a))
instance Functor f => Functor (Free f) where
fmap f (Pure x) = Pure (f x)
fmap f (Free x) = Free ((fmap f) <$> x)
instance Functor f => Applicative (Free f) where
pure = Pure
Pure f <*> Pure x = Pure (f x)
Pure f <*> Free x = Free ((fmap f) <$> x)
Free f <*> x = Free ((<*> x) <$> f)
instance Functor f => Monad (Free f) where
return = Pure
Pure x >>= f = f x
Free x >>= f = Free ((>>= f) <$> x)
liftF :: Functor f => f a -> Free f a
liftF = Free . fmap pure
data FExp a = GetSomething (Int -> a)
| WithSomething Int (Int -> a)
| DoSomething Int a
deriving (Functor)
getSomething :: Free FExp Int
getSomething = liftF $ GetSomething id
withSomething :: Int -> Free FExp Int
withSomething = liftF . flip WithSomething id
doSomething :: Int -> Free FExp ()
doSomething = liftF . flip DoSomething ()
ohNo :: Free FExp ()
ohNo = do
x <- getSomething
y <- withSomething x
z <- withSomething y
doSomething z