hw-polysemy 0.2.6.0 → 0.2.7.0

raw patch · 4 files changed

+265/−4 lines, 4 filesdep +aeson-prettyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson-pretty

API changes (from Hackage documentation)

Files

• hedgehog/HaskellWorks/Polysemy/Hedgehog.hs +17/−0
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Assert.hs +82/−3
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Jot.hs +162/−0
• hw-polysemy.cabal +4/−1

@@ -9,11 +9,16 @@      leftFail,     leftFailM,+    leftFailJson,+    leftFailJsonM,     catchFail,     nothingFail,     nothingFailM,     requireHead,     trapFail,+    trapFailJson,+    trapFailJsonPretty,+    trapFailYaml,      failure,     failMessage,@@ -30,6 +35,12 @@      jotShow,     jotShow_,+    jotJson,+    jotJson_,+    jotJsonPretty,+    jotJsonPretty_,+    jotYaml,+    jotYaml_,     jotWithCallstack,     jot,     jot_,@@ -42,6 +53,12 @@     jotIO_,     jotShowM,     jotShowM_,+    jotJsonM,+    jotJsonM_,+    jotJsonPrettyM,+    jotJsonPrettyM_,+    jotYamlM,+    jotYamlM_,     jotShowIO,     jotShowIO_,     jotEach,

@@ -2,11 +2,16 @@   ( Hedgehog,     leftFail,     leftFailM,+    leftFailJson,+    leftFailJsonM,     nothingFail,     nothingFailM,     requireHead,     catchFail,     trapFail,+    trapFailJson,+    trapFailJsonPretty,+    trapFailYaml,     evalIO,     failure,     failMessage,@@ -29,9 +34,16 @@   import           Control.Lens                                   ((^.))-import           Data.Aeson                                     (Value)+import           Data.Aeson                                     (ToJSON, Value)+import qualified Data.Aeson                                     as J+import qualified Data.Aeson.Encode.Pretty                       as J import           Data.Generics.Product.Any import qualified Data.List                                      as L+import qualified Data.Text                                      as T+import qualified Data.Text.Encoding                             as T+import qualified Data.Text.Lazy                                 as LT+import qualified Data.Text.Lazy.Encoding                        as LT+import qualified Data.Yaml                                      as Y import qualified GHC.Stack                                      as GHC import           HaskellWorks.Polysemy.Error import           HaskellWorks.Polysemy.File@@ -65,6 +77,19 @@   Right a -> pure a   Left e  -> failMessage GHC.callStack ("Expected Right: " <> show e) +-- | Fail when the result is Left with the error message as JSON.+leftFailJson :: ()+  => Member Hedgehog r+  => ToJSON e+  => HasCallStack+  => Either e a+  -> Sem r a+leftFailJson r = withFrozenCallStack $ case r of+  Right a -> pure a+  Left e  -> do+    let msg = LT.unpack $ LT.decodeUtf8 $ J.encode e+    failMessage GHC.callStack ("Expected Right: " <> msg)+ nothingFail :: ()   => Member Hedgehog r   => HasCallStack@@ -99,6 +124,15 @@ leftFailM f =   withFrozenCallStack $ f >>= leftFail +leftFailJsonM :: forall e r a. ()+  => Member Hedgehog r+  => ToJSON e+  => HasCallStack+  => Sem r (Either e a)+  -> Sem r a+leftFailJsonM f =+  withFrozenCallStack $ f >>= leftFailJson+ nothingFailM :: forall r a. ()   => Member Hedgehog r   => HasCallStack@@ -123,8 +157,53 @@   => Show e   => Sem (Error e ': r) a   -> Sem r a-trapFail f =-  withFrozenCallStack $ f & runError & leftFailM+trapFail f = do+  r <- withFrozenCallStack $ f & runError+  case r of+    Right a -> pure a+    Left e  -> failMessage GHC.callStack $ show e++trapFailJson :: forall e r a.()+  => Member Hedgehog r+  => HasCallStack+  => ToJSON e+  => Sem (Error e ': r) a+  -> Sem r a+trapFailJson f = do+  r <- withFrozenCallStack $ f & runError+  case r of+    Right a -> pure a+    Left e  -> do+      let msg = LT.unpack $ LT.decodeUtf8 $ J.encode e+      failMessage GHC.callStack msg++trapFailJsonPretty :: forall e r a.()+  => Member Hedgehog r+  => HasCallStack+  => ToJSON e+  => Sem (Error e ': r) a+  -> Sem r a+trapFailJsonPretty f = do+  r <- withFrozenCallStack $ f & runError+  case r of+    Right a -> pure a+    Left e  -> do+      let msg = LT.unpack $ LT.decodeUtf8 $ J.encodePretty e+      failMessage GHC.callStack msg++trapFailYaml :: forall e r a.()+  => Member Hedgehog r+  => HasCallStack+  => ToJSON e+  => Sem (Error e ': r) a+  -> Sem r a+trapFailYaml f = do+  r <- withFrozenCallStack $ f & runError+  case r of+    Right a -> pure a+    Left e  -> do+      let msg = T.unpack $ T.decodeUtf8 $ Y.encode e+      failMessage GHC.callStack msg  requireHead :: ()   => Member Hedgehog r

@@ -18,6 +18,18 @@     jotShowM_,     jotShowIO,     jotShowIO_,+    jotJson,+    jotJson_,+    jotJsonM,+    jotJsonM_,+    jotJsonPretty,+    jotJsonPretty_,+    jotJsonPrettyM,+    jotJsonPrettyM_,+    jotYaml,+    jotYaml_,+    jotYamlM,+    jotYamlM_,     jotEach,     jotEach_,     jotEachM,@@ -31,12 +43,18 @@     jotTempFile,   ) where +import           Data.Aeson                                     (ToJSON) +import qualified Data.Aeson                                     as J+import qualified Data.Aeson.Encode.Pretty                       as J import qualified Data.ByteString.Lazy                           as LBS+import qualified Data.Text                                      as T import qualified Data.Text                                      as Text+import qualified Data.Text.Encoding                             as T import qualified Data.Text.Encoding                             as Text import qualified Data.Text.Lazy                                 as LT import qualified Data.Text.Lazy.Encoding                        as LT+import qualified Data.Yaml                                      as Y import qualified GHC.Stack                                      as GHC import           HaskellWorks.Polysemy.Prelude @@ -217,6 +235,150 @@ jotShowIO_ f = GHC.withFrozenCallStack $ do   !a <- evalIO f   jotWithCallstack GHC.callStack (show a)+  return ()++-- | Annotate the given value as JSON.+jotJson :: ()+  => Member Hedgehog r+  => GHC.HasCallStack+  => ToJSON a+  => a+  -> Sem r a+jotJson a = GHC.withFrozenCallStack $ do+  !b <- eval a+  jotWithCallstack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encode b+  return b++-- | Annotate the given value as JSON.+jotJson_ :: ()+  => Member Hedgehog r+  => GHC.HasCallStack+  => ToJSON a+  => a+  -> Sem r ()+jotJson_ a = GHC.withFrozenCallStack $ do+  !b <- eval a+  jotWithCallstack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encode b+  return ()++-- | Annotate the given value as JSON in a monadic context.+jotJsonM :: ()+  => Member Hedgehog r+  => GHC.HasCallStack+  => ToJSON a+  => Sem r a+  -> Sem r a+jotJsonM a = GHC.withFrozenCallStack $ do+  !b <- evalM a+  jotWithCallstack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encode b+  return b++-- | Annotate the given value as JSON in a monadic context.+jotJsonM_ :: ()+  => Member Hedgehog r+  => GHC.HasCallStack+  => ToJSON a+  => Sem r a+  -> Sem r ()+jotJsonM_ a = GHC.withFrozenCallStack $ do+  !b <- evalM a+  jotWithCallstack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encode b+  return ()++-- | Annotate the given value as JSON.+jotJsonPretty :: ()+  => Member Hedgehog r+  => GHC.HasCallStack+  => ToJSON a+  => a+  -> Sem r a+jotJsonPretty a = GHC.withFrozenCallStack $ do+  !b <- eval a+  jotWithCallstack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encodePretty b+  return b++-- | Annotate the given value as JSON.+jotJsonPretty_ :: ()+  => Member Hedgehog r+  => GHC.HasCallStack+  => ToJSON a+  => a+  -> Sem r ()+jotJsonPretty_ a = GHC.withFrozenCallStack $ do+  !b <- eval a+  jotWithCallstack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encodePretty b+  return ()++-- | Annotate the given value as JSON in a monadic context.+jotJsonPrettyM :: ()+  => Member Hedgehog r+  => GHC.HasCallStack+  => ToJSON a+  => Sem r a+  -> Sem r a+jotJsonPrettyM a = GHC.withFrozenCallStack $ do+  !b <- evalM a+  jotWithCallstack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encodePretty b+  return b++-- | Annotate the given value as JSON in a monadic context.+jotJsonPrettyM_ :: ()+  => Member Hedgehog r+  => GHC.HasCallStack+  => ToJSON a+  => Sem r a+  -> Sem r ()+jotJsonPrettyM_ a = GHC.withFrozenCallStack $ do+  !b <- evalM a+  jotWithCallstack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encodePretty b+  return ()++-- | Annotate the given value as JSON.+jotYaml :: ()+  => Member Hedgehog r+  => GHC.HasCallStack+  => ToJSON a+  => a+  -> Sem r a+jotYaml a = GHC.withFrozenCallStack $ do+  !b <- eval a+  jotWithCallstack GHC.callStack $ T.unpack $ T.decodeUtf8 $ Y.encode b+  return b++-- | Annotate the given value as JSON.+jotYaml_ :: ()+  => Member Hedgehog r+  => GHC.HasCallStack+  => ToJSON a+  => a+  -> Sem r ()+jotYaml_ a = GHC.withFrozenCallStack $ do+  !b <- eval a+  jotWithCallstack GHC.callStack $ T.unpack $ T.decodeUtf8 $ Y.encode b+  return ()++-- | Annotate the given value as JSON in a monadic context.+jotYamlM :: ()+  => Member Hedgehog r+  => GHC.HasCallStack+  => ToJSON a+  => Sem r a+  -> Sem r a+jotYamlM a = GHC.withFrozenCallStack $ do+  !b <- evalM a+  jotWithCallstack GHC.callStack $ T.unpack $ T.decodeUtf8 $ Y.encode b+  return b++-- | Annotate the given value as JSON in a monadic context.+jotYamlM_ :: ()+  => Member Hedgehog r+  => GHC.HasCallStack+  => ToJSON a+  => Sem r a+  -> Sem r ()+jotYamlM_ a = GHC.withFrozenCallStack $ do+  !b <- evalM a+  jotWithCallstack GHC.callStack $ T.unpack $ T.decodeUtf8 $ Y.encode b   return ()  -- | Annotate the each value in the given traversable.

@@ -1,6 +1,6 @@ cabal-version:          3.4 name:                   hw-polysemy-version:                0.2.6.0+version:                0.2.7.0 synopsis:               Opinionated polysemy library description:            Opinionated polysemy library. license:                Apache-2.0@@ -20,6 +20,7 @@ common base                       { build-depends: base                       >= 4.13       && < 5      }  common aeson                      { build-depends: aeson                                       < 2.3    }+common aeson-pretty               { build-depends: aeson-pretty                                < 0.9    } common async                      { build-depends: async                                       < 2.3    } common bytestring                 { build-depends: bytestring                                  < 0.13   } common contravariant              { build-depends: contravariant                               < 1.6    }@@ -152,6 +153,7 @@ library hedgehog   import:               base, project-config,                         aeson,+                        aeson-pretty,                         async,                         bytestring,                         contravariant,@@ -168,6 +170,7 @@                         polysemy,                         process,                         text,+                        yaml,   visibility:           public   exposed-modules:      HaskellWorks.Polysemy.Hedgehog                         HaskellWorks.Polysemy.Hedgehog.Assert