diff --git a/fourmolu.yaml b/fourmolu.yaml index ef571e8..afa9418 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -3,6 +3,14 @@ column-limit: 80 # ignored until v12 / ghc-9.6 function-arrows: leading comma-style: leading # default import-export-style: leading +import-grouping: # needs fourmolu >= v0.17 + - name: "Preludes" + rules: + - glob: Prelude + - name: "Everything else" + rules: + - match: all + priority: 100 indent-wheres: false # default record-brace-space: true newlines-between-decls: 1 # default @@ -10,6 +18,7 @@ haddock-style: single-line let-style: mixed in-style: left-align single-constraint-parens: never # ignored until v12 / ghc-9.6 +trailing-section-operators: false # needs fourmolu >= v0.17 unicode: never # default respectful: true # default fixities: [] # default diff --git a/src/Graphula.hs b/src/Graphula.hs index 3b60d3c..ccb3e55 100755 --- a/src/Graphula.hs +++ b/src/Graphula.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} @@ -133,6 +134,9 @@ module Graphula , NodeOptions , GenerateKey , NoConstraint +#if MIN_VERSION_base(4,20,0) + , GraphulaSeed(..) +#endif ) where import Prelude hiding (readFile) @@ -168,7 +172,23 @@ import Test.HUnit.Lang ) import Test.QuickCheck (Arbitrary (..)) import Test.QuickCheck.Random (QCGen, mkQCGen) -import UnliftIO.Exception (catch, throwIO) +import UnliftIO.Exception (Exception (..), SomeException, catch, throwIO) + +#if MIN_VERSION_base(4,20,0) +import Control.Exception (addExceptionContext) +import Control.Exception.Annotation (ExceptionAnnotation(..)) + +newtype GraphulaSeed = GraphulaSeed Int + deriving stock (Show) + +instance ExceptionAnnotation GraphulaSeed + +addSeedContext :: Int -> SomeException -> SomeException +addSeedContext seed = addExceptionContext $ GraphulaSeed seed +#else +addSeedContext :: Int -> SomeException -> SomeException +addSeedContext _ = id +#endif -- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'. -- @@ -262,12 +282,24 @@ runGraphulaT mSeed runDB action = do 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) +logFailingSeed :: MonadIO m => Int -> SomeException -> m a +logFailingSeed seed = + throwIO + . addSeedContext seed + . whenException (prefixHUnitFailure ("Graphula with seed: " <> show seed)) + +prefixHUnitFailure :: String -> HUnitFailure -> HUnitFailure +prefixHUnitFailure message (HUnitFailure l r) = + HUnitFailure l . Reason $ message ++ "\n\n" ++ formatFailureReason r -rethrowHUnitWith :: MonadIO m => String -> HUnitFailure -> m a -rethrowHUnitWith message (HUnitFailure l r) = - throwIO . HUnitFailure l . Reason $ message ++ "\n\n" ++ formatFailureReason r +-- | Apply a function to a 'SomeException' when it's the expected type +whenException + :: Exception e + => (e -> e) + -- ^ Function to apply if 'fromException' at this type returns 'Just' + -> SomeException + -> SomeException +whenException f ex = maybe ex (toException . f) $ fromException ex type GraphulaNode m a = ( HasDependencies a diff --git a/test/README.lhs b/test/README.lhs index 343be64..66b82af 100644 --- a/test/README.lhs +++ b/test/README.lhs @@ -192,6 +192,21 @@ generationFailureSpec = do Right _ -> pure () ``` +## Seed + +`HUnitFailure` exceptions will have their reason prefixed by the seed used for +Graphula's arbitrary data, making it visible in expectation-failure messages. +Re-supplying this seed to `runGraphulaT` will reproduce the same graph, to +hopefully reproduce intermittent test failures caused by randomness. + +If using `base >= 4.20`, **all** exceptions will also have this seed added to +the [exception's context][ghc-docs]. This won't be visible anywhere (besides +`HUnitFailure`) by default, but can be extracted through custom exception +handling, e.g. in a `SpecHook`. We hope tools like `hspec` make using exception +context more ergonomic in the future. + +[ghc-docs]: https://hackage-content.haskell.org/package/base-4.22.0.0/docs/Control-Exception-Context.html + ## Running It ```haskell