free_monad_haskell_to_scalaz.scala

// import Control.Monad.Free
// import System.Exit hiding (ExitSuccess)

:paste
import scalaz._, Scalaz._, scalaz.Free.{Suspend, Return, liftF}


// data TeletypeF x
//   = PutStrLn String x
//   | GetLine (String -> x)
//   | ExitSuccess

sealed trait TeletypeF[+A]
case class PutStrLn[A](msg: String, o: A) extends TeletypeF[A]
case class GetLine[A](o: String => A) extends TeletypeF[A]
case class ExitSuccess[A]() extends TeletypeF[A]
 

// instance Functor TeletypeF where
//     fmap f (PutStrLn str x) = PutStrLn str (f x)
//     fmap f (GetLine      k) = GetLine (f . k)
//     fmap f  ExitSuccess     = ExitSuccess

implicit def teletypeFFunctor[B]: Functor[TeletypeF] = new Functor[TeletypeF] {
  def map[A,B](fa: TeletypeF[A])(f: A => B): TeletypeF[B] = 
    fa match {
      case PutStrLn(msg, a) => PutStrLn(msg, f(a))
      case GetLine(h) => GetLine(x => f(h(x)))
      case ExitSuccess() => ExitSuccess()
    }
}


// type Teletype = Free TeletypeF

type Teletype[A] = Free[TeletypeF, A]


// putStrLn' :: String -> Teletype ()
// putStrLn' str = liftF $ PutStrLn str ()

def putStrLn(str: String): Free[TeletypeF, Unit] = liftF { PutStrLn(str, ()) }


// getLine' :: Teletype String
// getLine' = liftF $ GetLine id

def getLine: Free[TeletypeF, String] = liftF { GetLine(v => v) }


// exitSuccess' :: Teletype r
// exitSuccess' = liftF ExitSuccess

def exitSuccess: Free[TeletypeF, Unit] = liftF { ExitSuccess() }


// run :: Teletype r -> IO r
// run (Pure r) = return r
// run (Free (PutStrLn str t)) = putStrLn str >>  run t
// run (Free (GetLine  f    )) = getLine      >>= run . f
// run (Free  ExitSuccess    ) = exitSuccess









def run[A](r: Teletype[A]): A = {
  import scalaz.{~>,Id}, Id.Id

  val exe: TeletypeF ~> Id = new (TeletypeF ~> Id) {
    def apply[B](l: TeletypeF[B]): B = l match { 
      case PutStrLn(msg, a) => { println(msg); a }
      case GetLine(h) => { h(readLine()) }
      case ExitSuccess() => ???
    }
  }
 
  r.runM(exe.apply[Teletype[A]])
}


// echo :: Teletype ()
// echo = do str <- getLine'
//           putStrLn' str
//           exitSuccess'
//           putStrLn' "Finished"

val echo = for {
  str <- getLine
  _ <- putStrLn(str)
  _ <- exitSuccess'
  _ <- putStrLn("Finished")
} yield()


// main = run echo
run(echo)