From 0503bbe48b1230f0531cc9de6924207e47b59e29 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Sat, 23 Nov 2024 10:28:12 +0100 Subject: [PATCH] Demo and prepare for release --- .github/workflows/haskell-ci.yml | 7 +- .gitignore | 1 + CHANGELOG.md | 6 +- LICENSE | 1 - cabal.project | 4 + cabal.project.ci | 5 + debuggable.cabal | 51 +++++- demo/Cmdline.hs | 114 +++++++++++++ demo/Demo.hs | 27 ++++ demo/Demo/Callback.hs | 43 +++++ demo/Demo/Callsite.hs | 40 +++++ demo/Demo/Invocation.hs | 56 +++++++ demo/Demo/NIIO.hs | 45 ++++++ demo/Demo/Scope.hs | 60 +++++++ src/Debug/NonInterleavedIO.hs | 5 +- src/Debug/NonInterleavedIO/Scoped.hs | 20 +-- src/Debug/Provenance.hs | 161 +------------------ src/Debug/Provenance/Callback.hs | 52 +++--- src/Debug/Provenance/Internal.hs | 230 +++++++++++++++++++++++++++ src/Debug/Provenance/Scope.hs | 13 +- 20 files changed, 733 insertions(+), 208 deletions(-) create mode 100644 cabal.project create mode 100644 cabal.project.ci create mode 100644 demo/Cmdline.hs create mode 100644 demo/Demo.hs create mode 100644 demo/Demo/Callback.hs create mode 100644 demo/Demo/Callsite.hs create mode 100644 demo/Demo/Invocation.hs create mode 100644 demo/Demo/NIIO.hs create mode 100644 demo/Demo/Scope.hs create mode 100644 src/Debug/Provenance/Internal.hs diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index d8ca822..00d1ab6 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' 'debuggable.cabal' +# haskell-ci 'github' 'cabal.project.ci' # # To regenerate the script (for example after adjusting tested-with) run # @@ -10,7 +10,7 @@ # # version: 0.19.20241121 # -# REGENDATA ("0.19.20241121",["github","debuggable.cabal"]) +# REGENDATA ("0.19.20241121",["github","cabal.project.ci"]) # name: Haskell-CI on: @@ -203,6 +203,9 @@ jobs: - name: build run: | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always + - name: tests + run: | + $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct - name: cabal check run: | cd ${PKGDIR_debuggable} || false diff --git a/.gitignore b/.gitignore index 11bc335..2a6c5ff 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ dist-newstyle/ .envrc +niio diff --git a/CHANGELOG.md b/CHANGELOG.md index 8151dcb..efe0f22 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,5 @@ -# Revision history for non-interleaved-logging +# Revision history for debuggable -## 0.1.0 -- YYYY-mm-dd +## 0.1.0 -- 2024-11-23 -* First version. Released on an unsuspecting world. +* First public release diff --git a/LICENSE b/LICENSE index f303075..7734dca 100644 --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,5 @@ 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: diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..0acf422 --- /dev/null +++ b/cabal.project @@ -0,0 +1,4 @@ +packages: . + +package debuggable + tests: True \ No newline at end of file diff --git a/cabal.project.ci b/cabal.project.ci new file mode 100644 index 0000000..47b50ba --- /dev/null +++ b/cabal.project.ci @@ -0,0 +1,5 @@ +packages: . + +package debuggable + tests: True + ghc-options: -Werror \ No newline at end of file diff --git a/debuggable.cabal b/debuggable.cabal index ab41cc5..b347e93 100644 --- a/debuggable.cabal +++ b/debuggable.cabal @@ -22,9 +22,12 @@ tested-with: GHC==8.10.7 , 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 - ghc-options: -Wall build-depends: base >= 4.14 && < 4.21 default-extensions: @@ -34,14 +37,27 @@ common lang 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 @@ -54,6 +70,9 @@ library Debug.Provenance.Callback Debug.Provenance.Scope + other-modules: + Debug.Provenance.Internal + build-depends: , containers >= 0.6 && < 0.8 , exceptions >= 0.9 && < 0.11 @@ -63,3 +82,33 @@ library 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 index 0000000..b6a9434 --- /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 index 0000000..b690a75 --- /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 index 0000000..96b2a59 --- /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 index 0000000..2474f0c --- /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 \ No newline at end of file diff --git a/demo/Demo/Invocation.hs b/demo/Demo/Invocation.hs new file mode 100644 index 0000000..49cf24b --- /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 \ No newline at end of file diff --git a/demo/Demo/NIIO.hs b/demo/Demo/NIIO.hs new file mode 100644 index 0000000..caf5037 --- /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 index 0000000..037a2c0 --- /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 \ No newline at end of file diff --git a/src/Debug/NonInterleavedIO.hs b/src/Debug/NonInterleavedIO.hs index dafa1bf..bee1a2d 100644 --- a/src/Debug/NonInterleavedIO.hs +++ b/src/Debug/NonInterleavedIO.hs @@ -2,7 +2,7 @@ -- -- Intended for qualifed import. -- --- > import qualified Debug.NonInterleavedIO as NIIO +-- > import Debug.NonInterleavedIO qualified as NIIO -- -- Alternatively, you can import "Debug.NonInterleavedIO.Trace" as a drop-in -- replacement for "Debug.Trace". @@ -36,11 +36,10 @@ 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 -import qualified System.IO as IO - {------------------------------------------------------------------------------- Output functions -------------------------------------------------------------------------------} diff --git a/src/Debug/NonInterleavedIO/Scoped.hs b/src/Debug/NonInterleavedIO/Scoped.hs index cb4bb4a..23ac8c8 100644 --- a/src/Debug/NonInterleavedIO/Scoped.hs +++ b/src/Debug/NonInterleavedIO/Scoped.hs @@ -1,10 +1,8 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - -- | Utilities for writing debugging messages that include provenance -- -- Intended for qualified import. -- --- > import qualified Debug.NonInterleavedIO.Scoped as Scoped +-- > import Debug.NonInterleavedIO.Scoped qualified as Scoped module Debug.NonInterleavedIO.Scoped ( putStrLn ) where @@ -13,25 +11,27 @@ import Prelude hiding (putStrLn) import Control.Monad.IO.Class import Data.List (intercalate) -import GHC.Stack -import Debug.Provenance +import Debug.NonInterleavedIO qualified as NIIO +import Debug.Provenance.Internal import Debug.Provenance.Scope -import qualified Debug.NonInterleavedIO as NIIO - {------------------------------------------------------------------------------- Uniques -------------------------------------------------------------------------------} -- | Print debug message, showing current scope putStrLn :: (HasCallStack, MonadIO m) => String -> m () -putStrLn str = withFrozenCallStack $ do +putStrLn str = do scope <- getScope - here <- newInvocation callSite + here <- newInvocationFrom callSite -- the call to 'putStrLn' let prettyScope :: String - prettyScope = intercalate "," $ map prettyInvocation (here : scope) + prettyScope = concat [ + "[" + , intercalate ", " $ map prettyInvocation (here : scope) + , "]" + ] NIIO.putStrLn $ case lines str of diff --git a/src/Debug/Provenance.hs b/src/Debug/Provenance.hs index 55e6db3..9f06c96 100644 --- a/src/Debug/Provenance.hs +++ b/src/Debug/Provenance.hs @@ -9,165 +9,10 @@ module Debug.Provenance ( , Invocation -- opaque , prettyInvocation , newInvocation + -- *** Convenience re-exports + , HasCallStack ) 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 +import Debug.Provenance.Internal diff --git a/src/Debug/Provenance/Callback.hs b/src/Debug/Provenance/Callback.hs index a081b11..e242766 100644 --- a/src/Debug/Provenance/Callback.hs +++ b/src/Debug/Provenance/Callback.hs @@ -1,16 +1,19 @@ {-# LANGUAGE ImplicitParams #-} -{-# OPTIONS_GHC -ddump-simpl -dsuppress-all -ddump-to-file #-} -- | 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 +import Debug.Provenance.Internal {------------------------------------------------------------------------------- Callback @@ -51,21 +54,34 @@ newtype Callback m a b = Wrap (Callback_ CallStack m a b) -- See 'Callback' for discussion and motivation of the /two/ 'HasCallStack' -- constraints. callback :: HasCallStack => (HasCallStack => a -> m b) -> Callback m a b -callback callbackFn = withFrozenCallStack $ Wrap (callback_ callbackFn) +callback callbackFn = Wrap (callback_ callSite callbackFn) -- | Invoke 'Callback' invokeCallback :: HasCallStack => Callback m a b -> a -> m b -invokeCallback (Wrap cb) a = invoke_ aux cb a +invokeCallback (Wrap cb) a = + callbackFunction (aux callStack) a where - aux :: CallSite -> CallStack -> CallStack - aux defSite = mapCallSites $ \cs -> + Callback_{callbackFunction, callbackDefSite} = cb + + aux :: CallStack -> CallStack + aux = mapCallSites $ \cs -> case cs of - (_, loc):cs' -> -- this is the call to invoke_ - ( "invoking callback defined at " ++ prettyCallSite defSite + (_, 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' - _otherwise -> + [] -> error $ "invokeCallback: unexpected CallStack" {-# NOINLINE callback #-} @@ -85,28 +101,16 @@ data Callback_ cs m a b = Callback_ { } callback_ :: forall cs m a b. - HasCallStack - => ((?callStack :: cs) => a -> m b) + CallSite + -> ((?callStack :: cs) => a -> m b) -> Callback_ cs m a b -callback_ f = Callback_ (mkExplicit f) callSite - -invoke_ :: - (?callStack :: cs) - => (CallSite -> cs -> cs) - -> Callback_ cs m a b -> a -> m b -invoke_ g Callback_{callbackFunction = fn, callbackDefSite = defSite} a = - mkImplicit (\cs -> fn (g defSite cs) a) +callback_ defSite f = Callback_ (mkExplicit f) defSite mkExplicit :: ((?callStack :: cs) => a) -> (cs -> a) mkExplicit f cs = let ?callStack = cs in f -mkImplicit :: (?callStack :: cs) => (cs -> a) -> a -mkImplicit f = f ?callStack - {-# NOINLINE callback_ #-} -{-# NOINLINE invoke_ #-} {-# NOINLINE mkExplicit #-} -{-# NOINLINE mkImplicit #-} {------------------------------------------------------------------------------- Internal: manipulating the callstack diff --git a/src/Debug/Provenance/Internal.hs b/src/Debug/Provenance/Internal.hs new file mode 100644 index 0000000..f343979 --- /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 index c83da22..5c83273 100644 --- a/src/Debug/Provenance/Scope.hs +++ b/src/Debug/Provenance/Scope.hs @@ -9,6 +9,8 @@ module Debug.Provenance.Scope ( -- * Scope across threads , forkInheritScope , inheritScope + -- *** Convenience re-exports + , HasCallStack ) where import Control.Concurrent @@ -18,14 +20,13 @@ 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 qualified Data.Map.Strict as Map - -import Debug.Provenance +import Debug.Provenance.Internal {------------------------------------------------------------------------------- Scope @@ -37,9 +38,9 @@ import Debug.Provenance 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 +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)