Flag.hs

{-|
Module:             STM.Flag
Description:        A flag plus a function to run an 'Async' and lower the flag when it's started.
Copyright:          © 2017 All rights reserved.
License:            GPL-3
Maintainer:         Evan Cofsky <evan@theunixman.com>
Stability:          experimental
Portability:        POSIX
-}

module STM.Flag where

import Lawless
import Control.Concurrent.Async.Lifted
import Control.Concurrent.STM.TSem
import STM.Base

-- | A 'Flag' used for mutexes.
newtype Flag = Flag TSem

-- | Creates a new 'Flag' in the held state.
newFlag ∷ (MonadBase IO m) ⇒ m Flag
newFlag = Flag <$> atomically (newTSem 0)

-- | Waits for a 'Flag' to be unheld.
waitFlag ∷ Flag → STM ()
waitFlag (Flag s) = waitTSem s

-- | Signals a 'Flag' has been released.
lowerFlag ∷ Flag → STM ()
lowerFlag (Flag s) = signalTSem s

-- | Runs @f@ in a new 'Async', waiting for the 'Async' to start
-- before continuing.
run ∷ MonadBaseControl IO m ⇒ m a → m (Async (StM m a))
run f = do
    g ← newFlag
    a ← async $ do
        atomically $ lowerFlag g
        f
    atomically $ waitFlag g
    return a