companion (empty) → 0.1.0

raw patch · 6 files changed

+161/−0 lines, 6 filesdep +basedep +riosetup-changed

Dependencies added: base, rio

Files

CHANGELOG.md +11/−0
LICENSE +28/−0
README.md +3/−0
Setup.hs +2/−0
companion.cabal +39/−0
src/Control/Concurrent/Companion.hs +78/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+# Changelog for `companion`
+
+All notable changes to this project will be documented in this file.
+
+The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
+and this project adheres to the
+[Haskell Package Versioning Policy](https://pvp.haskell.org/).
+
+## 0.1.0 - 2023-07-07
+
+* Spin out module `Pantry.Internal.Companion` from package `pantry-0.8.3`.

+ LICENSE view

@@ -0,0 +1,28 @@+BSD 3-Clause License
+
+Copyright (c) 2015-2023, Stack contributors
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+   list of conditions and the following disclaimer.
+
+2. 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.
+
+3. Neither the name of the copyright holder nor the names of its
+   contributors may 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 HOLDER 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.

+ README.md view

@@ -0,0 +1,3 @@+# companion
+
+A Haskell library to provide companion threads.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ companion.cabal view

@@ -0,0 +1,39 @@+cabal-version: 1.12
++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           companion+version:        0.1.0+synopsis:       A Haskell library to provide companion threads.+description:    Please see the README on GitHub at <https://github.com/commercialhaskell/companion#readme>+category:       Concurrency+homepage:       https://github.com/commercialhaskell/companion#readme+bug-reports:    https://github.com/commercialhaskell/companion/issues+author:         Michael Snoyman+maintainer:     Mike Pilgrem <public@pilgrem.com>+copyright:      2018-2023 FP Complete+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/commercialhaskell/companion++library+  exposed-modules:+      Control.Concurrent.Companion+  other-modules:+      Paths_companion+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.12 && <5+    , rio+  default-language: Haskell2010

+ src/Control/Concurrent/Companion.hs view

@@ -0,0 +1,78 @@+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RankNTypes        #-}
+
+-- | Companion threads, such as for printing messages saying we're still busy.
+module Control.Concurrent.Companion
+  ( withCompanion
+  , onCompanionDone
+  , Companion
+  , Delay
+  , StopCompanion
+  ) where
+
+import           RIO
+
+-- | A companion thread which can perform arbitrary actions as well as delay.
+type Companion m = Delay -> m ()
+
+-- | Delay the given number of microseconds. If 'StopCompanion' is triggered
+-- before the timer completes, a 'CompanionDone' exception will be thrown (which
+-- is caught internally by 'withCompanion').
+type Delay = forall mio. MonadIO mio => Int -> mio ()
+
+-- | Tell the 'Companion' to stop. The next time 'Delay' is called, or if a
+-- 'Delay' is currently blocking, the 'Companion' thread will exit with a
+-- 'CompanionDone' exception.
+type StopCompanion m = m ()
+
+-- | When a delay was interrupted because we're told to stop, perform this
+-- action.
+onCompanionDone
+  :: MonadUnliftIO m
+  => m () -- ^ the delay
+  -> m () -- ^ action to perform
+  -> m ()
+onCompanionDone theDelay theAction =
+  theDelay `withException` \CompanionDone -> theAction
+
+-- | Internal exception used by 'withCompanion' to allow short-circuiting of the
+-- 'Companion'. Should not be used outside of this module.
+data CompanionDone = CompanionDone
+  deriving (Show, Typeable)
+
+instance Exception CompanionDone
+
+-- | Keep running the 'Companion' action until either the inner action completes
+-- or calls the 'StopCompanion' action. This can be used to give the user status
+-- information while running a long running operations.
+withCompanion ::
+     forall m a. MonadUnliftIO m
+  => Companion m
+  -> (StopCompanion m -> m a)
+  -> m a
+withCompanion companion inner = do
+  -- Variable to indicate 'Delay'ing should result in a 'CompanionDone'
+  -- exception.
+  shouldStopVar <- newTVarIO False
+  let -- Relatively simple: set shouldStopVar to True
+      stopCompanion = atomically $ writeTVar shouldStopVar True
+
+      delay :: Delay
+      delay usec = do
+        -- Register a delay with the runtime system
+        delayDoneVar <- registerDelay usec
+        join $ atomically $
+          -- Delay has triggered, keep going
+          (pure () <$ (readTVar delayDoneVar >>= checkSTM)) <|>
+          -- Time to stop the companion, throw a 'CompanionDone' exception
+          -- immediately
+          (throwIO CompanionDone <$ (readTVar shouldStopVar >>= checkSTM))
+
+  -- Run the 'Companion' and inner action together
+  runConcurrently $
+    -- Ignore a 'CompanionDone' exception from the companion, that's expected
+    -- behavior
+    Concurrently (companion delay `catch` \CompanionDone -> pure ()) *>
+    -- Run the inner action, giving it the 'StopCompanion' action, and
+    -- ensuring it is called regardless of exceptions.
+    Concurrently (inner stopCompanion `finally` stopCompanion)