1 files changed, 155 insertions, 0 deletions
diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs
new file mode 100644
index 0000000000..3c7bfd1fa0
--- /dev/null
+++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs
@@ -0,0 +1,155 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+-- |
+-- Module      : Data.Primitive.MVar
+-- License     : BSD2
+-- Portability : non-portable
+--
+-- Primitive operations on @MVar@. This module provides a similar interface
+-- to "Control.Concurrent.MVar". However, the functions are generalized to
+-- work in any 'PrimMonad' instead of only working in 'IO'. Note that all
+-- of the functions here are completely deterministic. Users of 'MVar' are
+-- responsible for designing abstractions that guarantee determinism in
+-- the presence of multi-threading.
+--
+-- @since 0.6.4.0
+module Data.Primitive.MVar
+  ( MVar(..)
+  , newMVar
+  , isEmptyMVar
+  , newEmptyMVar
+  , putMVar
+  , readMVar
+  , takeMVar
+  , tryPutMVar
+  , tryReadMVar
+  , tryTakeMVar
+  ) where
+
+import Control.Monad.Primitive
+import Data.Primitive.Internal.Compat (isTrue#)
+import GHC.Exts (MVar#,newMVar#,takeMVar#,sameMVar#,putMVar#,tryTakeMVar#,
+  isEmptyMVar#,tryPutMVar#,(/=#))
+
+#if __GLASGOW_HASKELL__ >= 708
+import GHC.Exts (readMVar#,tryReadMVar#)
+#endif
+
+data MVar s a = MVar (MVar# s a)
+
+instance Eq (MVar s a) where
+  MVar mvar1# == MVar mvar2# = isTrue# (sameMVar# mvar1# mvar2#)
+
+-- | Create a new 'MVar' that is initially empty.
+newEmptyMVar :: PrimMonad m => m (MVar (PrimState m) a)
+newEmptyMVar = primitive $ \ s# ->
+  case newMVar# s# of
+    (# s2#, svar# #) -> (# s2#, MVar svar# #)
+
+
+-- | Create a new 'MVar' that holds the supplied argument.
+newMVar :: PrimMonad m => a -> m (MVar (PrimState m) a)
+newMVar value =
+  newEmptyMVar >>= \ mvar ->
+  putMVar mvar value >>
+  return mvar
+
+-- | Return the contents of the 'MVar'.  If the 'MVar' is currently
+-- empty, 'takeMVar' will wait until it is full.  After a 'takeMVar',
+-- the 'MVar' is left empty.
+takeMVar :: PrimMonad m => MVar (PrimState m) a -> m a
+takeMVar (MVar mvar#) = primitive $ \ s# -> takeMVar# mvar# s#
+
+-- | Atomically read the contents of an 'MVar'.  If the 'MVar' is
+-- currently empty, 'readMVar' will wait until it is full.
+-- 'readMVar' is guaranteed to receive the next 'putMVar'.
+--
+-- /Multiple Wakeup:/ 'readMVar' is multiple-wakeup, so when multiple readers
+-- are blocked on an 'MVar', all of them are woken up at the same time.
+--
+-- /Compatibility note:/ On GHCs prior to 7.8, 'readMVar' is a combination
+-- of 'takeMVar' and 'putMVar'. Consequently, its behavior differs in the
+-- following ways:
+--
+-- * It is single-wakeup instead of multiple-wakeup.
+-- * It might not receive the value from the next call to 'putMVar' if
+--   there is already a pending thread blocked on 'takeMVar'.
+-- * If another thread puts a value in the 'MVar' in between the
+--   calls to 'takeMVar' and 'putMVar', that value may be overridden.
+readMVar :: PrimMonad m => MVar (PrimState m) a -> m a
+#if __GLASGOW_HASKELL__ >= 708
+readMVar (MVar mvar#) = primitive $ \ s# -> readMVar# mvar# s#
+#else
+readMVar mv = do
+  a <- takeMVar mv
+  putMVar mv a
+  return a
+#endif
+
+-- |Put a value into an 'MVar'.  If the 'MVar' is currently full,
+-- 'putMVar' will wait until it becomes empty.
+putMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m ()
+putMVar (MVar mvar#) x = primitive_ (putMVar# mvar# x)
+
+-- |A non-blocking version of 'takeMVar'.  The 'tryTakeMVar' function
+-- returns immediately, with 'Nothing' if the 'MVar' was empty, or
+-- @'Just' a@ if the 'MVar' was full with contents @a@.  After 'tryTakeMVar',
+-- the 'MVar' is left empty.
+tryTakeMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a)
+tryTakeMVar (MVar m) = primitive $ \ s ->
+  case tryTakeMVar# m s of
+    (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty
+    (# s', _,  a #) -> (# s', Just a  #) -- MVar is full
+
+
+-- |A non-blocking version of 'putMVar'.  The 'tryPutMVar' function
+-- attempts to put the value @a@ into the 'MVar', returning 'True' if
+-- it was successful, or 'False' otherwise.
+tryPutMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m Bool
+tryPutMVar (MVar mvar#) x = primitive $ \ s# ->
+    case tryPutMVar# mvar# x s# of
+        (# s, 0# #) -> (# s, False #)
+        (# s, _  #) -> (# s, True #)
+
+-- | A non-blocking version of 'readMVar'.  The 'tryReadMVar' function
+-- returns immediately, with 'Nothing' if the 'MVar' was empty, or
+-- @'Just' a@ if the 'MVar' was full with contents @a@.
+--
+-- /Compatibility note:/ On GHCs prior to 7.8, 'tryReadMVar' is a combination
+-- of 'tryTakeMVar' and 'putMVar'. Consequently, its behavior differs in the
+-- following ways:
+--
+-- * It is single-wakeup instead of multiple-wakeup.
+-- * In the presence of other threads calling 'putMVar', 'tryReadMVar'
+--   may block.
+-- * If another thread puts a value in the 'MVar' in between the
+--   calls to 'tryTakeMVar' and 'putMVar', that value may be overridden.
+tryReadMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a)
+#if __GLASGOW_HASKELL__ >= 708
+tryReadMVar (MVar m) = primitive $ \ s ->
+    case tryReadMVar# m s of
+        (# s', 0#, _ #) -> (# s', Nothing #)      -- MVar is empty
+        (# s', _,  a #) -> (# s', Just a  #)      -- MVar is full
+#else
+tryReadMVar mv = do
+  ma <- tryTakeMVar mv
+  case ma of
+    Just a -> do
+      putMVar mv a
+      return (Just a)
+    Nothing -> return Nothing
+#endif
+
+-- | Check whether a given 'MVar' is empty.
+--
+-- Notice that the boolean value returned  is just a snapshot of
+-- the state of the MVar. By the time you get to react on its result,
+-- the MVar may have been filled (or emptied) - so be extremely
+-- careful when using this operation.   Use 'tryTakeMVar' instead if possible.
+isEmptyMVar :: PrimMonad m => MVar (PrimState m) a -> m Bool
+isEmptyMVar (MVar mv#) = primitive $ \ s# ->
+  case isEmptyMVar# mv# s# of
+    (# s2#, flg #) -> (# s2#, isTrue# (flg /=# 0#) #)