control-monad-queue-0.0.9: tests/SideChannelQ.hs

{-# OPTIONS_GHC -O2 -fno-full-laziness  #-}
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE NoMonomorphismRestriction  #-}
-- Argh... for whatever reason this file cannot be compiled with optimization
-- -fno-full-laziness fixes this
-- Todo: check ghc-core to find out why

module SideChannelQ (Q(), enQ, deQ, runResultQueue) where

--import Control.Monad.Queue.Class
import Control.Monad.Cont.Class
import Data.IORef
import System.IO.Unsafe
import qualified Debug.Trace

-- trace   = Debug.Trace.trace
-- traceIO = putStr

trace   _ = id
traceIO _ = return ()

type QSt r' r  = IORef r' -> IORef [r] -> Int -> [r] -> [r]

newtype Q r' r a = Q { unQ :: ((a -> QSt r' r) -> QSt r' r) }

instance Monad (Q r' r) where
    return a = Q ($a)
    m >>= f  = Q (\k -> unQ m (\a -> unQ (f a) k))

instance MonadCont (Q r' r) where
  callCC f = Q (\k -> unQ (f (\a -> Q (\_ -> k a))) k)


unsafeRead  ref   = unsafePerformIO (readIORef  ref  )
unsafeWrite ref a = unsafePerformIO (writeIORef ref a)
unsafeNew   a     = unsafePerformIO (newIORef   a    )


enQ x = Q (\k rr' rr !n xs -> let !n' = n+1
                                  xs'  = k () rr' rr n' xs
                               in trace ("enQ $ " ++ show x)
                                   (unsafeWrite rr xs' `seq` (x:xs')))

deQ = Q delta
  where
    delta k rr' rr 0        xs  = trace ("deQ failed")     (k Nothing  rr' rr 0 xs)
    delta k rr' rr (n+1) (x:xs) = trace ("deQ " ++ show x) (k (Just x) rr' rr n xs)


breakK a rr' rr n xs = trace ("setting return value: " ++ show a)
                         (unsafeWrite rr' (\() -> a) `seq` [])


force [] = return ()
force (_:_) = return ()

demand [] = ()
demand (_:_) = ()

runResultQueue m
     = (trace "reading return value" `seq` unsafeRead rr' (), queue)
   where
     rr' = unsafeNew init
     init () = unsafePerformIO $ do
                 traceIO "forcing computation\n"
                 xs <- readIORef rr
                 force xs
                 traceIO "reading return value\n"
                 f <- readIORef rr'
                 return (f ())
     rr  = unsafeNew queue
     queue = unQ m breakK rr' rr 0 queue