packages feed

debuggable (empty) → 0.1.0

raw patch · 17 files changed

+1170/−0 lines, 17 filesdep +asyncdep +basedep +containers

Dependencies added: async, base, containers, debuggable, exceptions, hashable, optparse-applicative, temporary, unordered-containers

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for debuggable++## 0.1.0 -- 2024-11-23++* First public release
+ LICENSE view
@@ -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.
+ debuggable.cabal view
@@ -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+
+ demo/Cmdline.hs view
@@ -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+    ]
+ demo/Demo.hs view
@@ -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+
+ demo/Demo/Callback.hs view
@@ -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)+
+ demo/Demo/Callsite.hs view
@@ -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
+ demo/Demo/Invocation.hs view
@@ -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
+ demo/Demo/NIIO.hs view
@@ -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+      )
+ demo/Demo/Scope.hs view
@@ -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
+ src/Debug/NonInterleavedIO.hs view
@@ -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<number>@. 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
+ src/Debug/NonInterleavedIO/Scoped.hs view
@@ -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
+ src/Debug/NonInterleavedIO/Trace.hs view
@@ -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
+ src/Debug/Provenance.hs view
@@ -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
+ src/Debug/Provenance/Callback.hs view
@@ -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 <callSite>+-- > 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+-- * @\<callSite\>@ 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
+ src/Debug/Provenance/Internal.hs view
@@ -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
+ src/Debug/Provenance/Scope.hs view
@@ -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+