content: {-# LANGUAGE MultiParamTypeClasses #-}
  
  module Hans.Monad (
      Hans()
    , runHans, runHansOnce
    , setEscape, escape, dropPacket
    , callCC
    , io
    , decode, decode'
    ) where
  
  import Hans.Device.Types (DeviceStats(),updateDropped,statRX)
  
  import qualified Control.Applicative as A
  import qualified Data.ByteString as S
  import           Data.IORef (newIORef,writeIORef,readIORef)
  import           Data.Serialize.Get (runGet,runGetState,Get)
  import           MonadLib (BaseM(..))
  
  
  newtype Hans a = Hans { unHans :: IO () -> (a -> IO ()) -> IO () }
  
  instance Functor Hans where
    fmap f m = Hans (\ e k -> unHans m e (k . f))
    {-# INLINE fmap #-}
  
  instance A.Applicative Hans where
    pure x  = Hans (\ _ k -> k x)
  
    f <*> x = Hans $ \ e k -> unHans f e
                   $ \ g   -> unHans x e
                   $ \ y   -> k (g y)
  
    {-# INLINE pure  #-}
    {-# INLINE (<*>) #-}
  
  instance Monad Hans where
    return  = A.pure
  
    m >>= f = Hans $ \ e k -> unHans m e
                   $ \ a   -> unHans (f a) e k
  
    {-# INLINE return #-}
    {-# INLINE (>>=)  #-}
  
  instance BaseM Hans IO where
    inBase = io
    {-# INLINE inBase #-}
  
  
  -- | Run only one iteration of the Hans monad.
  runHansOnce :: Hans a -> IO (Maybe a)
  runHansOnce (Hans f) =
    do res <- newIORef Nothing
       f (writeIORef res Nothing) (\x -> writeIORef res (Just x))
       readIORef res
  
  
  -- | Loop forever, running the underlying operation.
  runHans :: Hans () -> IO ()
  runHans (Hans m) = loop ()
    where
    loop () = m (loop ()) loop
  {-# INLINE runHans #-}
  
  -- | Set the escape continuation to the current position, within the operation
  -- given, so that control flow always restores back through this point.
  setEscape :: Hans () -> Hans ()
  setEscape m = Hans (\ _ k -> unHans m (k ()) k)
  {-# INLINE setEscape #-}
  
  -- | Invoke the escape continuation.
  escape :: Hans a
  escape  = Hans (\ e _ -> e)
  {-# INLINE escape #-}
  
  -- | Call-cc. NOTE: the continuation will inherit the escape point of the
  -- calling context.
  callCC :: ((b -> Hans a) -> Hans b) -> Hans b
  callCC f = Hans (\e k -> unHans (f (\b -> Hans (\_ _ -> k b))) e k)
  {-# INLINE callCC #-}
  
  -- | Synonym for 'escape' that also updates device statistics.
  dropPacket :: DeviceStats -> Hans a
  dropPacket stats =
    do io (updateDropped statRX stats)
       escape
  {-# INLINE dropPacket #-}
  
  -- | Lift an 'IO' operation into 'Hans'.
  io :: IO a -> Hans a
  io m = Hans (\ _ k -> m >>= k )
  {-# INLINE io #-}
  
  -- | Run a Get action in the context of the Hans monad, 
  decode :: DeviceStats -> Get a -> S.ByteString -> Hans a
  decode dev m bytes =
    case runGet m bytes of
      Right a -> return a
      Left _  -> dropPacket dev
  {-# INLINE decode #-}
  
  -- | Run a Get action in the context of the Hans monad, returning any unconsumed
  -- input.
  decode' :: DeviceStats -> Get a -> S.ByteString -> Hans (a,S.ByteString)
  decode' dev m bytes =
    case runGetState m bytes 0 of
      Right a -> return a
      Left _  -> dropPacket dev
  