Improve logging callstack for createProcessWithLogging etc. and add demo

demos/demo-processes/LICENSE

@@ -0,0 +1,30 @@
+Copyright Tom McLaughlin (c) 2023
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * 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.
+
+    * Neither the name of Tom McLaughlin nor the names of other
+      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
+OWNER 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.

demos/demo-processes/app/Main.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Main where
+
+import Common
+import Control.Concurrent
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Data.String.Interpolate
+import System.Exit
+import System.Process
+import Test.Sandwich
+
+
+parallelNDemo :: TopSpec
+parallelNDemo = describe "Creating processes with logging" $ do
+  it "createProcessWithLogging" $ do
+    p <- createProcessWithLogging (shell "echo hiiiiii")
+    liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess)
+
+  it "createProcessWithLogging'" $ do
+    p <- createProcessWithLogging' LevelDebug (shell "echo hiiiiii")
+    liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess)
+
+  it "createProcessWithLoggingAndStdin" $ do
+    p <- createProcessWithLoggingAndStdin (shell "echo hiiiiii") ""
+    liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess)
+
+  it "createProcessWithLoggingAndStdin'" $ do
+    p <- createProcessWithLoggingAndStdin' LevelDebug (shell "echo hiiiiii") ""
+    liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess)
+
+  it "readCreateProcessWithLogging" $ do
+    stdout <- readCreateProcessWithLogging (shell ">&2 echo hiiiiii") ""
+    info [i|Got stdout: #{stdout}|]
+
+  it "readCreateProcessWithLogging'" $ do
+    stdout <- readCreateProcessWithLogging' LevelDebug (shell ">&2 echo hiiiiii") ""
+    info [i|Got stdout: #{stdout}|]
+
+  it "callCommandWithLogging" $ do
+    callCommandWithLogging ">&2 echo hiiiiii"
+
+  it "callCommandWithLogging'" $ do
+    callCommandWithLogging' LevelDebug ">&2 echo hiiiiii"
+
+testOptions = defaultOptions {
+  optionsTestArtifactsDirectory = defaultTestArtifactsDirectory
+  }
+
+main :: IO ()
+main = runSandwichWithCommandLineArgs testOptions parallelNDemo

demos/demo-processes/demo-processes.cabal

@@ -0,0 +1,37 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.36.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:           demo-processes
+version:        0.1.0.0
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+
+executable demo-processes
+  main-is: Main.hs
+  other-modules:
+      Paths_demo_processes
+  hs-source-dirs:
+      app
+  default-extensions:
+      OverloadedStrings
+      QuasiQuotes
+      NamedFieldPuns
+      RecordWildCards
+      ScopedTypeVariables
+      FlexibleContexts
+      FlexibleInstances
+      LambdaCase
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base
+    , monad-logger
+    , process
+    , sandwich
+    , sandwich-demos
+    , string-interpolate
+    , time
+  default-language: Haskell2010

demos/demo-processes/package.yaml

@@ -0,0 +1,32 @@
+name:                demo-processes
+version:             0.1.0.0
+license:             BSD3
+
+dependencies:
+- base
+- monad-logger
+- process
+- sandwich
+- sandwich-demos
+- string-interpolate
+- time
+
+default-extensions:
+- OverloadedStrings
+- QuasiQuotes
+- NamedFieldPuns
+- RecordWildCards
+- ScopedTypeVariables
+- FlexibleContexts
+- FlexibleInstances
+- LambdaCase
+
+ghc-options:
+- -threaded
+- -rtsopts
+- -with-rtsopts=-N
+
+executables:
+  demo-processes:
+    main: Main.hs
+    source-dirs: app

sandwich/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## Unreleased changes
 
+* Make createProcessWithLogging, readCreateProcessWithLogging etc. log with the callstack from the line where they're called (and not an internal line).
+
 ## 0.2.2.0
 
 * Add primed versions of createProcessWithLogging etc. with customizable log level

sandwich/src/Test/Sandwich/Logging.hs

@@ -74,11 +74,11 @@ logOther = logOtherCS callStack
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
 -- Every line output by the process will be fed to a 'debug' call.
-createProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> m ProcessHandle
-createProcessWithLogging = createProcessWithLogging' LevelDebug
+createProcessWithLogging :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> m ProcessHandle
+createProcessWithLogging = withFrozenCallStack (createProcessWithLogging' LevelDebug)
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
-createProcessWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> m ProcessHandle
+createProcessWithLogging' :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> CreateProcess -> m ProcessHandle
 createProcessWithLogging' logLevel cp = do
   (hRead, hWrite) <- liftIO createPipe
 
@@ -88,18 +88,18 @@ createProcessWithLogging' logLevel cp = do
 
   _ <- async $ forever $ do
     line <- liftIO $ hGetLine hRead
-    logOther logLevel [i|#{name}: #{line}|]
+    logOtherCS callStack logLevel [i|#{name}: #{line}|]
 
   (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite })
   return p
 
 -- | Like 'readCreateProcess', but capture the stderr output in the logs.
 -- Every line output by the process will be fed to a 'debug' call.
-readCreateProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> String -> m String
-readCreateProcessWithLogging = readCreateProcessWithLogging' LevelDebug
+readCreateProcessWithLogging :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> String -> m String
+readCreateProcessWithLogging = withFrozenCallStack (readCreateProcessWithLogging' LevelDebug)
 
 -- | Like 'readCreateProcess', but capture the stderr output in the logs.
-readCreateProcessWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> String -> m String
+readCreateProcessWithLogging' :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m String
 readCreateProcessWithLogging' logLevel cp input = do
   (hReadErr, hWriteErr) <- liftIO createPipe
 
@@ -109,7 +109,7 @@ readCreateProcessWithLogging' logLevel cp input = do
 
   _ <- async $ forever $ do
     line <- liftIO $ hGetLine hReadErr
-    logOther logLevel [i|#{name}: #{line}|]
+    logOtherCS callStack logLevel [i|#{name}: #{line}|]
 
   -- Do this just like 'readCreateProcess'
   -- https://hackage.haskell.org/package/process-1.6.17.0/docs/src/System.Process.html#readCreateProcess
@@ -149,11 +149,11 @@ readCreateProcessWithLogging' logLevel cp input = do
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
 -- Every line output by the process will be fed to a 'debug' call.
-createProcessWithLoggingAndStdin :: (MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> String -> m ProcessHandle
-createProcessWithLoggingAndStdin = createProcessWithLoggingAndStdin' LevelDebug
+createProcessWithLoggingAndStdin :: (HasCallStack, MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> String -> m ProcessHandle
+createProcessWithLoggingAndStdin = withFrozenCallStack (createProcessWithLoggingAndStdin' LevelDebug)
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
-createProcessWithLoggingAndStdin' :: (MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> String -> m ProcessHandle
+createProcessWithLoggingAndStdin' :: (HasCallStack, MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m ProcessHandle
 createProcessWithLoggingAndStdin' logLevel cp input = do
   (hRead, hWrite) <- liftIO createPipe
 
@@ -163,7 +163,7 @@ createProcessWithLoggingAndStdin' logLevel cp input = do
 
   _ <- async $ forever $ do
     line <- liftIO $ hGetLine hRead
-    logOther logLevel [i|#{name}: #{line}|]
+    logOtherCS callStack logLevel [i|#{name}: #{line}|]
 
   (Just inh, _, _, p) <- liftIO $ createProcess (
     cp { std_out = UseHandle hWrite
@@ -179,11 +179,11 @@ createProcessWithLoggingAndStdin' logLevel cp input = do
   return p
 
 -- | Higher level version of 'createProcessWithLogging', accepting a shell command.
-callCommandWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m ()
-callCommandWithLogging = callCommandWithLogging' LevelDebug
+callCommandWithLogging :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m ()
+callCommandWithLogging = withFrozenCallStack (callCommandWithLogging' LevelDebug)
 
 -- | Higher level version of 'createProcessWithLogging'', accepting a shell command.
-callCommandWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> String -> m ()
+callCommandWithLogging' :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> String -> m ()
 callCommandWithLogging' logLevel cmd = do
   (hRead, hWrite) <- liftIO createPipe
 
@@ -195,7 +195,7 @@ callCommandWithLogging' logLevel cmd = do
 
   _ <- async $ forever $ do
     line <- liftIO $ hGetLine hRead
-    logOther logLevel [i|#{cmd}: #{line}|]
+    logOtherCS callStack logLevel [i|#{cmd}: #{line}|]
 
   liftIO (waitForProcess p) >>= \case
     ExitSuccess -> return ()

stack.yaml

@@ -27,6 +27,7 @@ packages:
 - ./demos/demo-hedgehog
 - ./demos/demo-landing
 - ./demos/demo-paralleln
+- ./demos/demo-processes
 - ./demos/demo-quickcheck
 - ./demos/demo-setup-teardown
 - ./demos/demo-slack