module Util.Registry(
Registry,
UntypedRegistry,
LockedRegistry,
UntypedLockedRegistry,
Untyped,
Unsafe,
UnsafeRegistry,
NewRegistry(..),
GetSetRegistry(..),
GetSetRegistryDyn(..),
KeyOpsRegistry(..),
ListRegistryContents(..),
changeKey,
getRegistryValue,
getValueDefault,
lockedRegistryCheck,
getValue',
getValueSafe,
getRegistryValueSafe,
) where
import Data.Maybe
import Control.Monad.Trans
import System.IO.Unsafe
import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Concurrent
import Control.Exception
import GHC.Prim(unsafeCoerce#)
import Util.ExtendedPrelude(newFallOut,mkBreakFn)
import Util.Dynamics
import Util.BinaryAll
import Util.CompileFlags
import Util.Object(ObjectID)
class NewRegistry registry where
newRegistry :: IO registry
emptyRegistry :: registry -> IO ()
class GetSetRegistry registry from to where
transformValue :: registry -> from -> (Maybe to -> IO (Maybe to,extra))
-> IO extra
getValueOpt :: registry -> from -> IO (Maybe to)
getValueOpt registry from = transformValue registry from
(\ valueOpt -> return (valueOpt,valueOpt))
getValue :: registry -> from -> IO to
getValue registry from =
do
valueOpt <- getValueOpt registry from
case valueOpt of
Nothing -> error "Registry.getValue - value undefined"
Just value -> return value
setValue :: registry -> from -> to -> IO ()
setValue registry from to =
transformValue registry from (\ _ -> return (Just to,()))
class ListRegistryContents registry from to where
listRegistryContents :: registry from to -> IO [(from,to)]
listRegistryContentsAndEmptyRegistry :: registry from to -> IO [(from,to)]
listToNewRegistry :: [(from,to)] -> IO (registry from to)
getValueDefault :: GetSetRegistry registry from to
=> to -> registry -> from -> IO to
getValueDefault defTo registry from =
do
toOpt <- getValueOpt registry from
case toOpt of
Nothing -> return defTo
Just to -> return to
class KeyOpsRegistry registry from where
deleteFromRegistryBool :: registry -> from -> IO Bool
deleteFromRegistry :: registry -> from -> IO ()
deleteFromRegistry registry from =
do
deleteFromRegistryBool registry from
return ()
listKeys :: registry -> IO [from]
newtype Ord from => Registry from to = Registry (MVar (Map.Map from to))
deriving (Typeable)
instance Ord from => NewRegistry (Registry from to) where
newRegistry =
do
mVar <- newMVar Map.empty
return (Registry mVar)
emptyRegistry (Registry mVar) =
do
takeMVar mVar
putMVar mVar Map.empty
instance Ord from => GetSetRegistry (Registry from to) from to where
getValue registry from =
do
valueOpt <- getValueOpt registry from
case valueOpt of
Nothing ->
ioError(userError "Registry.getValue - value not found")
Just value -> return value
getValueOpt (Registry mVar) from =
do
map <- readMVar mVar
return (Map.lookup from map)
transformValue (Registry mVar) from transformer =
modifyMVar mVar
(\ map ->
do
(newSetting,extra) <- transformer (Map.lookup from map)
newMap <- case newSetting of
Just newTo -> return (Map.insert from newTo map)
Nothing -> return (Map.delete from map)
return (newMap,extra)
)
setValue (Registry mVar) from to =
do
map <- takeMVar mVar
putMVar mVar (Map.insert from to map)
getRegistryValue :: Ord from => Registry from to -> from -> IO to
getRegistryValue registry from = getValue registry from
getRegistryValueSafe :: Ord from => String -> Registry from to -> from -> IO to
getRegistryValueSafe label registry from = getValueSafe label registry from
instance Ord from => KeyOpsRegistry (Registry from to) from where
deleteFromRegistryBool (Registry mVar) from =
do
map <- takeMVar mVar
if Map.member from map
then
do
putMVar mVar (Map.delete from map)
return True
else
do
putMVar mVar map
return False
deleteFromRegistry (Registry mVar) from =
do
map <- takeMVar mVar
putMVar mVar (Map.delete from map)
listKeys (Registry mVar) =
do
map <- readMVar mVar
return (Map.keys map)
instance Ord from => ListRegistryContents Registry from to where
listRegistryContents (Registry mVar) =
do
fm <- readMVar mVar
return (Map.toList fm)
listRegistryContentsAndEmptyRegistry (Registry mVar) =
modifyMVar mVar (\ fm ->
return (Map.empty,Map.toList fm)
)
listToNewRegistry contents =
do
let map = Map.fromList contents
mVar <- newMVar map
return (Registry mVar)
changeKey :: Ord from => Registry from to -> from -> from -> IO ()
changeKey (Registry mVar) oldKey newKey =
modifyMVar_ mVar (\ fmap0 -> return (case Map.lookup oldKey fmap0 of
Nothing -> fmap0
Just elt ->
let
fmap1 = Map.delete oldKey fmap0
fmap2 = Map.insert newKey elt fmap1
in
fmap2
)
)
type UntypedRegistry from = Untyped Registry from
newtype Untyped registry from = Untyped (registry from Dyn)
instance NewRegistry (registry from Dyn)
=> NewRegistry (Untyped registry from) where
newRegistry =
do
registry <- newRegistry
return (Untyped registry)
emptyRegistry (Untyped registry) = emptyRegistry registry
fromDynamicMessage :: Typeable to => String -> Dyn -> to
fromDynamicMessage fName dyn =
case fromDynamic dyn of
Just to -> to
Nothing -> error ("Registry."++fName++" - value has wrong type")
instance (Typeable to,GetSetRegistry (registry from Dyn) from Dyn)
=> GetSetRegistry (Untyped registry from) from to where
transformValue (Untyped registry) from transformer =
do
let
valMapIn = fromDynamicMessage "transformValue"
valMapOut val = toDyn val
transformerDyn dynInOpt =
do
let valInOpt = (fmap valMapIn) dynInOpt
(valOutOpt,extra) <- transformer valInOpt
let dynOutOpt = (fmap valMapOut) valOutOpt
return (dynOutOpt,extra)
transformValue registry from transformerDyn
instance KeyOpsRegistry (registry from Dyn) from
=> KeyOpsRegistry (Untyped registry from) from where
deleteFromRegistryBool (Untyped registry) from =
deleteFromRegistryBool registry from
deleteFromRegistry (Untyped registry) from =
deleteFromRegistry registry from
listKeys (Untyped registry) = listKeys registry
class GetSetRegistryDyn registry from where
setValueAsDyn :: registry -> from -> Dyn -> IO ()
getValueAsDyn :: registry -> from -> IO Dyn
instance GetSetRegistry (registry from Dyn) from Dyn
=> GetSetRegistryDyn (Untyped registry from) from where
setValueAsDyn (Untyped registry) from dyn =
setValue registry from dyn
getValueAsDyn (Untyped registry) from =
getValue registry from
type UnsafeRegistry from = Unsafe Registry from
data Obj = Obj
toObj :: a -> Obj
toObj = unsafeCoerce#
fromObj :: Obj -> a
fromObj = unsafeCoerce#
newtype Unsafe registry from = Unsafe (registry from Obj)
instance NewRegistry (registry from Obj)
=> NewRegistry (Unsafe registry from) where
newRegistry =
do
registry <- newRegistry
return (Unsafe registry)
emptyRegistry (Unsafe registry) = emptyRegistry registry
instance (GetSetRegistry (registry from Obj) from Obj)
=> GetSetRegistry (Unsafe registry from) from to where
transformValue (Unsafe registry) from transformer =
do
let
transformerObj objInOpt =
do
let valInOpt = (fmap fromObj) objInOpt
(valOutOpt,extra) <- transformer valInOpt
let objOutOpt = (fmap toObj) valOutOpt
return (objOutOpt,extra)
transformValue registry from transformerObj
instance KeyOpsRegistry (registry from Obj) from
=> KeyOpsRegistry (Unsafe registry from) from where
deleteFromRegistryBool (Unsafe registry) from =
deleteFromRegistryBool registry from
deleteFromRegistry (Unsafe registry) from =
deleteFromRegistry registry from
listKeys (Unsafe registry) = listKeys registry
newtype LockedRegistry from to
= Locked (Registry from (MVar (Maybe to),Set.Set ThreadId))
deriving (Typeable)
type UntypedLockedRegistry from = Untyped LockedRegistry from
instance Ord from => NewRegistry (LockedRegistry from to) where
newRegistry =
do
registry <- newRegistry
return (Locked registry)
emptyRegistry (Locked registry) = emptyRegistry registry
takeVal :: Ord from => LockedRegistry from to -> from -> IO (Maybe to)
takeVal (Locked registry) from =
do
mVar <-
transformValue registry from
(\ dataOpt ->
do
threadId <- myThreadId
case dataOpt of
Nothing ->
do
mVar <- newMVar Nothing
return (Just (mVar,Set.singleton threadId),mVar)
Just (mVar,set0) ->
if Set.member threadId set0
then
mkBreakFn lockedFallOutId
("Circular transformValue detected in "
++ "Registry.LockedRegistry")
else
return (Just (mVar,Set.insert threadId set0),mVar)
)
takeMVar mVar
putVal :: Ord from => LockedRegistry from to -> from -> Maybe to -> IO ()
putVal (Locked registry) from toOpt =
transformValue registry from
(\ dataOpt ->
do
threadId <- myThreadId
case dataOpt of
Nothing -> error "Registry: unmatched putVal"
Just (mVar,set0) ->
do
let
set1 = Set.delete threadId set0
if Set.null set1 && not (isJust toOpt)
then
return (Nothing,())
else
do
putMVar mVar toOpt
return (Just (mVar,set1),())
)
lockedRegistryCheck :: IO a -> IO (Either String a)
lockedFallOutId :: ObjectID
(lockedFallOutId,lockedRegistryCheck) = lockedCheckBreak
lockedCheckBreak :: (ObjectID,IO a -> IO (Either String a))
lockedCheckBreak = unsafePerformIO newFallOut
instance Ord from => GetSetRegistry (LockedRegistry from to) from to where
transformValue lockedRegistry from transformer =
do
valInOpt <- takeVal lockedRegistry from
resultOrError <- Control.Exception.try (transformer valInOpt)
case resultOrError of
Left error ->
do
putVal lockedRegistry from valInOpt
Control.Exception.throw (error :: SomeException)
Right (valOutOpt,extra) ->
do
putVal lockedRegistry from valOutOpt
return extra
instance Ord from => KeyOpsRegistry (LockedRegistry from to) from where
deleteFromRegistryBool lockedRegistry from =
do
toOpt <- takeVal lockedRegistry from
putVal lockedRegistry from Nothing
return (isJust toOpt)
listKeys (Locked registry) = listKeys registry
getValueSafe :: GetSetRegistry registry from to
=> String -> registry -> from -> IO to
getValueSafe = getValue'
getValue' :: GetSetRegistry registry from to
=> String -> registry -> from -> IO to
getValue' =
if isDebug
then
(\ label registry from ->
do
toOpt <- getValueOpt registry from
case toOpt of
Nothing -> error ("Registry.getValue' - failed with "
++ label)
Just to -> return to
)
else
(\ label -> getValue)
instance (HasBinary (from,to) m,Ord from,MonadIO m)
=> HasBinary (Registry from to) m where
writeBin = mapWriteIO listRegistryContents
readBin = mapReadIO listToNewRegistry