RLock.hs

{-# LANGUAGE BangPatterns, DeriveDataTypeable, NoImplicitPrelude, UnicodeSyntax #-}

--------------------------------------------------------------------------------
-- |
-- Module     : Control.Concurrent.RLock
-- Copyright  : (c) 2010 Bas van Dijk & Roel van Dijk
-- License    : BSD3 (see the file LICENSE)
-- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
--            , Roel van Dijk <vandijk.roel@gmail.com>
--
-- This module provides the 'RLock' synchronization mechanism. It was inspired
-- by the Python @RLock@ and Java @ReentrantLock@ objects and should behave in a
-- similar way. See:
--
-- <http://docs.python.org/3.1/library/threading.html#rlock-objects>
--
-- and:
--
-- <http://java.sun.com/javase/7/docs/api/java/util/concurrent/locks/ReentrantLock.html>
--
-- All functions are /exception safe/. Throwing asynchronous exceptions will not
-- compromise the internal state of a 'RLock'.
--
-- This module is intended to be imported qualified. We suggest importing it like:
--
-- @
-- import           Control.Concurrent.RLock          ( RLock )
-- import qualified Control.Concurrent.RLock as RLock ( ... )
-- @
--
--------------------------------------------------------------------------------

module Control.Concurrent.RLock
    ( RLock

      -- * Creating reentrant locks
    , new
    , newAcquired

      -- * Locking and unlocking
    , acquire
    , tryAcquire

    , release

      -- * Convenience functions
    , with
    , tryWith

      -- * Querying reentrant locks
    , recursionLevel
    ) where


--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------

-- from base:
import Control.Applicative     ( (<$>), liftA2 )
import Control.Concurrent      ( ThreadId, myThreadId )
import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, readMVar, putMVar )
import Control.Exception       ( block, bracket_, finally )
import Control.Monad           ( Monad, return, (>>=), fail, (>>), fmap )
import Data.Bool               ( Bool(False, True), otherwise )
import Data.Eq                 ( Eq )
import Data.Function           ( ($) )
import Data.Maybe              ( Maybe(Nothing, Just), maybe )
import Data.Tuple              ( fst, snd )
import Data.Typeable           ( Typeable )
import Prelude                 ( Integer, fromInteger, succ, pred, error )
import System.IO               ( IO )

-- from base-unicode-symbols
import Data.Eq.Unicode         ( (≡) )
import Data.Function.Unicode   ( (∘) )
import Data.Monoid.Unicode     ( (⊕) )

-- from ourselves:
import           Control.Concurrent.Lock ( Lock )
import qualified Control.Concurrent.Lock as Lock
    ( new, newAcquired, acquire, release )


--------------------------------------------------------------------------------
-- Reentrant locks
--------------------------------------------------------------------------------

newtype RLock = RLock {un ∷ MVar (Maybe (ThreadId, Integer), Lock)}
    deriving (Eq, Typeable)

new ∷ IO RLock
new = do lock ← Lock.new
         RLock <$> newMVar (Nothing, lock)

newAcquired ∷ IO RLock
newAcquired = do myTID ← myThreadId
                 lock ← Lock.newAcquired
                 RLock <$> newMVar (Just (myTID, 1), lock)

acquire ∷ RLock → IO ()
acquire (RLock mv) = do
  myTID ← myThreadId
  block $ let go = do t@(mb, lock) ← takeMVar mv
                      case mb of
                        Nothing         → do Lock.acquire lock
                                             putMVar mv (Just (myTID, 1), lock)
                        Just (tid, n)
                          | myTID ≡ tid → let !sn = succ n
                                          in putMVar mv (Just (tid, sn), lock)
                          | otherwise   → do putMVar mv t
                                             Lock.acquire lock
                                             Lock.release lock
                                             go
          in go

tryAcquire ∷ RLock → IO Bool
tryAcquire (RLock mv) = do
  myTID ← myThreadId
  block $ do
    t@(mb, lock) ← takeMVar mv
    case mb of
      Nothing         → do Lock.acquire lock
                           putMVar mv (Just (myTID, 1), lock)
                           return True
      Just (tid, n)
        | myTID ≡ tid → do let !sn = succ n
                           putMVar mv (Just (tid, sn), lock)
                           return True

        | otherwise   → do putMVar mv t
                           return False

release ∷ RLock → IO ()
release (RLock mv) = do
  myTID ← myThreadId
  block $ do
    t@(mb, lock) ← takeMVar mv
    let err msg = do putMVar mv t
                     error $ "Control.Concurrent.RLock.release: " ⊕ msg
    case mb of
      Nothing → err "Can't release an unacquired RLock!"
      Just (tid, n)
        | myTID ≡ tid → if n ≡ 1
                        then do Lock.release lock
                                putMVar mv (Nothing, lock)
                        else let !pn = pred n
                             in putMVar mv (Just (tid, pn), lock)
        | otherwise → err "Calling thread does not own the RLock!"

with ∷ RLock → IO α → IO α
with = liftA2 bracket_ acquire release

tryWith ∷ RLock → IO α → IO (Maybe α)
tryWith l a = block $ do
  acquired ← tryAcquire l
  if acquired
    then fmap Just $ a `finally` release l
    else return Nothing

recursionLevel ∷ RLock → IO Integer
recursionLevel = fmap (maybe 0 snd ∘ fst) ∘ readMVar ∘ un


-- The End ---------------------------------------------------------------------