diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for debuggable + +## 0.1.0 -- 2024-11-23 + +* First public release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2024, Well-Typed LLP + +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 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. diff --git a/debuggable.cabal b/debuggable.cabal new file mode 100644 --- /dev/null +++ b/debuggable.cabal @@ -0,0 +1,114 @@ +cabal-version: 3.0 +name: debuggable +version: 0.1.0 +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 +maintainer: edsko@well-typed.com +category: Development +build-type: Simple +extra-doc-files: CHANGELOG.md +tested-with: GHC==8.10.7 + , GHC==9.2.8 + , GHC==9.4.8 + , GHC==9.6.6 + , GHC==9.8.2 + , GHC==9.10.1 + +source-repository head + type: git + location: https://github.com/well-typed/debuggable + +common lang + default-language: Haskell2010 + build-depends: base >= 4.14 && < 4.21 + + default-extensions: + BangPatterns + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DerivingStrategies + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + NamedFieldPuns + NumericUnderscores + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + + ghc-options: + -Wall + -Wredundant-constraints + -Wprepositive-qualified-module + -Widentities + -Wmissing-export-lists + + if impl(ghc >= 9.0) + ghc-options: + -Wunused-packages + +library + import: lang + hs-source-dirs: src + + exposed-modules: + Debug.NonInterleavedIO + Debug.NonInterleavedIO.Scoped + Debug.NonInterleavedIO.Trace + Debug.Provenance + Debug.Provenance.Callback + Debug.Provenance.Scope + + other-modules: + Debug.Provenance.Internal + + build-depends: + , containers >= 0.6 && < 0.8 + , exceptions >= 0.9 && < 0.11 + , hashable >= 1.4 && < 1.6 + , temporary >= 1.2.1 && < 1.4 + , unordered-containers >= 0.2 && < 0.3 + + other-extensions: + ImplicitParams + +test-suite demo + import: lang + type: exitcode-stdio-1.0 + main-is: Demo.hs + hs-source-dirs: demo + + ghc-options: + -main-is Demo + -rtsopts + -threaded + "-with-rtsopts=-N" + + other-modules: + Cmdline + Demo.Callback + Demo.Callsite + Demo.Invocation + Demo.NIIO + Demo.Scope + + build-depends: + -- inherited dependencies + debuggable + + build-depends: + -- additional dependencies + , async >= 2.2 && < 2.3 + , optparse-applicative >= 0.18 && < 0.19 + diff --git a/demo/Cmdline.hs b/demo/Cmdline.hs new file mode 100644 --- /dev/null +++ b/demo/Cmdline.hs @@ -0,0 +1,114 @@ +module Cmdline ( + Cmdline(..) + , Demo(..) + , getCmdline + ) where + +import Options.Applicative + +import Demo.Invocation qualified as Invocation +import Demo.Scope qualified as Scope + +{------------------------------------------------------------------------------- + Top-level +-------------------------------------------------------------------------------} + +data Cmdline = Cmdline { + cmdDemo :: Maybe Demo + } + deriving stock (Show) + +data Demo = + DemoNiioWithout + | DemoNiioUse + | DemoCallsiteWithout + | DemoCallsiteUse + | DemoInvocationWithout + | DemoInvocationUse Invocation.Example + | DemoScopeUse Scope.Example + | DemoCallbackWithout + | DemoCallbackUse + deriving stock (Show) + +getCmdline :: IO Cmdline +getCmdline = execParser opts + where + opts :: ParserInfo Cmdline + opts = info (parseCmdline <**> helper) $ mconcat [ + fullDesc + , header "Demo of the debuggable package" + ] + +{------------------------------------------------------------------------------- + Parser +-------------------------------------------------------------------------------} + +parseCmdline :: Parser Cmdline +parseCmdline = + Cmdline + <$> optional parseDemo + +parseDemo :: Parser Demo +parseDemo = subparser $ mconcat [ + command' + "niio" + ( parseWithoutUse + (pure DemoNiioWithout) + (pure DemoNiioUse) + ) + "Demo Debug.NonInterleavedIO" + , command' + "callsite" + ( parseWithoutUse + (pure DemoCallsiteWithout) + (pure DemoCallsiteUse) + ) + "Demo CallSite from Debug.Provenance" + , command' + "invocation" + ( parseWithoutUse + (pure DemoInvocationWithout) + (DemoInvocationUse <$> parseInvocationExample) + ) + "Demo Invocation from Debug.Provenance" + , command' + "scope" + ( DemoScopeUse <$> parseScopeExample ) + "Demo Debug.Provenance.Scope" + , command' + "callback" + ( parseWithoutUse + (pure DemoCallbackWithout) + (pure DemoCallbackUse) + ) + "Demo Debug.Provenance.Callback" + ] + +parseWithoutUse :: Parser a -> Parser a -> Parser a +parseWithoutUse without use = subparser $ mconcat [ + command' "without-debuggable" without "Without debuggable" + , command' "use-debuggable" use "Use debuggable" + ] + +parseInvocationExample :: Parser Invocation.Example +parseInvocationExample = subparser $ mconcat [ + command' "example1" (pure Invocation.Example1) "Example 1" + , command' "example2" (pure Invocation.Example2) "Example 2" + ] + +parseScopeExample :: Parser Scope.Example +parseScopeExample = subparser $ mconcat [ + command' "example1" (pure Scope.Example1) "Example 1" + , command' "example2" (pure Scope.Example2) "Example 2" + , command' "example3" (pure Scope.Example3) "Example 3" + , command' "example4" (pure Scope.Example4) "Example 4" + ] + +{------------------------------------------------------------------------------- + Auxiliary optparse-applicative +-------------------------------------------------------------------------------} + +command' :: String -> Parser a -> String -> Mod CommandFields a +command' cmd parser desc = command cmd $ info (parser <**> helper) $ mconcat [ + progDesc desc + ] diff --git a/demo/Demo.hs b/demo/Demo.hs new file mode 100644 --- /dev/null +++ b/demo/Demo.hs @@ -0,0 +1,27 @@ +module Demo (main) where + +import Cmdline + +import Demo.Callback qualified as Callback +import Demo.Callsite qualified as Callsite +import Demo.Invocation qualified as Invocation +import Demo.NIIO qualified as NIIO +import Demo.Scope qualified as Scope + +main :: IO () +main = do + Cmdline{cmdDemo} <- getCmdline + case cmdDemo of + Nothing -> putStrLn "Please select a demo (see --help)" + Just demo -> + case demo of + DemoNiioWithout -> NIIO.withoutDebuggable + DemoNiioUse -> NIIO.useDebuggable + DemoCallsiteWithout -> Callsite.withoutDebuggable + DemoCallsiteUse -> Callsite.useDebuggable + DemoInvocationWithout -> Invocation.withoutDebuggable + DemoInvocationUse ex -> Invocation.useDebuggable ex + DemoScopeUse ex -> Scope.useDebuggable ex + DemoCallbackWithout -> Callback.withoutDebuggable + DemoCallbackUse -> Callback.useDebuggable + diff --git a/demo/Demo/Callback.hs b/demo/Demo/Callback.hs new file mode 100644 --- /dev/null +++ b/demo/Demo/Callback.hs @@ -0,0 +1,43 @@ +module Demo.Callback ( + withoutDebuggable + , useDebuggable + ) where + +import GHC.Stack + +import Debug.NonInterleavedIO.Scoped qualified as Scoped +import Debug.Provenance.Callback +import Debug.Provenance.Scope + +{------------------------------------------------------------------------------- + Without the library +-------------------------------------------------------------------------------} + +f1 :: HasCallStack => (Int -> IO ()) -> IO () +f1 k = f2 k + +f2 :: HasCallStack => (Int -> IO ()) -> IO () +f2 k = scoped $ k 1 + +g1 :: HasCallStack => Int -> IO () +g1 n = g2 n + +g2 :: HasCallStack => Int -> IO () +g2 n = Scoped.putStrLn $ "n = " ++ show n ++ " at " ++ prettyCallStack callStack + +withoutDebuggable :: HasCallStack => IO () +withoutDebuggable = f1 g1 + +{------------------------------------------------------------------------------- + Using the library +-------------------------------------------------------------------------------} + +h1 :: HasCallStack => Callback IO Int () -> IO () +h1 k = h2 k + +h2 :: HasCallStack => Callback IO Int () -> IO () +h2 k = scoped $ invokeCallback k 1 + +useDebuggable :: HasCallStack => IO () +useDebuggable = h1 (callback g1) + diff --git a/demo/Demo/Callsite.hs b/demo/Demo/Callsite.hs new file mode 100644 --- /dev/null +++ b/demo/Demo/Callsite.hs @@ -0,0 +1,40 @@ +module Demo.Callsite ( + withoutDebuggable + , useDebuggable + ) where + +import GHC.Stack (prettyCallStack, callStack) + +import Debug.Provenance + +{------------------------------------------------------------------------------- + Without the library +-------------------------------------------------------------------------------} + +f1 :: IO () +f1 = f2 + +f2 :: HasCallStack => IO () +f2 = f3 + +f3 :: HasCallStack => IO () +f3 = putStrLn $ prettyCallStack callStack + +withoutDebuggable :: IO () +withoutDebuggable = f1 + +{------------------------------------------------------------------------------- + Using the library +-------------------------------------------------------------------------------} + +g1 :: IO () +g1 = g2 + +g2 :: HasCallStack => IO () +g2 = g3 + +g3 :: HasCallStack => IO () +g3 = print callSite + +useDebuggable :: IO () +useDebuggable = g1 diff --git a/demo/Demo/Invocation.hs b/demo/Demo/Invocation.hs new file mode 100644 --- /dev/null +++ b/demo/Demo/Invocation.hs @@ -0,0 +1,56 @@ +module Demo.Invocation ( + Example(..) + , withoutDebuggable + , useDebuggable + ) where + +import Control.Monad + +import Debug.Provenance + +data Example = + Example1 + | Example2 + deriving stock (Show) + +{------------------------------------------------------------------------------- + Without the library +-------------------------------------------------------------------------------} + +f4 :: IO () +f4 = do + putStrLn "f4:1" + -- f4 does something .. + putStrLn "f4:2" + -- f4 does something else .. + putStrLn "f4:3" + +withoutDebuggable :: IO () +withoutDebuggable = f4 + +{------------------------------------------------------------------------------- + Using the library +-------------------------------------------------------------------------------} + +g1 :: IO () +g1 = replicateM_ 2 g2 + +g2 :: HasCallStack => IO () +g2 = do + print =<< newInvocation + replicateM_ 2 g3 + +g3 :: HasCallStack => IO () +g3 = print =<< newInvocation + +g4 :: HasCallStack => IO () +g4 = do + print =<< newInvocation + -- f4 does something .. + print =<< newInvocation + -- f4 does something else .. + print =<< newInvocation + +useDebuggable :: Example -> IO () +useDebuggable Example1 = g1 +useDebuggable Example2 = g4 diff --git a/demo/Demo/NIIO.hs b/demo/Demo/NIIO.hs new file mode 100644 --- /dev/null +++ b/demo/Demo/NIIO.hs @@ -0,0 +1,45 @@ +module Demo.NIIO ( + withoutDebuggable + , useDebuggable + ) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Monad +import System.IO + +import Debug.NonInterleavedIO qualified as NIIO + +{------------------------------------------------------------------------------- + Without the library +-------------------------------------------------------------------------------} + +withoutDebuggable :: IO () +withoutDebuggable = do + hSetBuffering stdout NoBuffering + + concurrently_ + ( replicateM_ 10 $ do + putStrLn "This is a message from the first thread" + threadDelay 100_000 + ) + ( replicateM_ 10 $ do + putStrLn "And this is a message from the second thread" + threadDelay 100_000 + ) + +{------------------------------------------------------------------------------- + Using the library +-------------------------------------------------------------------------------} + +useDebuggable :: IO () +useDebuggable = do + concurrently_ + ( replicateM_ 10 $ do + NIIO.putStrLn "This is a message from the first thread" + threadDelay 100_000 + ) + ( replicateM_ 10 $ do + NIIO.putStrLn "And this is a message from the second thread" + threadDelay 100_000 + ) diff --git a/demo/Demo/Scope.hs b/demo/Demo/Scope.hs new file mode 100644 --- /dev/null +++ b/demo/Demo/Scope.hs @@ -0,0 +1,60 @@ +module Demo.Scope ( + Example(..) + , useDebuggable + ) where + +import Control.Concurrent +import Control.Concurrent.Async + +import Debug.NonInterleavedIO.Scoped qualified as Scoped +import Debug.Provenance.Scope + +{------------------------------------------------------------------------------- + Using the library +-------------------------------------------------------------------------------} + +data Example = + Example1 + | Example2 + | Example3 + | Example4 + deriving (Show) + +g1 :: IO () +g1 = g2 + +g2 :: HasCallStack => IO () +g2 = scoped g3 + +g3 :: HasCallStack => IO () +g3 = scoped g4 + +g4 :: HasCallStack => IO () +g4 = do + Scoped.putStrLn "start" + -- f4 does something .. + Scoped.putStrLn "middle" + -- f4 does something else .. + Scoped.putStrLn "end" + +concurrent :: IO () +concurrent = concurrently_ g4 g4 + +h1 :: IO () +h1 = h2 + +h2 :: HasCallStack => IO () +h2 = scoped h3 + +h3 :: HasCallStack => IO () +h3 = scoped $ do + tid <- myThreadId + concurrently_ + (inheritScope tid >> g4) + (inheritScope tid >> g4) + +useDebuggable :: Example -> IO () +useDebuggable Example1 = g4 +useDebuggable Example2 = g1 +useDebuggable Example3 = concurrent +useDebuggable Example4 = h1 diff --git a/src/Debug/NonInterleavedIO.hs b/src/Debug/NonInterleavedIO.hs new file mode 100644 --- /dev/null +++ b/src/Debug/NonInterleavedIO.hs @@ -0,0 +1,101 @@ +-- | Functions for non-interleaved output +-- +-- Intended for qualifed import. +-- +-- > import Debug.NonInterleavedIO qualified 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.Exception +import Control.Monad.IO.Class +import System.Environment +import System.IO qualified as IO +import System.IO.Temp (getCanonicalTemporaryDirectory) +import System.IO.Unsafe + +{------------------------------------------------------------------------------- + Output functions +-------------------------------------------------------------------------------} + +-- | Non-interleaved version of 'Prelude.putStr' +putStr :: MonadIO m => String -> m () +putStr str = liftIO $ withMVar globalHandle $ \h -> do + IO.hPutStr h str + IO.hFlush h + +-- | 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 $ uninterruptibleMask_ $ 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 + newMVar h diff --git a/src/Debug/NonInterleavedIO/Scoped.hs b/src/Debug/NonInterleavedIO/Scoped.hs new file mode 100644 --- /dev/null +++ b/src/Debug/NonInterleavedIO/Scoped.hs @@ -0,0 +1,39 @@ +-- | Utilities for writing debugging messages that include provenance +-- +-- Intended for qualified import. +-- +-- > import Debug.NonInterleavedIO.Scoped qualified as Scoped +module Debug.NonInterleavedIO.Scoped ( + putStrLn + ) where + +import Prelude hiding (putStrLn) + +import Control.Monad.IO.Class +import Data.List (intercalate) + +import Debug.NonInterleavedIO qualified as NIIO +import Debug.Provenance.Internal +import Debug.Provenance.Scope + +{------------------------------------------------------------------------------- + Uniques +-------------------------------------------------------------------------------} + +-- | Print debug message, showing current scope +putStrLn :: (HasCallStack, MonadIO m) => String -> m () +putStrLn str = do + scope <- getScope + here <- newInvocationFrom callSite -- the call to 'putStrLn' + + let prettyScope :: String + prettyScope = concat [ + "[" + , 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 --- /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 --- /dev/null +++ b/src/Debug/Provenance.hs @@ -0,0 +1,18 @@ +-- | Utilities for tracking provenance: where and when things are called +module Debug.Provenance ( + -- * Callsites + CallSite -- opaque + , prettyCallSite + , callSite + , callSiteWithLabel + -- * Invocations + , Invocation -- opaque + , prettyInvocation + , newInvocation + -- *** Convenience re-exports + , HasCallStack + ) where + +import GHC.Stack + +import Debug.Provenance.Internal diff --git a/src/Debug/Provenance/Callback.hs b/src/Debug/Provenance/Callback.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Provenance/Callback.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE ImplicitParams #-} + +-- | Provenance for callbacks +module Debug.Provenance.Callback ( + -- * Callbacks + Callback -- opaque + , callback + , invokeCallback + -- *** Convenience re-exports + , HasCallStack + ) where + +import Data.Maybe (fromMaybe) +import GHC.Stack + +import Debug.Provenance.Internal + +{------------------------------------------------------------------------------- + Callback +-------------------------------------------------------------------------------} + +-- | Callback of type @(a -> m b)@ +-- +-- When we invoke a callback, it is useful to distinguish between two things: +-- +-- * The 'CallStack' of the /invocation/ of the callback +-- * The 'CallSite' of the /definition/ of the callback +-- +-- The purpose of this module is to be careful about this distinction; a +-- 'HasCallStack' backtrace originating from an invocation of a callback will +-- look something like this: +-- +-- > gM, called at .. +-- > .. +-- > g2, called at .. +-- > g1, called at .. +-- > callbackFn, called at .. +-- > invoking callback defined at +-- > invokeCallback, called at .. +-- > fN, called at .. +-- > .. +-- > f2, called at .. +-- > f1, called at .. +-- +-- where +-- +-- * @f1 .. fN@ are the function calls leading up to the callback +-- * @g1 .. gM@ are the function calls made inside of the callback +-- * @\@ tells us where the callback was defined +newtype Callback m a b = Wrap (Callback_ CallStack m a b) + +-- | Define 'Callback' +-- +-- See 'Callback' for discussion and motivation of the /two/ 'HasCallStack' +-- constraints. +callback :: HasCallStack => (HasCallStack => a -> m b) -> Callback m a b +callback callbackFn = Wrap (callback_ callSite callbackFn) + +-- | Invoke 'Callback' +invokeCallback :: HasCallStack => Callback m a b -> a -> m b +invokeCallback (Wrap cb) a = + callbackFunction (aux callStack) a + where + Callback_{callbackFunction, callbackDefSite} = cb + + aux :: CallStack -> CallStack + aux = mapCallSites $ \cs -> + case cs of + (_, loc):cs' -> -- this is the call to invokeCallback + ( concat [ + "invoking callback defined at " + -- callee is 'callback', no point showing that + , fromMaybe "{unknown}" $ + callSiteCaller callbackDefSite + , maybe "" (\l -> " (" ++ briefSrcLoc l ++ ")") $ + callSiteSrcLoc callbackDefSite + + ] + -- "invoking callback defined at " + -- ++ prettyCallSite callbackDefSite + , loc + ) + : cs' + [] -> + error $ "invokeCallback: unexpected CallStack" + +{-# NOINLINE callback #-} +{-# NOINLINE invokeCallback #-} + +{------------------------------------------------------------------------------- + Internal: generalize over 'CallStack' + + By working with a polymorphic @cs@ instead of 'CallStack' here, we avoid + @ghc@ manipulating the 'CallStack' itself. (This of course means that we + depend on the fact that 'HasCallStack' is defined as an implicit parameter.) +-------------------------------------------------------------------------------} + +data Callback_ cs m a b = Callback_ { + callbackFunction :: !(cs -> a -> m b) + , callbackDefSite :: !CallSite + } + +callback_ :: forall cs m a b. + CallSite + -> ((?callStack :: cs) => a -> m b) + -> Callback_ cs m a b +callback_ defSite f = Callback_ (mkExplicit f) defSite + +mkExplicit :: ((?callStack :: cs) => a) -> (cs -> a) +mkExplicit f cs = let ?callStack = cs in f + +{-# NOINLINE callback_ #-} +{-# NOINLINE mkExplicit #-} + +{------------------------------------------------------------------------------- + Internal: manipulating the callstack +-------------------------------------------------------------------------------} + +mapCallSites :: + ([([Char], SrcLoc)] -> [([Char], SrcLoc)]) + -> CallStack -> CallStack +mapCallSites f = fromCallSiteList . f . getCallStack diff --git a/src/Debug/Provenance/Internal.hs b/src/Debug/Provenance/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Provenance/Internal.hs @@ -0,0 +1,230 @@ +module Debug.Provenance.Internal ( + -- * Callsites + CallSite(..) + , prettyCallSite + , briefSrcLoc + , callSite + , callSiteWithLabel + -- * Invocations + , Invocation -- opaque + , prettyInvocation + , newInvocation + , newInvocationFrom + ) where + +import Control.Monad.IO.Class +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.IORef +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import GHC.Generics +import GHC.Stack +import System.IO.Unsafe (unsafePerformIO) + +{------------------------------------------------------------------------------- + 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 @{unknown}@ 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 +-- @{unknown}@. 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 :: Maybe SrcLoc + , callSiteCaller :: Maybe String + , callSiteCallee :: Maybe String + , callSiteLabel :: Label + } + deriving stock (Eq) + +instance Show CallSite where + show = prettyCallSite + +-- | 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 cs = + concat [ + intercalate " -> " [ + fromMaybe "{unknown}" callSiteCaller + , fromMaybe "{unknown}" callSiteCallee + ] + , " (" + , intercalate ", " $ concat [ + [ briefSrcLoc loc + | Just loc <- [callSiteSrcLoc] + ] + , [ show label + | Label label <- [callSiteLabel] + ] + ] + , ")" + ] + where + CallSite{ + callSiteSrcLoc + , callSiteCaller + , callSiteCallee + , callSiteLabel + } = cs + +-- | Variant on 'prettySrcLoc' which omits the package and module name +briefSrcLoc :: SrcLoc -> [Char] +briefSrcLoc loc = intercalate ":" [ + srcLocFile loc + , show $ srcLocStartLine loc + , show $ srcLocStartCol loc + ] + +instance Hashable CallSite where + hashWithSalt salt cs = + hashWithSalt salt ( + prettySrcLoc <$> callSiteSrcLoc + , callSiteCaller + , callSiteCallee + , callSiteLabel + ) + where + CallSite{ + callSiteSrcLoc + , callSiteCaller + , callSiteCallee + , callSiteLabel + } = cs + + +-- | Current 'CallSite' +callSite :: HasCallStack => CallSite +callSite = withFrozenCallStack $ mkCallSite NoLabel + +-- | Current 'CallSite' with user-defined label +callSiteWithLabel :: HasCallStack => 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 = + -- drop the call to @callSite{withLabel}@ + case getCallStack cs of + _ : (callee, loc) : [] -> CallSite { + callSiteSrcLoc = Just loc + , callSiteCaller = Nothing + , callSiteCallee = Just callee + , callSiteLabel + } + _ : (callee, loc) : (caller, _) : _ -> CallSite { + callSiteSrcLoc = Just loc + , callSiteCaller = Just caller + , callSiteCallee = Just callee + , callSiteLabel + } + _otherwise -> CallSite { + callSiteSrcLoc = Nothing + , callSiteCaller = Nothing + , callSiteCallee = Nothing + , callSiteLabel + } + +{------------------------------------------------------------------------------- + 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) + +instance Show Invocation where + show = prettyInvocation + +-- | Render 'Invocation' to human-readable format +prettyInvocation :: Invocation -> String +prettyInvocation (Invocation cs n) = + concat [ + fromMaybe "{unknown}" callSiteCaller + , " (" + , intercalate ", " $ concat [ + [ intercalate ":" [ + srcLocFile loc + , show $ srcLocStartLine loc + , show $ srcLocStartCol loc + ] + | Just loc <- [callSiteSrcLoc] + ] + , [ show label + | Label label <- [callSiteLabel] + ] + ] + , ") #" + , show n + ] + where + -- the callee is 'newInvocation' + CallSite{ + callSiteSrcLoc + , callSiteCaller + , callSiteLabel + } = cs + +-- | New invocation +-- +-- See 'Invocation' for discussion. +newInvocation :: (HasCallStack, MonadIO m) => m Invocation +newInvocation = + -- We intentionally do /NOT/ freeze the callstack here: when function @foo@ + -- calls @newInvocation@, we want a 'CallSite' of @foo -> newInvocation@, + -- not @bar -> foo@. + newInvocationFrom callSite + +-- | Generalization of 'newInvocation' +newInvocationFrom :: MonadIO m => CallSite -> m Invocation +newInvocationFrom cs = liftIO $ do + atomicModifyIORef' globalCounters $ \counters -> + let i = HashMap.findWithDefault 1 cs counters + in (HashMap.insert cs (succ i) counters, Invocation cs i) + +{------------------------------------------------------------------------------- + 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 --- /dev/null +++ b/src/Debug/Provenance/Scope.hs @@ -0,0 +1,114 @@ +-- | Utilities for tracking scope: nested 'Invocation's +-- +-- Intended for unqualified import. +module Debug.Provenance.Scope ( + -- * Thread-local scope + Scope + , scoped + , getScope + -- * Scope across threads + , forkInheritScope + , inheritScope + -- *** Convenience re-exports + , HasCallStack + ) 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.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Tuple (swap) +import GHC.Stack +import System.IO.Unsafe (unsafePerformIO) + +import Debug.Provenance.Internal + +{------------------------------------------------------------------------------- + Scope +-------------------------------------------------------------------------------} + +-- | Thread-local scope +-- +-- Most recent invocations are first in the list. +type Scope = [Invocation] + +-- | Extend current scope +scoped :: (HasCallStack, MonadMask m, MonadIO m) => m a -> m a +scoped k = (\(a, ()) -> a) <$> do + i <- newInvocationFrom callSite -- the call to 'scoped' + 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_ $ \case + [] -> error "popInvocation: empty stack" + _:s -> s + +{------------------------------------------------------------------------------- + Internal: globals +-------------------------------------------------------------------------------} + +globalScope :: IORef (Map ThreadId Scope) +{-# NOINLINE globalScope #-} +globalScope = unsafePerformIO $ newIORef Map.empty +