{-# 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 <- forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar forall a. Seq a
Seq.empty
    forall (m :: * -> *) a. Monad m => a -> m a
return (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
    forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> (a -> a) -> m ()
modifyMutVar MutVar (PrimState m) (Seq a)
ref (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 <- forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar (PrimState m) (Seq a)
ref
    case forall a. Seq a -> ViewL a
Seq.viewl Seq a
s of
      ViewL a
Seq.EmptyL -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      a
val Seq.:< Seq a
s' -> do
        forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (Seq a)
ref Seq a
s'
        forall (m :: * -> *) a. Monad m => a -> m a
return (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 <- forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar (PrimState m) (Seq a)
ref
    forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (Seq a)
ref forall a. Seq a
Seq.empty
    forall (m :: * -> *) a. Monad m => a -> m a
return (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 <- forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar MutVar (PrimState m) (Seq a)
ref
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! 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
  forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (Seq a)
ref forall a. Seq a
Seq.empty