{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NoMonoPatBinds #-}
{-# LANGUAGE UndecidableInstances #-}
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
registry from
from = registry
-> from -> (Maybe to -> IO (Maybe to, Maybe to)) -> IO (Maybe to)
forall registry from to extra.
GetSetRegistry registry from to =>
registry -> from -> (Maybe to -> IO (Maybe to, extra)) -> IO extra
transformValue registry
registry from
from
(\ Maybe to
valueOpt -> (Maybe to, Maybe to) -> IO (Maybe to, Maybe to)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe to
valueOpt,Maybe to
valueOpt))
getValue :: registry -> from -> IO to
getValue registry
registry from
from =
do
Maybe to
valueOpt <- registry -> from -> IO (Maybe to)
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> IO (Maybe to)
getValueOpt registry
registry from
from
case Maybe to
valueOpt of
Maybe to
Nothing -> [Char] -> IO to
forall a. HasCallStack => [Char] -> a
error [Char]
"Registry.getValue - value undefined"
Just to
value -> to -> IO to
forall (m :: * -> *) a. Monad m => a -> m a
return to
value
setValue :: registry -> from -> to -> IO ()
setValue registry
registry from
from to
to =
registry -> from -> (Maybe to -> IO (Maybe to, ())) -> IO ()
forall registry from to extra.
GetSetRegistry registry from to =>
registry -> from -> (Maybe to -> IO (Maybe to, extra)) -> IO extra
transformValue registry
registry from
from (\ Maybe to
_ -> (Maybe to, ()) -> IO (Maybe to, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (to -> Maybe to
forall a. a -> Maybe a
Just to
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 :: to -> registry -> from -> IO to
getValueDefault to
defTo registry
registry from
from =
do
Maybe to
toOpt <- registry -> from -> IO (Maybe to)
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> IO (Maybe to)
getValueOpt registry
registry from
from
case Maybe to
toOpt of
Maybe to
Nothing -> to -> IO to
forall (m :: * -> *) a. Monad m => a -> m a
return to
defTo
Just to
to -> to -> IO to
forall (m :: * -> *) a. Monad m => a -> m a
return to
to
class KeyOpsRegistry registry from where
deleteFromRegistryBool :: registry -> from -> IO Bool
deleteFromRegistry :: registry -> from -> IO ()
deleteFromRegistry registry
registry from
from =
do
registry -> from -> IO Bool
forall registry from.
KeyOpsRegistry registry from =>
registry -> from -> IO Bool
deleteFromRegistryBool registry
registry from
from
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
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 :: IO (Registry from to)
newRegistry =
do
MVar (Map from to)
mVar <- Map from to -> IO (MVar (Map from to))
forall a. a -> IO (MVar a)
newMVar Map from to
forall k a. Map k a
Map.empty
Registry from to -> IO (Registry from to)
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar (Map from to) -> Registry from to
forall from to. MVar (Map from to) -> Registry from to
Registry MVar (Map from to)
mVar)
emptyRegistry :: Registry from to -> IO ()
emptyRegistry (Registry MVar (Map from to)
mVar) =
do
MVar (Map from to) -> IO (Map from to)
forall a. MVar a -> IO a
takeMVar MVar (Map from to)
mVar
MVar (Map from to) -> Map from to -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Map from to)
mVar Map from to
forall k a. Map k a
Map.empty
instance Ord from => GetSetRegistry (Registry from to) from to where
getValue :: Registry from to -> from -> IO to
getValue Registry from to
registry from
from =
do
Maybe to
valueOpt <- Registry from to -> from -> IO (Maybe to)
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> IO (Maybe to)
getValueOpt Registry from to
registry from
from
case Maybe to
valueOpt of
Maybe to
Nothing ->
IOError -> IO to
forall a. IOError -> IO a
ioError([Char] -> IOError
userError [Char]
"Registry.getValue - value not found")
Just to
value -> to -> IO to
forall (m :: * -> *) a. Monad m => a -> m a
return to
value
getValueOpt :: Registry from to -> from -> IO (Maybe to)
getValueOpt (Registry MVar (Map from to)
mVar) from
from =
do
Map from to
map <- MVar (Map from to) -> IO (Map from to)
forall a. MVar a -> IO a
readMVar MVar (Map from to)
mVar
Maybe to -> IO (Maybe to)
forall (m :: * -> *) a. Monad m => a -> m a
return (from -> Map from to -> Maybe to
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup from
from Map from to
map)
transformValue :: Registry from to
-> from -> (Maybe to -> IO (Maybe to, extra)) -> IO extra
transformValue (Registry MVar (Map from to)
mVar) from
from Maybe to -> IO (Maybe to, extra)
transformer =
MVar (Map from to)
-> (Map from to -> IO (Map from to, extra)) -> IO extra
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Map from to)
mVar
(\ Map from to
map ->
do
(Maybe to
newSetting,extra
extra) <- Maybe to -> IO (Maybe to, extra)
transformer (from -> Map from to -> Maybe to
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup from
from Map from to
map)
Map from to
newMap <- case Maybe to
newSetting of
Just to
newTo -> Map from to -> IO (Map from to)
forall (m :: * -> *) a. Monad m => a -> m a
return (from -> to -> Map from to -> Map from to
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert from
from to
newTo Map from to
map)
Maybe to
Nothing -> Map from to -> IO (Map from to)
forall (m :: * -> *) a. Monad m => a -> m a
return (from -> Map from to -> Map from to
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete from
from Map from to
map)
(Map from to, extra) -> IO (Map from to, extra)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map from to
newMap,extra
extra)
)
setValue :: Registry from to -> from -> to -> IO ()
setValue (Registry MVar (Map from to)
mVar) from
from to
to =
do
Map from to
map <- MVar (Map from to) -> IO (Map from to)
forall a. MVar a -> IO a
takeMVar MVar (Map from to)
mVar
MVar (Map from to) -> Map from to -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Map from to)
mVar (from -> to -> Map from to -> Map from to
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert from
from to
to Map from to
map)
getRegistryValue :: Ord from => Registry from to -> from -> IO to
getRegistryValue :: Registry from to -> from -> IO to
getRegistryValue Registry from to
registry from
from = Registry from to -> from -> IO to
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> IO to
getValue Registry from to
registry from
from
getRegistryValueSafe :: Ord from => String -> Registry from to -> from -> IO to
getRegistryValueSafe :: [Char] -> Registry from to -> from -> IO to
getRegistryValueSafe [Char]
label Registry from to
registry from
from = [Char] -> Registry from to -> from -> IO to
forall registry from to.
GetSetRegistry registry from to =>
[Char] -> registry -> from -> IO to
getValueSafe [Char]
label Registry from to
registry from
from
instance Ord from => KeyOpsRegistry (Registry from to) from where
deleteFromRegistryBool :: Registry from to -> from -> IO Bool
deleteFromRegistryBool (Registry MVar (Map from to)
mVar) from
from =
do
Map from to
map <- MVar (Map from to) -> IO (Map from to)
forall a. MVar a -> IO a
takeMVar MVar (Map from to)
mVar
if from -> Map from to -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member from
from Map from to
map
then
do
MVar (Map from to) -> Map from to -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Map from to)
mVar (from -> Map from to -> Map from to
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete from
from Map from to
map)
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else
do
MVar (Map from to) -> Map from to -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Map from to)
mVar Map from to
map
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
deleteFromRegistry :: Registry from to -> from -> IO ()
deleteFromRegistry (Registry MVar (Map from to)
mVar) from
from =
do
Map from to
map <- MVar (Map from to) -> IO (Map from to)
forall a. MVar a -> IO a
takeMVar MVar (Map from to)
mVar
MVar (Map from to) -> Map from to -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Map from to)
mVar (from -> Map from to -> Map from to
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete from
from Map from to
map)
listKeys :: Registry from to -> IO [from]
listKeys (Registry MVar (Map from to)
mVar) =
do
Map from to
map <- MVar (Map from to) -> IO (Map from to)
forall a. MVar a -> IO a
readMVar MVar (Map from to)
mVar
[from] -> IO [from]
forall (m :: * -> *) a. Monad m => a -> m a
return (Map from to -> [from]
forall k a. Map k a -> [k]
Map.keys Map from to
map)
instance Ord from => ListRegistryContents Registry from to where
listRegistryContents :: Registry from to -> IO [(from, to)]
listRegistryContents (Registry MVar (Map from to)
mVar) =
do
Map from to
fm <- MVar (Map from to) -> IO (Map from to)
forall a. MVar a -> IO a
readMVar MVar (Map from to)
mVar
[(from, to)] -> IO [(from, to)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Map from to -> [(from, to)]
forall k a. Map k a -> [(k, a)]
Map.toList Map from to
fm)
listRegistryContentsAndEmptyRegistry :: Registry from to -> IO [(from, to)]
listRegistryContentsAndEmptyRegistry (Registry MVar (Map from to)
mVar) =
MVar (Map from to)
-> (Map from to -> IO (Map from to, [(from, to)]))
-> IO [(from, to)]
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Map from to)
mVar (\ Map from to
fm ->
(Map from to, [(from, to)]) -> IO (Map from to, [(from, to)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Map from to
forall k a. Map k a
Map.empty,Map from to -> [(from, to)]
forall k a. Map k a -> [(k, a)]
Map.toList Map from to
fm)
)
listToNewRegistry :: [(from, to)] -> IO (Registry from to)
listToNewRegistry [(from, to)]
contents =
do
let map :: Map from to
map = [(from, to)] -> Map from to
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(from, to)]
contents
MVar (Map from to)
mVar <- Map from to -> IO (MVar (Map from to))
forall a. a -> IO (MVar a)
newMVar Map from to
map
Registry from to -> IO (Registry from to)
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar (Map from to) -> Registry from to
forall from to. MVar (Map from to) -> Registry from to
Registry MVar (Map from to)
mVar)
changeKey :: Ord from => Registry from to -> from -> from -> IO ()
changeKey :: Registry from to -> from -> from -> IO ()
changeKey (Registry MVar (Map from to)
mVar) from
oldKey from
newKey =
MVar (Map from to) -> (Map from to -> IO (Map from to)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map from to)
mVar (\ Map from to
fmap0 -> Map from to -> IO (Map from to)
forall (m :: * -> *) a. Monad m => a -> m a
return (case from -> Map from to -> Maybe to
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup from
oldKey Map from to
fmap0 of
Maybe to
Nothing -> Map from to
fmap0
Just to
elt ->
let
fmap1 :: Map from to
fmap1 = from -> Map from to -> Map from to
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete from
oldKey Map from to
fmap0
fmap2 :: Map from to
fmap2 = from -> to -> Map from to -> Map from to
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert from
newKey to
elt Map from to
fmap1
in
Map from to
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 :: IO (Untyped registry from)
newRegistry =
do
registry from Dyn
registry <- IO (registry from Dyn)
forall registry. NewRegistry registry => IO registry
newRegistry
Untyped registry from -> IO (Untyped registry from)
forall (m :: * -> *) a. Monad m => a -> m a
return (registry from Dyn -> Untyped registry from
forall (registry :: * -> * -> *) from.
registry from Dyn -> Untyped registry from
Untyped registry from Dyn
registry)
emptyRegistry :: Untyped registry from -> IO ()
emptyRegistry (Untyped registry from Dyn
registry) = registry from Dyn -> IO ()
forall registry. NewRegistry registry => registry -> IO ()
emptyRegistry registry from Dyn
registry
fromDynamicMessage :: Typeable to => String -> Dyn -> to
fromDynamicMessage :: [Char] -> Dyn -> to
fromDynamicMessage [Char]
fName Dyn
dyn =
case Dyn -> Maybe to
forall a. Typeable a => Dyn -> Maybe a
fromDynamic Dyn
dyn of
Just to
to -> to
to
Maybe to
Nothing -> [Char] -> to
forall a. HasCallStack => [Char] -> a
error ([Char]
"Registry."[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
fName[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" - value has wrong type")
instance (Typeable to,GetSetRegistry (registry from Dyn) from Dyn)
=> GetSetRegistry (Untyped registry from) from to where
transformValue :: Untyped registry from
-> from -> (Maybe to -> IO (Maybe to, extra)) -> IO extra
transformValue (Untyped registry from Dyn
registry) from
from Maybe to -> IO (Maybe to, extra)
transformer =
do
let
valMapIn :: Dyn -> to
valMapIn = [Char] -> Dyn -> to
forall to. Typeable to => [Char] -> Dyn -> to
fromDynamicMessage [Char]
"transformValue"
valMapOut :: a -> Dyn
valMapOut a
val = a -> Dyn
forall a. Typeable a => a -> Dyn
toDyn a
val
transformerDyn :: Maybe Dyn -> IO (Maybe Dyn, extra)
transformerDyn Maybe Dyn
dynInOpt =
do
let valInOpt :: Maybe to
valInOpt = ((Dyn -> to) -> Maybe Dyn -> Maybe to
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dyn -> to
valMapIn) Maybe Dyn
dynInOpt
(Maybe to
valOutOpt,extra
extra) <- Maybe to -> IO (Maybe to, extra)
transformer Maybe to
valInOpt
let dynOutOpt :: Maybe Dyn
dynOutOpt = ((to -> Dyn) -> Maybe to -> Maybe Dyn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap to -> Dyn
forall a. Typeable a => a -> Dyn
valMapOut) Maybe to
valOutOpt
(Maybe Dyn, extra) -> IO (Maybe Dyn, extra)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Dyn
dynOutOpt,extra
extra)
registry from Dyn
-> from -> (Maybe Dyn -> IO (Maybe Dyn, extra)) -> IO extra
forall registry from to extra.
GetSetRegistry registry from to =>
registry -> from -> (Maybe to -> IO (Maybe to, extra)) -> IO extra
transformValue registry from Dyn
registry from
from Maybe Dyn -> IO (Maybe Dyn, extra)
transformerDyn
instance KeyOpsRegistry (registry from Dyn) from
=> KeyOpsRegistry (Untyped registry from) from where
deleteFromRegistryBool :: Untyped registry from -> from -> IO Bool
deleteFromRegistryBool (Untyped registry from Dyn
registry) from
from =
registry from Dyn -> from -> IO Bool
forall registry from.
KeyOpsRegistry registry from =>
registry -> from -> IO Bool
deleteFromRegistryBool registry from Dyn
registry from
from
deleteFromRegistry :: Untyped registry from -> from -> IO ()
deleteFromRegistry (Untyped registry from Dyn
registry) from
from =
registry from Dyn -> from -> IO ()
forall registry from.
KeyOpsRegistry registry from =>
registry -> from -> IO ()
deleteFromRegistry registry from Dyn
registry from
from
listKeys :: Untyped registry from -> IO [from]
listKeys (Untyped registry from Dyn
registry) = registry from Dyn -> IO [from]
forall registry from.
KeyOpsRegistry registry from =>
registry -> IO [from]
listKeys registry from Dyn
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 -> from -> Dyn -> IO ()
setValueAsDyn (Untyped registry from Dyn
registry) from
from Dyn
dyn =
registry from Dyn -> from -> Dyn -> IO ()
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> to -> IO ()
setValue registry from Dyn
registry from
from Dyn
dyn
getValueAsDyn :: Untyped registry from -> from -> IO Dyn
getValueAsDyn (Untyped registry from Dyn
registry) from
from =
registry from Dyn -> from -> IO Dyn
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> IO to
getValue registry from Dyn
registry from
from
type UnsafeRegistry from = Unsafe Registry from
data Obj = Obj
toObj :: a -> Obj
toObj :: a -> Obj
toObj = a -> Obj
unsafeCoerce#
fromObj :: Obj -> a
fromObj :: Obj -> a
fromObj = Obj -> a
unsafeCoerce#
newtype Unsafe registry from = Unsafe (registry from Obj)
instance NewRegistry (registry from Obj)
=> NewRegistry (Unsafe registry from) where
newRegistry :: IO (Unsafe registry from)
newRegistry =
do
registry from Obj
registry <- IO (registry from Obj)
forall registry. NewRegistry registry => IO registry
newRegistry
Unsafe registry from -> IO (Unsafe registry from)
forall (m :: * -> *) a. Monad m => a -> m a
return (registry from Obj -> Unsafe registry from
forall (registry :: * -> * -> *) from.
registry from Obj -> Unsafe registry from
Unsafe registry from Obj
registry)
emptyRegistry :: Unsafe registry from -> IO ()
emptyRegistry (Unsafe registry from Obj
registry) = registry from Obj -> IO ()
forall registry. NewRegistry registry => registry -> IO ()
emptyRegistry registry from Obj
registry
instance (GetSetRegistry (registry from Obj) from Obj)
=> GetSetRegistry (Unsafe registry from) from to where
transformValue :: Unsafe registry from
-> from -> (Maybe to -> IO (Maybe to, extra)) -> IO extra
transformValue (Unsafe registry from Obj
registry) from
from Maybe to -> IO (Maybe to, extra)
transformer =
do
let
transformerObj :: Maybe Obj -> IO (Maybe Obj, extra)
transformerObj Maybe Obj
objInOpt =
do
let valInOpt :: Maybe b
valInOpt = ((Obj -> b) -> Maybe Obj -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Obj -> b
forall a. Obj -> a
fromObj) Maybe Obj
objInOpt
(Maybe to
valOutOpt,extra
extra) <- Maybe to -> IO (Maybe to, extra)
transformer Maybe to
forall b. Maybe b
valInOpt
let objOutOpt :: Maybe Obj
objOutOpt = ((to -> Obj) -> Maybe to -> Maybe Obj
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap to -> Obj
forall a. a -> Obj
toObj) Maybe to
valOutOpt
(Maybe Obj, extra) -> IO (Maybe Obj, extra)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Obj
objOutOpt,extra
extra)
registry from Obj
-> from -> (Maybe Obj -> IO (Maybe Obj, extra)) -> IO extra
forall registry from to extra.
GetSetRegistry registry from to =>
registry -> from -> (Maybe to -> IO (Maybe to, extra)) -> IO extra
transformValue registry from Obj
registry from
from Maybe Obj -> IO (Maybe Obj, extra)
transformerObj
instance KeyOpsRegistry (registry from Obj) from
=> KeyOpsRegistry (Unsafe registry from) from where
deleteFromRegistryBool :: Unsafe registry from -> from -> IO Bool
deleteFromRegistryBool (Unsafe registry from Obj
registry) from
from =
registry from Obj -> from -> IO Bool
forall registry from.
KeyOpsRegistry registry from =>
registry -> from -> IO Bool
deleteFromRegistryBool registry from Obj
registry from
from
deleteFromRegistry :: Unsafe registry from -> from -> IO ()
deleteFromRegistry (Unsafe registry from Obj
registry) from
from =
registry from Obj -> from -> IO ()
forall registry from.
KeyOpsRegistry registry from =>
registry -> from -> IO ()
deleteFromRegistry registry from Obj
registry from
from
listKeys :: Unsafe registry from -> IO [from]
listKeys (Unsafe registry from Obj
registry) = registry from Obj -> IO [from]
forall registry from.
KeyOpsRegistry registry from =>
registry -> IO [from]
listKeys registry from Obj
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 :: IO (LockedRegistry from to)
newRegistry =
do
Registry from (MVar (Maybe to), Set ThreadId)
registry <- IO (Registry from (MVar (Maybe to), Set ThreadId))
forall registry. NewRegistry registry => IO registry
newRegistry
LockedRegistry from to -> IO (LockedRegistry from to)
forall (m :: * -> *) a. Monad m => a -> m a
return (Registry from (MVar (Maybe to), Set ThreadId)
-> LockedRegistry from to
forall from to.
Registry from (MVar (Maybe to), Set ThreadId)
-> LockedRegistry from to
Locked Registry from (MVar (Maybe to), Set ThreadId)
registry)
emptyRegistry :: LockedRegistry from to -> IO ()
emptyRegistry (Locked Registry from (MVar (Maybe to), Set ThreadId)
registry) = Registry from (MVar (Maybe to), Set ThreadId) -> IO ()
forall registry. NewRegistry registry => registry -> IO ()
emptyRegistry Registry from (MVar (Maybe to), Set ThreadId)
registry
takeVal :: Ord from => LockedRegistry from to -> from -> IO (Maybe to)
takeVal :: LockedRegistry from to -> from -> IO (Maybe to)
takeVal (Locked Registry from (MVar (Maybe to), Set ThreadId)
registry) from
from =
do
MVar (Maybe to)
mVar <-
Registry from (MVar (Maybe to), Set ThreadId)
-> from
-> (Maybe (MVar (Maybe to), Set ThreadId)
-> IO (Maybe (MVar (Maybe to), Set ThreadId), MVar (Maybe to)))
-> IO (MVar (Maybe to))
forall registry from to extra.
GetSetRegistry registry from to =>
registry -> from -> (Maybe to -> IO (Maybe to, extra)) -> IO extra
transformValue Registry from (MVar (Maybe to), Set ThreadId)
registry from
from
(\ Maybe (MVar (Maybe to), Set ThreadId)
dataOpt ->
do
ThreadId
threadId <- IO ThreadId
myThreadId
case Maybe (MVar (Maybe to), Set ThreadId)
dataOpt of
Maybe (MVar (Maybe to), Set ThreadId)
Nothing ->
do
MVar (Maybe to)
mVar <- Maybe to -> IO (MVar (Maybe to))
forall a. a -> IO (MVar a)
newMVar Maybe to
forall b. Maybe b
Nothing
(Maybe (MVar (Maybe to), Set ThreadId), MVar (Maybe to))
-> IO (Maybe (MVar (Maybe to), Set ThreadId), MVar (Maybe to))
forall (m :: * -> *) a. Monad m => a -> m a
return ((MVar (Maybe to), Set ThreadId)
-> Maybe (MVar (Maybe to), Set ThreadId)
forall a. a -> Maybe a
Just (MVar (Maybe to)
mVar,ThreadId -> Set ThreadId
forall a. a -> Set a
Set.singleton ThreadId
threadId),MVar (Maybe to)
mVar)
Just (MVar (Maybe to)
mVar,Set ThreadId
set0) ->
if ThreadId -> Set ThreadId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ThreadId
threadId Set ThreadId
set0
then
ObjectID
-> [Char]
-> IO (Maybe (MVar (Maybe to), Set ThreadId), MVar (Maybe to))
ObjectID -> BreakFn
mkBreakFn ObjectID
lockedFallOutId
([Char]
"Circular transformValue detected in "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Registry.LockedRegistry")
else
(Maybe (MVar (Maybe to), Set ThreadId), MVar (Maybe to))
-> IO (Maybe (MVar (Maybe to), Set ThreadId), MVar (Maybe to))
forall (m :: * -> *) a. Monad m => a -> m a
return ((MVar (Maybe to), Set ThreadId)
-> Maybe (MVar (Maybe to), Set ThreadId)
forall a. a -> Maybe a
Just (MVar (Maybe to)
mVar,ThreadId -> Set ThreadId -> Set ThreadId
forall a. Ord a => a -> Set a -> Set a
Set.insert ThreadId
threadId Set ThreadId
set0),MVar (Maybe to)
mVar)
)
MVar (Maybe to) -> IO (Maybe to)
forall a. MVar a -> IO a
takeMVar MVar (Maybe to)
mVar
putVal :: Ord from => LockedRegistry from to -> from -> Maybe to -> IO ()
putVal :: LockedRegistry from to -> from -> Maybe to -> IO ()
putVal (Locked Registry from (MVar (Maybe to), Set ThreadId)
registry) from
from Maybe to
toOpt =
Registry from (MVar (Maybe to), Set ThreadId)
-> from
-> (Maybe (MVar (Maybe to), Set ThreadId)
-> IO (Maybe (MVar (Maybe to), Set ThreadId), ()))
-> IO ()
forall registry from to extra.
GetSetRegistry registry from to =>
registry -> from -> (Maybe to -> IO (Maybe to, extra)) -> IO extra
transformValue Registry from (MVar (Maybe to), Set ThreadId)
registry from
from
(\ Maybe (MVar (Maybe to), Set ThreadId)
dataOpt ->
do
ThreadId
threadId <- IO ThreadId
myThreadId
case Maybe (MVar (Maybe to), Set ThreadId)
dataOpt of
Maybe (MVar (Maybe to), Set ThreadId)
Nothing -> [Char] -> IO (Maybe (MVar (Maybe to), Set ThreadId), ())
forall a. HasCallStack => [Char] -> a
error [Char]
"Registry: unmatched putVal"
Just (MVar (Maybe to)
mVar,Set ThreadId
set0) ->
do
let
set1 :: Set ThreadId
set1 = ThreadId -> Set ThreadId -> Set ThreadId
forall a. Ord a => a -> Set a -> Set a
Set.delete ThreadId
threadId Set ThreadId
set0
if Set ThreadId -> Bool
forall a. Set a -> Bool
Set.null Set ThreadId
set1 Bool -> Bool -> Bool
&& Bool -> Bool
not (Maybe to -> Bool
forall a. Maybe a -> Bool
isJust Maybe to
toOpt)
then
(Maybe (MVar (Maybe to), Set ThreadId), ())
-> IO (Maybe (MVar (Maybe to), Set ThreadId), ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MVar (Maybe to), Set ThreadId)
forall b. Maybe b
Nothing,())
else
do
MVar (Maybe to) -> Maybe to -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe to)
mVar Maybe to
toOpt
(Maybe (MVar (Maybe to), Set ThreadId), ())
-> IO (Maybe (MVar (Maybe to), Set ThreadId), ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((MVar (Maybe to), Set ThreadId)
-> Maybe (MVar (Maybe to), Set ThreadId)
forall a. a -> Maybe a
Just (MVar (Maybe to)
mVar,Set ThreadId
set1),())
)
lockedRegistryCheck :: IO a -> IO (Either String a)
lockedFallOutId :: ObjectID
(ObjectID
lockedFallOutId,IO a -> IO (Either [Char] a)
lockedRegistryCheck) = (ObjectID, IO a -> IO (Either [Char] a))
forall a. (ObjectID, IO a -> IO (Either [Char] a))
lockedCheckBreak
lockedCheckBreak :: (ObjectID,IO a -> IO (Either String a))
lockedCheckBreak :: (ObjectID, IO a -> IO (Either [Char] a))
lockedCheckBreak = IO (ObjectID, IO a -> IO (Either [Char] a))
-> (ObjectID, IO a -> IO (Either [Char] a))
forall a. IO a -> a
unsafePerformIO IO (ObjectID, IO a -> IO (Either [Char] a))
forall a. IO (ObjectID, IO a -> IO (Either [Char] a))
newFallOut
{-# NOINLINE lockedCheckBreak #-}
instance Ord from => GetSetRegistry (LockedRegistry from to) from to where
transformValue :: LockedRegistry from to
-> from -> (Maybe to -> IO (Maybe to, extra)) -> IO extra
transformValue LockedRegistry from to
lockedRegistry from
from Maybe to -> IO (Maybe to, extra)
transformer =
do
Maybe to
valInOpt <- LockedRegistry from to -> from -> IO (Maybe to)
forall from to.
Ord from =>
LockedRegistry from to -> from -> IO (Maybe to)
takeVal LockedRegistry from to
lockedRegistry from
from
Either SomeException (Maybe to, extra)
resultOrError <- IO (Maybe to, extra) -> IO (Either SomeException (Maybe to, extra))
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (Maybe to -> IO (Maybe to, extra)
transformer Maybe to
valInOpt)
case Either SomeException (Maybe to, extra)
resultOrError of
Left SomeException
error ->
do
LockedRegistry from to -> from -> Maybe to -> IO ()
forall from to.
Ord from =>
LockedRegistry from to -> from -> Maybe to -> IO ()
putVal LockedRegistry from to
lockedRegistry from
from Maybe to
valInOpt
SomeException -> IO extra
forall a e. Exception e => e -> a
Control.Exception.throw (SomeException
error :: SomeException)
Right (Maybe to
valOutOpt,extra
extra) ->
do
LockedRegistry from to -> from -> Maybe to -> IO ()
forall from to.
Ord from =>
LockedRegistry from to -> from -> Maybe to -> IO ()
putVal LockedRegistry from to
lockedRegistry from
from Maybe to
valOutOpt
extra -> IO extra
forall (m :: * -> *) a. Monad m => a -> m a
return extra
extra
instance Ord from => KeyOpsRegistry (LockedRegistry from to) from where
deleteFromRegistryBool :: LockedRegistry from to -> from -> IO Bool
deleteFromRegistryBool LockedRegistry from to
lockedRegistry from
from =
do
Maybe to
toOpt <- LockedRegistry from to -> from -> IO (Maybe to)
forall from to.
Ord from =>
LockedRegistry from to -> from -> IO (Maybe to)
takeVal LockedRegistry from to
lockedRegistry from
from
LockedRegistry from to -> from -> Maybe to -> IO ()
forall from to.
Ord from =>
LockedRegistry from to -> from -> Maybe to -> IO ()
putVal LockedRegistry from to
lockedRegistry from
from Maybe to
forall b. Maybe b
Nothing
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe to -> Bool
forall a. Maybe a -> Bool
isJust Maybe to
toOpt)
listKeys :: LockedRegistry from to -> IO [from]
listKeys (Locked Registry from (MVar (Maybe to), Set ThreadId)
registry) = Registry from (MVar (Maybe to), Set ThreadId) -> IO [from]
forall registry from.
KeyOpsRegistry registry from =>
registry -> IO [from]
listKeys Registry from (MVar (Maybe to), Set ThreadId)
registry
getValueSafe :: GetSetRegistry registry from to
=> String -> registry -> from -> IO to
getValueSafe :: [Char] -> registry -> from -> IO to
getValueSafe = [Char] -> registry -> from -> IO to
forall registry from to.
GetSetRegistry registry from to =>
[Char] -> registry -> from -> IO to
getValue'
getValue' :: GetSetRegistry registry from to
=> String -> registry -> from -> IO to
getValue' :: [Char] -> registry -> from -> IO to
getValue' =
if Bool
isDebug
then
(\ [Char]
label registry
registry from
from ->
do
Maybe to
toOpt <- registry -> from -> IO (Maybe to)
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> IO (Maybe to)
getValueOpt registry
registry from
from
case Maybe to
toOpt of
Maybe to
Nothing -> [Char] -> IO to
forall a. HasCallStack => [Char] -> a
error ([Char]
"Registry.getValue' - failed with "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
label)
Just to
to -> to -> IO to
forall (m :: * -> *) a. Monad m => a -> m a
return to
to
)
else
(\ [Char]
label -> registry -> from -> IO to
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> IO to
getValue)
instance (HasBinary (from,to) m,Ord from,MonadIO m)
=> HasBinary (Registry from to) m where
writeBin :: WriteBinary m -> Registry from to -> m ()
writeBin = (Registry from to -> IO [(from, to)])
-> WriteBinary m -> Registry from to -> m ()
forall b (m :: * -> *) a.
(HasBinary b m, MonadIO m) =>
(a -> IO b) -> WriteBinary m -> a -> m ()
mapWriteIO Registry from to -> IO [(from, to)]
forall (registry :: * -> * -> *) from to.
ListRegistryContents registry from to =>
registry from to -> IO [(from, to)]
listRegistryContents
readBin :: ReadBinary m -> m (Registry from to)
readBin = ([(from, to)] -> IO (Registry from to))
-> ReadBinary m -> m (Registry from to)
forall b (m :: * -> *) a.
(HasBinary b m, MonadIO m) =>
(b -> IO a) -> ReadBinary m -> m a
mapReadIO [(from, to)] -> IO (Registry from to)
forall (registry :: * -> * -> *) from to.
ListRegistryContents registry from to =>
[(from, to)] -> IO (registry from to)
listToNewRegistry