Merge pull request #15 from well-typed/edsko/demo

Demo and prepare for release

.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

.gitignore

@@ -1,2 +1,3 @@
 dist-newstyle/
 .envrc
+niio

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

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:
 

cabal.project

@@ -0,0 +1,4 @@
+packages: .
+
+package debuggable
+  tests: True

cabal.project.ci

@@ -0,0 +1,5 @@
+packages: .
+
+package debuggable
+  tests: True
+  ghc-options: -Werror

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
+

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
+    ]

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
+

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)
+

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