Merge pull request #87 from alexfmpe/cont-label

Add 'label' method to MonadCont

Author: emilypi

Control/Monad/Cont.hs

@@ -53,6 +53,9 @@ to understand and maintain.
 module Control.Monad.Cont (
     -- * MonadCont class
     MonadCont.MonadCont(..),
+    MonadCont.label,
+    MonadCont.label_,
+
     -- * The Cont monad
     Cont.Cont,
     Cont.cont,
@@ -71,9 +74,12 @@ module Control.Monad.Cont (
 
     -- * Example 2: Using @callCC@
     -- $callCCExample
-    
+
     -- * Example 3: Using @ContT@ Monad Transformer
     -- $ContTExample
+
+    -- * Example 4: Using @label@
+    -- $labelExample
   ) where
 
 import qualified Control.Monad.Cont.Class as MonadCont
@@ -165,3 +171,19 @@ and passes it to the continuation.
 and returning @IO ()@.
 Compare its signature to 'runContT' definition.
 -}
+
+{-$labelExample
+
+The early exit behavior of 'Control.Monad.Cont.Class.callCC' can be leveraged to produce other idioms:
+
+> whatsYourNameLabel :: IO ()
+> whatsYourNameLabel = evalContT $ do
+>   (beginning, attempts) <- label (0 :: Int)
+>   liftIO $ putStrLn $ "Attempt #" <> show attempts
+>   liftIO $ putStrLn $ "What's your name?"
+>   name <- liftIO getLine
+>   when (null name) $ beginning (attempts + 1)
+>   liftIO $ putStrLn $ "Welcome, " ++ name ++ "!"
+
+Calling @beggining@ will interrupt execution of the block, skipping the welcome message, which will be printed only once at the very end of the loop.
+-}

Control/Monad/Cont/Class.hs

@@ -56,8 +56,11 @@ to understand and maintain.
 
 module Control.Monad.Cont.Class (
     MonadCont(..),
+    label,
+    label_,
   ) where
 
+import Control.Monad.Fix (fix)
 import Control.Monad.Trans.Cont (ContT)
 import qualified Control.Monad.Trans.Cont as ContT
 import Control.Monad.Trans.Except (ExceptT)
@@ -152,3 +155,19 @@ instance
   , MonadCont m
   ) => MonadCont (AccumT w m) where
     callCC = Accum.liftCallCC callCC
+
+-- | Introduces a recursive binding to the continuation.
+-- Due to the use of @callCC@, calling the continuation will interrupt execution
+-- of the current block creating an effect similar to goto/setjmp in C.
+--
+-- @since 2.3.1
+--
+label :: MonadCont m  => a -> m (a -> m b, a)
+label a = callCC $ \k -> let go b = k (go, b) in return (go, a)
+
+-- | Simplified version of `label` without arguments 
+-- 
+-- @since 2.3.1
+--
+label_ :: MonadCont m => m (m a)
+label_ = callCC $ return . fix