{-# LANGUAGE Unsafe #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE CPP #-}
module LIO.TCB.LObj (
LObj(..)
, blessTCB, blessPTCB
, blessWriteOnlyTCB, blessWriteOnlyPTCB
, blessReadOnlyTCB, blessReadOnlyPTCB
, GuardIO(..)
) where
import safe Data.Typeable
import safe LIO.Core
import safe LIO.Error
import safe LIO.Label
import LIO.TCB
data LObj label object = LObjTCB !label !object deriving (Typeable)
instance LabelOf LObj where
{-# INLINE labelOf #-}
labelOf (LObjTCB l _) = l
instance (Label l, Show t) => ShowTCB (LObj l t) where
showTCB (LObjTCB l t) = show t ++ " {" ++ show l ++ "}"
class GuardIO l io lio | l io -> lio where
guardIOTCB :: (LIO l ()) -> io -> lio
instance GuardIO l (IO r) (LIO l r) where
{-# INLINE guardIOTCB #-}
guardIOTCB guard io = guard >> ioTCB io
#define GUARDIO(types, vals) \
instance GuardIO l (types -> IO r) (types -> LIO l r) where { \
{-# INLINE guardIOTCB #-}; \
guardIOTCB guard io vals = guard >> ioTCB (io vals); \
}
GUARDIO(a1, \
a1); \
GUARDIO(a1 -> a2, \
a1 a2); \
GUARDIO(a1 -> a2 -> a3, \
a1 a2 a3); \
GUARDIO(a1 -> a2 -> a3 -> a4, \
a1 a2 a3 a4); \
GUARDIO(a1 -> a2 -> a3 -> a4 -> a5, \
a1 a2 a3 a4 a5); \
GUARDIO(a1 -> a2 -> a3 -> a4 -> a5 -> a6, \
a1 a2 a3 a4 a5 a6); \
GUARDIO(a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7, \
a1 a2 a3 a4 a5 a6 a7); \
GUARDIO(a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8, \
a1 a2 a3 a4 a5 a6 a7 a8); \
GUARDIO(a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9, \
a1 a2 a3 a4 a5 a6 a7 a8 a9); \
GUARDIO(a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10, \
a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
blessTCB :: (GuardIO l io lio, Label l) =>
String -> (a -> io) -> (LObj l a) -> lio
{-# INLINE blessTCB #-}
blessTCB name io (LObjTCB l a) =
guardIOTCB (withContext name $ guardWrite l) (io a)
blessPTCB :: (GuardIO l io lio, PrivDesc l p) =>
String -> (a -> io) -> Priv p -> (LObj l a) -> lio
{-# INLINE blessPTCB #-}
blessPTCB name io p (LObjTCB l a) =
guardIOTCB (withContext name $ guardWriteP p l) (io a)
blessWriteOnlyTCB :: (GuardIO l io lio, Label l) =>
String -> (a -> io) -> (LObj l a) -> lio
{-# INLINE blessWriteOnlyTCB #-}
blessWriteOnlyTCB name io (LObjTCB l a) =
guardIOTCB (withContext name $ guardAlloc l) (io a)
blessWriteOnlyPTCB :: (GuardIO l io lio, PrivDesc l p) =>
String -> (a -> io) -> Priv p -> (LObj l a) -> lio
{-# INLINE blessWriteOnlyPTCB #-}
blessWriteOnlyPTCB name io p (LObjTCB l a) =
guardIOTCB (withContext name $ guardAllocP p l) (io a)
blessReadOnlyTCB :: (GuardIO l io lio, Label l) =>
String -> (a -> io) -> (LObj l a) -> lio
{-# INLINE blessReadOnlyTCB #-}
blessReadOnlyTCB name io (LObjTCB l a) =
guardIOTCB (withContext name $ taint l) (io a)
blessReadOnlyPTCB :: (GuardIO l io lio, PrivDesc l p) =>
String -> (a -> io) -> Priv p -> (LObj l a) -> lio
{-# INLINE blessReadOnlyPTCB #-}
blessReadOnlyPTCB name io p (LObjTCB l a) =
guardIOTCB (withContext name $ taintP p l) (io a)