{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NoMonoPatBinds #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Description: Store information by key.
--
-- A Registry is a mapping from ordered values.  For the Registry
-- type itself, all target values have the same type.  For the
-- UntypedRegistry type, the values
-- can have any Typeable type.
module Util.Registry(
   Registry, -- A "Registry from to" maps from values to to values.
   UntypedRegistry, -- An "UntypedRegistry from" maps from values to
                -- any Typeable values.
   LockedRegistry, -- A "LockedRegistry from to" is like a
      -- "Registry from to" but with finer locking.
   UntypedLockedRegistry, -- An "UntypedLockedRegistry from" is
      -- like an "UntypedRegistry from" but with finer locking.
   Untyped, -- Type constructor for registries with untyped contents.

   -- Unsafe/UnsafeRegistry are equivalent to Untyped/UntypedRegistry except
   -- for the additional functionality of causing a core-dump if misused,
   -- and not requiring Typeable.  THIS WILL GO IN GHC6.04
   Unsafe,
   UnsafeRegistry,

   NewRegistry(..),
   GetSetRegistry(..),
   GetSetRegistryDyn(..), -- direct access to dynamic values in
      -- Untyped's.
   KeyOpsRegistry(..),
      -- These classes describe access operations for registries.
   ListRegistryContents(..),
      -- extra block functions for typed registries.

   -- other specific operations
   changeKey,
      -- :: Ord from => Registry from to -> from -> from -> IO ()

   -- Operation for getting values directly from a Registry
   getRegistryValue,
      -- :: Ord from => Registry from to -> from -> IO to
      -- (This can be used to get a value without having to put
      -- a type annotation on it.)

   getValueDefault, -- :: ... => to -> registry -> from -> IO to

   lockedRegistryCheck, -- :: IO a -> IO (Either String a)
      -- For operations involving LockedRegistry's, catches the exception
      -- raised when we attempt to access a value inside a transformValue
      -- operation.


   getValue',
      -- Function to be used instead of getValue for debugging purposes.
   getValueSafe,
      -- alias for that (useful in combination with CPP).
   getRegistryValueSafe,
      -- :: Ord from => String -> Registry from to -> from -> IO to
      -- corresponds to getValueSafe and getRegistryValue
   ) 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#)
   -- Ouch.  Will go with ghc6

import Util.ExtendedPrelude(newFallOut,mkBreakFn)
import Util.Dynamics
import Util.BinaryAll
import Util.CompileFlags
import Util.Object(ObjectID)


-- ----------------------------------------------------------------------
-- Classes, which describe the implementation.
-- ----------------------------------------------------------------------

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
      -- transform a value, where "Nothing" means "value is not in
      -- the registry.  Locking is important, but depends on the
      -- implementation.
      -- Only this function has to be defined.
   getValueOpt :: registry -> from -> IO (Maybe to)
      -- returns Nothing if the value is not defined or
      -- has the wrong type.
   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
      -- should raise an IO error if the value is not defined or-
      -- (for Untyped) has the wrong type.
   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,()))


-- | ListRegistryContents will not be implemented for the untyped registries.
class ListRegistryContents registry from to where
   listRegistryContents :: registry from to -> IO [(from,to)]

   listRegistryContentsAndEmptyRegistry :: registry from to -> IO [(from,to)]
      -- ^ this is atomic.

   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
   -- deleteFromRegistryBool returns True if the element was in
   -- the registry and deletes it, otherwise False (and does nothing).
   deleteFromRegistry :: registry -> from -> IO ()
   -- This should fail silently if the key does not
   -- exist in the map.
   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]

-- ----------------------------------------------------------------------
-- Typed registries
-- The locking here for transformValue is not so clever and just locks the
-- whole map while the fallback action runs.
-- ----------------------------------------------------------------------

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)

-- | look up the element given by the first key, and if it exists
-- delete it, replacing it with the element given by the second key.
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
         )
      )

-- ----------------------------------------------------------------------
-- Untyped Registries
-- ----------------------------------------------------------------------

-- We abbreviate a common case:
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

-- We also provide direct setting/unsetting of Dyn values.
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

-- ----------------------------------------------------------------------
-- Unsafe Registries
-- To be used only in dire emergency where GHC's obscure multi-parameter
-- type rules aren't able to infer Typeable, these will cause core dumps
-- if the types are wrong.
-- ----------------------------------------------------------------------

type UnsafeRegistry from = Unsafe Registry from

data Obj = Obj
 -- to hold the value, which may be of any type.

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

-- ----------------------------------------------------------------------
-- Locked registries.  These improve on the previous model in
-- that transformValue actions do not lock the whole registry,
-- but only the key whose value is being transformed.
--
-- They also catch cases where an locked registry function is used
-- inside a transformValue, and throw an appropriate exception, which
-- can be caught using lockedRegistryCheck.
-- ----------------------------------------------------------------------

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

-- utility functions transformValue will need
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 -- error
                              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


-- ----------------------------------------------------------------------
-- Function to be preferred to getValue when it is not absolutely certain
-- if a value is there, since it prints the label if things go wrong.
-- ----------------------------------------------------------------------

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 of HasBinary for monads which have IO.
-- ----------------------------------------------------------------------

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