module Data.LVar.PureMap
(
IMap,
newEmptyMap, newMap, newFromList,
insert,
getKey, waitValue, waitSize, modify,
forEach, forEachHP,
withCallbacksThenFreeze,
freezeMap, fromIMap,
copy, traverseMap, traverseMap_, union,
traverseMapHP, traverseMapHP_, unionHP
) where
import Control.Monad (void)
import Control.Exception (throw)
import Control.Applicative (Applicative, (<$>),(*>), pure, getConst, Const(Const))
import Data.Monoid (Monoid(..))
import Data.IORef
import qualified Data.Map.Strict as M
import qualified Data.LVar.IVar as IV
import qualified Data.Foldable as F
import Data.LVar.Generic
import Data.LVar.Generic.Internal (unsafeCoerceLVar)
import Data.UtilInternal (traverseWithKey_)
import Data.List (intersperse)
import Control.LVish.DeepFrz.Internal
import Control.LVish
import Control.LVish.Internal as LI
import Control.LVish.SchedIdempotent (newLV, putLV, putLV_, getLV, freezeLV, freezeLVAfter)
import qualified Control.LVish.SchedIdempotent as L
import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO)
import System.Mem.StableName (makeStableName, hashStableName)
newtype IMap k s v = IMap (LVar s (IORef (M.Map k v)) (k,v))
instance Eq (IMap k s v) where
IMap lv1 == IMap lv2 = state lv1 == state lv2
instance LVarData1 (IMap k) where
freeze orig@(IMap (WrapLVar lv)) = WrapPar$ do freezeLV lv; return (unsafeCoerceLVar orig)
addHandler mh mp fn = forEachHP mh mp (\ _k v -> fn v)
sortFrzn (IMap lv) = AFoldable$ unsafeDupablePerformIO (readIORef (state lv))
instance OrderedLVarData1 (IMap k) where
snapFreeze is = unsafeCoerceLVar <$> freeze is
instance F.Foldable (IMap k Frzn) where
foldr fn zer (IMap lv) =
let set = unsafeDupablePerformIO (readIORef (state lv)) in
F.foldr fn zer set
instance F.Foldable (IMap k Trvrsbl) where
foldr fn zer mp = F.foldr fn zer (castFrzn mp)
instance DeepFrz a => DeepFrz (IMap k s a) where
type FrzType (IMap k s a) = IMap k Frzn (FrzType a)
frz = unsafeCoerceLVar
instance (Show k, Show a) => Show (IMap k Frzn a) where
show (IMap lv) =
let mp' = unsafeDupablePerformIO (readIORef (state lv)) in
"{IMap: " ++
(concat $ intersperse ", " $ map show $
M.toList mp') ++ "}"
instance (Show k, Show a) => Show (IMap k Trvrsbl a) where
show lv = show (castFrzn lv)
newEmptyMap :: Par d s (IMap k s v)
newEmptyMap = WrapPar$ fmap (IMap . WrapLVar) $ newLV$ newIORef M.empty
newMap :: M.Map k v -> Par d s (IMap k s v)
newMap m = WrapPar$ fmap (IMap . WrapLVar) $ newLV$ newIORef m
newFromList :: (Ord k, Eq v) =>
[(k,v)] -> Par d s (IMap k s v)
newFromList = newMap . M.fromList
withCallbacksThenFreeze :: forall k v b s . Eq b =>
IMap k s v -> (k -> v -> QPar s ()) -> QPar s b -> QPar s b
withCallbacksThenFreeze (IMap (WrapLVar lv)) callback action =
do hp <- newPool
res <- IV.new
WrapPar$ freezeLVAfter lv (initCB hp res) deltaCB
quiesce hp
IV.get res
where
deltaCB (k,v) = return$ Just$ unWrapPar $ callback k v
initCB :: HandlerPool -> IV.IVar s b -> (IORef (M.Map k v)) -> IO (Maybe (L.Par ()))
initCB hp resIV ref = do
mp <- readIORef ref
return $ Just $ unWrapPar $ do
traverseWithKey_ (\ k v -> forkHP (Just hp)$ callback k v) mp
res <- action
IV.put_ resIV res
forEachHP :: Maybe HandlerPool
-> IMap k s v
-> (k -> v -> Par d s ())
-> Par d s ()
forEachHP mh (IMap (WrapLVar lv)) callb = WrapPar $ do
L.addHandler mh lv globalCB deltaCB
return ()
where
deltaCB (k,v) = return$ Just$ unWrapPar $ callb k v
globalCB ref = do
mp <- readIORef ref
return $ Just $ unWrapPar $
traverseWithKey_ (\ k v -> forkHP mh$ callb k v) mp
forEach :: IMap k s v -> (k -> v -> Par d s ()) -> Par d s ()
forEach = forEachHP Nothing
insert :: (Ord k, Eq v) =>
k -> v -> IMap k s v -> Par d s ()
insert !key !elm (IMap (WrapLVar lv)) = WrapPar$ putLV lv putter
where putter ref = atomicModifyIORef' ref update
update mp =
let mp' = M.insertWith fn key elm mp
fn v1 v2 | v1 == v2 = v1
| otherwise = throw$ ConflictingPutExn$ "Multiple puts to one entry in an IMap!"
in
if M.size mp' > M.size mp
then (mp',Just (key,elm))
else (mp, Nothing)
modify :: forall f a b d s key . (Ord key, LVarData1 f, Show key, Ord a) =>
IMap key s (f s a)
-> key
-> (Par d s (f s a))
-> (f s a -> Par d s b)
-> Par d s b
modify (IMap lv) key newBottom fn = WrapPar $ do
let ref = state lv
mp <- L.liftIO$ readIORef ref
case M.lookup key mp of
Just lv2 -> do L.logStrLn$ " [Map.modify] key already present: "++show key++
" adding to inner "++show(unsafeName lv2)
unWrapPar$ fn lv2
Nothing -> do
bot <- unWrapPar newBottom :: L.Par (f s a)
L.logStrLn$ " [Map.modify] allocated new inner "++show(unsafeName bot)
let putter _ = L.liftIO$ atomicModifyIORef' ref $ \ mp2 ->
case M.lookup key mp2 of
Just lv2 -> (mp2, (Nothing, unWrapPar$ fn lv2))
Nothing -> (M.insert key bot mp2,
(Just (key, bot),
do L.logStrLn$ " [Map.modify] key absent, adding the new one."
unWrapPar$ fn bot))
act <- putLV_ (unWrapLVar lv) putter
act
getKey :: Ord k => k -> IMap k s v -> Par d s v
getKey !key (IMap (WrapLVar lv)) = WrapPar$ getLV lv globalThresh deltaThresh
where
globalThresh ref _frzn = do
mp <- readIORef ref
return (M.lookup key mp)
deltaThresh (k,v) | k == key = return$ Just v
| otherwise = return Nothing
waitValue :: (Ord k, Eq v) => v -> IMap k s v -> Par d s ()
waitValue !val (IMap (WrapLVar lv)) = WrapPar$ getLV lv globalThresh deltaThresh
where
globalThresh ref _frzn = do
mp <- readIORef ref
let fn Nothing v | v == val = Just ()
| otherwise = Nothing
fn just _ = just
return $! M.foldl fn Nothing mp
deltaThresh (_,v) | v == val = return$ Just ()
| otherwise = return Nothing
waitSize :: Int -> IMap k s v -> Par d s ()
waitSize !sz (IMap (WrapLVar lv)) = WrapPar $
getLV lv globalThresh deltaThresh
where
globalThresh ref _frzn = do
mp <- readIORef ref
case M.size mp >= sz of
True -> return (Just ())
False -> return (Nothing)
deltaThresh _ = globalThresh (L.state lv) False
freezeMap :: IMap k s v -> QPar s (M.Map k v)
freezeMap (IMap (WrapLVar lv)) = WrapPar $
do freezeLV lv
getLV lv globalThresh deltaThresh
where
globalThresh _ False = return Nothing
globalThresh ref True = fmap Just $ readIORef ref
deltaThresh _ = return Nothing
fromIMap :: IMap k Frzn a -> M.Map k a
fromIMap (IMap lv) = unsafeDupablePerformIO (readIORef (state lv))
traverseMap :: (Ord k, Eq b) =>
(k -> a -> Par d s b) -> IMap k s a -> Par d s (IMap k s b)
traverseMap f s = traverseMapHP Nothing f s
traverseMap_ :: (Ord k, Eq b) =>
(k -> a -> Par d s b) -> IMap k s a -> IMap k s b -> Par d s ()
traverseMap_ f s o = traverseMapHP_ Nothing f s o
union :: (Ord k, Eq a) => IMap k s a -> IMap k s a -> Par d s (IMap k s a)
union = unionHP Nothing
copy :: (Ord k, Eq v) => IMap k s v -> Par d s (IMap k s v)
copy = traverseMap (\ _ x -> return x)
traverseMapHP :: (Ord k, Eq b) =>
Maybe HandlerPool -> (k -> a -> Par d s b) -> IMap k s a ->
Par d s (IMap k s b)
traverseMapHP mh fn set = do
os <- newEmptyMap
traverseMapHP_ mh fn set os
return os
traverseMapHP_ :: (Ord k, Eq b) =>
Maybe HandlerPool -> (k -> a -> Par d s b) -> IMap k s a -> IMap k s b ->
Par d s ()
traverseMapHP_ mh fn set os = do
forEachHP mh set $ \ k x -> do
x' <- fn k x
insert k x' os
unionHP :: (Ord k, Eq a) => Maybe HandlerPool ->
IMap k s a -> IMap k s a -> Par d s (IMap k s a)
unionHP mh m1 m2 = do
os <- newEmptyMap
forEachHP mh m1 (\ k v -> insert k v os)
forEachHP mh m2 (\ k v -> insert k v os)
return os
unsafeName :: a -> Int
unsafeName x = unsafePerformIO $ do
sn <- makeStableName x
return (hashStableName sn)