Skip to content
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
4 changes: 2 additions & 2 deletions backends/katip/benign-katip.cabal
Original file line number Diff line number Diff line change
@@ -1,12 +1,12 @@
cabal-version: 1.12

-- This file has been generated from package.yaml by hpack version 0.35.0.
-- This file has been generated from package.yaml by hpack version 0.38.0.
--
-- see: https://github.com/sol/hpack

name: benign-katip
version: 0.1.0
synopsis: A library for benign effects
synopsis: A Benign backend for the Katip library
description: see README.md.
homepage: https://github.com/aspiwack/haskell-benign#readme
bug-reports: https://github.com/aspiwack/haskell-benign/issues
Expand Down
2 changes: 1 addition & 1 deletion backends/katip/package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ author: Arnaud Spiwack
maintainer: [email protected]
github: aspiwack/haskell-benign
copyright: MIT
synopsis: A library for benign effects
synopsis: A Benign backend for the Katip library
description: see README.md.

dependencies:
Expand Down
43 changes: 26 additions & 17 deletions backends/katip/src/Benign/Katip.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,19 @@
{-# LANGUAGE GHC2021 #-}

module Benign.Katip where
-- | This module is a small wrapper around
-- [Katip](https://hackage.haskell.org/package/katip) to allow logging in pure
-- code.
--
-- The wrapper is a little primitive still and you will have to handle the
-- transition from IO code to pure code manually. Pull requests are, of course,
-- welcome.
module Benign.Katip
( withKatipContext,
withKatipNamespace,
withKatip,
logLocM,
)
where

import Benign qualified
import GHC.Stack
Expand All @@ -22,19 +35,13 @@ katipNamespace = unsafePerformIO Benign.newField

-- | See 'Katip.katipAddContext'.
withKatipContext :: (Katip.LogItem i) => i -> Benign.Strat a -> a -> a
withKatipContext item = Benign.withAltering katipContext addContext
where
addContext (Just st) = Just $ st <> Katip.liftPayload item
addContext Nothing = error "todo"
withKatipContext item = Benign.withAltering katipContext (<> Just (Katip.liftPayload item))

-- | See 'Katip.katipAddNamespace'.
withKatipNamespace :: Katip.Namespace -> Benign.Strat a -> a -> a
withKatipNamespace namespace = Benign.withAltering katipNamespace addNamespace
where
addNamespace (Just st) = Just $ st <> namespace
addNamespace Nothing = error "todo"
withKatipNamespace namespace = Benign.withAltering katipNamespace (<> Just namespace)

-- | Within this computation, Katip is configured.
-- | Within this computation, Katip is configured for pure code.
withKatip ::
(Katip.LogItem c) =>
Katip.LogEnv ->
Expand All @@ -48,7 +55,9 @@ withKatip env ctx namespace strat =
. Benign.withSettingIO' katipContext (Katip.liftPayload ctx)
. Benign.withSettingIO katipNamespace namespace strat

logLocM :: forall a. (HasCallStack) => Katip.Severity -> Katip.LogStr -> Benign.Strat a -> a -> a
-- | @'logLocM' s msg a@ logs a an event, like Katip's 'Katip.logLocM', before
-- evaluating @a@.
logLocM :: forall a. (HasCallStack) => Katip.Severity -> Katip.LogStr -> a -> a
logLocM severity str = withFrozenCallStack spanLog
where
-- The whole purpose of naming `span` is to freeze the call stack. It's
Expand All @@ -59,16 +68,16 @@ logLocM severity str = withFrozenCallStack spanLog
-- scratch. This would be invisible. I tried to harden this function by
-- declaring type signatures everywhere. I haven't tested it yet though. It
-- may be wrong.
spanLog :: HasCallStack => Benign.Strat a -> a -> a
spanLog = Benign.unsafeSpanBenign doLog (return ())
spanLog :: (HasCallStack) => a -> a
spanLog = Benign.unsafeSpanBenign doLog (return ()) Benign.whnf

doLog :: HasCallStack => IO ()
doLog :: (HasCallStack) => IO ()
doLog = do
-- Making an intermediary `KatipContextT` is a little roundabout, but it's
-- easier than reaching to Katip's internals.
--
-- TODO: catch errors
Just env <- Benign.lookupLocalState katipEnv
Just ctx <- Benign.lookupLocalState katipContext
Just namespace <- Benign.lookupLocalState katipNamespace
Just env <- Benign.lookupLexicalState katipEnv
Just ctx <- Benign.lookupLexicalState katipContext
Just namespace <- Benign.lookupLexicalState katipNamespace
Katip.runKatipContextT env ctx namespace $ Katip.logLocM severity str
6 changes: 3 additions & 3 deletions backends/timestats/benign-timestats.cabal
Original file line number Diff line number Diff line change
@@ -1,13 +1,13 @@
cabal-version: 1.12

-- This file has been generated from package.yaml by hpack version 0.35.0.
-- This file has been generated from package.yaml by hpack version 0.38.0.
--
-- see: https://github.com/sol/hpack

name: benign-timestats
version: 0.1.0
synopsis: A library for benign effects
description: see README.md.
synopsis: A Benign backend for the Timestats library
description: See the Benign library.
homepage: https://github.com/aspiwack/haskell-benign#readme
bug-reports: https://github.com/aspiwack/haskell-benign/issues
author: Arnaud Spiwack
Expand Down
4 changes: 2 additions & 2 deletions backends/timestats/package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -4,8 +4,8 @@ author: Arnaud Spiwack
maintainer: [email protected]
github: aspiwack/haskell-benign
copyright: MIT
synopsis: A library for benign effects
description: see README.md.
synopsis: A Benign backend for the Timestats library
description: See the Benign library.

dependencies:
- base
Expand Down
2 changes: 2 additions & 0 deletions backends/timestats/src/Benign/TimeStats.hs
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,8 @@ import Control.Exception
import Debug.TimeStats qualified as TimeStats
import System.IO.Unsafe (unsafePerformIO)

-- | @'measure' label strat thing@ measures, in the style of
-- 'TimeStats.measurePure', of running @strat thing@.
measure :: String -> Benign.Strat a -> a -> a
measure label strat thing = unsafePerformIO $ TimeStats.measureM label $ do Benign.E <- evaluate (strat thing); return thing
{-# NOINLINE measure #-}
4 changes: 2 additions & 2 deletions benign.cabal
Original file line number Diff line number Diff line change
@@ -1,13 +1,13 @@
cabal-version: 1.12

-- This file has been generated from package.yaml by hpack version 0.35.0.
-- This file has been generated from package.yaml by hpack version 0.38.0.
--
-- see: https://github.com/sol/hpack

name: benign
version: 0.1.0
synopsis: A library for benign effects
description: see README.md.
description: See the Benign library.
homepage: https://github.com/aspiwack/haskell-benign#readme
bug-reports: https://github.com/aspiwack/haskell-benign/issues
author: Arnaud Spiwack
Expand Down
2 changes: 1 addition & 1 deletion examples/SimplePrint.hs
Original file line number Diff line number Diff line change
Expand Up @@ -42,7 +42,7 @@ log log_line = Benign.unsafeSpanBenign do_log (return ())
where
do_log :: IO ()
do_log = do
ctx <- Benign.lookupLocalState context
ctx <- Benign.lookupLexicalState context
putStrLn (fromMaybe "" ctx ++ " " ++ log_line)

------------------------------------------------------------------------------
Expand Down
6 changes: 3 additions & 3 deletions nix/sources.json
Original file line number Diff line number Diff line change
Expand Up @@ -5,10 +5,10 @@
"homepage": "https://github.com/NixOS/nixpkgs",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "7f9be6a505a31f88499c5d20d11f98accf5ae6ba",
"sha256": "147wp515k1x08blm3nn2z994wbdnbl0vhp472ym1habfihfr7x65",
"rev": "2e1496bf8652ff4af4e4d4737277f71e4a4f5cb2",
"sha256": "0afb9y45zp2ikbzpbicy72l4dh9n0mgank8kqmyqxb8ib7s6qmsx",
"type": "tarball",
"url": "https://github.com/NixOS/nixpkgs/archive/7f9be6a505a31f88499c5d20d11f98accf5ae6ba.tar.gz",
"url": "https://github.com/NixOS/nixpkgs/archive/2e1496bf8652ff4af4e4d4737277f71e4a4f5cb2.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
}
}
2 changes: 1 addition & 1 deletion package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@ maintainer: [email protected]
github: aspiwack/haskell-benign
copyright: MIT
synopsis: A library for benign effects
description: see README.md.
description: See the Benign library.

dependencies:
- base
Expand Down
2 changes: 1 addition & 1 deletion shell.nix
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ let
sources = import ./nix/sources.nix;
pkgs = import sources.nixpkgs { };
# ghc924 matches the version from Stack
ghcVersion = "924";
ghcVersion = "984";
in

let
Expand Down
Loading