-- Copyright (c) 2016-2020 Lars Kuhtz <lakuhtz@gmail.com>
-- Copyright (c) 2014-2015 PivotCloud, Inc.
--
-- System.Logger
--
-- Please feel free to contact us at licensing@pivotmail.com with any
-- contributions, additions, or other feedback; we would love to hear from
-- you.
--
-- Licensed under the Apache License, Version 2.0 (the "License"); you may
-- not use this file except in compliance with the License. You may obtain a
-- copy of the License at http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
-- License for the specific language governing permissions and limitations
-- under the License.

-- |
-- Module: System.Logger.Internal.Queue
-- Description: Queues for Usage with Yet Another Logger
-- Copyright:
--     Copyright © 2016-2022 Lars Kuhtz <lakuhtz@gmail.com>
--     Copyright © 2015 PivotCloud, Inc.
-- License: Apache-2.0
-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>
-- Stability: experimental
--

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}

module System.Logger.Internal.Queue
( BoundedCloseableQueue(..)
, FairTBMQueue
, TBMQueue
, TBMChan
) where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TBMChan
import Control.Concurrent.STM.TBMQueue
import Control.Monad.Unicode

import Numeric.Natural

import Prelude.Unicode


-- -------------------------------------------------------------------------- --
-- Queue Abstraction

class BoundedCloseableQueue q a | q → a where
    newQueue ∷ Natural → IO q
    closeQueue ∷ q → IO ()

    -- | Returns 'False' if and only if the queue
    -- is closed. If the queue is full this function blocks.
    --
    writeQueue ∷ q → a → IO Bool

    -- | Non-blocking version of 'writeQueue'. Returns 'Nothing' if the
    -- queue was full. Otherwise it returns 'Just True' if the value
    -- was successfully written and 'Just False' if the queue was closed.
    --
    tryWriteQueue ∷ q → a → IO (Maybe Bool)

    -- | Returns 'Nothing' if and only if the queue is
    -- closed. If this queue is empty this function blocks.
    --
    readQueue ∷ q → IO (Maybe a)

    {-
    -- | Non-blocking version of 'readQueue'. Returns 'Nothing' if the
    -- queue is empty. Returns 'Just Nothing' if the queue is closed
    -- and and 'Just (Just a)' otherwise.
    --
    tryReadQueue ∷ q → IO (Maybe (Maybe a))
    -}

-- -------------------------------------------------------------------------- --
-- TBMQueue

instance BoundedCloseableQueue (TBMQueue a) a where
    newQueue :: Natural -> IO (TBMQueue a)
newQueue = Int -> IO (TBMQueue a)
forall a. Int -> IO (TBMQueue a)
newTBMQueueIO (Int -> IO (TBMQueue a))
-> (Natural -> Int) -> Natural -> IO (TBMQueue a)
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    closeQueue :: TBMQueue a -> IO ()
closeQueue = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (TBMQueue a -> STM ()) -> TBMQueue a -> IO ()
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ TBMQueue a -> STM ()
forall a. TBMQueue a -> STM ()
closeTBMQueue
    writeQueue :: TBMQueue a -> a -> IO Bool
writeQueue TBMQueue a
q a
a = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TBMQueue a -> STM Bool
forall a. TBMQueue a -> STM Bool
isClosedTBMQueue TBMQueue a
q STM Bool -> (Bool -> STM Bool) -> STM Bool
forall (m :: * -> *) α β. Monad m => m α -> (α -> m β) -> m β
≫= \case
        Bool
True → Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Bool
False → do
            TBMQueue a -> a -> STM ()
forall a. TBMQueue a -> a -> STM ()
writeTBMQueue TBMQueue a
q a
a
            Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    tryWriteQueue :: TBMQueue a -> a -> IO (Maybe Bool)
tryWriteQueue TBMQueue a
q a
a = STM (Maybe Bool) -> IO (Maybe Bool)
forall a. STM a -> IO a
atomically (STM (Maybe Bool) -> IO (Maybe Bool))
-> STM (Maybe Bool) -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ TBMQueue a -> a -> STM (Maybe Bool)
forall a. TBMQueue a -> a -> STM (Maybe Bool)
tryWriteTBMQueue TBMQueue a
q a
a STM (Maybe Bool)
-> (Maybe Bool -> STM (Maybe Bool)) -> STM (Maybe Bool)
forall (m :: * -> *) α β. Monad m => m α -> (α -> m β) -> m β
≫= \case
        Maybe Bool
Nothing → Maybe Bool -> STM (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Bool -> STM (Maybe Bool)) -> Maybe Bool -> STM (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        Just Bool
False → Maybe Bool -> STM (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
        Just Bool
True → Maybe Bool -> STM (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Bool -> STM (Maybe Bool)) -> Maybe Bool -> STM (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    readQueue :: TBMQueue a -> IO (Maybe a)
readQueue TBMQueue a
q = STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically (STM (Maybe a) -> IO (Maybe a)) -> STM (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ TBMQueue a -> STM (Maybe a)
forall a. TBMQueue a -> STM (Maybe a)
readTBMQueue TBMQueue a
q

-- -------------------------------------------------------------------------- --
-- TBMChan

instance BoundedCloseableQueue (TBMChan a) a where
    newQueue :: Natural -> IO (TBMChan a)
newQueue = Int -> IO (TBMChan a)
forall a. Int -> IO (TBMChan a)
newTBMChanIO (Int -> IO (TBMChan a))
-> (Natural -> Int) -> Natural -> IO (TBMChan a)
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    closeQueue :: TBMChan a -> IO ()
closeQueue = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (TBMChan a -> STM ()) -> TBMChan a -> IO ()
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ TBMChan a -> STM ()
forall a. TBMChan a -> STM ()
closeTBMChan
    writeQueue :: TBMChan a -> a -> IO Bool
writeQueue TBMChan a
q a
a = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TBMChan a -> STM Bool
forall a. TBMChan a -> STM Bool
isClosedTBMChan TBMChan a
q STM Bool -> (Bool -> STM Bool) -> STM Bool
forall (m :: * -> *) α β. Monad m => m α -> (α -> m β) -> m β
≫= \case
        Bool
True → Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Bool
False → do
            TBMChan a -> a -> STM ()
forall a. TBMChan a -> a -> STM ()
writeTBMChan TBMChan a
q a
a
            Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    tryWriteQueue :: TBMChan a -> a -> IO (Maybe Bool)
tryWriteQueue TBMChan a
q a
a = STM (Maybe Bool) -> IO (Maybe Bool)
forall a. STM a -> IO a
atomically (STM (Maybe Bool) -> IO (Maybe Bool))
-> STM (Maybe Bool) -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ TBMChan a -> a -> STM (Maybe Bool)
forall a. TBMChan a -> a -> STM (Maybe Bool)
tryWriteTBMChan TBMChan a
q a
a STM (Maybe Bool)
-> (Maybe Bool -> STM (Maybe Bool)) -> STM (Maybe Bool)
forall (m :: * -> *) α β. Monad m => m α -> (α -> m β) -> m β
≫= \case
        Maybe Bool
Nothing → Maybe Bool -> STM (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Bool -> STM (Maybe Bool)) -> Maybe Bool -> STM (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        Just Bool
False → Maybe Bool -> STM (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
        Just Bool
True → Maybe Bool -> STM (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Bool -> STM (Maybe Bool)) -> Maybe Bool -> STM (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    readQueue :: TBMChan a -> IO (Maybe a)
readQueue TBMChan a
q = STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically (STM (Maybe a) -> IO (Maybe a)) -> STM (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ TBMChan a -> STM (Maybe a)
forall a. TBMChan a -> STM (Maybe a)
readTBMChan TBMChan a
q

-- -------------------------------------------------------------------------- --
-- FairTBMQueue

data FairTBMQueue α = FairTBMQueue
    { FairTBMQueue α -> TBMQueue α
fairTBMQueueQueue ∷ !(TBMQueue α)
    , FairTBMQueue α -> MVar ()
fairTBMQueueLock ∷ !(MVar ())
    }

instance BoundedCloseableQueue (FairTBMQueue a) a where
    newQueue :: Natural -> IO (FairTBMQueue a)
newQueue Natural
i = TBMQueue a -> MVar () -> FairTBMQueue a
forall α. TBMQueue α -> MVar () -> FairTBMQueue α
FairTBMQueue (TBMQueue a -> MVar () -> FairTBMQueue a)
-> IO (TBMQueue a) -> IO (MVar () -> FairTBMQueue a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO (TBMQueue a)
forall a. Int -> IO (TBMQueue a)
newTBMQueueIO (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
i) IO (MVar () -> FairTBMQueue a)
-> IO (MVar ()) -> IO (FairTBMQueue a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    closeQueue :: FairTBMQueue a -> IO ()
closeQueue = TBMQueue a -> IO ()
forall q a. BoundedCloseableQueue q a => q -> IO ()
closeQueue (TBMQueue a -> IO ())
-> (FairTBMQueue a -> TBMQueue a) -> FairTBMQueue a -> IO ()
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ FairTBMQueue a -> TBMQueue a
forall α. FairTBMQueue α -> TBMQueue α
fairTBMQueueQueue
    readQueue :: FairTBMQueue a -> IO (Maybe a)
readQueue = TBMQueue a -> IO (Maybe a)
forall q a. BoundedCloseableQueue q a => q -> IO (Maybe a)
readQueue (TBMQueue a -> IO (Maybe a))
-> (FairTBMQueue a -> TBMQueue a) -> FairTBMQueue a -> IO (Maybe a)
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ FairTBMQueue a -> TBMQueue a
forall α. FairTBMQueue α -> TBMQueue α
fairTBMQueueQueue
    writeQueue :: FairTBMQueue a -> a -> IO Bool
writeQueue FairTBMQueue{MVar ()
TBMQueue a
fairTBMQueueLock :: MVar ()
fairTBMQueueQueue :: TBMQueue a
fairTBMQueueLock :: forall α. FairTBMQueue α -> MVar ()
fairTBMQueueQueue :: forall α. FairTBMQueue α -> TBMQueue α
..} a
a = do
        MVar () -> (() -> IO Bool) -> IO Bool
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
fairTBMQueueLock ((() -> IO Bool) -> IO Bool) -> (() -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \()
_ → do
            TBMQueue a -> a -> IO Bool
forall q a. BoundedCloseableQueue q a => q -> a -> IO Bool
writeQueue TBMQueue a
fairTBMQueueQueue a
a
    tryWriteQueue :: FairTBMQueue a -> a -> IO (Maybe Bool)
tryWriteQueue FairTBMQueue{MVar ()
TBMQueue a
fairTBMQueueLock :: MVar ()
fairTBMQueueQueue :: TBMQueue a
fairTBMQueueLock :: forall α. FairTBMQueue α -> MVar ()
fairTBMQueueQueue :: forall α. FairTBMQueue α -> TBMQueue α
..} a
a = do
        MVar () -> (() -> IO (Maybe Bool)) -> IO (Maybe Bool)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
fairTBMQueueLock ((() -> IO (Maybe Bool)) -> IO (Maybe Bool))
-> (() -> IO (Maybe Bool)) -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ \()
_ → do
            TBMQueue a -> a -> IO (Maybe Bool)
forall q a. BoundedCloseableQueue q a => q -> a -> IO (Maybe Bool)
tryWriteQueue TBMQueue a
fairTBMQueueQueue a
a