graphula 2.1.2.0 → 2.1.3.0

raw patch · 6 files changed

+204/−17 lines, 6 filesdep −markdown-unlitPVP ok

version bump matches the API change (PVP)

Dependencies removed: markdown-unlit

API changes (from Hackage documentation)

Files

• README.md +65/−2
• graphula.cabal +8/−7
• src/Graphula.hs +18/−6
• src/Graphula/Arbitrary.hs +1/−0
• src/Graphula/ExceptionContext.hs +47/−0
• test/README.lhs +65/−2

@@ -11,6 +11,7 @@  <!-- ```haskell+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}@@ -32,7 +33,11 @@  module Main (module Main) where -import Control.Exception (try, Exception(..))+import Control.Exception (try, Exception(..), SomeException)+#if MIN_VERSION_base(4,20,0)+import Control.Exception (someExceptionContext)+import Control.Exception.Context (getExceptionAnnotations)+#endif import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger (NoLoggingT)@@ -42,10 +47,12 @@ import Database.Persist.TH import GHC.Generics (Generic) import Graphula+#if MIN_VERSION_base(4,20,0)+import Graphula.ExceptionContext (GraphulaExceptionContext (..))+#endif import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Arbitrary.Generic-import Text.Markdown.Unlit ()  instance (ToBackendKey SqlBackend a) => Arbitrary (Key a) where   arbitrary = toSqlKey <$> arbitrary@@ -193,6 +200,57 @@     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++```haskell+seedPrefixesHUnitFailureSpec :: IO ()+seedPrefixesHUnitFailureSpec = do+  result <- try $ runGraphulaT (Just 1) runDB $ do+    liftIO $ (1 :: Int) `shouldBe` 2++  case result :: Either SomeException () of+    Left ex -> show ex `shouldContain` "Graphula with seed: 1"+    Right () -> expectationFailure "expected an exception"++#if MIN_VERSION_base(4,20,0)+seedExceptionContextSpec :: IO ()+seedExceptionContextSpec = do+  result <- try $ runGraphulaT (Just 2) runDB $ do+    liftIO $ (1 :: Int) `shouldBe` 2++  case result :: Either SomeException () of+    Left ex -> seedsInContext ex `shouldBe` [2]+    Right () -> expectationFailure "expected an exception"++seedExceptionContextNonHUnitFailureSpec :: IO ()+seedExceptionContextNonHUnitFailureSpec = do+  result <- try $ runGraphulaT (Just 3) runDB $ do+    liftIO $ ioError $ userError "boom"++  case result :: Either SomeException () of+    Left ex -> seedsInContext ex `shouldBe` [3]+    Right () -> expectationFailure "expected an exception"++seedsInContext :: SomeException -> [Int]+seedsInContext ex =+  map graphulaExceptionContextSeed+    $ getExceptionAnnotations (someExceptionContext ex)+#endif+```+ ## Running It  ```haskell@@ -226,6 +284,11 @@     it "generates and links arbitrary graphs of data" simpleSpec     it "allows logging graphs" loggingSpec     it "shows informative generation failures" generationFailureSpec+    it "prefixes HUnitFailure reasons with the seed" seedPrefixesHUnitFailureSpec+#if MIN_VERSION_base(4,20,0)+    it "adds the seed to exception context, for HUnitFailure" seedExceptionContextSpec+    it "adds the seed to exception context, for other exceptions" seedExceptionContextNonHUnitFailureSpec+#endif  runDB :: MonadUnliftIO m => ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a runDB f = runSqlite "test.db" $ do

@@ -1,6 +1,6 @@ cabal-version:      1.12 name:               graphula-version:            2.1.2.0+version:            2.1.3.0 license:            MIT license-file:       LICENSE maintainer:         Freckle Education@@ -31,6 +31,7 @@         Graphula.Class         Graphula.Dependencies         Graphula.Dependencies.Generic+        Graphula.ExceptionContext         Graphula.Idempotent         Graphula.Key         Graphula.Logged@@ -74,11 +75,12 @@         ghc-options: -Wno-redundant-constraints  test-suite readme-    type:             exitcode-stdio-1.0-    main-is:          README.lhs-    hs-source-dirs:   test-    other-modules:    Paths_graphula-    default-language: Haskell2010+    type:               exitcode-stdio-1.0+    main-is:            README.lhs+    build-tool-depends: markdown-unlit:markdown-unlit+    hs-source-dirs:     test+    other-modules:      Paths_graphula+    default-language:   Haskell2010     ghc-options:         -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude         -Wno-missing-import-lists -Wno-safe -Wno-unsafe -pgmL@@ -90,7 +92,6 @@         generic-arbitrary >=0.1.0,         graphula,         hspec >=2.5.5,-        markdown-unlit >=0.5.0,         monad-logger >=0.3.30,         persistent >=2.8.2,         persistent-sqlite >=2.8.2,

@@ -156,6 +156,7 @@ import Database.Persist.Sql (SqlBackend) import Graphula.Class import Graphula.Dependencies+import Graphula.ExceptionContext import Graphula.Idempotent import Graphula.Logged import Graphula.NoConstraint@@ -168,7 +169,7 @@   ) import Test.QuickCheck (Arbitrary (..)) import Test.QuickCheck.Random (QCGen, mkQCGen)-import UnliftIO.Exception (catch, throwIO)+import UnliftIO.Exception (Exception (..), SomeException, catch)  -- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'. --@@ -262,12 +263,23 @@   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 =+  throwWithGraphulaExceptionContext (GraphulaExceptionContext seed)+    . whenException (prefixHUnitFailure ("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+prefixHUnitFailure :: String -> HUnitFailure -> HUnitFailure+prefixHUnitFailure message (HUnitFailure l r) =+  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

@@ -1,4 +1,5 @@ -- | 'Arbitrary' operations that respect Graphula's seed+{-# OPTIONS_GHC -Wno-deprecations #-} module Graphula.Arbitrary   ( generate   ) where

@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}++module Graphula.ExceptionContext+  ( GraphulaExceptionContext (..)+  , throwWithGraphulaExceptionContext+  ) where++import Prelude++import Control.Exception (SomeException (..), throwIO)+import Control.Monad.IO.Class (MonadIO, liftIO)++#if MIN_VERSION_base(4,20,0)+import Control.Exception (ExceptionWithContext (..), someExceptionContext)+import Control.Exception.Annotation (ExceptionAnnotation)+import Control.Exception.Context (addExceptionAnnotation)+#endif++newtype GraphulaExceptionContext = GraphulaExceptionContext+  { graphulaExceptionContextSeed :: Int+  }+  deriving stock (Show)++#if MIN_VERSION_base(4,20,0)+instance ExceptionAnnotation GraphulaExceptionContext+#endif++-- | Attach the seed as exception context, then rethrow+--+-- On @base < 4.20@, where exception context does not exist, this simply+-- rethrows the given exception unchanged.+throwWithGraphulaExceptionContext+  :: MonadIO m+  => GraphulaExceptionContext+  -> SomeException+  -> m a+#if MIN_VERSION_base(4,20,0)+throwWithGraphulaExceptionContext ctx ex@(SomeException e) =+  liftIO+    . throwIO+    $ ExceptionWithContext+      (addExceptionAnnotation ctx (someExceptionContext ex))+      e+#else+throwWithGraphulaExceptionContext _ctx ex = liftIO $ throwIO ex+#endif

@@ -11,6 +11,7 @@  <!-- ```haskell+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}@@ -32,7 +33,11 @@  module Main (module Main) where -import Control.Exception (try, Exception(..))+import Control.Exception (try, Exception(..), SomeException)+#if MIN_VERSION_base(4,20,0)+import Control.Exception (someExceptionContext)+import Control.Exception.Context (getExceptionAnnotations)+#endif import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger (NoLoggingT)@@ -42,10 +47,12 @@ import Database.Persist.TH import GHC.Generics (Generic) import Graphula+#if MIN_VERSION_base(4,20,0)+import Graphula.ExceptionContext (GraphulaExceptionContext (..))+#endif import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Arbitrary.Generic-import Text.Markdown.Unlit ()  instance (ToBackendKey SqlBackend a) => Arbitrary (Key a) where   arbitrary = toSqlKey <$> arbitrary@@ -193,6 +200,57 @@     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++```haskell+seedPrefixesHUnitFailureSpec :: IO ()+seedPrefixesHUnitFailureSpec = do+  result <- try $ runGraphulaT (Just 1) runDB $ do+    liftIO $ (1 :: Int) `shouldBe` 2++  case result :: Either SomeException () of+    Left ex -> show ex `shouldContain` "Graphula with seed: 1"+    Right () -> expectationFailure "expected an exception"++#if MIN_VERSION_base(4,20,0)+seedExceptionContextSpec :: IO ()+seedExceptionContextSpec = do+  result <- try $ runGraphulaT (Just 2) runDB $ do+    liftIO $ (1 :: Int) `shouldBe` 2++  case result :: Either SomeException () of+    Left ex -> seedsInContext ex `shouldBe` [2]+    Right () -> expectationFailure "expected an exception"++seedExceptionContextNonHUnitFailureSpec :: IO ()+seedExceptionContextNonHUnitFailureSpec = do+  result <- try $ runGraphulaT (Just 3) runDB $ do+    liftIO $ ioError $ userError "boom"++  case result :: Either SomeException () of+    Left ex -> seedsInContext ex `shouldBe` [3]+    Right () -> expectationFailure "expected an exception"++seedsInContext :: SomeException -> [Int]+seedsInContext ex =+  map graphulaExceptionContextSeed+    $ getExceptionAnnotations (someExceptionContext ex)+#endif+```+ ## Running It  ```haskell@@ -226,6 +284,11 @@     it "generates and links arbitrary graphs of data" simpleSpec     it "allows logging graphs" loggingSpec     it "shows informative generation failures" generationFailureSpec+    it "prefixes HUnitFailure reasons with the seed" seedPrefixesHUnitFailureSpec+#if MIN_VERSION_base(4,20,0)+    it "adds the seed to exception context, for HUnitFailure" seedExceptionContextSpec+    it "adds the seed to exception context, for other exceptions" seedExceptionContextNonHUnitFailureSpec+#endif  runDB :: MonadUnliftIO m => ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a runDB f = runSqlite "test.db" $ do