TestContTAlternative.hs

{-# LANGUAGE CPP #-}

module Main (main) where

import Control.Monad.Trans.Cont
import Control.Applicative
import Control.Monad.IO.Class

main :: IO ()
main = evalContT example1 >>= putStrLn

#if 1

instance (Monoid r, Applicative m) => Alternative (ContT r m) where
    empty = ContT $ const (pure mempty)
    (ContT f) <|> (ContT g) = ContT $ \c -> liftA2 (<>) (f c) (g c)

{-
running foo and stopping
Past callCC
running bar
Past callCC
stoppedran bar
-}

#else

instance (Alternative m) => Alternative (ContT r m) where
    empty = ContT $ \_ -> empty
    (ContT f) <|> (ContT g) = ContT $ \c -> f c <|> g c

{-
running foo and stopping
Past callCC
stopped
-}

#endif

example1 :: ContT String IO String
example1 = do
    result <- callCC $ \stop -> do
        let foo = liftIO (putStrLn "running foo and stopping") >> stop "stopped"
            bar = liftIO (putStrLn "running bar") >> return "ran bar"

        foo <|> bar

    liftIO $ putStrLn "Past callCC"
    return result