Compositional do notation

ComposeDo.hs

{-# LANGUAGE RebindableSyntax #-}

import Control.Arrow
import Control.Monad
import Data.Function
import Data.Monoid
import Prelude
import System.IO

main :: IO ()
main = test ()
  where

    test :: s -> IO ()                     -- Polymorphic initial state ignored
    test = do
      set "What is your name? "            -- "set" sets it
      aside $ hFlush stdout                -- "aside" preserves it
      putStr                               -- Actions take arguments from it
      const getLine                        -- "const" drops it
      ("Hello, " <>) >>> (<> "!") >>> pure -- Pure functions can modify it
      putStrLn
      set "What is your favorite color? "
      aside $ hFlush stdout
      putStr
      name <- getLine                      -- Results can be bound to locals
      set ("I like " <> name <> " too!")
      putStrLn

    (>>) :: (Monad m) => (a -> m b) -> (b -> m c) -> a -> m c
    (>>) = (>=>)

    (>>=) :: (Monad m) => m a -> (a -> b -> m c) -> b -> m c
    m >>= k = \ s -> m Prelude.>>= (`k` s)

    return :: (Applicative f) => a -> f a
    return = pure

set :: (Applicative f) => a -> b -> f a
set = const . pure

aside :: IO a -> b -> IO b
aside action = (action >>) . pure