module Data.Order.Internals (
OrderRep (OrderRep),
newOrderRep,
localOrderRep,
AlgorithmOf,
Local,
Global,
Element (Element),
newMinimum,
newMaximum,
newAfter,
newBefore
) where
import Control.Monad.ST
import Control.Concurrent.MVar
import Control.Exception
import Data.IORef
import Data.Order.Raw
hiding (newMinimum, newMaximum, newAfter, newBefore)
import qualified Data.Order.Raw as Raw
import Data.Order.Raw.Algorithm
import System.IO.Unsafe
import GHC.IORef
type family AlgorithmOf o
data Local a
type instance AlgorithmOf (Local a) = a
data Global
type instance AlgorithmOf Global = DefaultAlgorithm
data OrderRep o = OrderRep (RawAlgorithm (AlgorithmOf o) RealWorld)
(Gate (AlgorithmOf o))
newOrderRep :: (forall s . RawAlgorithm (AlgorithmOf o) s) -> IO (OrderRep o)
newOrderRep rawAlg = do
rawOrder <- stToIO $ Raw.newOrder rawAlg
gate <- newGate rawOrder
return (OrderRep rawAlg gate)
localOrderRep :: (forall s . RawAlgorithm a s) -> OrderRep (Local a)
localOrderRep rawAlg = unsafePerformIO $ newOrderRep rawAlg
data Element o = Element (RawAlgorithm (AlgorithmOf o) RealWorld)
(Gate (AlgorithmOf o))
(RawElement (AlgorithmOf o) RealWorld)
instance Eq (Element o) where
(==) (Element (RawAlgorithm _ _ _ _ _ _ _) _ rawElem1)
(Element _ _ rawElem2) = equal where
equal = rawElem1 == rawElem2
instance Ord (Element o) where
compare (Element rawAlg gate rawElem1)
(Element _ _ rawElem2) = unsafePerformIO $
withRawOrder gate $ \ rawOrder ->
stToIO $
compareElements rawAlg
rawOrder
rawElem1
rawElem2
newMinimum :: OrderRep o -> IO (Element o)
newMinimum = fromRawNew Raw.newMinimum
newMaximum :: OrderRep o -> IO (Element o)
newMaximum = fromRawNew Raw.newMaximum
newAfter :: Element o -> OrderRep o -> IO (Element o)
newAfter = fromRawNeighbor Raw.newAfter
newBefore :: Element o -> OrderRep o -> IO (Element o)
newBefore = fromRawNeighbor Raw.newBefore
fromRawNeighbor :: (RawAlgorithm (AlgorithmOf o) RealWorld
-> RawOrder (AlgorithmOf o) RealWorld
-> RawElement (AlgorithmOf o) RealWorld
-> ST RealWorld (RawElement (AlgorithmOf o) RealWorld))
-> Element o
-> OrderRep o
-> IO (Element o)
fromRawNeighbor rawNewNeighbor (Element _ _ rawElem) = fromRawNew rawNew where
rawNew rawAlg rawOrder = rawNewNeighbor rawAlg rawOrder rawElem
fromRawNew :: (RawAlgorithm (AlgorithmOf o) RealWorld
-> RawOrder (AlgorithmOf o) RealWorld
-> ST RealWorld (RawElement (AlgorithmOf o) RealWorld))
-> OrderRep o
-> IO (Element o)
fromRawNew rawNew (OrderRep rawAlg gate) = withRawOrder gate $ \ rawOrder -> do
rawElem <- stToIO $ rawNew rawAlg rawOrder
mkWeakIORef (IORef rawElem)
(withRawOrder gate $ \ rawOrder ->
stToIO $
delete rawAlg rawOrder rawElem)
return (Element rawAlg gate rawElem)
newtype Gate a = Gate (MVar (RawOrder a RealWorld))
newGate :: RawOrder a RealWorld -> IO (Gate a)
newGate = fmap Gate . newMVar
withRawOrder :: Gate a -> (RawOrder a RealWorld -> IO r) -> IO r
withRawOrder (Gate mVar) cont = bracket (takeMVar mVar) (putMVar mVar) cont