Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Reframe as debuggable #12

Merged
merged 1 commit into from
Nov 22, 2024
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension


Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
47 changes: 26 additions & 21 deletions .github/workflows/haskell-ci.yml
Original file line number Diff line number Diff line change
@@ -1,16 +1,16 @@
# This GitHub workflow config has been generated by a script via
#
# haskell-ci 'github' 'niio.cabal'
# haskell-ci 'github' 'debuggable.cabal'
#
# To regenerate the script (for example after adjusting tested-with) run
#
# haskell-ci regenerate
#
# For more information, see https://github.com/haskell-CI/haskell-ci
#
# version: 0.19.20240708
# version: 0.19.20241121
#
# REGENDATA ("0.19.20240708",["github","niio.cabal"])
# REGENDATA ("0.19.20241121",["github","debuggable.cabal"])
#
name: Haskell-CI
on:
Expand Down Expand Up @@ -64,15 +64,29 @@ jobs:
allow-failure: false
fail-fast: false
steps:
- name: apt
- name: apt-get install
run: |
apt-get update
apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
- name: Install GHCup
run: |
mkdir -p "$HOME/.ghcup/bin"
curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup"
chmod a+x "$HOME/.ghcup/bin/ghcup"
"$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
- name: Install cabal-install
run: |
"$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
- name: Install GHC (GHCup)
if: matrix.setup-method == 'ghcup'
run: |
"$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
echo "HC=$HC" >> "$GITHUB_ENV"
echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
env:
HCKIND: ${{ matrix.compilerKind }}
HCNAME: ${{ matrix.compiler }}
Expand All @@ -83,21 +97,12 @@ jobs:
echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
HCDIR=/opt/$HCKIND/$HCVER
HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
echo "HC=$HC" >> "$GITHUB_ENV"
echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
echo "GHCJSARITH=0" >> "$GITHUB_ENV"
env:
HCKIND: ${{ matrix.compilerKind }}
HCNAME: ${{ matrix.compiler }}
Expand Down Expand Up @@ -165,17 +170,17 @@ jobs:
find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
- name: generate cabal.project
run: |
PKGDIR_niio="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/niio-[0-9.]*')"
echo "PKGDIR_niio=${PKGDIR_niio}" >> "$GITHUB_ENV"
PKGDIR_debuggable="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/debuggable-[0-9.]*')"
echo "PKGDIR_debuggable=${PKGDIR_debuggable}" >> "$GITHUB_ENV"
rm -f cabal.project cabal.project.local
touch cabal.project
touch cabal.project.local
echo "packages: ${PKGDIR_niio}" >> cabal.project
echo "package niio" >> cabal.project
echo "packages: ${PKGDIR_debuggable}" >> cabal.project
echo "package debuggable" >> cabal.project
echo " ghc-options: -Werror=missing-methods" >> cabal.project
cat >> cabal.project <<EOF
EOF
$HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(niio)$/; }' >> cabal.project.local
$HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(debuggable)$/; }' >> cabal.project.local
cat cabal.project
cat cabal.project.local
- name: dump install plan
Expand All @@ -200,7 +205,7 @@ jobs:
$CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
- name: cabal check
run: |
cd ${PKGDIR_niio} || false
cd ${PKGDIR_debuggable} || false
${CABAL} -vnormal check
- name: haddock
run: |
Expand All @@ -210,8 +215,8 @@ jobs:
rm -f cabal.project.local
$CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
- name: save cache
uses: actions/cache/save@v4
if: always()
uses: actions/cache/save@v4
with:
key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
path: ~/.cabal/store
67 changes: 4 additions & 63 deletions README.md
Original file line number Diff line number Diff line change
@@ -1,65 +1,6 @@
# `niio`: functions for debugging that guarantee non-interleaved output
# `provenance`: utilities for tracking provenance

This package provides analogues of various standard output functions; all of
these functions are safe to use in a concurrent setting, and guarantee that the
output of one function call will not be interleaved with the output of another.
Examples include
This package provides utilities that can help track when and where things are
defined, to aid debugging. It also provides some utilities for non-interleaved
output, for debugging concurrent code.

```haskell
niPutStr :: MonadIO m => String -> m ()
niPutStrLn :: MonadIO m => String -> m ()
niPrint :: (MonadIO m, Show a) => a -> m ()
niTrace :: String -> a -> a
niTraceShow :: Show a => a -> b -> b
niTraceShowId :: Show a => a -> a
niTraceM :: Applicative m => String -> m ()
niTraceShowM :: (Applicative m, Show a) => a -> m ()
```

In addition, we provide some support for creating uniques, to be able to
support correlating log messages, and some functionality for working with
these uniques:

```haskell
niGetUnique :: (MonadIO m, HasCallStack) => m NiUnique
niPutStrAt :: MonadIO m => [NiUnique] -> String -> m ()
```

and

```haskell
niBracket ::
(MonadIO m, MonadMask m, HasCallStack)
=> (NiUnique -> m ()) -- ^ Prior to the action
-> (NiUnique -> ExitCase a -> m ()) -- ^ After
-> (NiUnique -> m a)
-> m a
```

For example:

```haskell
-- > niBracket (\i -> niPutStrAt [i] "start") (\i -> niPutStrAt [i] . show) $ \i ->
-- > ..
-- > niBracket (\j -> niPutStrAt [i, j] "start") (\j -> niPutStrAt [i, j] . show) $ \j ->
-- > ..
-- > niPutStrAt [i, j] $ "foo: " ++ E.displayException e
-- > ..
```

might result in

```
-- > ["exampleFun(./Example/File.hs:100:5)/1"] start
-- > ["exampleFun(./Example/File.hs:100:5)/1","exampleFun(./Example/File.hs:120:13)/1"] start
-- > ["exampleFun(./Example/File.hs:100:5)/1","exampleFun(./Example/File.hs:120:13)/1"]
-- > foo: ExampleException
-- > HasCallStack backtrace:
-- > collectBacktraces, called at (..)
-- > toExceptionWithBacktrace, called at (..)
-- > throwIO, called at (..)
-- > ["exampleFun(./Example/File.hs:100:5)/1","exampleFun(./Example/File.hs:120:13)/1"] ExitCaseSuccess ()
-- > ["exampleFun(./Example/File.hs:100:5)/1"] ExitCaseSuccess ()
```

This package is intended for debugging only.
25 changes: 20 additions & 5 deletions niio.cabal → debuggable.cabal
Original file line number Diff line number Diff line change
@@ -1,7 +1,13 @@
cabal-version: 3.0
name: niio
name: debuggable
version: 0.1.0
synopsis: Functions for debugging that guarantee non-interleaved output
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
Expand All @@ -28,14 +34,23 @@ common lang
DerivingStrategies
GeneralizedNewtypeDeriving
NamedFieldPuns
ScopedTypeVariables
StandaloneDeriving
TupleSections

library
import: lang
exposed-modules: System.IO.NonInterleaved
hs-source-dirs: src
import: lang
hs-source-dirs: src

exposed-modules:
Debug.NonInterleavedIO
Debug.NonInterleavedIO.Scoped
Debug.NonInterleavedIO.Trace
Debug.Provenance
Debug.Provenance.Scope

build-depends:
, containers >= 0.6 && < 0.8
, exceptions >= 0.9 && < 0.11
, hashable >= 1.4 && < 1.6
, temporary >= 1.2.1 && < 1.4
Expand Down
100 changes: 100 additions & 0 deletions src/Debug/NonInterleavedIO.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,100 @@
-- | Functions for non-interleaved output
--
-- Intended for qualifed import.
--
-- > import qualified Debug.NonInterleavedIO 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.Monad.IO.Class
import System.Environment
import System.IO.Temp (getCanonicalTemporaryDirectory)
import System.IO.Unsafe

import qualified System.IO as IO

{-------------------------------------------------------------------------------
Output functions
-------------------------------------------------------------------------------}

-- | Non-interleaved version of 'Prelude.putStr'
putStr :: MonadIO m => String -> m ()
putStr str = liftIO $ withMVar globalHandle $ \h -> IO.hPutStr h str

-- | 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 $ 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
IO.hSetBuffering h IO.NoBuffering
newMVar h
39 changes: 39 additions & 0 deletions src/Debug/NonInterleavedIO/Scoped.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,39 @@
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Utilities for writing debugging messages that include provenance
--
-- Intended for qualified import.
--
-- > import qualified Debug.NonInterleavedIO.Scoped as Scoped
module Debug.NonInterleavedIO.Scoped (
putStrLn
) where

import Prelude hiding (putStrLn)

import Control.Monad.IO.Class
import Data.List (intercalate)
import GHC.Stack

import Debug.Provenance
import Debug.Provenance.Scope

import qualified Debug.NonInterleavedIO as NIIO

{-------------------------------------------------------------------------------
Uniques
-------------------------------------------------------------------------------}

-- | Print debug message, showing current scope
putStrLn :: MonadIO m => String -> m ()
putStrLn str = withFrozenCallStack $ do
scope <- getScope
here <- newInvocation callSite

let prettyScope :: String
prettyScope = intercalate "," $ map prettyInvocation (here : scope)

NIIO.putStrLn $
case lines str of
[one] -> prettyScope ++ " " ++ one
many -> intercalate "\n" $ prettyScope : map (" " ++) many
14 changes: 14 additions & 0 deletions src/Debug/NonInterleavedIO/Trace.hs
Original file line number Diff line number Diff line change
@@ -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
Loading