Merge pull request #26 from aspiwack/strat-redesign

Completely redesign the API around explicit strategies

Author: aspiwack

README.md

@@ -24,27 +24,26 @@ The Benign library is an attempt to address this gap. A difficulty is
 laziness. With laziness, things have a beginning (when the thunk is
 being forced), but not a well-defined end. So what do we measure the
 time of? The solution of the Benign library is to be less lazy. We
-keep laziness for algorithms, but use strict (or at least stricter)
-types to assemble bigger steps. It's fine to log or trace in pure
-code, since we don't consider that these observations are part of the
-semantics of the program.
+keep laziness for algorithms, but use evaluate more strictly when
+assembling bigger steps. It's fine to log or trace in pure code, since
+we don't consider that these observations are part of the semantics of
+the program.
 
 The Benign library provides facilities to create benign effects,
-including to use strict types to assemble these large steps.
+including evaluation strategies to express precisely how strict we
+want to be.
 
 The premise underlying all this, as well as the implementation of the
 library, is that logging or tracing is not very fast. So we don't want
 to log or trace in places where performance is really essential. This
 is why at the most inner level, where tight loops and algorithms live,
 laziness is not a problem: we are not going to log there, this would
-cost too much performance. At a more outer level, we can use
-strictness to make steps with a beginning and an end. It's ok if there
-is a cost in terms of conversion, this is not where we need to
-optimise too much. The library can, and does, prevent optimisation
-through its functions (note that cost-centre profiling also prevents
-optimisation through cost centres; it isn't surprising that we are
-having a similar problem). With the optimisation not working at that
-level, strictness is much less of a problem.
+cost too much performance. The library can, and does, prevent
+optimisation through its functions anyway (note that cost-centre
+profiling also prevents optimisation through cost centres; it isn't
+surprising that we are having a similar problem). So benign effects
+all must happen at rather macro steps, where we don't have to worry
+too much about the impact of evaluation.
 
 ## Backends
 

backends/katip/src/Benign/Katip.hs

@@ -21,33 +21,34 @@ katipNamespace = unsafePerformIO Benign.newField
 {-# NOINLINE katipNamespace #-}
 
 -- | See 'Katip.katipAddContext'.
-withKatipContext :: (Katip.LogItem i, Benign.Eval a) => i -> a -> Benign.Result a
+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"
 
 -- | See 'Katip.katipAddNamespace'.
-withKatipNamespace :: Benign.Eval a => Katip.Namespace -> a -> Benign.Result a
+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"
 
 -- | Within this computation, Katip is configured.
 withKatip ::
-  (Katip.LogItem c, Benign.EvalIO a) =>
+  (Katip.LogItem c) =>
   Katip.LogEnv ->
   c ->
   Katip.Namespace ->
-  a ->
-  IO (Benign.ResultIO a)
-withKatip env ctx namespace =
-  Benign.withSettingIO katipEnv env
-    . Benign.withSettingIO katipContext (Katip.liftPayload ctx)
-    . Benign.withSettingIO katipNamespace namespace
+  Benign.Strat a ->
+  IO a ->
+  IO a
+withKatip env ctx namespace strat =
+  Benign.withSettingIO' katipEnv env
+    . Benign.withSettingIO' katipContext (Katip.liftPayload ctx)
+    . Benign.withSettingIO katipNamespace namespace strat
 
-logLocM :: forall a. (Benign.Eval a, HasCallStack) => Katip.Severity -> Katip.LogStr -> a -> Benign.Result a
+logLocM :: forall a. (HasCallStack) => Katip.Severity -> Katip.LogStr -> Benign.Strat a -> a -> a
 logLocM severity str = withFrozenCallStack spanLog
   where
     -- The whole purpose of naming `span` is to freeze the call stack. It's
@@ -58,7 +59,7 @@ 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 => a -> Benign.Result a
+    spanLog :: HasCallStack => Benign.Strat a -> a -> a
     spanLog = Benign.unsafeSpanBenign doLog (return ())
 
     doLog :: HasCallStack => IO ()

backends/timestats/src/Benign/TimeStats.hs

@@ -3,9 +3,10 @@
 module Benign.TimeStats where
 
 import Benign qualified
+import Control.Exception
 import Debug.TimeStats qualified as TimeStats
 import System.IO.Unsafe (unsafePerformIO)
 
-measure :: Benign.Eval a => String -> a -> Benign.Result a
-measure label thing = unsafePerformIO $ TimeStats.measureM label $ Benign.evalIO (Benign.PureEval 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 #-}

benign.cabal

@@ -34,7 +34,6 @@ library
     , containers
     , deepseq
     , stm
-    , strict-wrapper
     , transformers
   default-language: Haskell2010
 
@@ -50,6 +49,5 @@ executable simple-print
     , containers
     , deepseq
     , stm
-    , strict-wrapper
     , transformers
   default-language: Haskell2010

examples/SimplePrint.hs

@@ -2,7 +2,6 @@
 
 module Main where
 
-import Benign (Seq (..))
 import Benign qualified
 import Data.Maybe
 import GHC.IO.Unsafe (unsafePerformIO)
@@ -30,15 +29,15 @@ context = unsafePerformIO Benign.newField
 {-# NOINLINE context #-}
 
 -- 'withContext' is called to extend the context in its scope.
-withContext :: Benign.Eval a => String -> a -> Benign.Result a
+withContext :: String -> Benign.Strat a -> a -> a
 withContext additional_ctx = Benign.withAltering context $ \ctx ->
   Just $
     fromMaybe "" ctx ++ " " ++ additional_ctx
 
 -- The 'log' function is the one performing the logging. It is a little
 -- degenerate, as far as benign effects go, as it doesn't do anything after the
 -- end of the evaluation.
-log :: Benign.Eval a => String -> a -> Benign.Result a
+log :: String -> Benign.Strat a -> a -> a
 log log_line = Benign.unsafeSpanBenign do_log (return ())
   where
     do_log :: IO ()
@@ -53,10 +52,10 @@ log log_line = Benign.unsafeSpanBenign do_log (return ())
 ------------------------------------------------------------------------------
 
 (+:) :: Int -> Int -> Int
-n +: p = (withContext "left:" (Seq n)) + (withContext "right:" (Seq p))
+n +: p = (withContext "left:" Benign.whnf n) + (withContext "right:" Benign.whnf p)
 
 incr :: Int -> Int
-incr n = log (show n) $ Seq $ n + 1
+incr n = log (show n) Benign.whnf $ n + 1
 
 myvalue :: Int
 myvalue = incr 18 +: incr 42 +: incr 57

package.yaml

@@ -13,7 +13,6 @@ dependencies:
   - containers
   - deepseq
   - stm
-  - strict-wrapper
   - transformers
 
 ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wredundant-constraints