"setjmp / longjmp" in Haskell (continuations)

ContLabel.hs

module ContLabel where

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

type Jmp r m a = (Maybe a, Label r m a)
newtype Label r m a = Label (Jmp r m a -> m r)

setjmp :: ContT r m (Jmp r m a)
setjmp = ContT $ \ c -> c (Nothing, Label c)

longjmp :: Label r m a -> a -> ContT r m b
longjmp l@(Label k) v = ContT $ \_ -> k (Just v, l)

main :: IO ()
main = evalContT $ callCC $ \ k -> do
  let pr = liftIO . putStrLn

  (j, label_0) <- setjmp
  pr ("1st setjmp returned: " ++ show j)

  case j of
    Nothing -> pr "First invocation, continue"
    Just s -> do
      pr (show (s :: Int) ++ ". Goodbye, world!")
      k ()

  (v, label_1) <- setjmp
  pr ("2nd setjmp returned: " ++ show (v :: Maybe String))

  (let
    forever m = x where x = m *> x
    m0 = do
      liftIO $ putStr "Choose your next target (A/B): "
      sel <- liftIO $ getLine
      case sel of
        ('A':_) -> m' "Int" label_0
        ('B':_) -> m' "String" label_1
        _ -> pr "Nope" >> m0
    m' tn label_x = forever $ do
      liftIO $ putStr ("Choose your " ++ tn ++ ": ")
      sel <- liftIO $ getLine
      case [ x | (x, "") <- reads sel ] of
        [x] -> longjmp label_x x
        [] -> pr "heck, no parse"
        _ -> pr "hell, ambiguous parse"
    in m0)