hw-polysemy 0.2.10.0 → 0.2.11.0

raw patch · 4 files changed

+176/−14 lines, 4 filesdep +prettyprinterPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: prettyprinter

API changes (from Hackage documentation)

Files

• core/HaskellWorks/Polysemy/Except.hs +71/−0
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Assert.hs +89/−13
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Effect/Hedgehog.hs +10/−0
• hw-polysemy.cabal +6/−1

@@ -0,0 +1,71 @@+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Description: The 'Except' effect, providing catch and throw functionality over the final+-- monad via MonadCatch.+module HaskellWorks.Polysemy.Except+  ( -- * Effect+    Except (..),++    -- * Actions+    catchEx,+    throwEx,++    -- * Interpretations+    catchExToFinal,+    catchExToFinalIO,+  ) where++import           Control.Exception    (Exception (..))+import qualified Control.Monad.Catch  as X+import           HaskellWorks.Prelude+import           Polysemy+import           Polysemy.Final++------------------------------------------------------------------------------+-- | An effect capable of providing 'X.catch' and 'X.throwM' semantics. Interpreters for+-- this will successfully run the catch the exceptions thrown in the IO monad.+data Except m a where+  CatchEx+    :: Exception e+    => m a+    -> (e -> m a)+    -> Except m a++  ThrowEx+    :: Exception e+    => e+    -> Except m a++makeSem ''Except++------------------------------------------------------------------------------+-- | Run a 'Except' effect in terms of 'X.catch' and 'X.throwM' through final monad.+--+-- /Beware/: Effects that aren't interpreted in terms of 'IO'+-- will have local state semantics in regards to 'Except' effects+-- interpreted this way. See 'Final'.+catchExToFinal :: forall m r a.()+  => X.MonadCatch m+  => X.MonadThrow m+  => Member (Final m) r+  => Sem (Except ': r) a+  -> Sem r a+catchExToFinal = interpretFinal $ \case+  CatchEx f h -> do+    s  <- getInitialStateS+    a  <- runS f+    h' <- bindS h+    pure $ X.catch a $ \e -> h' $ e <$ s+  ThrowEx e ->+    pure $ X.throwM e+{-# INLINE catchExToFinal #-}++------------------------------------------------------------------------------+-- | Run a 'Except' effect in terms of 'X.catch' and 'X.throwM' through final IO monad.+catchExToFinalIO :: forall r a.()+  => Member (Final IO) r+  => Sem (Except ': r) a+  -> Sem r a+catchExToFinalIO = catchExToFinal+{-# INLINE catchExToFinalIO #-}

@@ -4,6 +4,12 @@     leftFailM,     leftFailJson,     leftFailJsonM,+    leftFailJsonPretty,+    leftFailJsonPrettyM,+    leftFailPretty,+    leftFailPrettyM,+    leftFailYaml,+    leftFailYamlM,     nothingFail,     nothingFailM,     requireHead,@@ -59,6 +65,9 @@ import           HaskellWorks.Polysemy.Hedgehog.Jot import           HaskellWorks.Polysemy.Prelude import           HaskellWorks.Polysemy.System.Directory+import           Prettyprinter                                  (Pretty)+import qualified Prettyprinter                                  as PP+import qualified Prettyprinter.Render.String                    as PP  import           HaskellWorks.Polysemy.System.IO                as IO import           HaskellWorks.Polysemy.System.Process@@ -87,19 +96,6 @@   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@@ -134,6 +130,19 @@ leftFailM f =   withFrozenCallStack $ f >>= leftFail +-- | 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)+ leftFailJsonM :: forall e r a. ()   => Member Hedgehog r   => ToJSON e@@ -142,6 +151,73 @@   -> Sem r a leftFailJsonM f =   withFrozenCallStack $ f >>= leftFailJson++-- | Fail when the result is Left with the error message as JSON.+leftFailPretty :: ()+  => Member Hedgehog r+  => Pretty e+  => HasCallStack+  => Either e a+  -> Sem r a+leftFailPretty r =+  withFrozenCallStack $ case r of+    Right a -> pure a+    Left e  -> do+      let msg = PP.renderString $ PP.layoutPretty PP.defaultLayoutOptions $ PP.pretty e+      failMessage GHC.callStack ("Expected Right: " <> msg)++leftFailPrettyM :: forall e r a. ()+  => Member Hedgehog r+  => Pretty e+  => HasCallStack+  => Sem r (Either e a)+  -> Sem r a+leftFailPrettyM f =+  withFrozenCallStack $ f >>= leftFailPretty++-- | Fail when the result is Left with the error message as JSON.+leftFailJsonPretty :: ()+  => Member Hedgehog r+  => ToJSON e+  => HasCallStack+  => Either e a+  -> Sem r a+leftFailJsonPretty r = withFrozenCallStack $ case r of+  Right a -> pure a+  Left e  -> do+    let msg = LT.unpack $ LT.decodeUtf8 $ J.encodePretty e+    failMessage GHC.callStack ("Expected Right: " <> msg)++leftFailJsonPrettyM :: forall e r a. ()+  => Member Hedgehog r+  => ToJSON e+  => HasCallStack+  => Sem r (Either e a)+  -> Sem r a+leftFailJsonPrettyM f =+  withFrozenCallStack $ f >>= leftFailJsonPretty++-- | Fail when the result is Left with the error message as JSON.+leftFailYaml :: ()+  => Member Hedgehog r+  => ToJSON e+  => HasCallStack+  => Either e a+  -> Sem r a+leftFailYaml r = withFrozenCallStack $ case r of+  Right a -> pure a+  Left e  -> do+    let msg = T.unpack $ T.decodeUtf8 $ Y.encode e+    failMessage GHC.callStack ("Expected Right: " <> msg)++leftFailYamlM :: forall e r a. ()+  => Member Hedgehog r+  => ToJSON e+  => HasCallStack+  => Sem r (Either e a)+  -> Sem r a+leftFailYamlM f =+  withFrozenCallStack $ f >>= leftFailYaml  nothingFailM :: forall r a. ()   => Member Hedgehog r

@@ -19,6 +19,8 @@   , hedgehogToPropertyFinal   , hedgehogToTestFinal +  , catchExToPropertyFinal+   ) where  import           HaskellWorks.Polysemy.Prelude@@ -28,6 +30,7 @@  import qualified Control.Monad.Catch                                     as IO import qualified Control.Monad.IO.Class                                  as IO+import           HaskellWorks.Polysemy.Except import qualified HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog.Internal as I import           Polysemy import           Polysemy.Final@@ -128,3 +131,10 @@   => Sem (Hedgehog ': r) a   -> Sem r a hedgehogToTestFinal = hedgehogToMonadTestFinal++catchExToPropertyFinal :: ()+  => Member (Final (H.PropertyT IO)) r+  => Sem (Except ': r) a+  -> Sem r a+catchExToPropertyFinal = catchExToFinal+{-# INLINE catchExToPropertyFinal #-}

@@ -1,6 +1,6 @@ cabal-version:          3.4 name:                   hw-polysemy-version:                0.2.10.0+version:                0.2.11.0 synopsis:               Opinionated polysemy library description:            Opinionated polysemy library. license:                Apache-2.0@@ -38,6 +38,7 @@ common polysemy-log               { build-depends: polysemy-log                                < 0.11   } common polysemy-plugin            { build-depends: polysemy-plugin                             < 0.5    } common polysemy-time              { build-depends: polysemy-time                               < 0.7    }+common prettyprinter              { build-depends: prettyprinter                               < 1.8    } common process                    { build-depends: process                                     < 1.7    } common resourcet                  { build-depends: resourcet                                   < 1.4    } common stm                        { build-depends: stm                                         < 2.6    }@@ -90,6 +91,7 @@                         async,                         bytestring,                         contravariant,+                        exceptions,                         directory,                         filepath,                         generic-lens,@@ -139,6 +141,7 @@                         HaskellWorks.Polysemy.Data.Text.Strict                         HaskellWorks.Polysemy.Error                         HaskellWorks.Polysemy.Error.Types+                        HaskellWorks.Polysemy.Except                         HaskellWorks.Polysemy.File                         HaskellWorks.Polysemy.FilePath                         HaskellWorks.Polysemy.OS@@ -169,9 +172,11 @@                         hedgehog,                         hw-polysemy-core,                         lens,+                        mtl,                         polysemy-log,                         polysemy-time,                         polysemy,+                        prettyprinter,                         process,                         resourcet,                         text,