hw-polysemy 0.2.7.0 → 0.2.8.0

raw patch · 6 files changed

+186/−14 lines, 6 filesdep +transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: transformers

API changes (from Hackage documentation)

Files

• core/HaskellWorks/Prelude.hs +22/−0
• hedgehog/HaskellWorks/Polysemy/Hedgehog.hs +9/−0
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Assert.hs +87/−0
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Effect/Hedgehog.hs +40/−12
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Effect/Hedgehog/Internal.hs +23/−1
• hw-polysemy.cabal +5/−1

@@ -108,6 +108,27 @@    , for_ +  , Fractional(..)+  , Real(..)+  , RealFrac(..)+  , Ratio(..)+  , Rational+  , fromIntegral+  , realToFrac+  , even+  , odd+  , numericEnumFrom+  , numericEnumFromThen+  , numericEnumFromTo+  , numericEnumFromThenTo+  , integralEnumFrom+  , integralEnumFromThen+  , integralEnumFromTo+  , integralEnumFromThenTo+  , numerator+  , denominator+  , (%)+   , Monad(..)   , MonadFail(..)   , MonadPlus(..)@@ -161,6 +182,7 @@ import           GHC.Base import           GHC.Generics import           GHC.Num+import           GHC.Real import           GHC.Stack import           System.FilePath import           Text.Show

@@ -24,6 +24,11 @@     failMessage,     (===), +    byDeadlineIO,+    byDeadlineM,+    byDurationIO,+    byDurationM,+     eval,     evalM,     evalIO,@@ -32,6 +37,10 @@     failWithCustom,     evalIO_,     evalM_,++    catchAssertion,+    throwAssertion,+    trapAssertion,      jotShow,     jotShow_,

@@ -15,6 +15,10 @@     evalIO,     failure,     failMessage,+    byDeadlineIO,+    byDeadlineM,+    byDurationIO,+    byDurationM,      (===), @@ -33,6 +37,7 @@   ) where  +import qualified Control.Concurrent                             as IO import           Control.Lens                                   ((^.)) import           Data.Aeson                                     (ToJSON, Value) import qualified Data.Aeson                                     as J@@ -43,13 +48,18 @@ import qualified Data.Text.Encoding                             as T import qualified Data.Text.Lazy                                 as LT import qualified Data.Text.Lazy.Encoding                        as LT+import           Data.Time.Clock                                (NominalDiffTime,+                                                                 UTCTime)+import qualified Data.Time.Clock                                as DTC import qualified Data.Yaml                                      as Y import qualified GHC.Stack                                      as GHC import           HaskellWorks.Polysemy.Error import           HaskellWorks.Polysemy.File import           HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog+import           HaskellWorks.Polysemy.Hedgehog.Jot import           HaskellWorks.Polysemy.Prelude import           HaskellWorks.Polysemy.System.Directory+ import           HaskellWorks.Polysemy.System.IO                as IO import           HaskellWorks.Polysemy.System.Process import           Polysemy@@ -377,3 +387,80 @@   exists <- doesDirectoryExist dir     & trap @IOException (const (pure False))   when exists $ failWithCustom GHC.callStack Nothing ("Directory '" <> dir <> "' does exist on the file system.")++byDeadlineIO :: ()+  => HasCallStack+  => Member (Embed m) r+  => Member (Embed IO) r+  => Member Hedgehog r+  => Member Log r+  => NominalDiffTime+  -> UTCTime+  -> String+  -> m a+  -> Sem r a+byDeadlineIO period deadline errorMessage f = GHC.withFrozenCallStack $ byDeadlineM period deadline errorMessage $ embed f++-- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.+--+-- Expiration of the deadline results in an assertion failure+byDeadlineM ::  ()+  => HasCallStack+  => Member Hedgehog r+  => Member Log r+  => Member (Embed IO) r+  => NominalDiffTime+  -> UTCTime+  -> String+  -> Sem r a+  -> Sem r a+byDeadlineM period deadline errorMessage f = GHC.withFrozenCallStack $ do+  start <- embed DTC.getCurrentTime+  a <- goM+  end <- embed DTC.getCurrentTime+  jot_ $ "Operation completed in " <> show (DTC.diffUTCTime end start)+  return a+  where goM = catchAssertion f $ \e -> do+          currentTime <- embed DTC.getCurrentTime+          if currentTime < deadline+            then do+              embed $ IO.threadDelay (floor (DTC.nominalDiffTimeToSeconds period * 1000000))+              goM+            else do+              jotShow_ currentTime+              void $ failMessage GHC.callStack $ "Condition not met by deadline: " <> errorMessage+              throwAssertion e++-- | Run the operation 'f' once a second until it returns 'True' or the duration expires.+--+-- Expiration of the duration results in an assertion failure+byDurationIO :: ()+  => HasCallStack+  => Member (Embed m) r+  => Member (Embed IO) r+  => Member Hedgehog r+  => Member Log r+  => NominalDiffTime+  -> NominalDiffTime+  -> String+  -> m b+  -> Sem r b+byDurationIO period duration errorMessage f =+  GHC.withFrozenCallStack $ byDurationM period duration errorMessage $ embed f++-- | Run the operation 'f' once a second until it returns 'True' or the duration expires.+--+-- Expiration of the duration results in an assertion failure+byDurationM :: ()+  => HasCallStack+  => Member (Embed IO) r+  => Member Hedgehog r+  => Member Log r+  => NominalDiffTime+  -> NominalDiffTime+  -> String+  -> Sem r b+  -> Sem r b+byDurationM period duration errorMessage f = GHC.withFrozenCallStack $ do+  deadline <- DTC.addUTCTime duration <$> embed DTC.getCurrentTime+  byDeadlineM period deadline errorMessage f

@@ -5,12 +5,15 @@   ( Hedgehog    , assertEquals+  , catchAssertion   , eval   , evalM   , evalIO   , writeLog   , failWith   , failWithCustom+  , throwAssertion+  , trapAssertion    , hedgehogToMonadTestFinal   , hedgehogToPropertyFinal@@ -18,7 +21,6 @@    ) where -import qualified GHC.Stack                                               as GHC import           HaskellWorks.Polysemy.Prelude  import qualified Hedgehog                                                as H@@ -31,50 +33,73 @@ import           Polysemy.Final  data Hedgehog m rv where-  AssertEquals :: (GHC.HasCallStack, Eq a, Show a)+  AssertEquals :: (HasCallStack, Eq a, Show a)     => a     -> a     -> Hedgehog m () -  Eval :: GHC.HasCallStack+  CatchAssertion :: HasCallStack+    => m a+    -> (H.Failure -> m a)+    -> Hedgehog m a++  Eval :: HasCallStack     => a     -> Hedgehog m a -  EvalM :: GHC.HasCallStack+  EvalM :: HasCallStack     => m a     -> Hedgehog m a -  EvalIO :: GHC.HasCallStack+  EvalIO :: HasCallStack     => IO a     -> Hedgehog m a -  WriteLog :: ()-    => H.Log-    -> Hedgehog m ()--  FailWith :: GHC.HasCallStack+  FailWith :: HasCallStack     => Maybe H.Diff     -> String     -> Hedgehog m a    FailWithCustom :: ()-    => GHC.CallStack+    => CallStack     -> Maybe H.Diff     -> String     -> Hedgehog m a +  ThrowAssertion :: HasCallStack+    => H.Failure+    -> Hedgehog m a++  WriteLog :: HasCallStack+    => H.Log+    -> Hedgehog m ()+ makeSem ''Hedgehog +trapAssertion :: ()+  => Member Hedgehog r+  => (H.Failure -> Sem r a)+  -> Sem r a+  -> Sem r a+trapAssertion = flip catchAssertion+ hedgehogToMonadTestFinal :: ()   => IO.MonadIO m   => IO.MonadCatch m   => H.MonadTest m+  => I.MonadAssertion m   => Member (Final m) r   => Sem (Hedgehog ': r) a   -> Sem r a hedgehogToMonadTestFinal = interpretFinal \case   AssertEquals a b ->     liftS $ a H.=== b+  CatchAssertion f h -> do+    s  <- getInitialStateS+    f' <- runS f+    h' <- bindS h+    pure $ I.catchAssertion f' $ \e -> do+      h' (e <$ s)   Eval a ->     liftS $ H.eval a   EvalIO f ->@@ -85,7 +110,10 @@   FailWith mdiff msg ->     liftS $ H.failWith mdiff msg   FailWithCustom cs mdiff msg ->-    liftS $ I.failWithCustom cs mdiff msg+    liftS $ I.failWithCustom cs+     mdiff msg+  ThrowAssertion e ->+    liftS $ I.throwAssertion e   WriteLog logValue ->     liftS $ H.writeLog logValue 

@@ -1,5 +1,9 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+ module HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog.Internal-  ( failWithCustom+  ( MonadAssertion(..)+  , failWithCustom   ) where  import           HaskellWorks.Polysemy.Prelude@@ -7,6 +11,11 @@ import qualified Hedgehog.Internal.Property    as H import qualified Hedgehog.Internal.Source      as H +import qualified Control.Monad.Trans.Except as E+import qualified Control.Monad.Trans.Resource as IO+import qualified Control.Monad.Trans.Resource.Internal as IO+import           Control.Monad.Trans.Class+ failWithCustom :: ()   => H.MonadTest m   => CallStack@@ -15,3 +24,16 @@   -> m a failWithCustom cs mdiff msg =   H.liftTest $ H.mkTest (Left $ H.Failure (H.getCaller cs) msg mdiff, mempty)+class Monad m => MonadAssertion m where+  throwAssertion :: H.Failure -> m a+  catchAssertion :: m a -> (H.Failure -> m a) -> m a++instance Monad m => MonadAssertion (H.TestT m) where+  throwAssertion f = H.liftTest $ H.mkTest (Left f, mempty)+  catchAssertion g h = H.TestT $ E.catchE (H.unTest g) (H.unTest . h)++instance MonadAssertion m => MonadAssertion (IO.ResourceT m) where+  throwAssertion = lift . throwAssertion+  catchAssertion r h = IO.ResourceT $ \i -> IO.unResourceT r i `catchAssertion` \e -> IO.unResourceT (h e) i++deriving instance Monad m => MonadAssertion (H.PropertyT m)

@@ -1,6 +1,6 @@ cabal-version:          3.4 name:                   hw-polysemy-version:                0.2.7.0+version:                0.2.8.0 synopsis:               Opinionated polysemy library description:            Opinionated polysemy library. license:                Apache-2.0@@ -45,6 +45,7 @@ common temporary                  { build-depends: temporary                                   < 1.4    } common text                       { build-depends: text                                        < 3      } common time                       { build-depends: time                                        < 2      }+common transformers               { build-depends: transformers                                < 0.7    } common unliftio                   { build-depends: unliftio                                    < 0.3    } common yaml                       { build-depends: yaml                                        < 0.12   } @@ -169,7 +170,10 @@                         polysemy-time,                         polysemy,                         process,+                        resourcet,                         text,+                        time,+                        transformers,                         yaml,   visibility:           public   exposed-modules:      HaskellWorks.Polysemy.Hedgehog