diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index b348e8a..d8ca822 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -1,6 +1,6 @@ # This GitHub workflow config has been generated by a script via # -# haskell-ci 'github' 'niio.cabal' +# haskell-ci 'github' 'debuggable.cabal' # # To regenerate the script (for example after adjusting tested-with) run # @@ -8,9 +8,9 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.19.20240708 +# version: 0.19.20241121 # -# REGENDATA ("0.19.20240708",["github","niio.cabal"]) +# REGENDATA ("0.19.20241121",["github","debuggable.cabal"]) # name: Haskell-CI on: @@ -64,15 +64,29 @@ jobs: allow-failure: false fail-fast: false steps: - - name: apt + - name: apt-get install run: | apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 + - name: Install GHCup + run: | mkdir -p "$HOME/.ghcup/bin" curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + - name: Install cabal-install + run: | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + - name: Install GHC (GHCup) + if: matrix.setup-method == 'ghcup' + run: | + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -83,21 +97,12 @@ jobs: echo "LANG=C.UTF-8" >> "$GITHUB_ENV" echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" - HCDIR=/opt/$HCKIND/$HCVER - HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") - HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') - HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" - echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" echo "HEADHACKAGE=false" >> "$GITHUB_ENV" echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" - echo "GHCJSARITH=0" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -165,17 +170,17 @@ jobs: find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; - name: generate cabal.project run: | - PKGDIR_niio="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/niio-[0-9.]*')" - echo "PKGDIR_niio=${PKGDIR_niio}" >> "$GITHUB_ENV" + PKGDIR_debuggable="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/debuggable-[0-9.]*')" + echo "PKGDIR_debuggable=${PKGDIR_debuggable}" >> "$GITHUB_ENV" rm -f cabal.project cabal.project.local touch cabal.project touch cabal.project.local - echo "packages: ${PKGDIR_niio}" >> cabal.project - echo "package niio" >> cabal.project + echo "packages: ${PKGDIR_debuggable}" >> cabal.project + echo "package debuggable" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project cat >> cabal.project <> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(debuggable)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan @@ -200,7 +205,7 @@ jobs: $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always - name: cabal check run: | - cd ${PKGDIR_niio} || false + cd ${PKGDIR_debuggable} || false ${CABAL} -vnormal check - name: haddock run: | @@ -210,8 +215,8 @@ jobs: rm -f cabal.project.local $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all - name: save cache - uses: actions/cache/save@v4 if: always() + uses: actions/cache/save@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store diff --git a/README.md b/README.md index 9abd9c9..2500ff4 100644 --- a/README.md +++ b/README.md @@ -1,65 +1,6 @@ -# `niio`: functions for debugging that guarantee non-interleaved output +# `provenance`: utilities for tracking provenance -This package provides analogues of various standard output functions; all of -these functions are safe to use in a concurrent setting, and guarantee that the -output of one function call will not be interleaved with the output of another. -Examples include +This package provides utilities that can help track when and where things are +defined, to aid debugging. It also provides some utilities for non-interleaved +output, for debugging concurrent code. -```haskell -niPutStr :: MonadIO m => String -> m () -niPutStrLn :: MonadIO m => String -> m () -niPrint :: (MonadIO m, Show a) => a -> m () -niTrace :: String -> a -> a -niTraceShow :: Show a => a -> b -> b -niTraceShowId :: Show a => a -> a -niTraceM :: Applicative m => String -> m () -niTraceShowM :: (Applicative m, Show a) => a -> m () -``` - -In addition, we provide some support for creating uniques, to be able to -support correlating log messages, and some functionality for working with -these uniques: - -```haskell -niGetUnique :: (MonadIO m, HasCallStack) => m NiUnique -niPutStrAt :: MonadIO m => [NiUnique] -> String -> m () -``` - -and - -```haskell -niBracket :: - (MonadIO m, MonadMask m, HasCallStack) - => (NiUnique -> m ()) -- ^ Prior to the action - -> (NiUnique -> ExitCase a -> m ()) -- ^ After - -> (NiUnique -> m a) - -> m a -``` - -For example: - -```haskell --- > niBracket (\i -> niPutStrAt [i] "start") (\i -> niPutStrAt [i] . show) $ \i -> --- > .. --- > niBracket (\j -> niPutStrAt [i, j] "start") (\j -> niPutStrAt [i, j] . show) $ \j -> --- > .. --- > niPutStrAt [i, j] $ "foo: " ++ E.displayException e --- > .. -``` - -might result in - -``` --- > ["exampleFun(./Example/File.hs:100:5)/1"] start --- > ["exampleFun(./Example/File.hs:100:5)/1","exampleFun(./Example/File.hs:120:13)/1"] start --- > ["exampleFun(./Example/File.hs:100:5)/1","exampleFun(./Example/File.hs:120:13)/1"] --- > foo: ExampleException --- > HasCallStack backtrace: --- > collectBacktraces, called at (..) --- > toExceptionWithBacktrace, called at (..) --- > throwIO, called at (..) --- > ["exampleFun(./Example/File.hs:100:5)/1","exampleFun(./Example/File.hs:120:13)/1"] ExitCaseSuccess () --- > ["exampleFun(./Example/File.hs:100:5)/1"] ExitCaseSuccess () -``` - -This package is intended for debugging only. diff --git a/niio.cabal b/debuggable.cabal similarity index 52% rename from niio.cabal rename to debuggable.cabal index d6da2a9..1de5f85 100644 --- a/niio.cabal +++ b/debuggable.cabal @@ -1,7 +1,13 @@ cabal-version: 3.0 -name: niio +name: debuggable version: 0.1.0 -synopsis: Functions for debugging that guarantee non-interleaved output +synopsis: Utilities for making your applications more debuggable. +description: This package provides various utilities that can be used to + make your application easier to debug. Some of these tools are + intended for use during actual debugging only (similar to + @Debug.Trace@, for example). Other tools can be used as a + regular component in your application, to facilitate debugging + if and when necessary, but always present in your code. license: BSD-3-Clause license-file: LICENSE author: Edsko de Vries @@ -28,14 +34,23 @@ common lang DerivingStrategies GeneralizedNewtypeDeriving NamedFieldPuns + ScopedTypeVariables StandaloneDeriving + TupleSections library - import: lang - exposed-modules: System.IO.NonInterleaved - hs-source-dirs: src + import: lang + hs-source-dirs: src + + exposed-modules: + Debug.NonInterleavedIO + Debug.NonInterleavedIO.Scoped + Debug.NonInterleavedIO.Trace + Debug.Provenance + Debug.Provenance.Scope build-depends: + , containers >= 0.6 && < 0.8 , exceptions >= 0.9 && < 0.11 , hashable >= 1.4 && < 1.6 , temporary >= 1.2.1 && < 1.4 diff --git a/src/Debug/NonInterleavedIO.hs b/src/Debug/NonInterleavedIO.hs new file mode 100644 index 0000000..ef67f28 --- /dev/null +++ b/src/Debug/NonInterleavedIO.hs @@ -0,0 +1,100 @@ +-- | Functions for non-interleaved output +-- +-- Intended for qualifed import. +-- +-- > import qualified Debug.NonInterleavedIO as NIIO +-- +-- Alternatively, you can import "Debug.NonInterleavedIO.Trace" as a drop-in +-- replacement for "Debug.Trace". +-- +-- The functions in this module can all be called concurrently, without +-- resulting in interleaved output: each function call is atomic. +-- +-- The first time any of these functions is called, we lookup the @NIIO_OUTPUT@ +-- environment variable. If set, we will write to the file specified (if the +-- file already exists, it will be overwritten). If @NIIO_OUTPUT@ is not set, a +-- temporary file will be created in the system temporary directory; typically +-- such a file will be called @/tmp/niio@. The name of this file is +-- written to @stderr@ (this is the /only/ output origiating from functions in +-- this module that is not written to the file). +module Debug.NonInterleavedIO ( + -- * Output functions + putStr + , putStrLn + , print + -- * Tracing functions + , trace + , traceShow + , traceShowId + , traceM + , traceShowM + ) where + +import Prelude hiding (putStr, putStrLn, print) + +import Control.Concurrent +import Control.Monad.IO.Class +import System.Environment +import System.IO.Temp (getCanonicalTemporaryDirectory) +import System.IO.Unsafe + +import qualified System.IO as IO + +{------------------------------------------------------------------------------- + Output functions +-------------------------------------------------------------------------------} + +-- | Non-interleaved version of 'Prelude.putStr' +putStr :: MonadIO m => String -> m () +putStr str = liftIO $ withMVar globalHandle $ \h -> IO.hPutStr h str + +-- | Non-interleaved version of 'Prelude.putStrLn' +putStrLn :: MonadIO m => String -> m () +putStrLn = putStr . (++ "\n") + +-- | Non-interleaved version of 'Prelude.print' +print :: MonadIO m => Show a => a -> m () +print = putStrLn . show + +{------------------------------------------------------------------------------- + Tracing +-------------------------------------------------------------------------------} + +-- | Non-interleaved version of 'Debug.Trace.trace' +trace :: String -> a -> a +trace str a = unsafePerformIO $ putStrLn str >> return a + +-- | Non-interleaved version of 'Debug.Trace.traceShow' +traceShow :: Show a => a -> b -> b +traceShow = trace . show + +-- | Non-interleaved version of 'Debug.Trace.traceShowId' +traceShowId :: Show a => a -> a +traceShowId a = traceShow (show a) a + +-- | Non-interleaved version of 'Debug.Trace.traceM' +traceM :: Applicative m => String -> m () +traceM str = trace str $ pure () + +-- | Non-interleaved version of 'Debug.Trace.traceShowM' +traceShowM :: (Applicative m, Show a) => a -> m () +traceShowM = traceM . show + +{------------------------------------------------------------------------------- + Internal: globals +-------------------------------------------------------------------------------} + +globalHandle :: MVar IO.Handle +{-# NOINLINE globalHandle #-} +globalHandle = unsafePerformIO $ do + mOutput <- lookupEnv "NIIO_OUTPUT" + (fp, h) <- case mOutput of + Nothing -> do + tmpDir <- getCanonicalTemporaryDirectory + IO.openTempFile tmpDir "niio" + Just fp -> do + (fp,) <$> IO.openFile fp IO.WriteMode + IO.hPutStrLn IO.stderr $ "niio output to " ++ fp + IO.hFlush IO.stderr + IO.hSetBuffering h IO.NoBuffering + newMVar h diff --git a/src/Debug/NonInterleavedIO/Scoped.hs b/src/Debug/NonInterleavedIO/Scoped.hs new file mode 100644 index 0000000..1985255 --- /dev/null +++ b/src/Debug/NonInterleavedIO/Scoped.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Utilities for writing debugging messages that include provenance +-- +-- Intended for qualified import. +-- +-- > import qualified Debug.NonInterleavedIO.Scoped as Scoped +module Debug.NonInterleavedIO.Scoped ( + putStrLn + ) where + +import Prelude hiding (putStrLn) + +import Control.Monad.IO.Class +import Data.List (intercalate) +import GHC.Stack + +import Debug.Provenance +import Debug.Provenance.Scope + +import qualified Debug.NonInterleavedIO as NIIO + +{------------------------------------------------------------------------------- + Uniques +-------------------------------------------------------------------------------} + +-- | Print debug message, showing current scope +putStrLn :: MonadIO m => String -> m () +putStrLn str = withFrozenCallStack $ do + scope <- getScope + here <- newInvocation callSite + + let prettyScope :: String + prettyScope = intercalate "," $ map prettyInvocation (here : scope) + + NIIO.putStrLn $ + case lines str of + [one] -> prettyScope ++ " " ++ one + many -> intercalate "\n" $ prettyScope : map (" " ++) many diff --git a/src/Debug/NonInterleavedIO/Trace.hs b/src/Debug/NonInterleavedIO/Trace.hs new file mode 100644 index 0000000..54a15c6 --- /dev/null +++ b/src/Debug/NonInterleavedIO/Trace.hs @@ -0,0 +1,14 @@ +-- | Drop-in replacement for "Debug.Trace" +-- +-- This module just re-exports some functions from "Debug.NonInterleavedIO"; +-- since it does not export anything that clashes with "Prelude" it can be +-- imported unqualified. +module Debug.NonInterleavedIO.Trace ( + trace + , traceShow + , traceShowId + , traceM + , traceShowM + ) where + +import Debug.NonInterleavedIO diff --git a/src/Debug/Provenance.hs b/src/Debug/Provenance.hs new file mode 100644 index 0000000..55e6db3 --- /dev/null +++ b/src/Debug/Provenance.hs @@ -0,0 +1,173 @@ +-- | Utilities for tracking provenance: where and when things are called +module Debug.Provenance ( + -- * Callsites + CallSite -- opaque + , prettyCallSite + , callSite + , callSiteWithLabel + -- * Invocations + , Invocation -- opaque + , prettyInvocation + , newInvocation + ) where + +import Control.Monad.IO.Class +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import Data.IORef +import Data.List (intercalate) +import GHC.Generics +import GHC.Stack +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.HashMap.Strict as HashMap + +{------------------------------------------------------------------------------- + Callsites +-------------------------------------------------------------------------------} + +-- | Callsite +-- +-- A callsite tells you where something was called: a location in the source, +-- and the name of the function that did the calling. Optionally, they can be +-- given an additional user-defined label also. +-- +-- /NOTE/: If you are seeing @@ instead of the function name, +-- the calling function does not have a 'HasCallStack' annotation: +-- +-- > yourFunction :: HasCallStack => IO () -- 'HasCallStack' probably missing +-- > yourFunction = do +-- > let cs = callSite +-- > .. +-- +-- Once you add this annotation, you should see @yourFunction@ instead of +-- @@. Similarly, if you have local function definitions, it may +-- be useful to give those 'HasCallStack' constraints of their own: +-- +-- > yourFunction :: HasCallStack => IO () +-- > yourFunction = .. +-- > where +-- > someLocalFn :: HasCallStack => IO () +-- > someLocalFn = do +-- > let cs = callSite +-- > .. +-- +-- In this example the 'HasCallStack' constraint on @someLocalFn@ means that the +-- calling function will be reported as @someLocalFn@ instead of @yourFunction@. +data CallSite = CallSite { + callSiteSrcLoc :: SrcLoc + , callSiteFunction :: Maybe String + , callSiteLabel :: Label + } + deriving stock (Eq) + +-- | Label associated with 'CallSite' +-- +-- This is an internal type. +data Label = Label String | NoLabel + deriving stock (Eq, Generic) + deriving anyclass (Hashable) + +-- | Render 'CallSite' to human-readable format +prettyCallSite :: CallSite -> String +prettyCallSite CallSite{callSiteSrcLoc, callSiteFunction, callSiteLabel} = + concat [ + case callSiteFunction of + Nothing -> "" + Just fn -> fn + , "(" + , intercalate ":" [ + srcLocFile callSiteSrcLoc + , show $ srcLocStartLine callSiteSrcLoc + , show $ srcLocStartCol callSiteSrcLoc + ] + , case callSiteLabel of + NoLabel -> "" + Label l -> "," ++ show l + , ")" + ] + +instance Hashable CallSite where + hashWithSalt salt CallSite{callSiteSrcLoc, callSiteFunction, callSiteLabel} = + hashWithSalt salt ( + prettySrcLoc callSiteSrcLoc + , callSiteFunction + , callSiteLabel + ) + +-- | Current 'CallSite' +callSite :: HasCallStack => CallSite +callSite = withFrozenCallStack $ mkCallSite NoLabel + +-- | Current 'CallSite' with user-defined label +callSiteWithLabel :: String -> CallSite +callSiteWithLabel label = withFrozenCallStack $ mkCallSite (Label label) + +-- | Internal auxiliary to 'callSite' and 'callSiteWithLabel' +mkCallSite :: HasCallStack => Label -> CallSite +mkCallSite callSiteLabel = aux callStack + where + aux :: CallStack -> CallSite + aux cs = + case getCallStack cs of + (_, loc) : [] -> CallSite { + callSiteSrcLoc = loc + , callSiteFunction = Nothing + , callSiteLabel + } + (_, loc) : (fn, _) : _ -> CallSite { + callSiteSrcLoc = loc + , callSiteFunction = Just fn + , callSiteLabel + } + [] -> + bug "callSite: emptycallstack" + +{------------------------------------------------------------------------------- + Invocations +-------------------------------------------------------------------------------} + +-- | Invocation +-- +-- An invocation not only tells you the /where/, but also the /when/: it pairs a +-- 'CallSite' with a count, automatically incremented on each call to +-- 'newInvocation'. Each 'CallSite' uses its own counter. +data Invocation = Invocation CallSite Int + deriving stock (Eq) + +-- | Render 'Invocation' to human-readable format +prettyInvocation :: Invocation -> String +prettyInvocation (Invocation cs n) = + concat [ + "\"" + , prettyCallSite cs + , "/" ++ show n + , "\"" + ] + +-- | New invocation +-- +-- See 'Invocation' for discussion. +newInvocation :: (MonadIO m, HasCallStack) => CallSite -> m Invocation +newInvocation cs = liftIO $ do + atomicModifyIORef' globalCounters $ \counters -> + let i = HashMap.findWithDefault 1 cs counters + in (HashMap.insert cs (succ i) counters, Invocation cs i) + +{------------------------------------------------------------------------------- + Internal: auxiliary +-------------------------------------------------------------------------------} + +bug :: String -> a +bug str = error . unlines $ [ + str + , "Please report this as a bug at https://github.com/well-typed/niio" + ] + +{------------------------------------------------------------------------------- + Internal: globals +-------------------------------------------------------------------------------} + +globalCounters :: IORef (HashMap CallSite Int) +{-# NOINLINE globalCounters #-} +globalCounters = unsafePerformIO $ newIORef HashMap.empty diff --git a/src/Debug/Provenance/Scope.hs b/src/Debug/Provenance/Scope.hs new file mode 100644 index 0000000..dcd633b --- /dev/null +++ b/src/Debug/Provenance/Scope.hs @@ -0,0 +1,109 @@ +-- | Utilities for tracking scope: nested 'Invocation's +module Debug.Provenance.Scope ( + -- * Thread-local scope + Scope + , scoped + , getScope + -- * Scope across threads + , forkInheritScope + , inheritScope + ) where + +import Control.Concurrent +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.Bifunctor +import Data.IORef +import Data.Map.Strict (Map) +import Data.Maybe (fromMaybe) +import Data.Tuple (swap) +import GHC.Stack +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.Map.Strict as Map + +import Debug.Provenance + +{------------------------------------------------------------------------------- + Scope +-------------------------------------------------------------------------------} + +-- | Thread-local scope +-- +-- Most recent invocations are first in the list. +type Scope = [Invocation] + +-- | Extend current scope +scoped :: (HasCallStack, MonadMask m, MonadIO m) => CallSite -> m a -> m a +scoped cs k = (\(a, ()) -> a) <$> do + i <- newInvocation cs + generalBracket + (pushInvocation i) + (\_ _ -> popInvocation) + (\_ -> k) + +-- | Get current scope +getScope :: MonadIO m => m Scope +getScope = modifyThreadLocalScope $ \s -> (s, s) + +{------------------------------------------------------------------------------- + Scope across threads +-------------------------------------------------------------------------------} + +-- | Inherit scope from a parent thread +-- +-- This sets the scope of the current thread to that of the parent. This should +-- be done prior to growing the scope of the child thread; 'inheritScope' will +-- fail with an exception if the scope in the child thread is not empty. +-- +-- See also 'forkInheritScope'. +inheritScope :: MonadIO m => ThreadId -> m () +inheritScope parent = liftIO $ do + parentScope <- Map.findWithDefault [] parent <$> readIORef globalScope + ok <- modifyThreadLocalScope $ \childScope -> + if null childScope + then (parentScope, True) + else (childScope, False) + unless ok $ fail "inheritScope: child scope non-empty" + +-- | Convenience combination of 'forkIO' and 'inheritScope' +forkInheritScope :: IO () -> IO ThreadId +forkInheritScope child = do + parent <- myThreadId + forkIO $ inheritScope parent >> child + +{------------------------------------------------------------------------------- + Internal: scope manipulation +-------------------------------------------------------------------------------} + +modifyThreadLocalScope :: forall m a. MonadIO m => (Scope -> (Scope, a)) -> m a +modifyThreadLocalScope f = liftIO $ do + tid <- myThreadId + atomicModifyIORef' globalScope $ swap . Map.alterF f' tid + where + f' :: Maybe Scope -> (a, Maybe Scope) + f' = second gcIfEmpty . swap . f . fromMaybe [] + + -- Remove the entry from the map altogether if the scope is empty. + gcIfEmpty :: Scope -> Maybe Scope + gcIfEmpty [] = Nothing + gcIfEmpty s = Just s + +modifyThreadLocalScope_ :: MonadIO m => (Scope -> Scope) -> m () +modifyThreadLocalScope_ f = modifyThreadLocalScope ((,()) . f) + +pushInvocation :: MonadIO m => Invocation -> m () +pushInvocation i = modifyThreadLocalScope_ (i:) + +popInvocation :: MonadIO m => m () +popInvocation = modifyThreadLocalScope_ tail + +{------------------------------------------------------------------------------- + Internal: globals +-------------------------------------------------------------------------------} + +globalScope :: IORef (Map ThreadId Scope) +{-# NOINLINE globalScope #-} +globalScope = unsafePerformIO $ newIORef Map.empty + diff --git a/src/System/IO/NonInterleaved.hs b/src/System/IO/NonInterleaved.hs deleted file mode 100644 index d96d3d9..0000000 --- a/src/System/IO/NonInterleaved.hs +++ /dev/null @@ -1,327 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - --- | Functions for non-interleaved output --- --- Intended for unqualified import. -module System.IO.NonInterleaved ( - -- * Output functions - niPutStr - , niPutStrLn - , niPrint - -- * Tracing functions - , niTrace - , niTraceShow - , niTraceShowId - , niTraceM - , niTraceShowM - -- * Uniques - , NiUnique -- opaque - , niUniqueLabel - , niGetUnique - , niGetLabelledUnique - , niPutStrAt - -- * Derived functionality - , niBracket - ) where - -import Control.Concurrent -import Control.Monad.Catch (MonadMask, ExitCase(..), generalBracket) -import Control.Monad.IO.Class -import Data.Hashable (Hashable(..)) -import Data.HashMap.Strict (HashMap) -import Data.IORef -import Data.List (intercalate) -import GHC.Generics (Generic) -import GHC.Stack -import System.Environment -import System.IO -import System.IO.Temp (getCanonicalTemporaryDirectory) -import System.IO.Unsafe - -import qualified Data.HashMap.Strict as HashMap - -{------------------------------------------------------------------------------- - Output functions --------------------------------------------------------------------------------} - --- | Non-interleaved version of 'putStr' --- --- Concurrent calls to 'niPutStr' will not result in interleaved output. --- --- The first output will create a new temporary file (typically in @/tmp@, --- depending on the OS), and a message is written to 'stderr' with the name of --- the file. If you prefer to specify which file to write to, you can set the --- @NIIO_OUTPUT@ environment variable. -niPutStr :: MonadIO m => String -> m () -niPutStr str = liftIO $ withMVar niHandle $ \h -> hPutStr h str >> hFlush h - --- | Non-interleaved version of 'putStrLn' --- --- See 'niPutStr' for additional discussion. -niPutStrLn :: MonadIO m => String -> m () -niPutStrLn = niPutStr . (++ "\n") - --- | Non-interleaved version of 'print' --- --- See 'niPutStr' for additional discussion. -niPrint :: MonadIO m => Show a => a -> m () -niPrint = niPutStrLn . show - -{------------------------------------------------------------------------------- - Tracing --------------------------------------------------------------------------------} - --- | Non-interleaved version of 'trace' --- --- This function can safely be used concurrently with 'niPutStr' and the other --- functions in this module. -niTrace :: String -> a -> a -niTrace str a = unsafePerformIO $ niPutStrLn str >> return a - --- | Non-interleaved version of 'traceShow' --- --- See 'niTrace' for additional discussion. -niTraceShow :: Show a => a -> b -> b -niTraceShow = niTrace . show - --- | Non-interleaved version of 'traceShowId' --- --- See 'niTrace' for additional discussion. -niTraceShowId :: Show a => a -> a -niTraceShowId a = niTraceShow (show a) a - --- | Non-interleaved version of 'traceM' --- --- See 'niTrace' for additional discussion. -niTraceM :: Applicative m => String -> m () -niTraceM str = niTrace str $ pure () - --- | Non-interleaved version of 'traceShowM' --- --- See 'niTrace' for additional discussion. -niTraceShowM :: (Applicative m, Show a) => a -> m () -niTraceShowM = niTraceM . show - -{------------------------------------------------------------------------------- - Uniques --------------------------------------------------------------------------------} - --- | Optional label for an 'NiUnique' -data Label = Label String | NoLabel - deriving stock (Eq, Generic) - deriving anyclass (Hashable) - --- | Unique value --- --- See 'niGetUnique'. -data NiUnique = NiUnique (CallSite, Label) Int - deriving stock (Eq) - --- | Label associated with this 'NiUnique', if any -niUniqueLabel :: NiUnique -> Maybe String -niUniqueLabel (NiUnique (_, NoLabel) _) = Nothing -niUniqueLabel (NiUnique (_, Label l) _) = Just l - -instance Show NiUnique where - show (NiUnique (cs, mLabel) i) = concat [ - "\"" - , prettyCallSite cs - , case mLabel of - NoLabel -> "" - Label l -> "/" ++ l - , "/" ++ show i - , "\"" - ] - --- | Get a unique value (useful for correlating different log messages) --- --- Each call to 'niGetUnique' will return a value that is unique relative to --- where 'niGetUnique' is called from. --- --- /NOTE/: If you are seeing @@ when showing the 'NiUnique', this --- means that the calling function does not have a 'HasCallStack' annotation: --- --- > yourFunction :: HasCallStack => IO () --- > yourFunction = do --- > i <- niGetUnique --- > .. --- --- once you add this annotation, you should see @yourFunction@ instead of --- @@. Similarly, if you have local function definitions, it may --- be useful to give those 'HasCallStack' constraints of their own: --- --- > yourFunction :: HasCallStack => IO () --- > yourFunction = .. --- > where --- > someLocalFn :: HasCallStack => IO () --- > someLocalFn = do --- > i <- niGetUnique --- > .. --- --- In this example the 'HasCallStack' constraint on 'someLocalFn' means that --- the 'NiUnique' will show @someLocalFn@ instead of @yourFunction@. -niGetUnique :: (MonadIO m, HasCallStack) => m NiUnique -niGetUnique = withFrozenCallStack $ niGetUniqueWithLabel NoLabel - --- | Variant of 'niGetUnique' with an additional label --- --- The combination of the call site and the label will determine the unique. -niGetLabelledUnique :: (MonadIO m, HasCallStack) => String -> m NiUnique -niGetLabelledUnique l = withFrozenCallStack $ niGetUniqueWithLabel (Label l) - --- | Output with 'NiUnique' prefix --- --- Example: --- --- > niPutStrAt [i, j] $ "foo: " ++ E.displayException e --- --- results in output such as --- --- > ["exampleFun(./Example/File.hs:100:5)/1","exampleFun2(./Example/File.hs:120:13)/1"] --- > foo: ExampleException --- > HasCallStack backtrace: --- > collectBacktraces, called at (..) --- > toExceptionWithBacktrace, called at (..) --- > throwIO, called at (..) -niPutStrAt :: MonadIO m => [NiUnique] -> String -> m () -niPutStrAt is str = - niPutStrLn $ - case lines str of - [one] -> show is ++ " " ++ one - many -> intercalate "\n" $ show is : map (" " ++) many - --- | Internal generalization of 'niGetUnique' and 'niGetLabelledUnique' -niGetUniqueWithLabel :: (MonadIO m, HasCallStack) => Label -> m NiUnique -niGetUniqueWithLabel l = withFrozenCallStack $ - liftIO $ atomicModifyIORef niUniques $ \uniques -> - let - cs = callSite - i = HashMap.findWithDefault 1 (cs, l) uniques - in - (HashMap.insert (cs, l) (succ i) uniques, NiUnique (cs, l) i) - -{------------------------------------------------------------------------------- - Derived functionality --------------------------------------------------------------------------------} - --- | Print a message before and after an action --- --- In order to make it easier to correlate the messages before and after the --- action, we give both a newly created 'Unique' (see 'niGetUnique'). --- --- A common way to invoke 'niBracket' is --- --- > niBracket (\i -> niPutStrAt [i] "start") (\i -> niPutStrAt [i] . show) $ \i -> --- --- resulting in output such as --- --- > ["exampleFun(./Example/File.hs:100:5)/1"] start --- > .. --- > ["exampleFun(./Example/File.hs:100:5)/1"] ExitCaseSuccess () --- --- When nesting calls to 'niBracket', it can be useful to combine the uniques --- in order to get better correlation: --- --- > niBracket (\i -> niPutStrAt [i] "start") (\i -> niPutStrAt [i] . show) $ \i -> --- > .. --- > niBracket (\j -> niPutStrAt [i, j] "start") (\j -> niPutStrAt [i, j] . show) $ \j -> --- > .. --- --- resulting in output such as --- --- > ["exampleFun(./Example/File.hs:100:5)/1"] start --- > .. --- > ["exampleFun(./Example/File.hs:100:5)/1","exampleFun(./Example/File.hs:120:13)/1"] start --- > .. --- > ["exampleFun(./Example/File.hs:100:5)/1","exampleFun(./Example/File.hs:120:13)/1"] ExitCaseSuccess () --- > .. --- > ["exampleFun(./Example/File.hs:100:5)/1"] ExitCaseSuccess () --- --- NOTE: We provide an (orphan) 'Functor' instance for 'ExitCase', which can --- be useful in cases where @a@ is not showable. -niBracket :: - (MonadIO m, MonadMask m, HasCallStack) - => (NiUnique -> m ()) -- ^ Prior to the action - -> (NiUnique -> ExitCase a -> m ()) -- ^ After - -> (NiUnique -> m a) - -> m a -niBracket before after act = withFrozenCallStack $ - fmap (\(a, ()) -> a) $ do - i <- niGetUnique - generalBracket - (before i) - (\() -> after i) - (\() -> act i) - --- | See 'niBracket' -deriving stock instance Functor ExitCase - -{------------------------------------------------------------------------------- - Internal: callsites --------------------------------------------------------------------------------} - -data CallSite = CallSite { - calledFromLoc :: SrcLoc - , calledFromFn :: Maybe String - } - deriving stock (Eq) - -prettyCallSite :: CallSite -> String -prettyCallSite CallSite{calledFromLoc, calledFromFn} = concat [ - case calledFromFn of - Nothing -> "" - Just fn -> fn - , "(" - , intercalate ":" [ - srcLocFile calledFromLoc - , show $ srcLocStartLine calledFromLoc - , show $ srcLocStartCol calledFromLoc - ] - , ")" - ] - -instance Hashable CallSite where - hashWithSalt salt CallSite{calledFromLoc, calledFromFn} = - hashWithSalt salt (prettySrcLoc calledFromLoc, calledFromFn) - -callSite :: HasCallStack => CallSite -callSite = aux callStack - where - aux :: CallStack -> CallSite - aux cs = - case getCallStack cs of - (_, loc) : [] -> CallSite loc Nothing - (_, loc) : (fn, _) : _ -> CallSite loc (Just fn) - [] -> bug "callSite: emptycallstack" - -{------------------------------------------------------------------------------- - Internal: globals --------------------------------------------------------------------------------} - -niHandle :: MVar Handle -{-# NOINLINE niHandle #-} -niHandle = unsafePerformIO $ do - mOutput <- lookupEnv "NIIO_OUTPUT" - case mOutput of - Nothing -> do - tmpDir <- getCanonicalTemporaryDirectory - (fp, h) <- openTempFile tmpDir "niio" - hPutStrLn stderr $ "niio output to " ++ fp - newMVar h - Just fp -> do - hPutStrLn stderr $ "niio output to " ++ fp - newMVar =<< openFile fp WriteMode - -niUniques :: IORef (HashMap (CallSite, Label) Int) -{-# NOINLINE niUniques #-} -niUniques = unsafePerformIO $ newIORef HashMap.empty - -{------------------------------------------------------------------------------- - Internal auxiliary --------------------------------------------------------------------------------} - -bug :: String -> a -bug str = error . unlines $ [ - str - , "Please report this as a bug at https://github.com/well-typed/niio" - ]