Freer.hs

{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}

import Control.Monad ((>=>))

{-
-- Initial style

data Console a = GetLine String (String -> Console a)
               | PutLine String (Console a)
               | Done a

instance Functor Console where
  fmap f (Done x) = Done (f x)
  fmap f (GetLine msg k) = GetLine msg (fmap f . k)
  fmap f (PutLine line k) = PutLine line (fmap f k)

instance Applicative Console where
  pure = Done

  (<*>) :: Console (a -> b) -> Console a -> Console b
  (Done f)        <*> (Done x) = Done (f x)
  (Done f)        <*> (GetLine msg k) = GetLine msg (fmap f . k)
  (Done f)        <*> (PutLine msg k) = PutLine msg (f <$> k)
  (GetLine msg k) <*> x = GetLine msg (\res -> k res <*> x)
  (PutLine msg f) <*> x = PutLine msg (f <*> x)

instance Monad Console where
  return = Done

  (GetLine msg k)  >>= f = GetLine msg (k >=> f)
  (PutLine line k) >>= f = PutLine line (k >>= f)
  (Done x)         >>= f = f x

consoleGet :: String -> Console String
consoleGet msg = GetLine msg return

consolePut :: String -> Console ()
consolePut line = PutLine line (return ())

runConsole :: Console a -> IO a
runConsole (Done x)        = return x
runConsole (GetLine msg k) = do putStrLn msg
                                l <- getLine
                                runConsole (k l)
runConsole (PutLine line k) = do putStrLn line
                                 runConsole k
-}

{-
-- Free monad

data ConsoleF r = GetLine String (String -> r)
                | PutLine String r

instance Functor ConsoleF where
  fmap :: (a -> b) -> ConsoleF a -> ConsoleF b
  fmap f (GetLine msg next)  = GetLine msg (f . next)
  fmap f (PutLine line next) = PutLine line (f next)

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

instance Functor f => Functor (Free f) where
  fmap :: (a -> b) -> Free f a -> Free f b
  fmap f (Pure x) = Pure (f x)
  fmap f (Free x) = Free (fmap (fmap f) x)

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

  (<*>) :: Free f (a -> b) -> Free f a -> Free f b
  Pure f <*> Pure x = Pure (f x)
  Pure f <*> Free x = Free $ fmap (fmap f) x 
  Free f <*> x      = Free $ fmap (<*> x) f

instance Functor f => Monad (Free f) where
  return = Pure

  (>>=) :: Free f a -> (a -> Free f b) -> Free f b
  Pure x >>= f = f x
  Free x >>= f = Free (fmap (>>= f) x)

liftF :: Functor f => f a -> Free f a
liftF = Free . fmap return

type Console = Free ConsoleF

consoleGet :: String -> Console String
consoleGet msg = liftF (GetLine msg id)

consolePut :: String -> Console ()
consolePut msg = liftF (PutLine msg ())

-- runConsole :: Console a -> IO a
-- runConsole (Pure x) = return x
-- runConsole (Free (GetLine msg k)) = do putStr msg
--                                        putStr " "
--                                        l <- getLine
--                                        runConsole (k l)
-- runConsole (Free (PutLine msg k)) = do putStrLn msg
--                                        runConsole k

foldFree :: Monad m => (forall r. f r -> m r) -> Free f a -> m a
foldFree _         (Pure x) = return x
foldFree interpret (Free x) = do
        x' <- interpret x
        foldFree interpret x'

interpret :: ConsoleF a -> IO a
interpret (GetLine msg k) = do putStr msg
                               putStr " "
                               l <- getLine
                               return (k l)
interpret (PutLine msg k) = do putStrLn msg
                               return k

runConsole = foldFree interpret
-}

{-
-- Operational Style

data Console a where
  GetLine :: String -> Console String
  PutLine :: String -> Console ()
  Done    :: a -> Console a
  Bind    :: Console a -> (a -> Console b) -> Console b

instance Functor Console where
  fmap :: (a -> b) -> Console a -> Console b
  fmap f x = x >>= return . f

instance Applicative Console where
  pure = Done

  (<*>) :: Console (a -> b) -> Console a -> Console b
  f <*> x = do f' <- f
               x' <- x
               return $ f' x'

instance Monad Console where
  return = Done
  (>>=)  = Bind

consoleGet :: String -> Console String
consoleGet = GetLine

consolePut :: String -> Console ()
consolePut = PutLine

runConsole :: Console a -> IO a
runConsole (GetLine msg) = putStr msg >> putStr " " >> getLine
runConsole (PutLine msg) = putStrLn msg
runConsole (Done x)      = return x
runConsole (Bind x f)    = runConsole x >>= runConsole . f
-}

{-
-- Freer monad

data ConsoleI a where
  GetLine :: String -> ConsoleI String
  PutLine :: String -> ConsoleI ()

data Freer instr a where
  Pure   :: a -> Freer instr a
  Impure :: instr a -> (a -> Freer instr b) -> Freer instr b

instance Functor (Freer instr) where
  fmap f x = x >>= return . f

instance Applicative (Freer instr) where
  pure = Pure

  f <*> x = do f' <- f
               x' <- x
               return $ f' x'

instance Monad (Freer instr) where
  return = Pure

  Pure x     >>= f = f x
  Impure x k >>= f = Impure x (k >=> f) 

type Console = Freer ConsoleI

consoleGet :: String -> Console String
consoleGet msg = Impure (GetLine msg) return

consolePut :: String -> Console ()
consolePut msg = Impure (PutLine msg) (\_ -> return ())

foldFreer :: Monad m => (forall r. instr r -> m r) -> Freer instr a -> m a
foldFreer _         (Pure a)         = return a
foldFreer interpret (Impure instr k) = interpret instr >>= foldFreer interpret . k

interpret :: ConsoleI a -> IO a
interpret (GetLine msg) = putStr msg >> putStr " " >> getLine
interpret (PutLine msg) = putStrLn msg

runConsole :: Console a -> IO a
runConsole = foldFreer interpret
-}

-- Coyoneda

data ConsoleI a where
  GetLine :: String -> ConsoleI String
  PutLine :: String -> ConsoleI ()

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

instance Functor f => Functor (Free f) where
  fmap :: (a -> b) -> Free f a -> Free f b
  fmap f (Pure x) = Pure (f x)
  fmap f (Free x) = Free (fmap (fmap f) x)

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

  (<*>) :: Free f (a -> b) -> Free f a -> Free f b
  Pure f <*> Pure x = Pure (f x)
  Pure f <*> Free x = Free $ fmap (fmap f) x 
  Free f <*> x      = Free $ fmap (<*> x) f

instance Functor f => Monad (Free f) where
  return = Pure

  (>>=) :: Free f a -> (a -> Free f b) -> Free f b
  Pure x >>= f = f x
  Free x >>= f = Free (fmap (>>= f) x)

data Coyoneda f a where
  Coyoneda :: (b -> a) -> f b -> Coyoneda f a

instance Functor (Coyoneda f) where
  fmap h (Coyoneda g x) = Coyoneda (h . g) x

type Freer f = Free (Coyoneda f)

type Console = Freer ConsoleI

consoleGet :: String -> Console String
consoleGet msg = Free (Coyoneda return (GetLine msg))

consolePut :: String -> Console ()
consolePut msg = Free (Coyoneda return (PutLine msg))

foldFreer :: Monad m => (forall r. instr r -> m r) -> Freer instr a -> m a
foldFreer _         (Pure x)              = return x
foldFreer interpret (Free (Coyoneda k x)) = interpret x >>= foldFreer interpret . k

interpret :: ConsoleI a -> IO a
interpret (GetLine msg) = putStr msg >> putStr " " >> getLine
interpret (PutLine msg) = putStrLn msg

runConsole :: Console a -> IO a
runConsole = foldFreer interpret

logic :: Console ()
logic = do
  consolePut "Welcome"
  name <- consoleGet "Enter name: "
  consolePut ("Hello " ++ name)
  return () 

main :: IO ()
main = runConsole logic

-- main = return ()