Merge pull request #4 from well-typed/edsko/niBracket

Add `niBracket`

niio.cabal

@@ -21,11 +21,18 @@ common lang
   ghc-options:      -Wall
   build-depends:    base >= 4.14 && < 4.21
 
+  default-extensions:
+      DeriveFunctor
+      DerivingStrategies
+      StandaloneDeriving
+
 library
   import:          lang
   exposed-modules: System.IO.NonInterleaved
   hs-source-dirs:  src
 
   build-depends:
-      temporary >= 1.3 && < 1.4
+    , exceptions >= 0.9   && < 0.11
+    , temporary  >= 1.2.1 && < 1.4
+
 

src/System/IO/NonInterleaved.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module System.IO.NonInterleaved (
     -- * Output functions
     niPutStr
@@ -9,9 +11,13 @@ module System.IO.NonInterleaved (
   , niTraceShowId
   , niTraceM
   , niTraceShowM
+    -- * Derived functionality
+  , niBracket
+  , niBracketLn
   ) where
 
 import Control.Concurrent
+import Control.Monad.Catch (ExitCase(..), generalBracket)
 import System.IO
 import System.IO.Temp (getCanonicalTemporaryDirectory)
 import System.IO.Unsafe
@@ -73,6 +79,32 @@ niTraceM str = niTrace str $ pure ()
 niTraceShowM :: (Applicative m, Show a) => a -> m ()
 niTraceShowM = niTraceM . show
 
+{-------------------------------------------------------------------------------
+  Derived functionality
+-------------------------------------------------------------------------------}
+
+-- | Print a message before and after an action
+--
+-- NOTE: We provide an (orphan) 'Functor' instance for 'ExitCase', which can
+-- be useful in cases where @a@ is not showable.
+niBracket ::
+     String                  -- ^ Message to print prior to the action
+  -> (ExitCase a -> String)  -- ^ Message to print after
+  -> IO a -> IO a
+niBracket before after act = fmap (\(a, ()) -> a) $
+    generalBracket
+      (niPutStr before)
+      (\() -> niPutStr . after)
+      (\() -> act)
+
+-- | Like 'niBracket', but adding linebreaks.
+--
+-- 'niBracketLn' is to 'niBracket' as 'niPutStrLn' is to 'niPutStr'.
+niBracketLn :: String -> (ExitCase a -> String) -> IO a -> IO a
+niBracketLn before after = niBracket (before ++ "\n") ((++ "\n") . after)
+
+deriving stock instance Functor ExitCase
+
 {-------------------------------------------------------------------------------
   Internal
 -------------------------------------------------------------------------------}