Skip to content

feat: add seed via exception context #113

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.

Sign up for GitHub

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

Draft
pbrisbin wants to merge 1 commit into
base: main
Choose a base branch
from
Draft

feat: add seed via exception context #113

Changes from all commits
Commits
Show all changes
1 commit
Select commit
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
41 changes: 28 additions & 13 deletions src/Graphula.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,8 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}

Check warning on line 5 in src/Graphula.hs

View workflow job for this annotation

GitHub Actions / lint 

Warning in module Graphula: Unused LANGUAGE pragma ▫︎ Found: "{-# LANGUAGE DeriveAnyClass #-}"
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
Expand Down Expand Up @@ -161,15 +163,35 @@
import Graphula.NoConstraint
import Graphula.Node
import System.Random (randomIO)
import Test.HUnit.Lang
( FailureReason (..)
, HUnitFailure (..)
, formatFailureReason
)
import Test.QuickCheck (Arbitrary (..))
import Test.QuickCheck.Random (QCGen, mkQCGen)

#if MIN_VERSION_base(4,20,0)
import Control.Exception (addExceptionContext)
import Control.Exception.Annotation (ExceptionAnnotation(..))
import UnliftIO.Exception (mapExceptionM)

newtype GraphulaSeed = GraphulaSeed Int
deriving stock (Show)
deriving anyclass (ExceptionAnnotation)

addSeedContext :: MonadUnliftIO m => m a -> Int -> m a
addSeedContext f seed = mapExceptionM (addExceptionContext (GraphulaSeed seed)) f
#else
import Test.HUnit.Lang (FailureReason (..) , HUnitFailure (..) , formatFailureReason)
import UnliftIO.Exception (catch, throwIO)

addSeedContext :: MonadUnliftIO m => m a -> Int -> m a
addSeedContext f seed = f `catch` logFailingSeed seed

logFailingSeed :: MonadIO m => Int -> HUnitFailure -> m a
logFailingSeed seed = rethrowHUnitWith ("Graphula with seed: " ++ show seed)

rethrowHUnitWith :: MonadIO m => String -> HUnitFailure -> m a
rethrowHUnitWith message (HUnitFailure l r) =
throwIO . HUnitFailure l . Reason $ message ++ "\n\n" ++ formatFailureReason r
#endif

-- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'.
--
-- Helpful for defining utility functions over many nodes.
Expand Down Expand Up @@ -260,14 +282,7 @@
seed <- maybe (liftIO randomIO) pure mSeed
qcGen <- liftIO $ newIORef $ mkQCGen seed
runReaderT (runGraphulaT' action) (Args (RunDB runDB) qcGen)
`catch` logFailingSeed seed

logFailingSeed :: MonadIO m => Int -> HUnitFailure -> m a
logFailingSeed seed = rethrowHUnitWith ("Graphula with seed: " ++ show seed)

rethrowHUnitWith :: MonadIO m => String -> HUnitFailure -> m a
rethrowHUnitWith message (HUnitFailure l r) =
throwIO . HUnitFailure l . Reason $ message ++ "\n\n" ++ formatFailureReason r
`addSeedContext` seed

type GraphulaNode m a =
( HasDependencies a
Expand Down
Loading