Alleviating callback hell in Haskell

callbacks.hs

{-------------------------------------------------------------------------------
  Discussion of ContT in terms of callbacks

  For an alternative exposition, see
  <http://www.haskellforall.com/2012/12/the-continuation-monad.html>.
-------------------------------------------------------------------------------}

{-# OPTIONS_GHC -Wall #-}

import Control.Exception
import Control.Monad.Cont
import Control.Monad.Trans.Cont (evalContT, resetT)

{-------------------------------------------------------------------------------
  Demonstrating callback hell
-------------------------------------------------------------------------------}

newtype Handle = H String deriving Show
newtype Sock = S String deriving Show

withFile :: String -> (Handle -> IO a) -> IO a
withFile fp k =
    bracket_ (putStrLn $ "Opening file " ++ fp)
             (putStrLn $ "Closing file " ++ fp)
             (k (H fp))

withSock :: String -> (Sock -> IO a) -> IO a
withSock addr k =
    bracket_ (putStrLn $ "Opening socket " ++ addr)
             (putStrLn $ "Closing socket " ++ addr)
             (k (S addr))

callbackHell :: IO ()
callbackHell = do
    withFile "a" $ \ha ->
      withSock "b" $ \sb ->
        withFile "c" $ \hc ->
          print (ha, sb, hc)

{-------------------------------------------------------------------------------
  Using ContT
-------------------------------------------------------------------------------}

withFileC :: String -> ContT r IO Handle
withFileC fp = ContT $ withFile fp

withSockC :: String -> ContT r IO Sock
withSockC addr = ContT $ withSock addr

usingCT :: IO ()
usingCT = evalContT $ do
    ha <- withFileC "a"
    sb <- withSockC "b"
    hc <- withFileC "c"
    lift $ print (ha, sb, hc)

{-------------------------------------------------------------------------------
  Misleading scope
-------------------------------------------------------------------------------}

-- Running @misleadingScope True True True@ gives
--
-- Opening file a
-- H "a"
-- Opening socket b
-- S "b"
-- Opening file c
-- H "c"
-- Closing file c
-- Closing socket b
-- Closing file a
misleadingScope :: Bool -> Bool -> Bool -> IO ()
misleadingScope openA openB openC = evalContT $ do
    when openA $ do
      ha <- withFileC "a"
      lift $ print ha
    when openB $ do
      sb <- withSockC "b"
      lift $ print sb
    when openC $ do
      hc <- withFileC "c"
      lift $ print hc

{-------------------------------------------------------------------------------
  Limiting scope
-------------------------------------------------------------------------------}

-- Running 'usingScope' gives
--
-- > Opening file a
-- > Opening socket b
-- > Opening file c
-- > (H "a",S "b",H "c")
-- > Closing file c
-- > Closing socket b
-- > Opening socket b
-- > Opening file c
-- > (H "a",S "b",H "c")
-- > Closing file c
-- > Closing socket b
-- > Closing file a
usingScope :: IO ()
usingScope = evalContT $ do
    ha <- withFileC "a"
    resetT $ do
      sb <- withSockC "b"
      hc <- withFileC "c"
      lift $ print (ha, sb, hc)
    resetT $ do
      sb <- withSockC "b"
      hc <- withFileC "c"
      lift $ print (ha, sb, hc)

-- Running @misleadingScopeFixed True True True@ gives
--
-- > Opening file a
-- > H "a"
-- > Closing file a
-- > Opening socket b
-- > S "b"
-- > Closing socket b
-- > Opening file c
-- > H "c"
-- > Closing file c
misleadingScopeFixed :: Bool -> Bool -> Bool -> IO ()
misleadingScopeFixed openA openB openC = evalContT $ do
    when openA $ resetT $ do
      ha <- withFileC "a"
      lift $ print ha
    when openB $ resetT $ do
      sb <- withSockC "b"
      lift $ print sb
    when openC $ resetT $ do
      hc <- withFileC "c"
      lift $ print hc

{-------------------------------------------------------------------------------
  Using callCC
-------------------------------------------------------------------------------}

newtype TempFile = TF String deriving Show

-- Consider a function 'validate' which expressly does NOT use bracket;
-- we construct a temporary file, call some callback to verify it, and only
-- when verified do we make it temporary.
validate :: String -> (TempFile -> IO a) -> IO a
validate file callback = do
     putStrLn $ "Creating temp file " ++ file
     result <- callback (TF file)
     putStrLn $ "Moving " ++ file ++ " to permanent location"
     return result

validateC :: String -> ContT r IO TempFile
validateC = ContT . validate

-- Using callCC
--
-- Running @usingCallCC 3@ gives
--
-- > Creating temp file a
-- > Creating temp file b
-- > Moving b to permanent location
-- > Moving a to permanent location
--
-- and then returns @3@. Note how the @a@ and @b@ files are still created.
usingCallCC :: Int -> IO Int
usingCallCC exitPoint = evalContT $ callCC $ \exit -> do
    when (exitPoint == 1) $ exit 1
    ha <- validateC "a"
    when (exitPoint == 2) $ exit 2
    sb <- validateC "b"
    when (exitPoint == 3) $ exit 3
    hc <- validateC "c"
    when (exitPoint == 4) $ exit 4
    lift $ print (ha, sb, hc)
    return 5

-- Compare to usingCallCC:
--
-- > Creating temp file a
-- > Creating temp file b
-- > *** Exception: user error (3)
usingThrow :: Int -> IO Int
usingThrow exitPoint = evalContT $ do
    when (exitPoint == 1) $ liftIO $ throwIO (userError "1")
    ha <- validateC "a"
    when (exitPoint == 2) $ liftIO $ throwIO (userError "2")
    sb <- validateC "b"
    when (exitPoint == 3) $ liftIO $ throwIO (userError "3")
    hc <- validateC "c"
    when (exitPoint == 4) $ liftIO $ throwIO (userError "4")
    lift $ print (ha, sb, hc)
    return 5