An example of how ApplicativeDo can be inefficient with uniform costs.

APDoTest.hs

{-# LANGUAGE ApplicativeDo #-}

module Main where

import Control.Concurrent
import Control.Concurrent.MVar
import Data.Time.Clock

-- We create a wrapper around IO for this example
newtype PIO a = PIO { runPIO :: IO a }

-- We declare functor and applicative instances, to be able
-- to use ApplicativeDo
instance Functor PIO where
  fmap f pa = PIO (f <$> runPIO pa)

instance Applicative PIO where
  pure pa = PIO (Prelude.pure pa)
  -- Here is the only change:
  -- instead of running Applicative applications sequentially,
  -- we run them in parallel.
  pa <*> pb = PIO $ do
                am <- newEmptyMVar
                aid <- forkIO (runPIO pa >>= putMVar am)
                b <- runPIO pb
                a <- takeMVar am
                return (a b)

instance Monad PIO where
  pa >>= pb = PIO $ runPIO pa >>= runPIO . pb

-- This is the delay of each operation, inteded to simulate
-- a long running computation or database fetch etc.
delay :: Int
delay = 2 * secsToMicrosecs
  where secsToMicrosecs = 1000000

-- We have 2 expensive operations and a cheap one, to demonstrate
-- the ineffectiveness of uniform costs. Here cheapOp is much cheaper
-- than expensiveOp1 and expensiveOp2
cheapOp :: String -> PIO String
cheapOp _ = return "cheap"

expensiveOp1 :: String -> PIO String
expensiveOp1 _ = PIO (threadDelay delay) >> return "expensive 1"

expensiveOp2 :: String -> PIO String
expensiveOp2 _ = PIO (threadDelay delay) >> return "expensive 2"


-- Here it runs (cheapOp | expensiveOp1); expensiveOp2
main1 :: IO ()
main1 = runPIO $ do
    x <- cheapOp ""
    y <- expensiveOp1 ""
    z <- expensiveOp2 x
    PIO (print (x,y,z))

-- but here it runs cheapOp; (expensiveOp1 | expensiveOp2)
main2 :: IO ()
main2 = runPIO $ cheapOp "" >>=
    (\x -> do
        y <- expensiveOp1 ""
        z <- expensiveOp2 x
        PIO (print (x,y,z))
    )
-- We do a simple measurement of the time each op takes,
-- to show whether the expensiveOps were run in parallel
-- or not
measure :: IO a -> IO NominalDiffTime
measure action = do
    start <- getCurrentTime
    action
    end <- getCurrentTime
    return (diffUTCTime end start)

main :: IO ()
main = do putStrLn $  "delay is " ++ show delayInSecs
          putStrLn "running main1"
          m1time <- measure main1
          putStrLn $ "main 1 took " ++ show m1time
          putStrLn "running main2"
          m2time <- measure main2
          putStrLn $ "main 2 took " ++ show m2time
          putStrLn $ "which is a difference of " ++ show (m1time - m2time)
        where delayInSecs = picosecondsToDiffTime $ fromIntegral $ delay * 1000000