-- Mutable sets.

module MutSet (
      MutSet, Remover, RemoverRef,callRemoverRef,mkRemover
    , newMutSet, clearMutSet, checkEmptyMutSet
    , sizeMutSet, addToMutSet
    , foreachInMutSet, foreachInMutSetRev,getMutSet,itemVal
    , killMutSet
    ) where

import IOExts                           -- IORefs
import Monad (unless)
import Compatibility
import Weak
import Utils
import Remover

-- Represent a weak set as a size and a mutable list.
-- There is also an iteration variable to say how many times the 
-- mutset has been cleared. We use this to prevent delete
-- actions being run after clearing. (See add and remove below)
-- It can also have been killed. In this case adding elements does 
-- nothing.

type MutSet a = IORef (MutSetRef a)
data MutSetRef a = MutSetRef {mutSize :: ! Int, 
			      mutIter :: ! Int,
                              mutElts :: ! (MutList a)} 
		 | DeadSetRef

type MutList a = Maybe (MutListEltRef a)
type MutListEltRef a = IORef (MutListElt a)
data MutListElt a = MutListElt {
	itemVal :: ! a,
	lastItem :: ! (MutList a),
	nextItem :: ! (MutList a),
	killRemover :: IO ()
	}


instance Show (MutSetRef a) where
 show _ = "<MutSetRef>"

--instance Show (MutList a) where
-- show _ = "<MutList>"

--instance Show (MutSet a) where
-- show _ = "<MutSet>"

-- mutlist is an element, a pointer to the next element, and
-- a pointer to the previous element

newMutSet :: IO (MutSet a)
newMutSet = newIORef $ MutSetRef 0 0 Nothing

killMutSet :: MutSet a -> IO ()
killMutSet ref = do
 rms <- getMutSet killRemover ref
 sequence rms
 writeIORef ref DeadSetRef

clearMutSet :: MutSet a -> IO ()
clearMutSet ref = do
 -- we've cleared the mutset so add one to the iteration counter
 iter <- fmap mutIter $ readIORef ref
 rms <- getMutSet killRemover ref
 sequence rms
 writeIORef ref (MutSetRef 0 (iter + 1) Nothing)

checkEmptyMutSet :: String -> MutSet a -> IO ()
checkEmptyMutSet nonemptyMsg ref = do
 ms <- readIORef ref
 case ms of
  DeadSetRef -> return ()
  (MutSetRef {mutElts = items, mutSize = n}) -> 
   case items of 
    Nothing | n == 0 -> putStrLn ("cleared empty mutset " ++ nonemptyMsg) >> return ()
    _ -> do
      putStrLn (nonemptyMsg ++ ": had " ++ show n
             ++ " item" ++ (if n ==1 then "" else "s"))
      clearMutSet ref

sizeMutSet :: MutSet b -> IO (Maybe Int)
sizeMutSet ref = do
 ms <- readIORef ref
 case ms of
  DeadSetRef -> return $! Nothing
  MutSetRef {mutSize = n} -> return $! Just n

 
addToMutSet :: MutSet a -> a -> IO Remover
addToMutSet ref a = do
 ms <- readIORef ref 
 case ms of
  DeadSetRef -> return (return ())
  (MutSetRef numelts iter head) -> do
   remref <- newIORef (return ())
   let elt = MutListElt a Nothing head (writeIORef remref (return ()))
   itemRef <- newIORef $! elt
   let itemList = Just itemRef
   case head of
     Nothing -> return ()
     Just theref -> do
      updIORef theref $ \v -> v {lastItem = itemList}
   writeIORef ref $! MutSetRef (numelts+1) iter itemList
   writeIORef remref $ removeFromMutSet ref itemRef iter
   return (callRemoverRef remref)

-- Remove.  Not exported. 
removeFromMutSet :: MutSet a -> MutListEltRef a -> Int -> IO ()
removeFromMutSet mset itemRef iter = do
 ms <- readIORef mset
 case ms of
  DeadSetRef -> return ()
  m@(MutSetRef {mutSize = size, mutIter = thisiter,mutElts = elts}) -> do
   -- check if mut set has been cleared since this remove action was created
   -- if so the item is already gone so don't do anything
   unless (iter /= thisiter) $ do
    (MutListElt _ last next _) <- readIORef itemRef
    link mset (m {mutSize = size - 1}) last next

link :: MutSet a -> MutSetRef a -> MutList a -> MutList a -> IO ()
link mset m Nothing Nothing = 
  -- there is nothing before or after element so head of list is now Null
    writeIORef mset (m {mutElts = Nothing})

link mset m Nothing ml@(Just nextRef) = do
  -- there is nothing before this element but something after it, so
  -- next element becomes new head of list
    updIORef nextRef $ \e -> e {lastItem = Nothing}
    writeIORef mset (m {mutElts = ml})
 
link mset m (Just lastRef) Nothing = do
  -- there is nothing after this element but something before it, so
  -- point previous element's forward reference to Null.
    updIORef lastRef $ \e -> e {nextItem = Nothing}
    writeIORef mset m

link mset m last@(Just lastRef) 
            next@(Just nextRef)
               = do
  -- there is something before and after this element, so point previous
  -- elts forward reference to the next element, and next elements back reference
  -- to the previous element.
     updIORef lastRef $ \e -> e {nextItem = next}
     updIORef nextRef $ \e -> e {lastItem = last} 
     writeIORef mset m


foreachInMutSet :: MutSet a -> (a -> IO ()) -> IO ()
foreachInMutSet mset f = getMutSet itemVal mset >>= mapM_ f 

foreachInMutSetRev :: MutSet a -> (a -> IO ()) -> IO ()
foreachInMutSetRev mset f = getMutSet itemVal mset >>= mapM_ f . reverse 

getMutSet :: (MutListElt a -> b) -> MutSet a -> IO [b]
getMutSet get ref = do
  ms <- readIORef ref
  case ms of
   DeadSetRef -> return []
   (MutSetRef {mutElts = elts,mutSize = sz}) -> runAlong elts []
 where

  -- build up a reverse ordered list of actions to perform, then when we've got all
  -- necessary actions peform them all.
  -- Why? - because an action can include deleting itself or other elements from the list 
  -- this may seriously mess up list traversal?

  --runAlong :: MutList a -> [b] -> IO [b]
  runAlong Nothing xs = return $! xs
  runAlong (Just itemRef) xs = do 
    me@(MutListElt {nextItem = next}) <- readIORef itemRef
    runAlong next (get me:xs)

{-
test = do
 m <- newMutSet 
 foreachInMutSet m (\s -> do putStrLn s)
 putStrLn "empty"

 r4 <- addToMutSet m "n4"
 foreachInMutSet m (\s -> do putStrLn s)
 putStrLn "posses n4"

 r3 <- addToMutSet m "n3"
 foreachInMutSet m (\s -> do putStrLn s)
 putStrLn "posses n3 n4"

 r2 <- addToMutSet m "n2"
 foreachInMutSet m (\s -> do putStrLn s)
 putStrLn "posses n2 n3 n4"

 r1 <- addToMutSet m "n1"
 foreachInMutSet m (\s -> do putStrLn s)
 putStrLn "posses n1 n2 n3 n4"

 r2
 foreachInMutSet m (\s -> do putStrLn s)
 putStrLn "possess n1 n3 n4"

 r2 
 foreachInMutSet m (\s -> do putStrLn s)
 putStrLn "possess n1 n3 n4"

 r3 
 foreachInMutSet m (\s -> do putStrLn s)
 putStrLn "possess n1 n4"


 r2
 foreachInMutSet m (\s -> do putStrLn s)
 putStrLn "possess n1 n4"


 r4
 foreachInMutSet m (\s -> do putStrLn s)
 putStrLn "possess n1"

 r1
 foreachInMutSet m (\s -> do putStrLn s)
 putStrLn "possess empty"
-}
