Merge pull request #16 from well-typed/edsko/ipe

Add demo of the use of the profiling callstack

debuggable.cabal

@@ -98,6 +98,7 @@ test-suite demo
   other-modules:
       Cmdline
       Demo.Callback
+      Demo.Callback.Profiling
       Demo.Callsite
       Demo.Invocation
       Demo.NIIO

demo/Cmdline.hs

@@ -6,7 +6,10 @@ module Cmdline (
 
 import Options.Applicative
 
+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
 
 {-------------------------------------------------------------------------------
@@ -19,15 +22,11 @@ data Cmdline = Cmdline {
   deriving stock (Show)
 
 data Demo =
-    DemoNiioWithout
-  | DemoNiioUse
-  | DemoCallsiteWithout
-  | DemoCallsiteUse
-  | DemoInvocationWithout
-  | DemoInvocationUse Invocation.Example
-  | DemoScopeUse Scope.Example
-  | DemoCallbackWithout
-  | DemoCallbackUse
+    DemoNiio NIIO.Example
+  | DemoCallsite Callsite.Example
+  | DemoInvocation Invocation.Example
+  | DemoScope Scope.Example
+  | DemoCallback Callback.Example
   deriving stock (Show)
 
 getCmdline :: IO Cmdline
@@ -52,56 +51,104 @@ parseDemo :: Parser Demo
 parseDemo = subparser $ mconcat [
       command'
         "niio"
-        ( parseWithoutUse
-            (pure DemoNiioWithout)
-            (pure DemoNiioUse)
-        )
+        (DemoNiio <$> parseNiioExample)
         "Demo Debug.NonInterleavedIO"
     , command'
         "callsite"
-        ( parseWithoutUse
-            (pure DemoCallsiteWithout)
-            (pure DemoCallsiteUse)
-        )
+        (DemoCallsite <$> parseCallsiteExample)
         "Demo CallSite from Debug.Provenance"
     , command'
         "invocation"
-        ( parseWithoutUse
-            (pure DemoInvocationWithout)
-            (DemoInvocationUse <$> parseInvocationExample)
-        )
+         (DemoInvocation <$> parseInvocationExample)
         "Demo Invocation from Debug.Provenance"
     , command'
         "scope"
-        ( DemoScopeUse <$> parseScopeExample )
+        (DemoScope <$> parseScopeExample)
         "Demo Debug.Provenance.Scope"
     , command'
         "callback"
-        ( parseWithoutUse
-            (pure DemoCallbackWithout)
-            (pure DemoCallbackUse)
-        )
+        (DemoCallback <$> parseCallbackExample)
         "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"
+parseNiioExample :: Parser NIIO.Example
+parseNiioExample = subparser $ mconcat [
+      command'
+        "without-debuggable"
+        (pure NIIO.WithoutDebuggable)
+        "Without debuggable"
+    , command'
+        "use-debuggable"
+        (pure NIIO.UseDebuggable)
+        "Use debuggable"
+    ]
+
+parseCallsiteExample :: Parser Callsite.Example
+parseCallsiteExample = subparser $ mconcat [
+      command'
+        "without-debuggable"
+        (pure Callsite.WithoutDebuggable)
+        "Without debuggable"
+    , command'
+        "use-debuggable"
+        (pure Callsite.UseDebuggable)
+        "Use debuggable"
     ]
 
 parseInvocationExample :: Parser Invocation.Example
 parseInvocationExample = subparser $ mconcat [
-      command' "example1" (pure Invocation.Example1) "Example 1"
-    , command' "example2" (pure Invocation.Example2) "Example 2"
+      command'
+        "without-debuggable"
+        (pure Invocation.WithoutDebuggable)
+        "Without debuggable"
+    , command'
+        "use-debuggable-1"
+        (pure $ Invocation.UseDebuggable Invocation.Example1)
+        "Use debuggable, example 1"
+    , command'
+        "use-debuggable-2"
+        (pure $ Invocation.UseDebuggable Invocation.Example2)
+        "Use debuggable, 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"
+      command'
+        "example1"
+        (pure Scope.Example1)
+        "Use debuggable, example 1"
+    , command'
+        "example2"
+        (pure Scope.Example2)
+        "Use debuggable, example 2"
+    , command'
+        "example3"
+        (pure Scope.Example3)
+        "Use debuggable, example 3"
+    , command'
+        "example4"
+        (pure Scope.Example4)
+        "Use debuggable, example 4"
+    ]
+
+parseCallbackExample :: Parser Callback.Example
+parseCallbackExample = subparser $ mconcat [
+      command'
+        "without-debuggable"
+        (pure Callback.WithoutDebuggable)
+        "Without debuggable"
+    , command'
+        "use-debuggable"
+        (pure Callback.UseDebuggable)
+        "Use debuggable"
+    , command'
+        "use-profiling-1"
+        (pure $ Callback.UseProfiling Nothing)
+        "Use profiling, example 1"
+    , command'
+        "use-profiling-2"
+        (Callback.UseProfiling . Just <$> argument auto (metavar "INT"))
+        "Use profiling, example 2"
     ]
 
 {-------------------------------------------------------------------------------
@@ -112,3 +159,4 @@ command' :: String -> Parser a -> String -> Mod CommandFields a
 command' cmd parser desc = command cmd $ info (parser <**> helper) $ mconcat [
       progDesc desc
     ]
+

demo/Demo.hs

@@ -15,13 +15,9 @@ main = do
       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
+          DemoNiio       ex -> NIIO.demo       ex
+          DemoCallsite   ex -> Callsite.demo   ex
+          DemoInvocation ex -> Invocation.demo ex
+          DemoScope      ex -> Scope.demo      ex
+          DemoCallback   ex -> Callback.demo   ex
 

demo/Demo/Callback.hs

@@ -1,14 +1,28 @@
-module Demo.Callback (
-    withoutDebuggable
-  , useDebuggable
-  ) where
+module Demo.Callback (Example(..), demo) where
 
 import GHC.Stack
 
 import Debug.NonInterleavedIO.Scoped qualified as Scoped
 import Debug.Provenance.Callback
 import Debug.Provenance.Scope
 
+import Demo.Callback.Profiling qualified as Profiling
+
+{-------------------------------------------------------------------------------
+  Top-level
+-------------------------------------------------------------------------------}
+
+data Example =
+    WithoutDebuggable
+  | UseDebuggable
+  | UseProfiling (Maybe Int)
+  deriving stock (Show)
+
+demo :: Example -> IO ()
+demo WithoutDebuggable = f1 g1
+demo UseDebuggable     = h1 (callback g1)
+demo (UseProfiling i)  = Profiling.demo i
+
 {-------------------------------------------------------------------------------
   Without the library
 -------------------------------------------------------------------------------}
@@ -25,9 +39,6 @@ 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
 -------------------------------------------------------------------------------}
@@ -37,7 +48,3 @@ 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/Callback/Profiling.hs

@@ -0,0 +1,35 @@
+-- | Profiling version of the callback demo
+--
+-- Requires the code to be built with profiling info.
+module Demo.Callback.Profiling (demo) where
+
+import GHC.Stack
+
+{-------------------------------------------------------------------------------
+  Top-level
+-------------------------------------------------------------------------------}
+
+demo :: Maybe Int -> IO ()
+demo Nothing  = f1 (\x -> g1 x)
+demo (Just i) = f1 (\x -> g1 (x + i))
+
+{-------------------------------------------------------------------------------
+  Demo proper
+-------------------------------------------------------------------------------}
+
+f1 :: (Int -> IO ()) -> IO ()
+f1 k = do
+    cs <- whoCreated k
+    putStrLn $ "f1: invoking callback defined at " ++ show (cs)
+    f2 k
+
+f2 :: (Int -> IO ()) -> IO ()
+f2 k = k 1
+
+g1 :: Int -> IO ()
+g1 n = g2 n
+
+g2 :: Int -> IO ()
+g2 n = do
+    cs <- currentCallStack
+    putStrLn $ "n = " ++ show n ++ " at " ++ show cs

demo/Demo/Callsite.hs

@@ -1,12 +1,22 @@
-module Demo.Callsite (
-    withoutDebuggable
-  , useDebuggable
-  ) where
+module Demo.Callsite (Example(..), demo) where
 
 import GHC.Stack (prettyCallStack, callStack)
 
 import Debug.Provenance
 
+{-------------------------------------------------------------------------------
+  Top-level
+-------------------------------------------------------------------------------}
+
+data Example =
+    WithoutDebuggable
+  | UseDebuggable
+  deriving stock (Show)
+
+demo :: Example -> IO ()
+demo WithoutDebuggable = f1
+demo UseDebuggable     = g1
+
 {-------------------------------------------------------------------------------
   Without the library
 -------------------------------------------------------------------------------}
@@ -20,9 +30,6 @@ f2 = f3
 f3 :: HasCallStack => IO ()
 f3 = putStrLn $ prettyCallStack callStack
 
-withoutDebuggable :: IO ()
-withoutDebuggable = f1
-
 {-------------------------------------------------------------------------------
   Using the library
 -------------------------------------------------------------------------------}
@@ -35,6 +42,3 @@ g2 = g3
 
 g3 :: HasCallStack => IO ()
 g3 = print callSite
-
-useDebuggable :: IO ()
-useDebuggable = g1

demo/Demo/Invocation.hs

@@ -1,18 +1,32 @@
 module Demo.Invocation (
     Example(..)
-  , withoutDebuggable
-  , useDebuggable
+  , DebuggableExample(..)
+  , demo
   ) where
 
 import Control.Monad
 
 import Debug.Provenance
 
+{-------------------------------------------------------------------------------
+  Top-level
+-------------------------------------------------------------------------------}
+
 data Example =
+    WithoutDebuggable
+  | UseDebuggable DebuggableExample
+  deriving stock (Show)
+
+data DebuggableExample =
     Example1
   | Example2
   deriving stock (Show)
 
+demo :: Example -> IO ()
+demo WithoutDebuggable        = f4
+demo (UseDebuggable Example1) = g1
+demo (UseDebuggable Example2) = g4
+
 {-------------------------------------------------------------------------------
   Without the library
 -------------------------------------------------------------------------------}
@@ -25,9 +39,6 @@ f4 = do
     -- f4 does something else ..
     putStrLn "f4:3"
 
-withoutDebuggable :: IO ()
-withoutDebuggable = f4
-
 {-------------------------------------------------------------------------------
   Using the library
 -------------------------------------------------------------------------------}
@@ -50,7 +61,3 @@ g4 = do
     print =<< newInvocation
     -- f4 does something else ..
     print =<< newInvocation
-
-useDebuggable :: Example -> IO ()
-useDebuggable Example1 = g1
-useDebuggable Example2 = g4