{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Internal.Data.SeqQueue
-- Copyright   :  (c) Masahiro Sakai 2012
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-- Queue implemented using IORef and Sequence.
--
-----------------------------------------------------------------------------
module ToySolver.Internal.Data.SeqQueue
  (
  -- * SeqQueue type
    SeqQueue

  -- * Constructors
  , NewFifo (..)

  -- * Operators
  , Enqueue (..)
  , Dequeue (..)
  , QueueSize (..)
  , clear
  ) where

import Control.Monad.Primitive
import Control.Monad.ST
import Data.Queue
import Data.Foldable
import Data.Primitive.MutVar
import qualified Data.Sequence as Seq

newtype SeqQueue m a = SeqQueue (MutVar (PrimState m) (Seq.Seq a))

instance PrimMonad m => NewFifo (SeqQueue m a) m where
  {-# INLINE newFifo #-}
  newFifo :: m (SeqQueue m a)
newFifo = do
    MutVar (PrimState m) (Seq a)
ref <- Seq a -> m (MutVar (PrimState m) (Seq a))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar Seq a
forall a. Seq a
Seq.empty
    SeqQueue m a -> m (SeqQueue m a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (MutVar (PrimState m) (Seq a) -> SeqQueue m a
forall (m :: * -> *) a.
MutVar (PrimState m) (Seq a) -> SeqQueue m a
SeqQueue MutVar (PrimState m) (Seq a)
ref)

instance PrimMonad m => Enqueue (SeqQueue m a) m a where
  {-# INLINE enqueue #-}
  enqueue :: SeqQueue m a -> a -> m ()
enqueue (SeqQueue MutVar (PrimState m) (Seq a)
ref) a
val = do
    MutVar (PrimState m) (Seq a) -> (Seq a -> Seq a) -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> (a -> a) -> m ()
modifyMutVar MutVar (PrimState m) (Seq a)
ref (Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
Seq.|> a
val)

instance PrimMonad m => Dequeue (SeqQueue m a) m a where
  {-# INLINE dequeue #-}
  dequeue :: SeqQueue m a -> m (Maybe a)
dequeue (SeqQueue MutVar (PrimState m) (Seq a)
ref) = do
    Seq a
s <- MutVar (PrimState m) (Seq a) -> m (Seq a)
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar (PrimState m) (Seq a)
ref
    case Seq a -> ViewL a
forall a. Seq a -> ViewL a
Seq.viewl Seq a
s of
      ViewL a
Seq.EmptyL -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
      a
val Seq.:< Seq a
s' -> do
        MutVar (PrimState m) (Seq a) -> Seq a -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (Seq a)
ref Seq a
s'
        Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
val)

  {-# INLINE dequeueBatch #-}
  dequeueBatch :: SeqQueue m a -> m [a]
dequeueBatch (SeqQueue MutVar (PrimState m) (Seq a)
ref) = do
    Seq a
s <- MutVar (PrimState m) (Seq a) -> m (Seq a)
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar (PrimState m) (Seq a)
ref
    MutVar (PrimState m) (Seq a) -> Seq a -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (Seq a)
ref Seq a
forall a. Seq a
Seq.empty
    [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq a -> [a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq a
s)

instance PrimMonad m => QueueSize (SeqQueue m a) m where
  {-# INLINE queueSize #-}
  queueSize :: SeqQueue m a -> m Int
queueSize (SeqQueue MutVar (PrimState m) (Seq a)
ref) = do
    Seq a
s <- MutVar (PrimState m) (Seq a) -> m (Seq a)
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar (PrimState m) (Seq a)
ref
    Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$! Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
s

{-# INLINE clear #-}
clear :: PrimMonad m => SeqQueue m a -> m ()
clear :: forall (m :: * -> *) a. PrimMonad m => SeqQueue m a -> m ()
clear (SeqQueue MutVar (PrimState m) (Seq a)
ref) = do
  MutVar (PrimState m) (Seq a) -> Seq a -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (Seq a)
ref Seq a
forall a. Seq a
Seq.empty