module Control.Monad.Trans.Order.Lazy (
Order,
evalOrder,
evalOrderWith,
OrderT,
evalOrderT,
force,
Element,
newMinimum,
newMaximum,
newAfter,
newBefore
) where
import Control.Monad.ST
import Control.Monad.Trans.State.Lazy
import Control.Monad.Trans.Order.Raw
import Control.Monad.Trans.Order.Lazy.Internals
import Control.Monad.Trans.Order.Algorithm
import Control.Monad.Trans.Order.Algorithm.Type
import Data.Functor.Identity
import Data.IORef
import System.IO.Unsafe
import GHC.IORef
type Order o = OrderT o Identity
evalOrder :: (forall o . Order o a) -> a
evalOrder order = runIdentity (evalOrderT order)
evalOrderWith :: Algorithm -> (forall o . Order o a) -> a
evalOrderWith alg order = runIdentity (evalOrderTWith alg order)
evalOrderT :: Monad m => (forall o . OrderT o m a) -> m a
evalOrderT = evalOrderTWith defaultAlgorithm
evalOrderTWith :: Monad m => Algorithm -> (forall o . OrderT o m a) -> m a
evalOrderTWith (Algorithm rawAlg) (OrderT stateT) = monad where
monad = evalStateT stateT (emptyOrderRep rawAlg)
force :: Monad m => OrderT o m ()
force = OrderT $ get >>= \ order -> order `seq` return ()
data Element o = Element (RawElement o RealWorld)
(RawAlgorithm o RealWorld)
Lock
instance Eq (Element o) where
(==) (Element rawElem1 (RawAlgorithm _ _ _ _ _ _ _) _)
(Element rawElem2 _ _) = equal where
equal = rawElem1 == rawElem2
instance Ord (Element o) where
compare (Element rawElem1 rawAlg lock)
(Element rawElem2 _ _) = ordering where
ordering = unsafePerformIO $
criticalSection lock $
stToIO $ compareElements rawAlg rawElem1 rawElem2
fromInsert :: Monad m
=> (RawAlgorithm o RealWorld
-> RawOrder o RealWorld
-> ST RealWorld (RawElement o RealWorld))
-> OrderT o m (Element o)
fromInsert insert = OrderT $ StateT (return . explicitStateInsert) where
explicitStateInsert order@(OrderRep rawOrder rawAlg lock) = output where
output = unsafePerformIO $
criticalSection lock $
do
rawElem <- stToIO $ insert rawAlg rawOrder
mkWeakIORef (IORef rawElem)
(criticalSection lock $
stToIO $
delete rawAlg rawElem rawOrder)
return (Element rawElem rawAlg lock, order)
newMinimum :: Monad m => OrderT o m (Element o)
newMinimum = fromInsert insertMinimum
newMaximum :: Monad m => OrderT o m (Element o)
newMaximum = fromInsert insertMaximum
newAfter :: Monad m => Element o -> OrderT o m (Element o)
newAfter (~(Element rawElem _ _)) = fromInsert (flip insertAfter rawElem)
newBefore :: Monad m => Element o -> OrderT o m (Element o)
newBefore (~(Element rawElem _ _)) = fromInsert (flip insertBefore rawElem)