Call f = Free (Lan f) -- following http://lpaste.net/148140

call.hs

{-#LANGUAGE GADTs #-}
import Control.Monad (ap)

newtype Free req r = Free {runFree :: Either r (req (Free req r))} 
data Lan f a = forall b. Lan (b -> a) (f b)
instance Functor (Lan f) where fmap f (Lan xa fx) = Lan (f . xa) fx

type Call_ req = Free (Lan req)

call_ :: forall a req . Call req a -> Call_ req a
call_ call = case call of 
  Call fa -> Free $ Right $ Lan return fa
  Fmap f call -> fmap f (call_ call)
  Pure a -> Free $ Left a
  Ap callf callx -> call_ callf <*> call_ callx
  Bind call xcall -> call_ call >>= call_ . xcall


instance Functor f => Functor (Free f) where 
  fmap f = Free . either (Left . f) (Right . fmap (fmap f)) . runFree
instance Functor f => Applicative (Free f) where pure = return; (<*>) = ap
instance Functor f => Monad (Free f) where 
  return = Free . Left
  free >>= f = Free $ case runFree free of
    Left a -> runFree (f a)
    Right fa -> Right (fmap (>>= f) fa)
    
data Call req a where
    -- The actual request
    Call :: req res -> Call req res

    -- Functor
    Fmap :: (res -> a) -> Call req res -> Call req a

    -- Applicative
    Pure :: a -> Call req a
    Ap :: Call req (a -> b) -> Call req a -> Call req b

    -- Monad
    Bind :: Call req res -> (res -> Call req a) -> Call req a

-- some general combinators using jargon from Pipes.Group and Streaming
maps :: Functor f => (forall s . f s -> g s) -> Free f r -> Free g r
maps f = loop where
  loop (Free free) = Free $ case free of
      Left r -> Left r
      Right ffr -> Right $ f (fmap loop ffr)

run :: Monad m => Free m r -> m r
run = loop where
  loop (Free e) = case e of
    Left r -> return r
    Right fr -> fr >>= loop


runCall :: (forall res. req res -> IO res) -> Call_ req out -> IO out
runCall phi  = run . maps (onLan phi)

onLan :: Functor f => (forall s . g s -> f s) -> Lan g r -> f r
onLan phi (Lan f rest) = fmap f (phi rest)