--------------------------------------------------------------------------------

-- Copyright © 2010-2012 Bas van Dijk & Roel van Dijk
-- Copyright © 2018 DFINITY Stiftung
--
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--     * Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--
--     * Redistributions in binary form must reproduce the above
--       copyright notice, this list of conditions and the following
--       disclaimer in the documentation and/or other materials provided
--       with the distribution.
--
--     * The names of Bas van Dijk, Roel van Dijk and the names of
--       contributors may NOT be used to endorse or promote products
--       derived from this software without specific prior written
--       permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

--------------------------------------------------------------------------------

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UndecidableInstances #-}

--------------------------------------------------------------------------------

-- |
-- Module     : Control.Concurrent.Classy.Lock
-- Copyright  : © 2010-2011 Bas van Dijk & Roel van Dijk
--            , © 2018 DFINITY Stiftung
-- Maintainer : DFINITY USA Research <team@dfinity.org>
--
-- This module provides the 'Lock' synchronisation mechanism. It was inspired by
-- the Python and Java @Lock@ objects and should behave in a similar way. See:
--
-- <http://docs.python.org/3.1/library/threading.html#lock-objects>
--
-- and:
--
-- <http://java.sun.com/javase/7/docs/api/java/util/concurrent/locks/Lock.html>
--
-- All functions are /exception safe/. Throwing asynchronous exceptions will not
-- compromise the internal state of a 'Lock'.

--------------------------------------------------------------------------------

module Control.Concurrent.Classy.Lock
  ( -- * @Lock@
    Lock

    -- * Creating locks
  , newLock
  , newAcquired

    -- * Locking and unlocking
  , acquire
  , tryAcquire
  , release

    -- * Convenience functions
  , with
  , tryWith
  , wait

    -- * Querying locks
  , locked
  ) where

--------------------------------------------------------------------------------

import           Control.Applicative            (pure, (<*>))
import           Control.Monad                  (when)
import           Data.Bool                      (Bool, not)
import           Data.Eq                        (Eq((==)))
import           Data.Function                  (($), (.))
import           Data.Functor                   (fmap, (<$>))
import           Data.Maybe                     (Maybe(Just, Nothing), isJust)
import           Data.Typeable                  (Typeable)
import           Prelude                        (error)

import qualified Control.Concurrent.Classy.MVar as MVar
import           Control.Monad.Catch            (bracket_, mask, onException)
import           Control.Monad.Conc.Class       (MonadConc(MVar))

--------------------------------------------------------------------------------

-- | A lock is in one of two states: \"locked\" or \"unlocked\".
--
-- @since 1.6.2.0
newtype Lock m
  = Lock
    { forall (m :: * -> *). Lock m -> MVar m ()
_fromLock :: MVar m ()
    }
  deriving (Typeable)

instance (Eq (MVar m ())) => Eq (Lock m) where
  == :: Lock m -> Lock m -> Bool
(==) (Lock MVar m ()
a) (Lock MVar m ()
b) = MVar m ()
a forall a. Eq a => a -> a -> Bool
== MVar m ()
b

--------------------------------------------------------------------------------

-- | Create a lock in the \"unlocked\" state.
--
-- @since 1.6.2.0
newLock :: (MonadConc m) => m (Lock m)
newLock :: forall (m :: * -> *). MonadConc m => m (Lock m)
newLock = forall (m :: * -> *). MVar m () -> Lock m
Lock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadConc m => a -> m (MVar m a)
MVar.newMVar ()

-- | Create a lock in the \"locked\" state.
--
-- @since 1.6.2.0
newAcquired :: (MonadConc m) => m (Lock m)
newAcquired :: forall (m :: * -> *). MonadConc m => m (Lock m)
newAcquired = forall (m :: * -> *). MVar m () -> Lock m
Lock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadConc m => m (MVar m a)
MVar.newEmptyMVar

--------------------------------------------------------------------------------

-- |
-- Acquires the 'Lock'. Blocks if another thread has acquired the 'Lock'.
--
-- @acquire@ behaves as follows:
--
-- * When the state is \"unlocked\" @acquire@ changes the state to \"locked\".
--
-- * When the state is \"locked\" @acquire@ /blocks/ until a call to 'release'
--   in another thread wakes the calling thread. Upon awakening it will change
--   the state to \"locked\".
--
-- There are two further important properties of @acquire@:
--
-- * @acquire@ is single-wakeup. That is, if there are multiple threads blocked
--   on @acquire@ and the lock is released, only one thread will be woken up.
--   The runtime guarantees that the woken thread completes its @acquire@
--   operation.
--
-- * When multiple threads are blocked on @acquire@, they are woken up in FIFO
--   order. This is useful for providing fairness properties of abstractions
--   built using locks. Note that this differs from the Python implementation
--   where the wake-up order is undefined.
--
-- @since 1.6.2.0
acquire :: (MonadConc m) => Lock m -> m ()
acquire :: forall (m :: * -> *). MonadConc m => Lock m -> m ()
acquire = forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
MVar.takeMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Lock m -> MVar m ()
_fromLock

-- |
-- A non-blocking 'acquire'.
--
-- * When the state is \"unlocked\" @tryAcquire@ changes the state to \"locked\"
--   and returns 'True'.
--
-- * When the state is \"locked\" @tryAcquire@ leaves the state unchanged and
--   returns 'False'.
--
-- @since 1.6.2.0
tryAcquire :: (MonadConc m) => Lock m -> m Bool
tryAcquire :: forall (m :: * -> *). MonadConc m => Lock m -> m Bool
tryAcquire = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadConc m => MVar m a -> m (Maybe a)
MVar.tryTakeMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Lock m -> MVar m ()
_fromLock

-- |
-- @release@ changes the state to \"unlocked\" and returns immediately.
--
-- Note that it is an error to release a lock in the \"unlocked\" state!
--
-- If there are any threads blocked on 'acquire' the thread that first called
-- @acquire@ will be woken up.
--
-- @since 1.6.2.0
release :: (MonadConc m) => Lock m -> m ()
release :: forall (m :: * -> *). MonadConc m => Lock m -> m ()
release (Lock MVar m ()
mv) = do
  Bool
b <- forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m Bool
MVar.tryPutMVar MVar m ()
mv ()
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
b) forall a b. (a -> b) -> a -> b
$
    forall a. HasCallStack => [Char] -> a
error [Char]
"Control.Concurrent.Classy.Lock.release: cannot release an unlocked Lock!"

--------------------------------------------------------------------------------

-- |
-- A convenience function which first acquires the lock and then performs the
-- computation. When the computation terminates, whether normally or by raising an
-- exception, the lock is released.
--
-- Note that: @with = 'bracket_' '<$>' 'acquire' '<*>' 'release'@.
--
-- @since 1.6.2.0
with :: (MonadConc m) => Lock m -> m a -> m a
with :: forall (m :: * -> *) a. MonadConc m => Lock m -> m a -> m a
with = forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadConc m => Lock m -> m ()
acquire forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadConc m => Lock m -> m ()
release

-- |
-- A non-blocking 'with'. @tryWith@ is a convenience function which first tries
-- to acquire the lock. If that fails, 'Nothing' is returned. If it succeeds,
-- the computation is performed. When the computation terminates, whether
-- normally or by raising an exception, the lock is released and 'Just' the
-- result of the computation is returned.
--
-- @since 1.6.2.0
tryWith :: (MonadConc m) => Lock m -> m a -> m (Maybe a)
tryWith :: forall (m :: * -> *) a. MonadConc m => Lock m -> m a -> m (Maybe a)
tryWith Lock m
l m a
a = forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
  Bool
acquired <- forall (m :: * -> *). MonadConc m => Lock m -> m Bool
tryAcquire Lock m
l
  if Bool
acquired
    then do a
r <- forall a. m a -> m a
restore m a
a forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` forall (m :: * -> *). MonadConc m => Lock m -> m ()
release Lock m
l
            forall (m :: * -> *). MonadConc m => Lock m -> m ()
release Lock m
l
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
r)
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- |
-- * When the state is \"locked\", @wait@ /blocks/ until a call to 'release'
--   in another thread changes it to \"unlocked\".
--
-- * @wait@ is multiple-wakeup, so when multiple waiters are blocked on
--   a @Lock@, all of them are woken up at the same time.
--
-- * When the state is \"unlocked\" @wait@ returns immediately.
--
-- @wait@ does not alter the state of the lock.
--
-- @since 1.6.2.0
wait :: (MonadConc m) => Lock m -> m ()
wait :: forall (m :: * -> *). MonadConc m => Lock m -> m ()
wait (Lock MVar m ()
mv) = forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
MVar.readMVar MVar m ()
mv

--------------------------------------------------------------------------------

-- |
-- Determines if the lock is in the \"locked\" state.
--
-- Note that this is only a snapshot of the state. By the time a program reacts
-- on its result it may already be out of date.
--
-- @since 1.6.2.0
locked :: (MonadConc m) => Lock m -> m Bool
locked :: forall (m :: * -> *). MonadConc m => Lock m -> m Bool
locked = forall (m :: * -> *) a. MonadConc m => MVar m a -> m Bool
MVar.isEmptyMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Lock m -> MVar m ()
_fromLock

--------------------------------------------------------------------------------