{-# LANGUAGE GADTs #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}

import Control.Monad

data Free f a = Pure a | Bind (f (Free f a))

instance Functor f => Functor (Free f) where
  fmap = liftM

instance Functor f => Applicative (Free f) where
  pure = Pure
  (<*>) = ap

instance Functor f => Monad (Free f) where
  Pure a >>= f = f a
  Bind m >>= f = Bind $ fmap (>>= f) m

liftF :: Functor f => f a -> Free f a
liftF = Bind . fmap pure

interpretFree :: (Functor f, Monad m) => (forall x. f x -> m x) -> Free f a -> m a
interpretFree _ (Pure a) = pure a
interpretFree translate (Bind a) = translate a >>= interpretFree translate

data Yoneda f a = forall x. Yoneda (x -> a) (f x)

instance Functor (Yoneda f) where
  fmap f (Yoneda g h) = Yoneda (f . g) h

liftY :: f a -> Yoneda f a
liftY = Yoneda id

unliftY :: Functor f => Yoneda f a -> f a
unliftY (Yoneda f a) = fmap f a

type Operational f = Free (Yoneda f)

translateYoneda :: Monad m => (forall x. f x -> m x) -> Yoneda f a -> m a
translateYoneda translate (Yoneda f a) = fmap f $ translate a

interpretOperational :: Monad m => (forall x. f x -> m x) -> Operational f a -> m a
interpretOperational translate =
  interpretFree $ translateYoneda translate

getLineMock :: IO String
getLineMock = pure "This is a standard input."

data CommandF a where
  PutStrLnF :: String -> CommandF ()
  GetLineF  :: CommandF String

type Command = Operational CommandF

putStrLn' :: String -> Command ()
putStrLn' = liftF . liftY . PutStrLnF

getLine' :: Command String
getLine' = liftF $ liftY GetLineF

translateCommandF :: CommandF a -> IO a
translateCommandF (PutStrLnF s) = putStrLn s
translateCommandF GetLineF = getLineMock

main :: IO ()
main = do
  interpretOperational translateCommandF $ do
    putStrLn' "Hello, Operational Monad!"
    getLine' >>= putStrLn'
    replicateM_ 3 $
      putStrLn' "The operational monad is a cost-free DSL for you."