Signal Handler — как сделать лучше?

data CFix a b = CFix {- state -} a  {- continuation -} !(CFix b)
              | Result b

computation :: ... -> CFix a b

runner :: Show a => CFix a b -> IO b
runner = loop
  where
    loop (Result x)  = return x
    loop (CFix s f') = do
      ifSomeStuffHappens (print s)
      loop $! f'

calc _ 0 = 0
calc f n = f $ n-1

fix' s f = readMVar s >>= \case 
   False -> do
     a <- unsafeInterleaveIO (fix' s f)
     return $ f a
   True -> return $ f id

{-# LANGUAGE LambdaCase #-}
import Control.Concurrent
import System.IO.Unsafe

calc _ 0 = 0
calc f n = f $ n-1

fix' s f = readMVar s >>= \case 
   False -> do
        a <- unsafeInterleaveIO (fix' s f)
	return $ f a
   True -> return $ f id

test = do
  fin <- newEmptyMVar
  x <- newMVar False
  t <- forkIO $ fix' x calc >>= print . ($150000) >> putMVar fin ()
  -- yield
  -- _ <- swapMVar x True
  takeMVar fin

data CFix a b = CFix a (a -> CFix a b)
              | Result a

calcc 0 = Result 0
calcc n = CFix (n-1) calcc

run _ (Result v) = return v
run s (CFix v f) = readMVar s >>= \case
  False -> run s (f v)
  True  -> return v

testc = do
  fin <- newEmptyMVar
  x <- newMVar False
  t <- forkIO $ run x (calcc 150000) >>= print >> putMVar fin ()
  -- yield
  -- _ <- swapMVar x True
  takeMVar fin

*Main> testc
0
(0.27 secs, 71795496 bytes)
*Main> test
0
(0.40 secs, 143504040 bytes)

calc _  done 0 = done 0
calc fp _    n = fp $ n+1

loop v f n = callCC $ \done -> loop' done (\fp -> f fp done) n
  where loop' done f' n = do
          n' <- liftIO (readMVar v) >>= \case
            False -> callCC $ \fp -> f' fp n
            True -> f' done n
          loop' done f' n'
  
setMVar v = (tryTakeMVar v >>) . putMVar v
  
main = do
  v <- newMVar False
  installHandler keyboardSignal (Catch $ setMVar v True) Nothing
  r <- evalContT $ loop v calc (7 ::Int)
  print r

{-# LANGUAGE BangPatterns #-}
import qualified Data.IORef as DI
import qualified System.Posix.Signals as SPS

-- pure computation
data Comp a = Partial !a
            | Done a
    deriving Show

calc :: Integer -> Comp Integer
calc v =
    case v of
        0 -> Done 0
        _ -> Partial (v+1)

-- messy stuff with signals and completion
compute :: Show a => a -> (a -> Comp a) -> IO a
compute ini calc' = do
    intermediate <- DI.newIORef ini

    -- signal stuff
    _ <- SPS.installHandler SPS.keyboardSignal
                            (SPS.Catch (DI.readIORef intermediate >>= print))
                            Nothing
    let loop v = do
        case calc' v of
            Done r -> return r
            Partial pr -> do
                DI.atomicModifyIORef intermediate
                                     (\_ -> (pr, ()))
                loop pr
    loop ini

main :: IO ()
main = do
    compute 42 calc >>= print