packages feed

effectful-zoo 0.0.2.0 → 0.0.3.0

raw patch · 77 files changed

+3455/−940 lines, 77 filesdep +amazonka-rdsdep +amazonka-secretsmanagerdep +base64-bytestringdep ~hw-preludedep ~tasty

Dependencies added: amazonka-rds, amazonka-secretsmanager, base64-bytestring, binary, directory, exceptions, filepath, http-conduit, lifted-base, process, stm, tasty-discover, temporary, testcontainers, ulid, uuid

Dependency ranges changed: hw-prelude, tasty

Files

components/amazonka/Effectful/Zoo/Amazonka/Api.hs view
@@ -3,7 +3,9 @@ module Effectful.Zoo.Amazonka.Api   ( module Effectful.Zoo.Amazonka.Api.Discover,     module Effectful.Zoo.Amazonka.Api.Log,+    module Effectful.Zoo.Amazonka.Api.Send,   ) where  import Effectful.Zoo.Amazonka.Api.Discover import Effectful.Zoo.Amazonka.Api.Log+import Effectful.Zoo.Amazonka.Api.Send
components/amazonka/Effectful/Zoo/Amazonka/Api/Run.hs view
@@ -4,14 +4,19 @@   ( runDataLogAwsLogEntryToLog,     runDataLogAwsLogEntryToLogWith,     runDataLogAwsLogEntryLocalToLogWith,+    runReaderAwsEnvDiscover,   ) where +import Amazonka qualified as AWS import Control.Monad.IO.Class import Data.ByteString.Builder qualified as B+import Data.Generics.Product.Any import Data.Text.Lazy qualified as LT import Data.Text.Lazy.Encoding qualified as LT import Data.Time.Clock qualified as IO import Effectful+import Effectful.Environment+import Effectful.Reader.Static import Effectful.Zoo.Amazonka.Api import Effectful.Zoo.Amazonka.Data import Effectful.Zoo.Core@@ -21,6 +26,8 @@ import Effectful.Zoo.Log.Data.LogMessage import Effectful.Zoo.Log.Data.Severity import HaskellWorks.Prelude+import Lens.Micro+import System.IO qualified as IO  runDataLogAwsLogEntryToLog :: forall a r. ()   => r <: DataLog (LogEntry (LogMessage Text))@@ -61,3 +68,26 @@         , time = now         , source = entry.callStack         }++runReaderAwsEnvDiscover :: forall a r. ()+  => r <: Environment+  => r <: IOE+  => Eff (Reader AwsEnv : r) a+  -> Eff r a+runReaderAwsEnvDiscover f = do+  logger' <- liftIO $ AWS.newLogger AWS.Debug IO.stdout++  mLocalStackHost <- lookupEnv "AWS_LOCALSTACK_HOST"+  mLocalStackPort <- lookupEnv "AWS_LOCALSTACK_PORT"++  mLocalStackEndpoint <- pure $ (,)+    <$> mLocalStackHost+    <*> mLocalStackPort++  discoveredAwsEnv <- liftIO $ AWS.newEnv AWS.discover++  awsEnv <- pure $ discoveredAwsEnv+    & the @"logger" .~ logger'+    & the @"overrides" %~ maybeSetEndpoint mLocalStackEndpoint++  runReader awsEnv f
components/blockfrost/Effectful/Zoo/Blockfrost/Api.hs view
@@ -339,10 +339,10 @@ import Data.Text import Effectful import Effectful.Dispatch.Dynamic-import Effectful.Error.Static import Effectful.Zoo.Blockfrost.Dynamic (Blockfrost, runBlockfrost) import Effectful.Zoo.Blockfrost.Dynamic qualified as BF import Effectful.Zoo.Core+import Effectful.Zoo.Error.Static import HaskellWorks.Prelude  -- Client@@ -507,15 +507,6 @@ getTxMetadataByLabelJSON            :: r <: Blockfrost => r <: Error BlockfrostError => Text -> Eff r [TxMetaJSON] getTxMetadataByLabelCBOR'           :: r <: Blockfrost => r <: Error BlockfrostError => Text -> Paged -> SortOrder -> Eff r [TxMetaCBOR] getTxMetadataByLabelCBOR            :: r <: Blockfrost => r <: Error BlockfrostError => Text -> Eff r [TxMetaCBOR]---fromEither :: forall e a r. ()-  => Show e-  => r <: Error e-  => Either e a-  -> Eff r a-fromEither =-  either throwError pure  -- Client getRoot                                     = fromEither =<< send do BF.GetRoot
components/blockfrost/Effectful/Zoo/Blockfrost/Dynamic.hs view
@@ -11,7 +11,7 @@ import Data.Maybe import Effectful import Effectful.Dispatch.Dynamic-import Effectful.Reader.Dynamic+import Effectful.Reader.Static import Effectful.Zoo.Core import HaskellWorks.Prelude
+ components/core/Effectful/Zoo/Aeson.hs view
@@ -0,0 +1,21 @@+module Effectful.Zoo.Aeson+  ( aesonDecode,+  ) where++import Data.Aeson (FromJSON)+import Data.Aeson qualified as Aeson+import Data.ByteString.Lazy qualified as LBS+import Effectful+import Effectful.Zoo.Core+import Effectful.Zoo.Error.Static+import HaskellWorks.Error.Types.JsonDecodeError+import HaskellWorks.Prelude++aesonDecode :: forall a r. ()+  => r <: Error JsonDecodeError+  => FromJSON a+  => LBS.ByteString+  -> Eff r a+aesonDecode bs =+  fromEither (Aeson.eitherDecode bs)+    & mapError newJsonDecodeError
components/core/Effectful/Zoo/Core.hs view
@@ -1,5 +1,6 @@ module Effectful.Zoo.Core-  ( type (<:)+  ( type (<:),+    type (<<:),   ) where -import           Effectful.Zoo.Core.Prim+import Effectful.Zoo.Prim
− components/core/Effectful/Zoo/Core/Error/Dynamic.hs 
@@ -1,100 +0,0 @@-module Effectful.Zoo.Core.Error.Dynamic-  ( Error,-    catch,-    catch_,-    throw,-    trap,-    trap_,--    catchWithCallStack,-    catchWithCallStack_,-    trapWithCallStack,-    trapWithCallStack_,-  ) where--import Effectful-import Effectful.Error.Dynamic (Error)-import Effectful.Error.Dynamic qualified as E-import Effectful.Zoo.Core-import HaskellWorks.Prelude--catchWithCallStack :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => Eff es a-  -> (CallStack -> e -> Eff es a)-  -> Eff es a-catchWithCallStack =-  E.catchError--catchWithCallStack_ :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => Eff es a-  -> (CallStack -> Eff es a)-  -> Eff es a-catchWithCallStack_ f h =-  catchWithCallStack @e f \cs _ -> h cs--trapWithCallStack :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => (CallStack -> e -> Eff es a)-  -> Eff es a-  -> Eff es a-trapWithCallStack =-  flip catchWithCallStack--trapWithCallStack_ :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => (CallStack -> Eff es a)-  -> Eff es a-  -> Eff es a-trapWithCallStack_ h =-  trapWithCallStack @e (const . h)--catch :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => Eff es a-  -> (e -> Eff es a)-  -> Eff es a-catch action handler =-  catchWithCallStack action (const handler)--catch_ :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => Eff es a-  -> Eff es a-  -> Eff es a-catch_ action handler =-  catch @e action (const handler)--throw :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => Show e-  => e-  -> Eff es a-throw =-  E.throwError--trap :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => (e -> Eff es a)-  -> Eff es a-  -> Eff es a-trap =-  flip catch--trap_ :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => Eff es a-  -> Eff es a-  -> Eff es a-trap_ handler =-  trap @e (const handler)
− components/core/Effectful/Zoo/Core/Error/Static.hs 
@@ -1,175 +0,0 @@-module Effectful.Zoo.Core.Error.Static-  ( Error,--    throw,--    catch,-    catch_,-    trap,-    trap_,--    catchWithCallStack,-    catchWithCallStack_,-    trapWithCallStack,-    trapWithCallStack_,--    catchIn,-    catchIn_,-    trapIn,-    trapIn_,--    catchWithCallStackIn,-    catchWithCallStackIn_,-    trapWithCallStackIn,-    trapWithCallStackIn_,-  ) where--import Effectful-import Effectful.Error.Static (Error)-import Effectful.Error.Static qualified as E-import Effectful.Zoo.Core-import HaskellWorks.Prelude--throw :: forall e r a. ()-  => HasCallStack-  => r <: Error e-  => Show e-  => e-  -> Eff r a-throw =-  E.throwError--catchWithCallStack :: forall e r a. ()-  => HasCallStack-  => Eff (Error e : r) a-  -> (CallStack -> e -> Eff r a)-  -> Eff r a-catchWithCallStack action handler =-  E.runError action-    & onLeftM (uncurry handler)--catchWithCallStack_ :: forall e r a. ()-  => HasCallStack-  => Eff (Error e : r) a-  -> (CallStack -> Eff r a)-  -> Eff r a-catchWithCallStack_ f h =-  catchWithCallStack @e f \cs _ -> h cs--trapWithCallStack :: forall e r a. ()-  => HasCallStack-  => (CallStack -> e -> Eff r a)-  -> Eff (Error e : r) a-  -> Eff r a-trapWithCallStack =-  flip catchWithCallStack--trapWithCallStack_ :: forall e r a. ()-  => HasCallStack-  => (CallStack -> Eff r a)-  -> Eff (Error e : r) a-  -> Eff r a-trapWithCallStack_ h =-  trapWithCallStack @e (const . h)--catch :: forall e r a. ()-  => Eff (Error e : r) a-  -> (e -> Eff r a)-  -> Eff r a-catch action handler =-  E.runError action-    & onLeftM (handler . snd)--catch_ :: forall e r a. ()-  => Eff (Error e : r) a-  -> Eff r a-  -> Eff r a-catch_ action handler =-  catch @e action (const handler)--trap :: forall e r a. ()-  => (e -> Eff r a)-  -> Eff (Error e : r) a-  -> Eff r a-trap =-  flip catch--trap_ :: forall e r a. ()-  => Eff r a-  -> Eff (Error e : r) a-  -> Eff r a-trap_ handler =-  trap @e (const handler)---catchWithCallStackIn :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => Eff es a-  -> (CallStack -> e -> Eff es a)-  -> Eff es a-catchWithCallStackIn =-  E.catchError--catchWithCallStackIn_ :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => Eff es a-  -> (CallStack -> Eff es a)-  -> Eff es a-catchWithCallStackIn_ f h =-  catchWithCallStackIn @e f \cs _ -> h cs--trapWithCallStackIn :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => (CallStack -> e -> Eff es a)-  -> Eff es a-  -> Eff es a-trapWithCallStackIn =-  flip catchWithCallStackIn--trapWithCallStackIn_ :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => (CallStack -> Eff es a)-  -> Eff es a-  -> Eff es a-trapWithCallStackIn_ h =-  trapWithCallStackIn @e (const . h)--catchIn :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => Eff es a-  -> (e -> Eff es a)-  -> Eff es a-catchIn action handler =-  catchWithCallStackIn action (const handler)--catchIn_ :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => Eff es a-  -> Eff es a-  -> Eff es a-catchIn_ action handler =-  catchIn @e action (const handler)--trapIn :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => (e -> Eff es a)-  -> Eff es a-  -> Eff es a-trapIn =-  flip catchIn--trapIn_ :: forall e es a. ()-  => HasCallStack-  => es <: Error e-  => Eff es a-  -> Eff es a-  -> Eff es a-trapIn_ handler =-  trapIn @e (const handler)
− components/core/Effectful/Zoo/Core/Exception.hs 
@@ -1,35 +0,0 @@-module Effectful.Zoo.Core.Exception-  ( Exception,-    catchIO,-    throwIO,-    trapIO,-  ) where--import Effectful-import Effectful.Exception (Exception)-import Effectful.Exception qualified as E-import HaskellWorks.Prelude--catchIO :: ()-  => E.Exception e-  => Eff es a-  -> (e -> Eff es a)-  -> Eff es a-catchIO =-  E.catch--throwIO :: ()-  => HasCallStack-  => E.Exception e-  => e-  -> Eff es a-throwIO =-  E.throwIO--trapIO-  :: E.Exception e-  => (e -> Eff es a)-  -> Eff es a-  -> Eff es a-trapIO =-  flip catchIO
− components/core/Effectful/Zoo/Core/Function.hs 
@@ -1,26 +0,0 @@-module Effectful.Zoo.Core.Function-  ( once,-  ) where--import Effectful-import Effectful.Concurrent-import Effectful.Concurrent.MVar-import Effectful.Zoo.Core.Prim-import HaskellWorks.Prelude--once :: ()-  => r <: Concurrent-  => Eff r a-  -> Eff r (Eff r a)-once f = do-  cache <- newMVar Nothing-  return $ do-    resultOrRunning <- takeMVar cache-    case resultOrRunning of-      Just result -> do-        putMVar cache (Just result)-        return result-      Nothing -> do-        result <- f-        putMVar cache (Just result)-        return result
− components/core/Effectful/Zoo/Core/Prim.hs 
@@ -1,7 +0,0 @@-module Effectful.Zoo.Core.Prim-  ( type (<:)-  ) where--import           Effectful ((:>))--type (<:) r e = (:>) e r
components/core/Effectful/Zoo/DataLog/Api.hs view
@@ -1,14 +1,25 @@ module Effectful.Zoo.DataLog.Api   ( dataLog,+    logEntryToJson,+    logMessageToJson,+    putJsonStdout,   ) where +import Data.Aeson (Value, object, (.=))+import Data.Aeson qualified as J+import Data.ByteString.Lazy qualified as LBS import Effectful import Effectful.Dispatch.Dynamic+import Effectful.Dispatch.Static import Effectful.Zoo.Core+import Effectful.Zoo.DataLog.Data.LogEntry import Effectful.Zoo.DataLog.Dynamic+import Effectful.Zoo.Log.Data.LogMessage+import GHC.Stack qualified as GHC import HaskellWorks.Prelude+import System.IO qualified as IO -dataLog :: ()+dataLog :: forall i r. ()   => HasCallStack   => r <: DataLog i   => i@@ -16,3 +27,41 @@ dataLog i =   withFrozenCallStack do     send $ DataLog i++logEntryToJson :: forall a. ()+  => (a -> Value)+  -> LogEntry a+  -> Value+logEntryToJson aToJson (LogEntry value time callstack) =+    object+      [ "time" .= time+      , "data" .= aToJson value+      , "callstack" .= fmap callsiteToJson (GHC.getCallStack callstack)+      ]+    where+      callsiteToJson :: ([Char], GHC.SrcLoc) -> Value+      callsiteToJson (caller, srcLoc) =+        object+          [ "caller"    .= caller+          , "package"   .= GHC.srcLocPackage srcLoc+          , "module"    .= GHC.srcLocModule srcLoc+          , "file"      .= GHC.srcLocFile srcLoc+          , "startLine" .= GHC.srcLocStartLine srcLoc+          , "startCol"  .= GHC.srcLocStartCol srcLoc+          , "endLine"   .= GHC.srcLocEndLine srcLoc+          , "endCol"    .= GHC.srcLocEndCol srcLoc+          ]++logMessageToJson :: LogMessage Text -> Value+logMessageToJson (LogMessage severity message) =+    object+      [ "severity" .= show severity+      , "message"  .= message+      ]++putJsonStdout :: ()+  => Value+  -> Eff r ()+putJsonStdout value = do+  unsafeEff_ $ LBS.putStr $ J.encode value <> "\n"+  unsafeEff_ $ IO.hFlush IO.stdout
+ components/core/Effectful/Zoo/Environment.hs view
@@ -0,0 +1,88 @@+module Effectful.Zoo.Environment+  ( -- * Effect+    Environment,++    -- ** Handlers+    E.runEnvironment,++    -- * Querying the environment+    E.getArgs,+    E.getProgName,+    E.getExecutablePath,+    E.getEnv,+    E.getEnvironment,+    lookupEnv,+    lookupEnvMaybe,+    lookupMapEnv,+    lookupParseMaybeEnv,+    lookupParseEitherEnv,++    -- * Modifying the environment+    E.setEnv,+    E.unsetEnv,+    E.withArgs,+    E.withProgName,+  )+  where++import Data.Text qualified as T+import Effectful+import Effectful.Environment (Environment)+import Effectful.Environment qualified as E+import Effectful.Zoo.Core+import Effectful.Zoo.Error.Static+import Effectful.Zoo.Errors.EnvironmentVariableInvalid+import Effectful.Zoo.Errors.EnvironmentVariableMissing+import HaskellWorks.Prelude++lookupEnv :: ()+  => r <: Environment+  => r <: Error EnvironmentVariableMissing+  => Text+  -> Eff r Text+lookupEnv envName =+  lookupEnvMaybe envName+    & onNothingM (throw $ EnvironmentVariableMissing envName)++lookupMapEnv :: ()+  => r <: Environment+  => r <: Error EnvironmentVariableMissing+  => Text+  -> (Text -> a)+  -> Eff r a+lookupMapEnv envName f =+  f <$> lookupEnv envName++lookupParseMaybeEnv :: ()+  => r <: Environment+  => r <: Error EnvironmentVariableInvalid+  => r <: Error EnvironmentVariableMissing+  => Text+  -> (Text -> Maybe a)+  -> Eff r a+lookupParseMaybeEnv envName parse = do+  text <- lookupEnv envName++  parse text+    & onNothing (throw $ EnvironmentVariableInvalid envName text Nothing)++lookupParseEitherEnv :: ()+  => r <: Environment+  => r <: Error EnvironmentVariableInvalid+  => r <: Error EnvironmentVariableMissing+  => Text+  -> (Text -> Either Text a)+  -> Eff r a+lookupParseEitherEnv envName parse = do+  text <- lookupEnv envName++  parse text+    & onLeft (throw . EnvironmentVariableInvalid envName text . Just)++lookupEnvMaybe :: ()+  => r <: Environment+  => Text+  -> Eff r (Maybe Text)+lookupEnvMaybe envName = do+  value <- E.lookupEnv $ T.unpack envName+  pure $ T.pack <$> value
+ components/core/Effectful/Zoo/Error/Dynamic.hs view
@@ -0,0 +1,212 @@+module Effectful.Zoo.Error.Dynamic+  ( Error,++    throw,++    catch,+    catch_,+    trap,+    trap_,++    catchWithCallStack,+    catchWithCallStack_,+    trapWithCallStack,+    trapWithCallStack_,++    catchIn,+    catchIn_,+    trapIn,+    trapIn_,++    catchWithCallStackIn,+    catchWithCallStackIn_,+    trapWithCallStackIn,+    trapWithCallStackIn_,++    fromEither,+    mapError,+    runError,+    runError_,+    runErrorMap_,+  ) where++import Effectful+import Effectful.Error.Dynamic (Error, runError)+import Effectful.Error.Dynamic qualified as E+import Effectful.Zoo.Core+import HaskellWorks.Prelude++throw :: forall e r a. ()+  => HasCallStack+  => r <: Error e+  => Show e+  => e+  -> Eff r a+throw =+  E.throwError++catchWithCallStack :: forall e r a. ()+  => HasCallStack+  => Eff (Error e : r) a+  -> (CallStack -> e -> Eff r a)+  -> Eff r a+catchWithCallStack action handler =+  E.runError action+    & onLeftM (uncurry handler)++catchWithCallStack_ :: forall e r a. ()+  => HasCallStack+  => Eff (Error e : r) a+  -> (CallStack -> Eff r a)+  -> Eff r a+catchWithCallStack_ f h =+  catchWithCallStack @e f \cs _ -> h cs++trapWithCallStack :: forall e r a. ()+  => HasCallStack+  => (CallStack -> e -> Eff r a)+  -> Eff (Error e : r) a+  -> Eff r a+trapWithCallStack =+  flip catchWithCallStack++trapWithCallStack_ :: forall e r a. ()+  => HasCallStack+  => (CallStack -> Eff r a)+  -> Eff (Error e : r) a+  -> Eff r a+trapWithCallStack_ h =+  trapWithCallStack @e (const . h)++catch :: forall e r a. ()+  => Eff (Error e : r) a+  -> (e -> Eff r a)+  -> Eff r a+catch action handler =+  E.runError action+    & onLeftM (handler . snd)++catch_ :: forall e r a. ()+  => Eff (Error e : r) a+  -> Eff r a+  -> Eff r a+catch_ action handler =+  catch @e action (const handler)++trap :: forall e r a. ()+  => (e -> Eff r a)+  -> Eff (Error e : r) a+  -> Eff r a+trap =+  flip catch++trap_ :: forall e r a. ()+  => Eff r a+  -> Eff (Error e : r) a+  -> Eff r a+trap_ handler =+  trap @e (const handler)++catchWithCallStackIn :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => Eff es a+  -> (CallStack -> e -> Eff es a)+  -> Eff es a+catchWithCallStackIn =+  E.catchError++catchWithCallStackIn_ :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => Eff es a+  -> (CallStack -> Eff es a)+  -> Eff es a+catchWithCallStackIn_ f h =+  catchWithCallStackIn @e f \cs _ -> h cs++trapWithCallStackIn :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => (CallStack -> e -> Eff es a)+  -> Eff es a+  -> Eff es a+trapWithCallStackIn =+  flip catchWithCallStackIn++trapWithCallStackIn_ :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => (CallStack -> Eff es a)+  -> Eff es a+  -> Eff es a+trapWithCallStackIn_ h =+  trapWithCallStackIn @e (const . h)++catchIn :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => Eff es a+  -> (e -> Eff es a)+  -> Eff es a+catchIn action handler =+  catchWithCallStackIn action (const handler)++catchIn_ :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => Eff es a+  -> Eff es a+  -> Eff es a+catchIn_ action handler =+  catchIn @e action (const handler)++trapIn :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => (e -> Eff es a)+  -> Eff es a+  -> Eff es a+trapIn =+  flip catchIn++trapIn_ :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => Eff es a+  -> Eff es a+  -> Eff es a+trapIn_ handler =+  trapIn @e (const handler)++fromEither :: forall e a r. ()+  => Show e+  => r <: Error e+  => Either e a+  -> Eff r a+fromEither =+  either throw pure++mapError :: forall d e a r. ()+  => HasCallStack+  => r <: Error e+  => Show e+  => (d -> e)+  -> Eff (Error d : r) a+  -> Eff r a+mapError f g =+  g & trap (throw . f)++runError_ :: ()+  => Eff (Error e : r) a+  -> Eff r (Either e a)+runError_ =+  fmap (first snd) . runError++-- | Run an 'Error' effect and map the error value to a different type.+runErrorMap_ :: ()+  => (e -> d)+  -> Eff (Error e : r) a+  -> Eff r (Either d a)+runErrorMap_ f =+  fmap (first (f . snd)) . runError
+ components/core/Effectful/Zoo/Error/Static.hs view
@@ -0,0 +1,212 @@+module Effectful.Zoo.Error.Static+  ( Error,++    throw,++    catch,+    catch_,+    trap,+    trap_,++    catchWithCallStack,+    catchWithCallStack_,+    trapWithCallStack,+    trapWithCallStack_,++    catchIn,+    catchIn_,+    trapIn,+    trapIn_,++    catchWithCallStackIn,+    catchWithCallStackIn_,+    trapWithCallStackIn,+    trapWithCallStackIn_,++    fromEither,+    mapError,+    runError,+    runError_,+    runErrorMap_,+  ) where++import Effectful+import Effectful.Error.Static (Error, runError)+import Effectful.Error.Static qualified as E+import Effectful.Zoo.Prim+import HaskellWorks.Prelude++throw :: forall e r a. ()+  => HasCallStack+  => r <: Error e+  => Show e+  => e+  -> Eff r a+throw =+  E.throwError++catchWithCallStack :: forall e r a. ()+  => HasCallStack+  => Eff (Error e : r) a+  -> (CallStack -> e -> Eff r a)+  -> Eff r a+catchWithCallStack action handler =+  E.runError action+    & onLeftM (uncurry handler)++catchWithCallStack_ :: forall e r a. ()+  => HasCallStack+  => Eff (Error e : r) a+  -> (CallStack -> Eff r a)+  -> Eff r a+catchWithCallStack_ f h =+  catchWithCallStack @e f \cs _ -> h cs++trapWithCallStack :: forall e r a. ()+  => HasCallStack+  => (CallStack -> e -> Eff r a)+  -> Eff (Error e : r) a+  -> Eff r a+trapWithCallStack =+  flip catchWithCallStack++trapWithCallStack_ :: forall e r a. ()+  => HasCallStack+  => (CallStack -> Eff r a)+  -> Eff (Error e : r) a+  -> Eff r a+trapWithCallStack_ h =+  trapWithCallStack @e (const . h)++catch :: forall e r a. ()+  => Eff (Error e : r) a+  -> (e -> Eff r a)+  -> Eff r a+catch action handler =+  E.runError action+    & onLeftM (handler . snd)++catch_ :: forall e r a. ()+  => Eff (Error e : r) a+  -> Eff r a+  -> Eff r a+catch_ action handler =+  catch @e action (const handler)++trap :: forall e r a. ()+  => (e -> Eff r a)+  -> Eff (Error e : r) a+  -> Eff r a+trap =+  flip catch++trap_ :: forall e r a. ()+  => Eff r a+  -> Eff (Error e : r) a+  -> Eff r a+trap_ handler =+  trap @e (const handler)++catchWithCallStackIn :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => Eff es a+  -> (CallStack -> e -> Eff es a)+  -> Eff es a+catchWithCallStackIn =+  E.catchError++catchWithCallStackIn_ :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => Eff es a+  -> (CallStack -> Eff es a)+  -> Eff es a+catchWithCallStackIn_ f h =+  catchWithCallStackIn @e f \cs _ -> h cs++trapWithCallStackIn :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => (CallStack -> e -> Eff es a)+  -> Eff es a+  -> Eff es a+trapWithCallStackIn =+  flip catchWithCallStackIn++trapWithCallStackIn_ :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => (CallStack -> Eff es a)+  -> Eff es a+  -> Eff es a+trapWithCallStackIn_ h =+  trapWithCallStackIn @e (const . h)++catchIn :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => Eff es a+  -> (e -> Eff es a)+  -> Eff es a+catchIn action handler =+  catchWithCallStackIn action (const handler)++catchIn_ :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => Eff es a+  -> Eff es a+  -> Eff es a+catchIn_ action handler =+  catchIn @e action (const handler)++trapIn :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => (e -> Eff es a)+  -> Eff es a+  -> Eff es a+trapIn =+  flip catchIn++trapIn_ :: forall e es a. ()+  => HasCallStack+  => es <: Error e+  => Eff es a+  -> Eff es a+  -> Eff es a+trapIn_ handler =+  trapIn @e (const handler)++fromEither :: forall e a r. ()+  => Show e+  => r <: Error e+  => Either e a+  -> Eff r a+fromEither =+  either throw pure++mapError :: forall d e a r. ()+  => HasCallStack+  => r <: Error e+  => Show e+  => (d -> e)+  -> Eff (Error d : r) a+  -> Eff r a+mapError f g =+  g & trap (throw . f)++runError_ :: ()+  => Eff (Error e : r) a+  -> Eff r (Either e a)+runError_ =+  fmap (first snd) . runError++-- | Run an 'Error' effect and map the error value to a different type.+runErrorMap_ :: ()+  => (e -> d)+  -> Eff (Error e : r) a+  -> Eff r (Either d a)+runErrorMap_ f =+  fmap (first (f . snd)) . runError
+ components/core/Effectful/Zoo/Errors/EnvironmentVariableInvalid.hs view
@@ -0,0 +1,24 @@+module Effectful.Zoo.Errors.EnvironmentVariableInvalid+  ( EnvironmentVariableInvalid (..),+  ) where++import Data.Aeson (ToJSON (..), (.=))+import Data.Aeson qualified as J+import GHC.Generics+import HaskellWorks.Prelude++data EnvironmentVariableInvalid = EnvironmentVariableInvalid+    { variable :: Text+    , text :: Text+    , reason :: Maybe Text+    }+    deriving stock (Eq, Show, Generic)++instance ToJSON EnvironmentVariableInvalid where+    toJSON e =+        J.object+            [ "error" .= id @Text "EnvironmentVariableInvalid"+            , "variable" .= e.variable+            , "text" .= e.text+            , "reason" .= e.reason+            ]
+ components/core/Effectful/Zoo/Errors/EnvironmentVariableMissing.hs view
@@ -0,0 +1,20 @@+module Effectful.Zoo.Errors.EnvironmentVariableMissing+  ( EnvironmentVariableMissing (..),+  ) where++import Data.Aeson (ToJSON (..), (.=))+import Data.Aeson qualified as J+import GHC.Generics+import HaskellWorks.Prelude++newtype EnvironmentVariableMissing = EnvironmentVariableMissing+    { variable :: Text+    }+    deriving stock (Eq, Show, Generic)++instance ToJSON EnvironmentVariableMissing where+    toJSON e =+        J.object+            [ "error" .= id @Text "EnvironmentVariableMissing"+            , "variable" .= e.variable+            ]
+ components/core/Effectful/Zoo/Exception.hs view
@@ -0,0 +1,35 @@+module Effectful.Zoo.Exception+  ( Exception,+    catchIO,+    throwIO,+    trapIO,+  ) where++import Effectful+import Effectful.Exception (Exception)+import Effectful.Exception qualified as E+import HaskellWorks.Prelude++catchIO :: ()+  => E.Exception e+  => Eff es a+  -> (e -> Eff es a)+  -> Eff es a+catchIO =+  E.catch++throwIO :: ()+  => HasCallStack+  => E.Exception e+  => e+  -> Eff es a+throwIO =+  E.throwIO++trapIO+  :: E.Exception e+  => (e -> Eff es a)+  -> Eff es a+  -> Eff es a+trapIO =+  flip catchIO
components/core/Effectful/Zoo/FileSystem.hs view
@@ -4,8 +4,20 @@     YamlDecodeError(..),     readByteStringFile,     readLazyByteStringFile,+    readStringFile,     readJsonFile,     readYamlFile,+    writeStringFile,+    getCanonicalTemporaryDirectory,+    createTempDirectory,+    removePathForcibly,+    doesFileExist,+    doesDirectoryExist,++    runFileSystem,++    getCurrentDirectory,+    canonicalizePath,   ) where  import Data.Aeson (FromJSON)@@ -16,17 +28,32 @@ import Data.Yaml qualified as Y import Effectful import Effectful.Dispatch.Static-import Effectful.FileSystem+import Effectful.FileSystem (FileSystem, runFileSystem) import Effectful.Zoo.Core-import Effectful.Zoo.Core.Error.Static-import Effectful.Zoo.Core.Exception+import Effectful.Zoo.Error.Static+import Effectful.Zoo.Exception import Effectful.Zoo.Log.Api.Text import Effectful.Zoo.Log.Dynamic import Effectful.Zoo.Unsafe import HaskellWorks.Error.Types.JsonDecodeError import HaskellWorks.Error.Types.YamlDecodeError import HaskellWorks.Prelude+import System.Directory qualified as D+import System.IO qualified as IO+import System.IO.Temp qualified as IO +readStringFile :: ()+  => HasCallStack+  => r <: Error IOException+  => r <: FileSystem+  => r <: Log Text+  => FilePath+  -> Eff r String+readStringFile filePath = withFrozenCallStack do+  info $ "Reading bytestring from file: " <> T.pack filePath+  unsafeFileSystemEff_ (IO.readFile filePath)+    & trapIO @IOException throw+ readLazyByteStringFile :: ()   => HasCallStack   => r <: Error IOException@@ -34,7 +61,7 @@   => r <: Log Text   => FilePath   -> Eff r LBS.ByteString-readLazyByteStringFile filePath = withFrozenCallStack $ do+readLazyByteStringFile filePath = withFrozenCallStack do   info $ "Reading bytestring from file: " <> T.pack filePath   unsafeFileSystemEff_ (LBS.readFile filePath)     & trapIO @IOException throw@@ -46,7 +73,7 @@   => r <: Log Text   => FilePath   -> Eff r ByteString-readByteStringFile filePath = withFrozenCallStack $ do+readByteStringFile filePath = withFrozenCallStack do   info $ "Reading bytestring from file: " <> T.pack filePath   unsafeFileSystemEff_ (BS.readFile filePath)     & trapIO @IOException throw@@ -61,7 +88,7 @@   => r <: Log Text   => FilePath   -> Eff r a-readJsonFile filePath = withFrozenCallStack $ do+readJsonFile filePath = withFrozenCallStack do   info $ "Reading JSON file: " <> T.pack filePath   contents <- readLazyByteStringFile filePath   J.eitherDecode contents@@ -77,8 +104,103 @@   => r <: Log Text   => FilePath   -> Eff r a-readYamlFile filePath = withFrozenCallStack $ do+readYamlFile filePath = withFrozenCallStack do   info $ "Reading YAML file: " <> T.pack filePath   contents <- LBS.toStrict <$> readLazyByteStringFile filePath   Y.decodeEither' contents     & onLeft (throw . YamlDecodeError . T.pack . Y.prettyPrintParseException)++writeStringFile :: ()+  => HasCallStack+  => r <: Error IOException+  => r <: FileSystem+  => r <: Log Text+  => FilePath+  -> String+  -> Eff r ()+writeStringFile filePath contents = withFrozenCallStack do+  info $ "Writing string to file: " <> T.pack filePath+  unsafeFileSystemEff_ (IO.writeFile filePath contents)+    & trapIO @IOException throw++getCanonicalTemporaryDirectory :: ()+  => HasCallStack+  => r <: Error IOException+  => r <: FileSystem+  => Eff r FilePath+getCanonicalTemporaryDirectory = withFrozenCallStack do+  unsafeFileSystemEff_ IO.getCanonicalTemporaryDirectory+    & trapIO @IOException throw+{-# INLINE getCanonicalTemporaryDirectory #-}++createTempDirectory :: ()+  => HasCallStack+  => r <: Error IOException+  => r <: FileSystem+  => FilePath+  -> String+  -> Eff r FilePath+createTempDirectory fp template = withFrozenCallStack do+  unsafeFileSystemEff_ (IO.createTempDirectory fp template)+    & trapIO @IOException throw+{-# INLINE createTempDirectory #-}++removePathForcibly :: ()+  => HasCallStack+  => r <: Error IOException+  => r <: FileSystem+  => r <: Log Text+  => FilePath+  -> Eff r ()+removePathForcibly fp = withFrozenCallStack $ do+  info $ "Calling: removePathForcibly " <> tshow fp++  unsafeFileSystemEff_ (D.removePathForcibly fp)+    & trapIO @IOException throw++doesFileExist :: ()+  => HasCallStack+  => r <: Error IOException+  => r <: FileSystem+  => r <: Log Text+  => FilePath+  -> Eff r Bool+doesFileExist fp = withFrozenCallStack $ do+  info "Calling: doesFileExist"++  unsafeFileSystemEff_ (D.doesFileExist fp)+    & trapIO @IOException throw++doesDirectoryExist :: ()+  => HasCallStack+  => r <: Error IOException+  => r <: FileSystem+  => r <: Log Text+  => FilePath+  -> Eff r Bool+doesDirectoryExist fp = withFrozenCallStack $ do+  info "Calling: doesDirectoryExist"++  unsafeFileSystemEff_ (D.doesDirectoryExist fp)+    & trapIO @IOException throw++getCurrentDirectory :: ()+  => HasCallStack+  => r <: Error IOException+  => r <: FileSystem+  => Eff r FilePath+getCurrentDirectory = withFrozenCallStack do+  unsafeFileSystemEff_ D.getCurrentDirectory+    & trapIO @IOException throw+{-# INLINE getCurrentDirectory #-}++canonicalizePath :: ()+  => HasCallStack+  => r <: Error IOException+  => r <: FileSystem+  => FilePath+  -> Eff r FilePath+canonicalizePath fp = withFrozenCallStack do+  unsafeFileSystemEff_ (D.canonicalizePath fp)+    & trapIO @IOException throw+{-# INLINE canonicalizePath #-}
+ components/core/Effectful/Zoo/Function.hs view
@@ -0,0 +1,26 @@+module Effectful.Zoo.Function+  ( once,+  ) where++import Effectful+import Effectful.Concurrent+import Effectful.Concurrent.MVar+import Effectful.Zoo.Prim+import HaskellWorks.Prelude++once :: ()+  => r <: Concurrent+  => Eff r a+  -> Eff r (Eff r a)+once f = do+  cache <- newMVar Nothing+  return $ do+    resultOrRunning <- takeMVar cache+    case resultOrRunning of+      Just result -> do+        putMVar cache (Just result)+        return result+      Nothing -> do+        result <- f+        putMVar cache (Just result)+        return result
components/core/Effectful/Zoo/Log/Api/Generic.hs view
@@ -11,6 +11,7 @@ import Effectful import Effectful.Dispatch.Dynamic import Effectful.Zoo.Core+import Effectful.Zoo.Log.Data.LogMessage import Effectful.Zoo.Log.Data.Severity import Effectful.Zoo.Log.Dynamic import HaskellWorks.Prelude@@ -23,7 +24,7 @@   -> Eff r () log severity message =   withFrozenCallStack $-    send (Log severity message)+    send (Log (LogMessage severity message))  trace :: ()   => HasCallStack
components/core/Effectful/Zoo/Log/Api/LazyText.hs view
@@ -11,6 +11,7 @@ import Effectful import Effectful.Dispatch.Dynamic import Effectful.Zoo.Core+import Effectful.Zoo.Log.Data.LogMessage import Effectful.Zoo.Log.Data.Severity import Effectful.Zoo.Log.Dynamic import HaskellWorks.Prelude@@ -23,7 +24,7 @@   -> Eff r () log severity message =   withFrozenCallStack $-    send (Log severity message)+    send (Log (LogMessage severity message))  trace :: ()   => HasCallStack
components/core/Effectful/Zoo/Log/Api/String.hs view
@@ -11,6 +11,7 @@ import Effectful import Effectful.Dispatch.Dynamic import Effectful.Zoo.Core+import Effectful.Zoo.Log.Data.LogMessage import Effectful.Zoo.Log.Data.Severity import Effectful.Zoo.Log.Dynamic import HaskellWorks.Prelude@@ -23,7 +24,7 @@   -> Eff r () log severity message =   withFrozenCallStack $-    send (Log severity message)+    send (Log (LogMessage severity message))  trace :: ()   => HasCallStack
components/core/Effectful/Zoo/Log/Api/Text.hs view
@@ -12,6 +12,7 @@ import Effectful.Dispatch.Dynamic import Effectful.Zoo.Core import Effectful.Zoo.Log.Data.Severity+import Effectful.Zoo.Log.Data.LogMessage import Effectful.Zoo.Log.Dynamic import HaskellWorks.Prelude @@ -23,7 +24,7 @@   -> Eff r () log severity message =   withFrozenCallStack $-    send (Log severity message)+    send (Log (LogMessage severity message))  trace :: ()   => HasCallStack
components/core/Effectful/Zoo/Log/Data/LogMessage.hs view
@@ -8,4 +8,4 @@   { severity :: !Severity   , message :: i   }-  deriving stock (Eq, Generic, Show)+  deriving stock (Eq, Functor, Generic, Show)
components/core/Effectful/Zoo/Log/Data/Logger.hs view
@@ -5,21 +5,22 @@  import Effectful import Effectful.Zoo.Core-import Effectful.Zoo.Log.Data.Severity+import Effectful.Zoo.Log.Data.LogMessage import HaskellWorks.Prelude  newtype Logger i = Logger-  { run :: CallStack -> Severity -> i -> IO ()+  { run :: CallStack -> LogMessage i -> IO ()   } deriving stock Generic  instance Contravariant Logger where-  contramap f (Logger g) = Logger \cs severity -> g cs severity . f+  contramap f (Logger g) =+    Logger \cs m -> g cs (fmap f m)  mkLogger :: ()   => r <: IOE   => UnliftStrategy-  -> (CallStack -> Severity -> i -> Eff r ())+  -> (CallStack -> LogMessage i -> Eff r ())   -> Eff r (Logger i) mkLogger strategy run =   withEffToIO strategy $ \effToIO ->-    pure $ Logger $ \cs severity i -> effToIO $ run cs severity i+    pure $ Logger $ \cs m -> effToIO $ run cs m
components/core/Effectful/Zoo/Log/Dynamic.hs view
@@ -6,15 +6,14 @@ import Effectful import Effectful.Dispatch.Dynamic import Effectful.Zoo.Core-import Effectful.Zoo.Log.Data.Severity+import Effectful.Zoo.Log.Data.LogMessage import Effectful.Zoo.Log.Static qualified as S import HaskellWorks.Prelude  data Log i :: Effect where   Log     :: HasCallStack-    => Severity-    -> i+    => LogMessage i     -> Log i m ()    Local@@ -24,13 +23,13 @@  type instance DispatchOf (Log a) = Dynamic -runLog :: ()+runLog :: forall i a r. ()   => r <: IOE   => UnliftStrategy-  -> (CallStack -> Severity -> i -> Eff r ())+  -> (CallStack -> LogMessage i -> Eff r ())   -> Eff (Log i : r) a   -> Eff r a runLog s run =   reinterpret (S.runLog s run) $ \env -> \case-    Log severity i -> S.log severity i+    Log m -> S.log m     Local f m -> localSeqUnlift env $ \unlift -> S.local f (unlift m)
components/core/Effectful/Zoo/Log/Static.hs view
@@ -15,7 +15,7 @@ import Effectful.Dispatch.Static import Effectful.Zoo.Core import Effectful.Zoo.Log.Data.Logger-import Effectful.Zoo.Log.Data.Severity+import Effectful.Zoo.Log.Data.LogMessage import GHC.Stack qualified as GHC import HaskellWorks.Prelude import System.IO qualified as IO@@ -30,7 +30,7 @@   => r <: IOE   => HasCallStack   => UnliftStrategy-  -> (CallStack -> Severity -> i -> Eff r ())+  -> (CallStack -> LogMessage i -> Eff r ())   -> Eff (Log i : r) a   -> Eff r a runLog strategy run f = do@@ -40,16 +40,16 @@ runLogToHandle :: ()   => HasCallStack   => Handle-  -> (Severity -> a -> Text)+  -> (LogMessage a -> Text)   -> Eff (Log a : r) a   -> Eff r a runLogToHandle h f =-  evalStaticRep $ Log $ Logger $ \_ severity i ->-    T.hPutStrLn h $ f severity i+  evalStaticRep $ Log $ Logger $ \_ m ->+    T.hPutStrLn h $ f m  runLogToStdout :: ()   => HasCallStack-  => (Severity -> a -> Text)+  => (LogMessage a -> Text)   -> Eff (Log a : r) a   -> Eff r a runLogToStdout =@@ -57,7 +57,7 @@  runLogToStderr :: ()   => HasCallStack-  => (Severity -> a -> Text)+  => (LogMessage a -> Text)   -> Eff (Log a : r) a   -> Eff r a runLogToStderr =@@ -93,13 +93,12 @@   => HasCallStack   => r <: Log i   => r <: IOE-  => Severity-  -> i+  => LogMessage i   -> Eff r ()-log severity i =+log m =   withFrozenCallStack do     dataLogger <- getDataLogger-    liftIO $ dataLogger.run GHC.callStack severity i+    liftIO $ dataLogger.run GHC.callStack m  local :: ()   => HasCallStack
+ components/core/Effectful/Zoo/Prim.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-}++module Effectful.Zoo.Prim+  ( type (<:),+    type (<<:)+  ) where++import           Effectful ((:>), (:>>))++type (<:) r e = (:>) e r++type (<<:) r e = (:>>) e r
+ components/core/Effectful/Zoo/Process.hs view
@@ -0,0 +1,273 @@+module Effectful.Zoo.Process+  ( IO.CreateProcess(..),+    IO.CmdSpec(..),+    IO.StdStream(..),+    Handle,+    ProcessHandle,+    ExitCode(..),+    FD,+    Pid,+    createProcess,+    createProcess_,+    IO.shell,+    IO.proc,+    callProcess,+    callCommand,+    spawnProcess,+    spawnCommand,+    readCreateProcess,+    readProcess,+    readCreateProcessWithExitCode,+    readProcessWithExitCode,+    cleanupProcess,+    getPid,+    getCurrentPid,+    interruptProcessGroupOf,+    createPipe,+    createPipeFd,+    runProcess,+    runCommand,+    runInteractiveProcess,+    runInteractiveCommand,+    system,+    rawSystem,++    waitSecondsForProcess,+  ) where++import Control.Exception qualified as CE+import HaskellWorks.Error+import HaskellWorks.Error.Types+import HaskellWorks.IO.Process qualified as IO+import HaskellWorks.Prelude+import Effectful+import Effectful.Zoo.Core+import Effectful.Zoo.Error.Static+import System.Exit (ExitCode (..))+import System.Posix.Internals (FD)+import System.Process (Pid, ProcessHandle)+import System.Process qualified as IO++createProcess :: ()+  => r <: Error IOException+  => r <: IOE+  => IO.CreateProcess+  -> Eff r (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)+createProcess cp = do+  r <- liftIO $ CE.try @IOException $ IO.createProcess cp+  fromEither r++createProcess_ :: ()+  => r <: Error IOException+  => r <: IOE+  => String+  -> IO.CreateProcess+  -> Eff r (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)+createProcess_ cmd cp = do+  r <- liftIO $ CE.try @IOException $ IO.createProcess_ cmd cp+  fromEither r++callProcess :: ()+  => r <: Error IOException+  => r <: IOE+  => String+  -> [String]+  -> Eff r ()+callProcess cmd args = do+  r <- liftIO $ CE.try @IOException $ IO.callProcess cmd args+  fromEither r++callCommand :: ()+  => r <: Error IOException+  => r <: IOE+  => String+  -> Eff r ()+callCommand cmd = do+  r <- liftIO $ CE.try @IOException $ IO.callCommand cmd+  fromEither r++spawnProcess :: ()+  => r <: Error IOException+  => r <: IOE+  => String+  -> [String]+  -> Eff r ProcessHandle+spawnProcess cmd args = do+  r <- liftIO $ CE.try @IOException $ IO.spawnProcess cmd args+  fromEither r++spawnCommand :: ()+  => r <: Error IOException+  => r <: IOE+  => String+  -> Eff r ProcessHandle+spawnCommand cmd = do+  r <- liftIO $ CE.try @IOException $ IO.spawnCommand cmd+  fromEither r++readCreateProcess :: ()+  => r <: Error IOException+  => r <: IOE+  => IO.CreateProcess+  -> String+  -> Eff r String+readCreateProcess cp input = do+  r <- liftIO $ CE.try @IOException $ IO.readCreateProcess cp input+  fromEither r++readProcess :: ()+  => r <: Error IOException+  => r <: IOE+  => String+  -> [String]+  -> String+  -> Eff r String+readProcess cmd args input = do+  r <- liftIO $ CE.try @IOException $ IO.readProcess cmd args input+  fromEither r++readCreateProcessWithExitCode :: ()+  => r <: Error IOException+  => r <: IOE+  => IO.CreateProcess+  -> String+  -> Eff r (ExitCode, String, String)+readCreateProcessWithExitCode cp input = do+  r <- liftIO $ CE.try @IOException $ IO.readCreateProcessWithExitCode cp input+  fromEither r++readProcessWithExitCode :: ()+  => r <: Error IOException+  => r <: IOE+  => String+  -> [String]+  -> String+  -> Eff r (ExitCode, String, String)+readProcessWithExitCode cmd args input = do+  r <- liftIO $ CE.try @IOException $ IO.readProcessWithExitCode cmd args input+  fromEither r++cleanupProcess :: ()+  => r <: Error IOException+  => r <: IOE+  => (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)+  -> Eff r ()+cleanupProcess (mIn, mOut, mErr, ph) = do+  r <- liftIO $ CE.try @IOException $ IO.cleanupProcess (mIn, mOut, mErr, ph)+  fromEither r++getPid :: ()+  => r <: Error IOException+  => r <: IOE+  => ProcessHandle+  -> Eff r (Maybe Pid)+getPid ph = do+  r <- liftIO $ CE.try @IOException $ IO.getPid ph+  fromEither r++getCurrentPid :: ()+  => r <: Error IOException+  => r <: IOE+  => Eff r Pid+getCurrentPid = do+  r <- liftIO $ CE.try @IOException $ IO.getCurrentPid+  fromEither r++interruptProcessGroupOf :: ()+  => r <: Error IOException+  => r <: IOE+  => ProcessHandle+  -> Eff r ()+interruptProcessGroupOf ph = do+  r <- liftIO $ CE.try @IOException $ IO.interruptProcessGroupOf ph+  fromEither r++createPipe :: ()+  => r <: Error IOException+  => r <: IOE+  => Eff r (Handle, Handle)+createPipe = do+  r <- liftIO $ CE.try @IOException $ IO.createPipe+  fromEither r++createPipeFd :: ()+  => r <: Error IOException+  => r <: IOE+  => Eff r (FD, FD)+createPipeFd = do+  r <- liftIO $ CE.try @IOException $ IO.createPipeFd+  fromEither r++runProcess :: ()+  => r <: Error IOException+  => r <: IOE+  => FilePath+  -> [String]+  -> Maybe FilePath+  -> Maybe [(String, String)]+  -> Maybe Handle+  -> Maybe Handle+  -> Maybe Handle+  -> Eff r ProcessHandle+runProcess cmd args mbStdIn mbEnv mbCwd mbStdOut mbStdErr = do+  r <- liftIO $ CE.try @IOException $ IO.runProcess cmd args mbStdIn mbEnv mbCwd mbStdOut mbStdErr+  fromEither r++runCommand :: ()+  => r <: Error IOException+  => r <: IOE+  => String+  -> Eff r ProcessHandle+runCommand cmd = do+  r <- liftIO $ CE.try @IOException $ IO.runCommand cmd+  fromEither r++runInteractiveProcess :: ()+  => r <: Error IOException+  => r <: IOE+  => FilePath+  -> [String]+  -> Maybe FilePath+  -> Maybe [(String, String)]+  -> Eff r (Handle, Handle, Handle, ProcessHandle)+runInteractiveProcess cmd args mbCwd mbEnv = do+  r <- liftIO $ CE.try @IOException $ IO.runInteractiveProcess cmd args mbCwd mbEnv+  fromEither r++runInteractiveCommand :: ()+  => r <: Error IOException+  => r <: IOE+  => String+  -> Eff r (Handle, Handle, Handle, ProcessHandle)+runInteractiveCommand cmd = do+  r <- liftIO $ CE.try @IOException $ IO.runInteractiveCommand cmd+  fromEither r++system :: ()+  => r <: Error IOException+  => r <: IOE+  => String+  -> Eff r ExitCode+system cmd = do+  r <- liftIO $ CE.try @IOException $ IO.system cmd+  fromEither r++rawSystem :: ()+  => r <: Error IOException+  => r <: IOE+  => String+  -> [String]+  -> Eff r ExitCode+rawSystem cmd args = do+  r <- liftIO $ CE.try @IOException $ IO.rawSystem cmd args+  fromEither r++waitSecondsForProcess :: ()+  => r <: Error TimedOut+  => r <: IOE+  => Int+  -> ProcessHandle+  -> Eff r (Maybe ExitCode)+waitSecondsForProcess seconds hProcess =+  liftIO (IO.waitSecondsForProcess seconds hProcess)+    & onLeftM @TimedOut throw
+ components/core/Effectful/Zoo/Reader/Static.hs view
@@ -0,0 +1,21 @@+module Effectful.Zoo.Reader.Static+  ( Reader,+    ask,+    asks,+    local,+    runReader,++    runReaderM,+  ) where++import Effectful+import Effectful.Reader.Static+import HaskellWorks.Prelude++runReaderM ::+    forall i r a.+    Eff r i ->+    Eff (Reader i ': r) a ->+    Eff r a+runReaderM f action = do+  f >>= flip runReader action
+ components/core/Effectful/Zoo/Resource.hs view
@@ -0,0 +1,6 @@+module Effectful.Zoo.Resource+  ( Resource,+    runResource,+  ) where++import Effectful.Resource
− components/hedgehog-test/Effectful/Zoo/Hedgehog/Test/HedgehogTest.hs 
@@ -1,22 +0,0 @@-module Effectful.Zoo.Hedgehog.Test.HedgehogTest where--import Effectful-import Effectful.Zoo.Core-import Effectful.Zoo.Log.Dynamic-import Effectful.Zoo.Log.Api.Text-import Effectful.Zoo.Hedgehog-import HaskellWorks.Prelude--foo :: ()-  => HasCallStack-  => r <: Log Text-  => Eff r ()-foo =-  info "This is a log"--test_simple :: UnitTest-test_simple =-  hedgehog do-    jot_ "This is a jot"--    foo
+ components/hedgehog-test/Effectful/Zoo/Hedgehog/Test/PropertySpec.hs view
@@ -0,0 +1,23 @@+{- HLINT ignore "Use camelCase" -}++module Effectful.Zoo.Hedgehog.Test.PropertySpec where++import Effectful.Zoo.Hedgehog+import Effectful.Zoo.Hedgehog.Effect.Run+import HaskellWorks.Prelude+import Hedgehog qualified as H+import Hedgehog.Gen qualified as G+import Hedgehog.Range qualified as R++tasty_property_spec :: PropertyT IO ()+tasty_property_spec = property do+  a <- forAll $ G.int (R.linear 0 100)+  True === True+  a === a+  H.success++tasty_unit_spec :: TestT IO ()+tasty_unit_spec = unit do+  True === True+  True === True+  H.success
components/hedgehog-test/Main.hs view
@@ -1,16 +1,1 @@-module Main where--import Effectful.Zoo.Hedgehog (unitTest)-import Effectful.Zoo.Hedgehog.Test.HedgehogTest (test_simple)-import Test.Tasty (TestTree, defaultMain, testGroup)-import HaskellWorks.Prelude--tests :: TestTree-tests =-  testGroup "all" [-    unitTest "Simple test" test_simple-  ]--main :: IO ()-main =-  defaultMain tests+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
components/hedgehog/Effectful/Zoo/Hedgehog/Api.hs view
@@ -1,15 +1,17 @@ module Effectful.Zoo.Hedgehog.Api-  ( module Effectful.Zoo.Hedgehog.Api.Assert,-    module Effectful.Zoo.Hedgehog.Api.Classify,-    module Effectful.Zoo.Hedgehog.Api.Eval,+  ( Property,+    PropertyT,+    Test,+    TestT,+    module Effectful.Zoo.Hedgehog.Api.Assert,+    module Effectful.Zoo.Hedgehog.Api.Hedgehog,     module Effectful.Zoo.Hedgehog.Api.Failure,     module Effectful.Zoo.Hedgehog.Api.Journal,-    module Effectful.Zoo.Hedgehog.Api.Run,   ) where  import Effectful.Zoo.Hedgehog.Api.Assert-import Effectful.Zoo.Hedgehog.Api.Classify-import Effectful.Zoo.Hedgehog.Api.Eval import Effectful.Zoo.Hedgehog.Api.Failure+import Effectful.Zoo.Hedgehog.Api.Hedgehog import Effectful.Zoo.Hedgehog.Api.Journal-import Effectful.Zoo.Hedgehog.Api.Run+import Effectful.Zoo.Hedgehog.Api.Tasty.Orphans ()+import Hedgehog
components/hedgehog/Effectful/Zoo/Hedgehog/Api/Assert.hs view
@@ -1,94 +1,218 @@ module Effectful.Zoo.Hedgehog.Api.Assert-  ( assert,-    (===),-    (/==),-    onNothingFail,+  ( onNothingFail,     onNothingFailM,     onLeftFail,     onLeftFailM,++    trapFail,+    trapFailJson,+    trapFailJsonPretty,+    trapFailYaml,++    failMessage,+    failWithCustom,++    byDurationM,+    byDeadlineM,   ) where +import Data.Aeson+import Data.Aeson qualified as J+import Data.Aeson.Encode.Pretty qualified as J+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Text.Lazy qualified as LT+import Data.Text.Lazy.Encoding qualified as LT+import Data.Time.Clock (NominalDiffTime, UTCTime)+import Data.Time.Clock qualified as DTC+import Data.Yaml qualified as Y import Effectful+import Effectful.Concurrent import Effectful.Dispatch.Dynamic import Effectful.Zoo.Core-import Effectful.Zoo.Hedgehog.Api.Failure-import Effectful.Zoo.Hedgehog.Dynamic+import Effectful.Zoo.Error.Static+import Effectful.Zoo.Hedgehog.Api.Hedgehog+import Effectful.Zoo.Hedgehog.Api.Journal+import Effectful.Zoo.Hedgehog.Api.MonadAssertion+import Effectful.Zoo.Hedgehog.Effect.Hedgehog+import GHC.Stack qualified as GHC import HaskellWorks.Prelude+import Hedgehog (MonadTest(..)) import Hedgehog qualified as H--infix 4 ===, /==--assert :: forall r. ()-  => HasCallStack-  => r <: Hedgehog-  => Bool-  -> Eff r ()-assert condition =-  withFrozenCallStack $-    H.assert condition--(===) :: forall a r. ()-  => HasCallStack-  => Eq a-  => Show a-  => r <: Hedgehog-  => a-  -> a-  -> Eff r ()-(===) a b =-  withFrozenCallStack $-    a H.=== b--(/==) :: forall a r. ()-  => HasCallStack-  => Eq a-  => Show a-  => r <: Hedgehog-  => a-  -> a-  -> Eff r ()-(/==) a b =-  withFrozenCallStack $-    a H./== b+import Hedgehog.Internal.Property qualified as H+import Hedgehog.Internal.Source qualified as H -onNothingFail :: forall a r. ()+onNothingFail :: forall a m. ()   => HasCallStack-  => r <: Hedgehog+  => MonadTest m   => Maybe a-  -> Eff r a+  -> m a onNothingFail mv =   withFrozenCallStack $     case mv of       Just a -> pure a       Nothing -> failWith Nothing "Expected Just, but got Nothing" -onNothingFailM :: forall a r. ()+onNothingFailM :: forall a m. ()   => HasCallStack-  => r <: Hedgehog-  => Eff r (Maybe a)-  -> Eff r a+  => MonadTest m+  => m (Maybe a)+  -> m a onNothingFailM f =   withFrozenCallStack $     f >>= onNothingFail -onLeftFail :: forall e a r. ()+onLeftFail :: forall e a m. ()   => HasCallStack+  => MonadTest m   => Show e-  => r <: Hedgehog   => Either e a-  -> Eff r a+  -> m a onLeftFail ea =   withFrozenCallStack $     case ea of       Right a -> pure a       Left e -> failWith Nothing $ "Expected Just, but got Left: " <> show e -onLeftFailM :: forall e a r. ()+onLeftFailM :: forall e a m. ()   => HasCallStack+  => MonadTest m   => Show e-  => r <: Hedgehog-  => Eff r (Either e a)-  -> Eff r a+  => m (Either e a)+  -> m a onLeftFailM f =   withFrozenCallStack $     f >>= onLeftFail++failMessage :: ()+  => H.MonadTest m+  => CallStack+  -> String+  -> m a+failMessage cs =+  withFrozenCallStack $+    failWithCustom cs Nothing++failWithCustom :: ()+  => H.MonadTest m+  => CallStack+  -> Maybe H.Diff+  -> String+  -> m a+failWithCustom cs mdiff msg =+  H.liftTest $ H.mkTest (Left $ H.Failure (H.getCaller cs) msg mdiff, mempty)++trapFail :: forall e a r. ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error H.Failure+  => r <: Hedgehog+  => Show e+  => Eff (Error e ': r) a+  -> Eff r a+trapFail f =+  withFrozenCallStack do+    r <- f & runError_+    case r of+      Right a -> pure a+      Left e  -> failWith Nothing $ show e++trapFailJson :: forall e a r. ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error H.Failure+  => r <: Hedgehog+  => ToJSON e+  => Eff (Error e ': r) a+  -> Eff r a+trapFailJson f =+  withFrozenCallStack do+    r <- withFrozenCallStack $ f & runError_+    case r of+      Right a -> pure a+      Left e  -> do+        let msg = LT.unpack $ LT.decodeUtf8 $ J.encode e+        failWith Nothing msg++trapFailJsonPretty :: forall e a r. ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error H.Failure+  => r <: Hedgehog+  => ToJSON e+  => Eff (Error e ': r) a+  -> Eff r a+trapFailJsonPretty f =+  withFrozenCallStack do+    r <- withFrozenCallStack $ f & runError_+    case r of+      Right a -> pure a+      Left e  -> do+        let msg = LT.unpack $ LT.decodeUtf8 $ J.encodePretty e+        failWith Nothing msg++trapFailYaml :: forall e a r. ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error H.Failure+  => r <: Hedgehog+  => ToJSON e+  => Eff (Error e ': r) a+  -> Eff r a+trapFailYaml f =+  withFrozenCallStack do+    r <- withFrozenCallStack $ f & runError_+    case r of+      Right a -> pure a+      Left e  -> do+        let msg = T.unpack $ T.decodeUtf8 $ Y.encode e+        failWith Nothing msg++-- | 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 :: forall a r. ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error H.Failure+  => r <: Hedgehog+  => r <: IOE+  => NominalDiffTime+  -> UTCTime+  -> String+  -> Eff r a+  -> Eff r a+byDeadlineM period deadline errorMessage f = GHC.withFrozenCallStack $ do+  start <- liftIO DTC.getCurrentTime+  a <- goM+  end <- liftIO DTC.getCurrentTime+  jot_ $ "Operation completed in " <> tshow (DTC.diffUTCTime end start)+  return a+  where goM = catchAssertion f $ \e -> do+          currentTime <- liftIO DTC.getCurrentTime+          if currentTime < deadline+            then do+              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+byDurationM :: forall b r. ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error H.Failure+  => r <: IOE+  => r <: Hedgehog+  => NominalDiffTime+  -> NominalDiffTime+  -> String+  -> Eff r b+  -> Eff r b+byDurationM period duration errorMessage f = GHC.withFrozenCallStack $ do+  deadline <- DTC.addUTCTime duration <$> liftIO DTC.getCurrentTime+  byDeadlineM period deadline errorMessage f
− components/hedgehog/Effectful/Zoo/Hedgehog/Api/Classify.hs 
@@ -1,20 +0,0 @@-module Effectful.Zoo.Hedgehog.Api.Classify-  ( classify,-  ) where--import Effectful-import Effectful.Dispatch.Dynamic-import Effectful.Zoo.Core-import Effectful.Zoo.Hedgehog.Dynamic-import HaskellWorks.Prelude-import Hedgehog qualified as H--classify :: forall r. ()-  => HasCallStack-  => r <: Hedgehog-  => H.LabelName-  -> Bool-  -> Eff r ()-classify name b =-  withFrozenCallStack $-    H.classify name b
− components/hedgehog/Effectful/Zoo/Hedgehog/Api/Eval.hs 
@@ -1,64 +0,0 @@-module Effectful.Zoo.Hedgehog.Api.Eval-  ( eval,-    evalIO,-    evalM,--    evalEither,-    evalMaybe,-  ) where--import Effectful-import Effectful.Dispatch.Dynamic-import Effectful.Zoo.Core-import Effectful.Zoo.Hedgehog.Dynamic-import HaskellWorks.Prelude-import Hedgehog qualified as H--eval :: forall a r. ()-  => HasCallStack-  => r <: Hedgehog-  => a-  -> Eff r a-eval a =-  withFrozenCallStack do-    H.eval a---- |Embeds 'Hedgehog.evalEither'.-evalEither :: forall a e r. ()-  => HasCallStack-  => r <: Hedgehog-  => Show e-  => Either e a-  -> Eff r a-evalEither e =-  withFrozenCallStack do-    H.evalEither e---- |Embeds 'Hedgehog.evalMaybe'.-evalMaybe :: forall a r. ()-  => HasCallStack-  => r <: Hedgehog-  => Maybe a-  -> Eff r a-evalMaybe e =-  withFrozenCallStack do-    H.evalMaybe e--evalIO :: forall a r. ()-  => HasCallStack-  => r <: IOE-  => r <: Hedgehog-  => IO a-  -> Eff r a-evalIO f =-  withFrozenCallStack do-    H.evalIO f--evalM :: forall a r. ()-  => HasCallStack-  => r <: Hedgehog-  => Eff r a-  -> Eff r a-evalM f =-  withFrozenCallStack do-    H.evalM f
components/hedgehog/Effectful/Zoo/Hedgehog/Api/Failure.hs view
@@ -1,74 +1,21 @@ module Effectful.Zoo.Hedgehog.Api.Failure-  ( failure,-    failException,-    failWith,+  ( H.Failure,     failWithCallStack,--    catchAssertion,-    throwAssertion,   ) where  import Effectful-import Effectful.Dispatch.Dynamic-import Effectful.Error.Static import Effectful.Zoo.Core-import Effectful.Zoo.Hedgehog.Dynamic+import Effectful.Zoo.Error.Static import HaskellWorks.Prelude import Hedgehog.Internal.Property qualified as H import Hedgehog.Internal.Source qualified as H -failure :: forall a r. ()-  => HasCallStack-  => r <: Hedgehog-  => Eff r a-failure =-  withFrozenCallStack-    H.failure--failException :: forall a r. ()-  => HasCallStack-  => r <: Hedgehog-  => SomeException-  -> Eff r a-failException e =-  withFrozenCallStack $-    H.failException e--failWith :: forall a r. ()-  => HasCallStack-  => r <: Hedgehog-  => Maybe H.Diff-  -> String-  -> Eff r a-failWith diff msg =-  withFrozenCallStack $-    H.failWith diff msg- failWithCallStack :: forall a r. ()-  => r <: Hedgehog+  => r <: Error H.Failure   => CallStack   -> Maybe H.Diff   -> String   -> Eff r a failWithCallStack cs diff msg =   withFrozenCallStack $-    throwAssertion (H.Failure (H.getCaller cs) msg diff)--catchAssertion :: forall a r. ()-  => HasCallStack-  => r <: Hedgehog-  => Eff r a -  -> (H.Failure -> Eff r a) -  -> Eff r a-catchAssertion m h =-  withFrozenCallStack $-    send $ CatchAssertion m h--throwAssertion :: forall a r. ()-  => HasCallStack-  => r <: Hedgehog-  => H.Failure-  -> Eff r a-throwAssertion e =-  withFrozenCallStack $-    send $ ThrowAssertion e+    throw (H.Failure (H.getCaller cs) msg diff)
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen.hs view
@@ -0,0 +1,7 @@+module Effectful.Zoo.Hedgehog.Api.Gen+  ( module Hedgehog.Gen,+    module Effectful.Zoo.Hedgehog.Api.Gen.Ulid,+  ) where++import Effectful.Zoo.Hedgehog.Api.Gen.Ulid+import Hedgehog.Gen
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen/Time.hs view
@@ -0,0 +1,18 @@+module Effectful.Zoo.Hedgehog.Api.Gen.Time+  ( genPosixTime,+  ) where++import Data.Time.Clock.POSIX (POSIXTime)+import HaskellWorks.Prelude+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++genPosixTime :: Gen POSIXTime+genPosixTime = do+  -- Generate a random integer within a reasonable range for POSIX time+  -- POSIXTime is a type synonym for NominalDiffTime, which is in seconds+  -- We'll use a range from 0 to a large number of seconds to cover a wide time span+  seconds <- Gen.integral (Range.linear 0 4_102_444_800) -- Up to year 2100++  pure $ fromIntegral @Word64 seconds
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen/Ulid.hs view
@@ -0,0 +1,32 @@+module Effectful.Zoo.Hedgehog.Api.Gen.Ulid (+    genUlid,+    genUlidRandom,+    genUlidTimeStamp,+) where++import Data.Binary (decodeOrFail)+import Data.ByteString.Lazy qualified as LBS+import Data.ULID (ULID (..))+import Data.ULID.Random (ULIDRandom)+import Data.ULID.TimeStamp (ULIDTimeStamp, mkULIDTimeStamp)+import Effectful.Zoo.Hedgehog.Api.Gen.Time+import HaskellWorks.Prelude+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++genUlidRandom :: Gen ULIDRandom+genUlidRandom = do+  bytes <- Gen.bytes (Range.singleton 10) -- 80 bits+  let lazyBytes = LBS.fromStrict bytes+  case decodeOrFail lazyBytes of+    Left (_, _, err)   -> fail $ "Failed to decode ULIDRandom: " <> err -- This shouldn't happen.+    Right (_, _, ulid) -> pure ulid++genUlidTimeStamp :: Gen ULIDTimeStamp+genUlidTimeStamp =+  mkULIDTimeStamp <$> genPosixTime++genUlid :: Gen ULID+genUlid =+  ULID <$> genUlidTimeStamp <*> genUlidRandom
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Hedgehog.hs view
@@ -0,0 +1,24 @@+module Effectful.Zoo.Hedgehog.Api.Hedgehog+  ( H.classify,++    H.eval,+    H.evalIO,+    H.evalM,++    H.evalEither,+    H.evalMaybe,++    H.assert,+    (H.===),+    (H./==),++    H.failure,+    H.failException,+    H.failWith,++    H.success,++  ) where++import Hedgehog qualified as H+import Hedgehog.Internal.Property qualified as H
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/Cabal.hs view
@@ -0,0 +1,90 @@+module Effectful.Zoo.Hedgehog.Api.Internal.Cabal+  ( findDefaultPlanJsonFile,+    getPlanJsonFile,+    binDist,+  ) where++import Data.Aeson+import Data.List qualified as L+import Data.Text qualified as T+import Effectful+import Effectful.Zoo.Core+import Effectful.Zoo.Environment+import Effectful.Zoo.Error.Static+import Effectful.Zoo.FileSystem+import Effectful.Zoo.Hedgehog.Api.Internal.Cabal.Types+import Effectful.Zoo.Hedgehog.Api.Internal.FilePath+import Effectful.Zoo.Log.Dynamic+import HaskellWorks.Error.Types+import HaskellWorks.Prelude+import System.FilePath (takeDirectory, (</>))++-- | Find the nearest plan.json going upwards from the current directory.+findDefaultPlanJsonFile :: ()+  => r <: Error IOException+  => r <: FileSystem+  => r <: IOE+  => r <: Log Text+  => Eff r FilePath+findDefaultPlanJsonFile = getCurrentDirectory >>= go+  where go :: ()+          => r <: Error IOException+          => r <: FileSystem+          => r <: IOE+          => r <: Log Text+          => FilePath+          -> Eff r FilePath+        go d = do+          let file = d </> "dist-newstyle/cache/plan.json"+          exists <- doesFileExist file+          if exists+            then return file+            else do+              let parent = takeDirectory d+              if parent == d+                then return "dist-newstyle/cache/plan.json"+                else go parent+++getPlanJsonFile :: ()+  => r <: Environment+  => r <: Error IOException+  => r <: FileSystem+  => r <: IOE+  => r <: Log Text+  => Eff r FilePath+getPlanJsonFile =  do+  maybeBuildDir <- lookupEnvMaybe "CABAL_BUILDDIR"+  case maybeBuildDir of+    Just buildDir -> pure $ ".." </> T.unpack buildDir </> "cache/plan.json"+    Nothing       -> findDefaultPlanJsonFile++-- | Consult the "plan.json" generated by cabal to get the path to the executable corresponding.+-- to a haskell package.  It is assumed that the project has already been configured and the+-- executable has been built.+binDist:: ()+  => r <: Environment+  => r <: Error GenericError+  => r <: Error IOException+  => r <: FileSystem+  => r <: IOE+  => r <: Log Text+  => String+  -- ^ Package name+  -> Eff r FilePath+  -- ^ Path to executable+binDist pkg = do+  planJsonFile <- getPlanJsonFile+  contents <- readLazyByteStringFile planJsonFile++  case eitherDecode @Plan contents of+    Right plan -> case L.filter matching plan.installPlan of+      (component:_) -> case component.binFile of+        Just bin -> return $ addExeSuffix (T.unpack bin)+        Nothing  -> throw $ GenericError $ "Missing bin-file in " <> tshow component+      [] -> throw $ GenericError $ "Cannot find exe " <> tshow pkg <> " in plan"+    Left msg -> throw $ GenericError $ "Cannot decode plan: " <> T.pack msg+  where matching :: Component -> Bool+        matching component = case component.componentName of+          Just name -> name == "exe:" <> T.pack pkg+          Nothing   -> False
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/Cabal/Types.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}++module Effectful.Zoo.Hedgehog.Api.Internal.Cabal.Types+  ( Plan(..),+    Component(..),+  ) where++import           Control.Applicative+import           Data.Aeson+import           Data.Eq+import           Data.Function+import           Data.Maybe+import           Data.Text           (Text)+import           GHC.Generics+import           Text.Show++data Component = Component+  { componentName :: Maybe Text+  , binFile       :: Maybe Text+  }+  deriving stock (Generic, Eq, Show)++newtype Plan = Plan+  { installPlan :: [Component]+  }+  deriving stock (Generic, Eq, Show)++instance FromJSON Plan where+  parseJSON = withObject "Plan" $ \v -> Plan+    <$> v .: "install-plan"++instance FromJSON Component where+  parseJSON = withObject "Plan" $ \v -> Component+    <$> v .:? "component-name"+    <*> v .:? "bin-file"
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/FilePath.hs view
@@ -0,0 +1,16 @@+module Effectful.Zoo.Hedgehog.Api.Internal.FilePath+  ( exeSuffix,+    addExeSuffix,+  ) where++import Data.List qualified as L+import Effectful.Zoo.Hedgehog.Api.Internal.OS qualified as OS+import HaskellWorks.Prelude++exeSuffix :: String+exeSuffix = if OS.isWin32 then ".exe" else ""++addExeSuffix :: String -> String+addExeSuffix s = if ".exe" `L.isSuffixOf` s+  then s+  else s <> exeSuffix
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/OS.hs view
@@ -0,0 +1,12 @@+module Effectful.Zoo.Hedgehog.Api.Internal.OS+  ( isWin32,+  ) where++import           Data.Bool+import           Data.Eq+import           System.Info++-- | Determine if the operating system is Windows.+isWin32 :: Bool+isWin32 = os == "mingw32"+{-# INLINE isWin32 #-}
components/hedgehog/Effectful/Zoo/Hedgehog/Api/Journal.hs view
@@ -1,9 +1,15 @@ module Effectful.Zoo.Hedgehog.Api.Journal-  ( jot,+  ( Failure,++    jot,     jot_,          jotWithCallStack,+    jotTextWithCallStack, +    jotString,+    jotString_,+    jotText,     jotText_,     jotM,     jotBsUtf8M,@@ -37,6 +43,11 @@     jotEachIO,     jotEachIO_, +    jotPkgInputFile,+    jotPkgGoldenFile,+    jotRootInputFile,+    jotTempFile,+     jotLogTextWithCallStack,      jotShowDataLog,@@ -44,6 +55,7 @@     writeLog,   ) where +import Control.Monad.Catch (MonadCatch) import Data.Aeson (ToJSON(..)) import Data.Aeson qualified as J import Data.Aeson.Encode.Pretty qualified as J@@ -55,91 +67,144 @@ import Data.Traversable import Data.Yaml qualified as Y import Effectful+import Effectful.Concurrent import Effectful.Dispatch.Dynamic import Effectful.Zoo.Core import Effectful.Zoo.DataLog.Dynamic import Effectful.Zoo.DataLog.Dynamic qualified as DataLog-import Effectful.Zoo.Hedgehog.Api.Eval-import Effectful.Zoo.Hedgehog.Api.Failure-import Effectful.Zoo.Hedgehog.Dynamic+import Effectful.Zoo.Error.Static+import Effectful.Zoo.Hedgehog.Api.Hedgehog+import Effectful.Zoo.Hedgehog.Data.PackagePath+import Effectful.Zoo.Hedgehog.Data.ProjectRoot+import Effectful.Zoo.Hedgehog.Data.Workspace+import Effectful.Zoo.Hedgehog.Effect.Hedgehog import Effectful.Zoo.Log.Data.Severity+import Effectful.Zoo.Reader.Static import GHC.Stack qualified as GHC import HaskellWorks.Prelude import HaskellWorks.String import HaskellWorks.ToText+import Hedgehog (MonadTest(..))+import Hedgehog.Internal.Property (Failure) import Hedgehog.Internal.Property qualified as H import Hedgehog.Internal.Source qualified as H  -- | Annotate the given string at the context supplied by the callstack.-jotWithCallStack :: forall r. ()-  => r <: Hedgehog+jotWithCallStack :: forall m. ()+  => MonadTest m   => CallStack   -> String-  -> Eff r ()+  -> m () jotWithCallStack cs a =   writeLog $ H.Annotation (H.getCaller cs) a +-- | Annotate the given string at the context supplied by the callstack.+jotTextWithCallStack :: forall m. ()+  => MonadTest m+  => CallStack+  -> Text+  -> m ()+jotTextWithCallStack cs a =+  writeLog $ H.Annotation (H.getCaller cs) $ T.unpack a+ -- | Annotate with the given string.-jot :: forall r. ()-  => r <: Hedgehog+jot :: forall m. ()   => HasCallStack-  => String-  -> Eff r String+  => MonadTest m+  => Text+  -> m Text jot a =   withFrozenCallStack do+    jotText a++-- | Annotate the given string returning unit.+jot_ :: forall m. ()+  => HasCallStack+  => MonadTest m+  => Text+  -> m ()+jot_ a =+  withFrozenCallStack do+    jotText_ a++-- | Annotate with the given string.+jotString :: forall m. ()+  => HasCallStack+  => MonadTest m+  => String+  -> m String+jotString a =+  withFrozenCallStack do     !b <- eval a     jotWithCallStack GHC.callStack b-    return b+    pure b --- | Annotate the given string returning unit.-jot_ :: forall r. ()-  => r <: Hedgehog+-- | Annotate with the given string.+jotString_ :: forall m. ()   => HasCallStack+  => MonadTest m+  => String+  -> m ()+jotString_ a =+  withFrozenCallStack do+    !b <- eval a+    jotWithCallStack GHC.callStack b++-- | Annotate the given text returning unit.+jotText :: forall m. ()+  => HasCallStack+  => MonadTest m   => Text-  -> Eff r ()-jot_ =+  -> m Text+jotText a =   withFrozenCallStack do-    jotText_+    !b <- eval a+    jotWithCallStack GHC.callStack $ T.unpack a+    pure b  -- | Annotate the given text returning unit.-jotText_ :: forall r. ()-  => r <: Hedgehog+jotText_ :: forall m. ()   => HasCallStack+  => MonadTest m   => Text-  -> Eff r ()+  -> m () jotText_ a =   withFrozenCallStack do-    jotWithCallStack GHC.callStack $ T.unpack a+    !b <- eval a+    jotWithCallStack GHC.callStack $ T.unpack b  -- | Annotate the given string in a monadic context.-jotM :: forall a r. ()-  => ToString a-  => r <: Hedgehog+jotM :: forall a m. ()   => HasCallStack-  => Eff r a-  -> Eff r a+  => MonadCatch m+  => MonadTest m+  => ToString a+  => m a+  -> m a jotM a =   withFrozenCallStack do     !b <- evalM a     jotWithCallStack GHC.callStack $ toString b     return b -jotBsUtf8M :: forall r. ()-  => r <: Hedgehog+jotBsUtf8M :: forall m. ()   => HasCallStack-  => Eff r ByteString-  -> Eff r ByteString+  => MonadCatch m+  => MonadTest m+  => m ByteString+  -> m ByteString jotBsUtf8M a =   withFrozenCallStack do     !b <- evalM a     jotWithCallStack GHC.callStack $ T.unpack $ T.decodeUtf8 b     return b -jotLbsUtf8M :: forall r. ()-  => r <: Hedgehog+jotLbsUtf8M :: forall m. ()   => HasCallStack-  => Eff r LBS.ByteString-  -> Eff r LBS.ByteString+  => MonadCatch m+  => MonadTest m+  => m LBS.ByteString+  -> m LBS.ByteString jotLbsUtf8M a =   withFrozenCallStack do     !b <- evalM a@@ -147,11 +212,12 @@     return b  -- | Annotate the given string in a monadic context returning unit.-jotM_ :: forall r. ()-  => r <: Hedgehog+jotM_ :: forall m. ()   => HasCallStack-  => Eff r String-  -> Eff r ()+  => MonadCatch m+  => MonadTest m+  => m String+  -> m () jotM_ a =   withFrozenCallStack do     !b <- evalM a@@ -159,12 +225,12 @@     return ()  -- | Annotate the given string in IO.-jotIO :: forall r. ()-  => r <: Hedgehog-  => r <: IOE+jotIO :: forall m. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => IO String-  -> Eff r String+  -> m String jotIO f =   withFrozenCallStack do     !a <- evalIO f@@ -172,12 +238,12 @@     return a  -- | Annotate the given string in IO returning unit.-jotIO_ :: forall r. ()-  => r <: Hedgehog-  => r <: IOE+jotIO_ :: forall m. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => IO String-  -> Eff r ()+  -> m () jotIO_ f =   withFrozenCallStack do     !a <- evalIO f@@ -185,12 +251,13 @@     return ()  -- | Annotate the given value.-jotShow :: forall a r. ()-  => r <: Hedgehog+jotShow :: forall a m. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => Show a   => a-  -> Eff r a+  -> m a jotShow a =   withFrozenCallStack do     !b <- eval a@@ -198,23 +265,24 @@     return b  -- | Annotate the given value returning unit.-jotShow_ :: forall a r. ()-  => r <: Hedgehog+jotShow_ :: forall a m. ()   => HasCallStack+  => MonadTest m   => Show a   => a-  -> Eff r ()+  -> m () jotShow_ a =   withFrozenCallStack do     jotWithCallStack GHC.callStack (show a)  -- | Annotate the given value in a monadic context.-jotShowM :: forall a r. ()-  => r <: Hedgehog+jotShowM :: forall a m. ()   => HasCallStack+  => MonadCatch m+  => MonadTest m   => Show a-  => Eff r a-  -> Eff r a+  => m a+  -> m a jotShowM a =   withFrozenCallStack do     !b <- evalM a@@ -222,12 +290,13 @@     return b  -- | Annotate the given value in a monadic context returning unit.-jotShowM_ :: forall a r. ()-  => r <: Hedgehog+jotShowM_ :: forall a m. ()   => HasCallStack+  => MonadCatch m+  => MonadTest m   => Show a-  => Eff r a-  -> Eff r ()+  => m a+  -> m () jotShowM_ a =   withFrozenCallStack do     !b <- evalM a@@ -235,13 +304,13 @@     return ()  -- | Annotate the given value in IO.-jotShowIO :: forall a r. ()-  => r <: Hedgehog-  => r <: IOE+jotShowIO :: forall a m. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => Show a   => IO a-  -> Eff r a+  -> m a jotShowIO f =   withFrozenCallStack do     !a <- evalIO f@@ -249,13 +318,13 @@     return a  -- | Annotate the given value in IO returning unit.-jotShowIO_ :: forall a r. ()-  => r <: Hedgehog-  => r <: IOE+jotShowIO_ :: forall a m. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => Show a   => IO a-  -> Eff r ()+  -> m () jotShowIO_ f =   withFrozenCallStack do     !a <- evalIO f@@ -263,13 +332,14 @@     return ()  -- | Annotate the given value.-jotShowRead :: forall a r. ()+jotShowRead :: forall a m. ()   => HasCallStack-  => r <: Hedgehog+  => MonadIO m+  => MonadTest m   => Read a   => Show a   => String-  -> Eff r a+  -> m a jotShowRead s =   withFrozenCallStack do     !result <- eval (readEither @a s)@@ -280,12 +350,13 @@         return a  -- | Annotate the given value as JSON.-jotJson :: forall a r. ()-  => r <: Hedgehog+jotJson :: forall a m. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => ToJSON a   => a-  -> Eff r a+  -> m a jotJson a =   withFrozenCallStack do     !b <- eval a@@ -293,12 +364,13 @@     return b  -- | Annotate the given value as JSON.-jotJson_ :: forall a r. ()-  => r <: Hedgehog+jotJson_ :: forall a m. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => ToJSON a   => a-  -> Eff r ()+  -> m () jotJson_ a =   withFrozenCallStack do     !b <- eval a@@ -306,12 +378,14 @@     return ()  -- | Annotate the given value as JSON in a monadic context.-jotJsonM :: forall a r. ()-  => r <: Hedgehog+jotJsonM :: forall a m. ()   => HasCallStack+  => MonadCatch m+  => MonadIO m+  => MonadTest m   => ToJSON a-  => Eff r a-  -> Eff r a+  => m a+  -> m a jotJsonM a =   withFrozenCallStack do     !b <- evalM a@@ -319,12 +393,14 @@     return b  -- | Annotate the given value as JSON in a monadic context.-jotJsonM_ :: forall a r. ()-  => r <: Hedgehog+jotJsonM_ :: forall a m. ()   => HasCallStack+  => MonadCatch m+  => MonadIO m+  => MonadTest m   => ToJSON a-  => Eff r a-  -> Eff r ()+  => m a+  -> m () jotJsonM_ a =   withFrozenCallStack do     !b <- evalM a@@ -332,12 +408,13 @@     return ()  -- | Annotate the given value as JSON.-jotJsonPretty :: forall a r. ()-  => r <: Hedgehog+jotJsonPretty :: forall a m. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => ToJSON a   => a-  -> Eff r a+  -> m a jotJsonPretty a =   withFrozenCallStack do     !b <- eval a@@ -345,12 +422,13 @@     return b  -- | Annotate the given value as JSON.-jotJsonPretty_ :: forall a r. ()-  => r <: Hedgehog+jotJsonPretty_ :: forall a m. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => ToJSON a   => a-  -> Eff r ()+  -> m () jotJsonPretty_ a =   withFrozenCallStack do     !b <- eval a@@ -358,12 +436,14 @@     return ()  -- | Annotate the given value as JSON in a monadic context.-jotJsonPrettyM :: forall a r. ()-  => r <: Hedgehog+jotJsonPrettyM :: forall a m. ()   => HasCallStack+  => MonadCatch m+  => MonadIO m+  => MonadTest m   => ToJSON a-  => Eff r a-  -> Eff r a+  => m a+  -> m a jotJsonPrettyM a =   withFrozenCallStack do     !b <- evalM a@@ -371,12 +451,14 @@     return b  -- | Annotate the given value as JSON in a monadic context.-jotJsonPrettyM_ :: forall a r. ()-  => r <: Hedgehog+jotJsonPrettyM_ :: forall a m. ()   => HasCallStack+  => MonadCatch m+  => MonadIO m+  => MonadTest m   => ToJSON a-  => Eff r a-  -> Eff r ()+  => m a+  -> m () jotJsonPrettyM_ a =   withFrozenCallStack do     !b <- evalM a@@ -384,12 +466,13 @@     return ()  -- | Annotate the given value as JSON.-jotYaml :: forall a r. ()-  => r <: Hedgehog+jotYaml :: forall a m. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => ToJSON a   => a-  -> Eff r a+  -> m a jotYaml a =   withFrozenCallStack do     !b <- eval a@@ -397,12 +480,13 @@     return b  -- | Annotate the given value as JSON.-jotYaml_ :: forall a r. ()-  => r <: Hedgehog+jotYaml_ :: forall a m. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => ToJSON a   => a-  -> Eff r ()+  -> m () jotYaml_ a =   withFrozenCallStack do     !b <- eval a@@ -410,12 +494,14 @@     return ()  -- | Annotate the given value as JSON in a monadic context.-jotYamlM :: forall a r. ()-  => r <: Hedgehog+jotYamlM :: forall a m. ()   => HasCallStack+  => MonadCatch m+  => MonadIO m+  => MonadTest m   => ToJSON a-  => Eff r a-  -> Eff r a+  => m a+  -> m a jotYamlM a =   withFrozenCallStack do     !b <- evalM a@@ -423,12 +509,14 @@     return b  -- | Annotate the given value as JSON in a monadic context.-jotYamlM_ :: forall a r. ()-  => r <: Hedgehog+jotYamlM_ :: forall a m. ()   => HasCallStack+  => MonadCatch m+  => MonadIO m+  => MonadTest m   => ToJSON a-  => Eff r a-  -> Eff r ()+  => m a+  -> m () jotYamlM_ a =   withFrozenCallStack do     !b <- evalM a@@ -436,37 +524,40 @@     return ()  -- | Annotate the each value in the given traversable.-jotEach :: forall a f r. ()-  => r <: Hedgehog+jotEach :: forall a m f. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => Show a   => Traversable f   => f a-  -> Eff r (f a)+  -> m (f a) jotEach as =   withFrozenCallStack do     for_ as $ jotWithCallStack GHC.callStack . show     return as  -- | Annotate the each value in the given traversable returning unit.-jotEach_ :: forall a f r. ()-  => r <: Hedgehog+jotEach_ :: forall a m f. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => Show a   => Traversable f   => f a-  -> Eff r ()+  -> m () jotEach_ as =   withFrozenCallStack $ for_ as $ jotWithCallStack GHC.callStack . show  -- | Annotate the each value in the given traversable in a monadic context.-jotEachM :: forall a f r. ()-  => r <: Hedgehog+jotEachM :: forall a m f. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => Show a   => Traversable f-  => Eff r (f a)-  -> Eff r (f a)+  => m (f a)+  -> m (f a) jotEachM f =   withFrozenCallStack do     !as <- f@@ -474,27 +565,28 @@     return as  -- | Annotate the each value in the given traversable in a monadic context returning unit.-jotEachM_ :: forall a f r. ()-  => r <: Hedgehog+jotEachM_ :: forall a m f. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => Show a   => Traversable f-  => Eff r (f a)-  -> Eff r ()+  => m (f a)+  -> m () jotEachM_ f =   withFrozenCallStack do     !as <- f     for_ as $ jotWithCallStack GHC.callStack . show  -- | Annotate the each value in the given traversable in IO.-jotEachIO :: forall a f r. ()-  => r <: Hedgehog-  => r <: IOE+jotEachIO :: forall a m f. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => Show a   => Traversable f   => IO (f a)-  -> Eff r (f a)+  -> m (f a) jotEachIO f =   withFrozenCallStack do     !as <- evalIO f@@ -502,25 +594,81 @@     return as  -- | Annotate the each value in the given traversable in IO returning unit.-jotEachIO_ :: forall a f r. ()-  => r <: Hedgehog-  => r <: IOE+jotEachIO_ :: forall a m f. ()   => HasCallStack+  => MonadIO m+  => MonadTest m   => Show a   => Traversable f   => IO (f a)-  -> Eff r ()+  -> m () jotEachIO_ f =   withFrozenCallStack do     !as <- evalIO f     for_ as $ jotWithCallStack GHC.callStack . show -jotLogTextWithCallStack :: forall r. ()+-- | Return the input file path after annotating it relative to the package directory+jotPkgInputFile :: forall r. ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error Failure   => r <: Hedgehog+  => r <: Reader PackagePath+  => FilePath+  -> Eff r FilePath+jotPkgInputFile fp = withFrozenCallStack $ do+  PackagePath { filePath = pkgPath } <- ask+  jotString_ $ pkgPath <> "/" <> fp+  return fp++-- | Return the golden file path after annotating it relative to the package directory+jotPkgGoldenFile :: forall r. ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error Failure+  => r <: Hedgehog+  => r <: Reader PackagePath+  => FilePath+  -> Eff r FilePath+jotPkgGoldenFile fp = withFrozenCallStack $ do+  PackagePath { filePath = pkgPath } <- ask+  jotString_ $ pkgPath <> "/" <> fp+  return fp++jotRootInputFile :: forall r. ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error Failure+  => r <: Hedgehog+  => r <: Reader ProjectRoot+  => FilePath+  -> Eff r FilePath+jotRootInputFile fp = withFrozenCallStack $ do+  ProjectRoot { filePath = pkgPath } <- ask+  jotString $ pkgPath <> "/" <> fp++-- | Return the test file path after annotating it relative to the project root directory+jotTempFile :: forall r. ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error Failure+  => r <: Hedgehog+  => r <: Reader Workspace+  => FilePath+  -> Eff r FilePath+jotTempFile fp = withFrozenCallStack $ do+  Workspace { filePath = workspace } <- ask+  let relPath = workspace <> "/" <> fp+  jotString_ $ workspace <> "/" <> relPath+  return relPath++jotLogTextWithCallStack :: forall m. ()+  => HasCallStack+  => MonadTest m   => CallStack   -> Severity   -> Text-  -> Eff r ()+  -> m () jotLogTextWithCallStack cs severity a =   withFrozenCallStack do     jotWithCallStack cs $ T.unpack $ "[" <> toText severity <> "] " <> a@@ -528,6 +676,8 @@ jotShowDataLog :: forall i a r. ()   => HasCallStack   => Show i+  => r <: Concurrent+  => r <: Error Failure   => r <: Hedgehog   => Eff (DataLog i : r) a   -> Eff r a@@ -536,11 +686,11 @@     DataLog.runDataLog jotShow_ {-# inline jotShowDataLog #-} -writeLog :: forall r. ()+writeLog :: forall m. ()   => HasCallStack-  => r <: Hedgehog+  => MonadTest m   => H.Log-  -> Eff r ()+  -> m () writeLog message =   withFrozenCallStack $     H.writeLog message
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/MonadAssertion.hs view
@@ -0,0 +1,47 @@+module Effectful.Zoo.Hedgehog.Api.MonadAssertion+  ( MonadAssertion(..),+    tryAssertion,+    tryExceptAssertion,+  ) where++import Control.Monad.Catch (MonadCatch(..))+import Control.Monad.Catch qualified as C+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except qualified as E+import Control.Monad.Trans.Resource qualified as IO+import Control.Monad.Trans.Resource.Internal qualified as IO+import Effectful.Zoo.Hedgehog.Data.TestResult+import HaskellWorks.Prelude+import Hedgehog.Internal.Property qualified as H++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 newtype instance Monad m => MonadAssertion (H.PropertyT m)++tryAssertion :: ()+  => MonadAssertion m+  => m a+  -> m (Either H.Failure a)+tryAssertion m =+  catchAssertion (Right <$> m) (pure . Left)++tryExceptAssertion :: ()+  => MonadAssertion m+  => MonadCatch m+  => m a+  -> m (TestResult a)+tryExceptAssertion m =+  tryAssertion (C.try m) >>= \case+    Right (Right a) -> pure $ TestResult a+    Right (Left e) -> pure $ TestError e+    Left f -> pure $ TestFailure f
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process.hs view
@@ -0,0 +1,313 @@+module Effectful.Zoo.Hedgehog.Api.Process+  ( ExecConfig(..),+    defaultExecConfig,+    execDetailFlex,+    execFlex,+    execFlexOk,+    execFlexOk',+    execOk,+    execOk_,+    exec,+    procFlex,+    procFlex',+    binFlex,++    waitSecondsForProcess,+    waitSecondsForProcessOk,++  ) where++import Data.List qualified as L+import Data.Monoid (Last (..))+import Data.Text qualified as T+import Effectful+import Effectful.Concurrent+import Effectful.Zoo.Core+import Effectful.Zoo.Environment+import Effectful.Zoo.Error.Static+import Effectful.Zoo.Hedgehog.Api.Assert+import Effectful.Zoo.Hedgehog.Api.Internal.Cabal+import Effectful.Zoo.Hedgehog.Api.Journal+import Effectful.Zoo.Hedgehog.Api.Process.Internal+import Effectful.Zoo.Hedgehog.Effect.Hedgehog+import Effectful.Zoo.Log.Dynamic+import Effectful.Zoo.Process+import GHC.Stack (callStack)+import HaskellWorks.Error.Types+import HaskellWorks.Prelude+import Effectful.FileSystem (FileSystem)++-- | Configuration for starting a new process.  This is a subset of 'IO.CreateProcess'.+data ExecConfig = ExecConfig+  { execConfigEnv :: Last [(String, String)]+  , execConfigCwd :: Last FilePath+  } deriving stock (Eq, Generic, Show)++defaultExecConfig :: ExecConfig+defaultExecConfig = ExecConfig+  { execConfigEnv = mempty+  , execConfigCwd = mempty+  }++-- | Create a process returning its stdout.+--+-- Being a 'flex' function means that the environment determines how the process is launched.+--+-- When running in a nix environment, the 'envBin' argument describes the environment variable+-- that defines the binary to use to launch the process.+--+-- When running outside a nix environment, the `pkgBin` describes the name of the binary+-- to launch via cabal exec.+execFlexOk :: ()+  => HasCallStack+  => r <: Concurrent+  => r <: Environment+  => r <: Error Failure+  => r <: Error GenericError+  => r <: Error IOException+  => r <: FileSystem+  => r <: Hedgehog+  => r <: IOE+  => r <: Log Text+  => String+  -> String+  -> [String]+  -> Eff r String+execFlexOk = execFlexOk' defaultExecConfig++execFlexOk' :: ()+  => HasCallStack+  => r <: Concurrent+  => r <: Environment+  => r <: Error Failure+  => r <: Error GenericError+  => r <: Error IOException+  => r <: FileSystem+  => r <: Hedgehog+  => r <: IOE+  => r <: Log Text+  => ExecConfig+  -> String+  -> String+  -> [String]+  -> Eff r String+execFlexOk' execConfig pkgBin envBin arguments =+  withFrozenCallStack do+    (exitResult, stdout, stderr) <- execFlex execConfig pkgBin envBin arguments+    case exitResult of+      ExitFailure exitCode -> do+        jotString_ $ L.unlines $+          [ "Process exited with non-zero exit-code: " <> show @Int exitCode ]+          <> (if L.null stdout then [] else ["━━━━ stdout ━━━━" , stdout])+          <> (if L.null stderr then [] else ["━━━━ stderr ━━━━" , stderr])+        failMessage callStack "Execute process failed"+      ExitSuccess -> return stdout++-- | Run a process, returning its exit code, its stdout, and its stderr.+-- Contrary to @execFlexOk'@, this function doesn't fail if the call fails.+-- So, if you want to test something negative, this is the function to use.+execFlex :: ()+  => HasCallStack+  => r <: Concurrent+  => r <: Environment+  => r <: Error Failure+  => r <: Error GenericError+  => r <: Error IOException+  => r <: FileSystem+  => r <: Hedgehog+  => r <: IOE+  => r <: Log Text+  => ExecConfig+  -> String -- ^ @pkgBin@: name of the binary to launch via 'cabal exec'+  -> String -- ^ @envBin@: environment variable defining the binary to launch the process, when in Nix+  -> [String]+  -> Eff r (ExitCode, String, String) -- ^ exit code, stdout, stderr+execFlex execConfig pkgBin envBin arguments =+  withFrozenCallStack do+    cp <- procFlex' execConfig pkgBin envBin arguments+    jotString_ . ("━━━━ command ━━━━\n" <>) $ case cmdspec cp of+      ShellCommand cmd    -> cmd+      RawCommand cmd args -> cmd <> " " <> L.unwords (argQuote <$> args)++    readCreateProcessWithExitCode cp ""++execDetailFlex :: ()+  => HasCallStack+  => r <: Concurrent+  => r <: Environment+  => r <: Error Failure+  => r <: Error GenericError+  => r <: Error IOException+  => r <: FileSystem+  => r <: Hedgehog+  => r <: IOE+  => r <: Log Text+  => ExecConfig+  -> String+  -> String+  -> [String]+  -> Eff r (ExitCode, String, String)+execDetailFlex execConfig pkgBin envBin arguments =+  withFrozenCallStack do+    cp <- procFlex' execConfig pkgBin envBin arguments+    jotString_ . ("Command: " <>) $ case cmdspec cp of+      ShellCommand cmd    -> cmd+      RawCommand cmd args -> cmd <> " " <> L.unwords args+    readCreateProcessWithExitCode cp ""++-- | Execute a process, returning '()'.+execOk_ :: ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error Failure+  => r <: Error IOException+  => r <: Hedgehog+  => r <: IOE+  => ExecConfig+  -> String+  -> [String]+  -> Eff r ()+execOk_ execConfig bin arguments =+  void $ execOk execConfig bin arguments++-- | Execute a process, returning the stdout. Fail if the call returns+-- with a non-zero exit code. For a version that doesn't fail upon receiving+-- a non-zero exit code, see 'execAny'.+execOk :: ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error Failure+  => r <: Error IOException+  => r <: Hedgehog+  => r <: IOE+  => ExecConfig+  -> String+  -> [String]+  -> Eff r String+execOk execConfig bin arguments =+  withFrozenCallStack do+    (exitResult, stdout, stderr) <- exec execConfig bin arguments+    case exitResult of+      ExitFailure exitCode ->failMessage callStack . L.unlines $+        [ "Process exited with non-zero exit-code: " <> show @Int exitCode ]+        <> (if L.null stdout then [] else ["━━━━ stdout ━━━━" , stdout])+        <> (if L.null stderr then [] else ["━━━━ stderr ━━━━" , stderr])+      ExitSuccess -> return stdout++-- | Execute a process, returning the error code, the stdout, and the stderr.+exec :: ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error Failure+  => r <: Error IOException+  => r <: Hedgehog+  => r <: IOE+  => ExecConfig+  -> String -- ^ The binary to launch+  -> [String] -- ^ The binary's arguments+  -> Eff r (ExitCode, String, String) -- ^ exit code, stdout, stderr+exec execConfig bin arguments =+  withFrozenCallStack do+    let cp = (proc bin arguments)+          { env = getLast execConfig.execConfigEnv+          , cwd = getLast execConfig.execConfigCwd+          }+    jotString_ . ( "━━━━ command ━━━━\n" <>) $ bin <> " " <> L.unwords (argQuote <$> arguments)+    readCreateProcessWithExitCode cp ""++-- | Wait a maximum of 'seconds' secons for process to exit.+waitSecondsForProcessOk :: ()+  => HasCallStack+  => r <: Concurrent+  => r <: Error Failure+  => r <: Hedgehog+  => r <: IOE+  => Int+  -> ProcessHandle+  -> Eff r ExitCode+waitSecondsForProcessOk seconds hProcess =+  withFrozenCallStack do+    maybeExitCode <- waitSecondsForProcess seconds hProcess+      & trapFail @TimedOut++    case maybeExitCode of+      Nothing -> failMessage callStack "No exit code for process"+      Just exitCode -> do+        jotString_ $ "Process exited " <> show exitCode+        return exitCode++-- | Compute the path to the binary given a package name or an environment variable override.+binFlex :: ()+  => HasCallStack+  => r <: Environment+  => r <: Error GenericError+  => r <: Error IOException+  => r <: FileSystem+  => r <: IOE+  => r <: Log Text+  => String+  -- ^ Package name+  -> String+  -- ^ Environment variable pointing to the binary to run+  -> Eff r FilePath+  -- ^ Path to executable+binFlex pkg binaryEnv =+  withFrozenCallStack do+    maybeEnvBin <- lookupEnvMaybe $ T.pack binaryEnv+    case maybeEnvBin of+      Just envBin -> return $ T.unpack envBin+      Nothing     -> binDist pkg++-- | Create a 'CreateProcess' describing how to start a process given the Cabal package name+-- corresponding to the executable, an environment variable pointing to the executable,+-- and an argument list.+--+-- The actual executable used will the one specified by the environment variable, but if+-- the environment variable is not defined, it will be found instead by consulting the+-- "plan.json" generated by cabal.  It is assumed that the project has already been+-- configured and the executable has been built.+procFlex :: ()+  => HasCallStack+  => r <: Environment+  => r <: Error GenericError+  => r <: Error IOException+  => r <: FileSystem+  => r <: IOE+  => r <: Log Text+  => String+  -- ^ Cabal package name corresponding to the executable+  -> String+  -- ^ Environment variable pointing to the binary to run+  -> [String]+  -- ^ Arguments to the CLI command+  -> Eff r CreateProcess+  -- ^ Captured stdout+procFlex =+  procFlex' defaultExecConfig++procFlex' :: ()+  => HasCallStack+  => r <: Environment+  => r <: Error GenericError+  => r <: Error IOException+  => r <: FileSystem+  => r <: IOE+  => r <: Log Text+  => ExecConfig+  -> String+  -- ^ Cabal package name corresponding to the executable+  -> String+  -- ^ Environment variable pointing to the binary to run+  -> [String]+  -- ^ Arguments to the CLI command+  -> Eff r CreateProcess+  -- ^ Captured stdout+procFlex' execConfig pkg binaryEnv arguments =+  withFrozenCallStack do+    bin <- binFlex pkg binaryEnv+    return (proc bin arguments)+      { env = getLast execConfig.execConfigEnv+      , cwd = getLast execConfig.execConfigCwd+      -- this allows sending signals to the created processes, without killing the test-suite process+      , create_group = True+      }
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process/Internal.hs view
@@ -0,0 +1,28 @@+module Effectful.Zoo.Hedgehog.Api.Process.Internal+  ( argQuote+  ) where++import Data.Bool+import Data.Semigroup+import Data.String++import qualified Data.List      as L++-- | Format argument for a shell CLI command.+--+-- This includes automatically embedding string in double quotes if necessary, including any necessary escaping.+--+-- Note, this function does not cover all the edge cases for shell processing, so avoid use in production code.+argQuote :: String -> String+argQuote arg = if ' ' `L.elem` arg || '"' `L.elem` arg || '$' `L.elem` arg+  then "\"" <> escape arg <> "\""+  else arg+  where escape :: String -> String+        escape ('"':xs)  = '\\':'"':escape xs+        escape ('\\':xs) = '\\':'\\':escape xs+        escape ('\n':xs) = '\\':'n':escape xs+        escape ('\r':xs) = '\\':'r':escape xs+        escape ('\t':xs) = '\\':'t':escape xs+        escape ('$':xs)  = '\\':'$':escape xs+        escape (x:xs)    = x:escape xs+        escape ""        = ""
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Range.hs view
@@ -0,0 +1,5 @@+module Effectful.Zoo.Hedgehog.Api.Range+  ( module Hedgehog.Range,+  ) where++import Hedgehog.Range
− components/hedgehog/Effectful/Zoo/Hedgehog/Api/Run.hs 
@@ -1,47 +0,0 @@-module Effectful.Zoo.Hedgehog.Api.Run-  ( UnitTest,--    hedgehog,-    unitTest,-  ) where--import Control.Monad.Trans.Writer.Lazy qualified as MTL-import Effectful-import Effectful.Error.Static-import Effectful.Writer.Static.Local-import Effectful.Zoo.Hedgehog.Api.Journal-import Effectful.Zoo.Hedgehog.Dynamic-import Effectful.Zoo.Log.Dynamic-import HaskellWorks.Prelude-import Hedgehog (TestT)-import Hedgehog qualified as H-import Hedgehog.Internal.Property (Failure, Journal)-import Hedgehog.Internal.Property qualified as H-import Test.Tasty (TestName, TestTree)-import Test.Tasty.Hedgehog (testProperty)--type UnitTest = TestT IO ()--hedgehog :: forall a. ()-  => Eff-      [ Log Text-      , Hedgehog-      , Error Failure-      , Writer Journal-      , IOE-      ] a-  -> H.TestT IO a-hedgehog f =-  f-    & runLog (ConcUnlift Persistent Unlimited) jotLogTextWithCallStack-    & runHedgehogIO-    & MTL.WriterT-    & ExceptT-    & H.TestT--unitTest :: ()-  => TestName -  -> UnitTest -  -> TestTree-unitTest desc =-  testProperty desc . H.withTests 1 . H.property . H.test
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Stack.hs view
@@ -0,0 +1,10 @@+module Effectful.Zoo.Hedgehog.Api.Stack+  ( callerModuleName,+  ) where++import GHC.Stack (callStack, getCallStack, srcLocModule)+import HaskellWorks.Prelude++-- | Get the module name of the caller.+callerModuleName :: HasCallStack => String+callerModuleName = maybe "<no-module>" (srcLocModule . snd) (listToMaybe (getCallStack callStack))
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Tasty.hs view
@@ -0,0 +1,20 @@+module Effectful.Zoo.Hedgehog.Api.Tasty+  ( ToTestTree(..),+  ) where++import HaskellWorks.Prelude+import Hedgehog (PropertyT, TestT)+import Hedgehog qualified as H+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Hedgehog (testProperty)++class ToTestTree a where+  toTestTree :: TestName -> a -> TestTree++instance ToTestTree (PropertyT IO ()) where+  toTestTree desc =+    testProperty desc . H.property++instance ToTestTree (TestT IO ()) where+  toTestTree desc =+    testProperty desc . H.withTests 1 . H.property . H.test
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Tasty/Orphans.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Effectful.Zoo.Hedgehog.Api.Tasty.Orphans where++import Data.Monoid+import HaskellWorks.Prelude+import Hedgehog (PropertyT, TestT)+import Hedgehog qualified as H+import Test.Tasty.Discover+import Test.Tasty.Discover.TastyInfo+import Test.Tasty.Hedgehog++instance Tasty (PropertyT IO ()) where+  tasty info = pure . testProperty testName . H.property+    where testName = fromMaybe "" $ getLast info.name++instance Tasty (TestT IO ()) where+  tasty info = tasty info . H.test
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Workspace.hs view
@@ -0,0 +1,112 @@+module Effectful.Zoo.Hedgehog.Api.Workspace+  ( PackagePath(..),+    ProjectRoot(..),+    Workspace(..),+    workspace,+    moduleWorkspace,+    findCabalProjectDir,+  ) where++import Data.Text qualified as T+import Effectful+import Effectful.Concurrent+import Effectful.Environment+import Effectful.Reader.Static+import Effectful.Zoo.Core+import Effectful.Zoo.Error.Static+import Effectful.Zoo.FileSystem+import Effectful.Zoo.Hedgehog.Api.Assert+import Effectful.Zoo.Hedgehog.Api.Hedgehog+import Effectful.Zoo.Hedgehog.Api.Journal+import Effectful.Zoo.Hedgehog.Api.Stack+import Effectful.Zoo.Hedgehog.Data.PackagePath+import Effectful.Zoo.Hedgehog.Data.ProjectRoot+import Effectful.Zoo.Hedgehog.Data.Workspace+import Effectful.Zoo.Hedgehog.Effect.Hedgehog+import Effectful.Zoo.Log.Dynamic+import HaskellWorks.Prelude+import Hedgehog.Internal.Property qualified as H+import System.FilePath ((</>))+import System.Info++-- | Create a workspace directory which will exist for at least the duration of+-- the supplied block.+--+-- The directory will have the supplied prefix but contain a generated random+-- suffix to prevent interference between tests+--+-- The directory will be deleted if the block succeeds, but left behind if+-- the block fails.+workspace :: ()+  => HasCallStack+  => r <: Concurrent+  => r <: Environment+  => r <: Error H.Failure+  => r <: FileSystem+  => r <: Hedgehog+  => r <: Log Text+  => FilePath+  -> Eff (Reader Workspace : r) ()+  -> Eff r ()+workspace prefixPath f = withFrozenCallStack $ do+  systemTemp <- getCanonicalTemporaryDirectory+    & trapFail @IOException+  maybeKeepWorkspace <- lookupEnv "KEEP_WORKSPACE"+  ws <- createTempDirectory systemTemp (prefixPath <> "-test")+    & trapFail @IOException+  jot_ $ "Workspace: " <> T.pack ws+  writeStringFile (ws </> "module") callerModuleName+    & trapFail @IOException+  runReader (Workspace ws) f+  when (os /= "mingw32" && maybeKeepWorkspace /= Just "1") $ do+    removePathForcibly ws+      & trapFail @IOException++-- | Create a workspace directory which will exist for at least the duration of+-- the supplied block.+--+-- The directory will have the prefix as "$prefixPath/$moduleName" but contain a generated random+-- suffix to prevent interference between tests+--+-- The directory will be deleted if the block succeeds, but left behind if+-- the block fails.+--+-- The 'prefix' argument should not contain directory delimeters.+moduleWorkspace ::  ()+  => HasCallStack+  => r <: Concurrent+  => r <: Environment+  => r <: Error H.Failure+  => r <: FileSystem+  => r <: Hedgehog+  => r <: Log Text+  => String+  -> Eff (Reader Workspace : r) ()+  -> Eff r ()+moduleWorkspace prefix f = withFrozenCallStack $+  workspace (prefix <> "-" <> callerModuleName) f++-- | Compute the project base.  This will be the first parent directory that contains+-- the `cabal.project` file.+-- This should should point to the root directory of the Github project checkout.+findCabalProjectDir :: ()+  => r <: Concurrent+  => r <: Environment+  => r <: Error H.Failure+  => r <: FileSystem+  => r <: Hedgehog+  => r <: Log Text+  => FilePath+  -> Eff r FilePath+findCabalProjectDir dir = do+  atBase <- doesFileExist (dir </> "cabal.project")+    & trap_ @IOException (pure False)+  if atBase+    then return dir+    else do+      let up = dir </> ".."+      upExist <- doesDirectoryExist up+        & trap_ @IOException (pure False)+      if upExist+        then findCabalProjectDir up+        else failWith Nothing "Could not detect project base directory (containing cabal.project)"
+ components/hedgehog/Effectful/Zoo/Hedgehog/Data.hs view
@@ -0,0 +1,15 @@+module Effectful.Zoo.Hedgehog.Data+  ( PackagePath(..),+    ProjectRoot(..),+    PropertyTest,+    TestResult(..),+    UnitTest,+    Workspace(..),+  ) where++import Effectful.Zoo.Hedgehog.Data.PackagePath+import Effectful.Zoo.Hedgehog.Data.ProjectRoot+import Effectful.Zoo.Hedgehog.Data.PropertyTest+import Effectful.Zoo.Hedgehog.Data.TestResult+import Effectful.Zoo.Hedgehog.Data.UnitTest+import Effectful.Zoo.Hedgehog.Data.Workspace
+ components/hedgehog/Effectful/Zoo/Hedgehog/Data/PackagePath.hs view
@@ -0,0 +1,11 @@+module Effectful.Zoo.Hedgehog.Data.PackagePath+  ( PackagePath(..),+  ) where++import           GHC.Generics+import           HaskellWorks.Prelude++newtype PackagePath = PackagePath+  { filePath :: FilePath+  }+  deriving stock (Eq, Generic, Show)
+ components/hedgehog/Effectful/Zoo/Hedgehog/Data/ProjectRoot.hs view
@@ -0,0 +1,11 @@+module Effectful.Zoo.Hedgehog.Data.ProjectRoot+  ( ProjectRoot(..),+  ) where++import           GHC.Generics+import           HaskellWorks.Prelude++newtype ProjectRoot = ProjectRoot+  { filePath :: FilePath+  }+  deriving stock (Eq, Generic, Show)
+ components/hedgehog/Effectful/Zoo/Hedgehog/Data/PropertyTest.hs view
@@ -0,0 +1,8 @@+module Effectful.Zoo.Hedgehog.Data.PropertyTest+  ( PropertyTest,+  ) where++import Hedgehog+import HaskellWorks.Prelude++type PropertyTest = PropertyT IO ()
+ components/hedgehog/Effectful/Zoo/Hedgehog/Data/TestResult.hs view
@@ -0,0 +1,11 @@+module Effectful.Zoo.Hedgehog.Data.TestResult+  ( TestResult(..),+  ) where++import HaskellWorks.Prelude+import Hedgehog.Internal.Property qualified as H++data TestResult a+  = TestResult a+  | TestFailure H.Failure+  | TestError SomeException
+ components/hedgehog/Effectful/Zoo/Hedgehog/Data/UnitTest.hs view
@@ -0,0 +1,8 @@+module Effectful.Zoo.Hedgehog.Data.UnitTest+  ( UnitTest,+  ) where++import Hedgehog+import HaskellWorks.Prelude++type UnitTest = TestT IO ()
+ components/hedgehog/Effectful/Zoo/Hedgehog/Data/Workspace.hs view
@@ -0,0 +1,11 @@+module Effectful.Zoo.Hedgehog.Data.Workspace+  ( Workspace(..),+  ) where++import           GHC.Generics+import           HaskellWorks.Prelude++newtype Workspace = Workspace+  { filePath :: FilePath+  }+  deriving stock (Eq, Generic, Show)
− components/hedgehog/Effectful/Zoo/Hedgehog/Dynamic.hs 
@@ -1,67 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Effectful.Zoo.Hedgehog.Dynamic-  ( Hedgehog(..),-    MonadTest(..),--    runHedgehogIO,-    runHedgehog,-  ) where--import Effectful-import Effectful.Dispatch.Dynamic-import Effectful.Error.Static-import Effectful.Writer.Static.Local-import Effectful.Zoo.Core-import Effectful.Zoo.Hedgehog.MonadTestProxy-import HaskellWorks.Prelude-import Hedgehog (MonadTest(..))-import Hedgehog qualified as H-import Hedgehog.Internal.Property (Failure, Journal)-import Hedgehog.Internal.Property qualified as H--data Hedgehog :: Effect where-  CatchAssertion :: HasCallStack-    => m a-    -> (H.Failure -> m a)-    -> Hedgehog m a--  LiftTest :: HasCallStack-    => H.Test a-    -> Hedgehog m a--  ThrowAssertion :: HasCallStack-    => H.Failure-    -> Hedgehog m a--type instance DispatchOf Hedgehog = Dynamic--instance (r <: Hedgehog) => MonadTest (Eff r) where-  liftTest t = send $ LiftTest t--runHedgehogIO :: forall a. ()-  => Eff-      [ Hedgehog-      , Error Failure-      , Writer Journal-      , IOE-      ] a-  -> IO (Either Failure a, Journal)-runHedgehogIO f =-  f-    & runHedgehog-    & runError @H.Failure-    & runWriter @H.Journal-    & fmap (first (first snd))-    & runEff--runHedgehog :: forall a r. ()-  => r <: Error Failure-  => r <: Writer Journal-  => Eff (Hedgehog : r) a-  -> Eff r a-runHedgehog =-  interpret $ \env -> \case-    CatchAssertion f h -> localUnlift env SeqUnlift $ \unlift -> catchError (unlift f) (const (unlift . h))-    LiftTest f -> liftTestProxy f-    ThrowAssertion failure -> throwError failure
+ components/hedgehog/Effectful/Zoo/Hedgehog/Effect/Hedgehog.hs view
@@ -0,0 +1,83 @@+{- HLINT ignore "Eta reduce" -}++{-# OPTIONS_GHC -Wno-orphans #-}++module Effectful.Zoo.Hedgehog.Effect.Hedgehog+  ( Hedgehog,+    HedgehogEnv(..),+    runHedgehogProperty,+    runHedgehogUnit,+  ) where++import Control.Concurrent.STM qualified as IO+import Control.Monad+import Control.Monad.Catch (MonadThrow(..))+import Effectful+import Effectful.Concurrent+import Effectful.Concurrent.STM+import Effectful.Dispatch.Static+import Effectful.Zoo.Core+import Effectful.Zoo.Error.Static+import Effectful.Zoo.Hedgehog.Api.MonadAssertion+import Effectful.Zoo.Hedgehog.Data.TestResult+import HaskellWorks.Prelude+import Hedgehog (MonadTest(..))+import Hedgehog qualified as H+import Hedgehog.Internal.Property qualified as H++-- | An effect for interacting with the filesystem.+data Hedgehog :: Effect++type instance DispatchOf Hedgehog = Static WithSideEffects+newtype instance StaticRep Hedgehog = Hedgehog HedgehogEnv++data HedgehogEnv+  = PropertyEnv (TMVar (H.PropertyT IO ()))+  | UnitTestEnv (TMVar (H.TestT IO ()))++instance {-# OVERLAPS #-}+    ( r <: Concurrent+    , r <: Error H.Failure+    , r <: Hedgehog+    ) => MonadTest (Eff r) where+  liftTest f = do+    Hedgehog env <- getStaticRep+    mvA <- newEmptyTMVarIO+    case env of+      PropertyEnv mvAction ->+        atomically $ putTMVar mvAction (tryExceptAssertion (liftTest f) >>= liftIO . IO.atomically . IO.putTMVar mvA)+      UnitTestEnv mvAction ->+        atomically $ putTMVar mvAction (tryExceptAssertion (liftTest f) >>= liftIO . IO.atomically . IO.putTMVar mvA)+    testResult <- atomically $ takeTMVar mvA+    getTestResult testResult++instance+    ( r <: Error H.Failure+    ) => MonadAssertion (Eff r) where+  throwAssertion f = throw f+  catchAssertion g h = g & trapIn h++getTestResult :: ()+  => r <: Error H.Failure+  => TestResult a+  -> Eff r a+getTestResult = \case+  TestResult a -> pure a+  TestFailure f -> throw f+  TestError e -> throwM e++runHedgehogProperty :: ()+  => r <: IOE+  => TMVar (H.PropertyT IO ())+  -> Eff (Hedgehog : r) a+  -> Eff r a+runHedgehogProperty tvAction =+  evalStaticRep (Hedgehog (PropertyEnv tvAction))++runHedgehogUnit :: ()+  => r <: IOE+  => TMVar (H.TestT IO ())+  -> Eff (Hedgehog : r) a+  -> Eff r a+runHedgehogUnit tvAction =+  evalStaticRep (Hedgehog (UnitTestEnv tvAction))
+ components/hedgehog/Effectful/Zoo/Hedgehog/Effect/HedgehogGen.hs view
@@ -0,0 +1,41 @@+{- HLINT ignore "Eta reduce" -}++{-# OPTIONS_GHC -Wno-orphans #-}++module Effectful.Zoo.Hedgehog.Effect.HedgehogGen+  ( HedgehogGen,+    HedgehogGenEnv(..),+    askHedgehogGenEnv,+    runHedgehogGenProperty,+  ) where++import Effectful+import Effectful.Concurrent.STM+import Effectful.Dispatch.Static+import Effectful.Zoo.Core+import HaskellWorks.Prelude+import Hedgehog qualified as H++-- | An effect for interacting with the filesystem.+data HedgehogGen :: Effect++type instance DispatchOf HedgehogGen = Static WithSideEffects+newtype instance StaticRep HedgehogGen = HedgehogGen HedgehogGenEnv++newtype HedgehogGenEnv+  = HedgehogGenEnv (TMVar (H.PropertyT IO ()))++askHedgehogGenEnv :: ()+  => r <: HedgehogGen+  => Eff r HedgehogGenEnv+askHedgehogGenEnv = do+  HedgehogGen env <- getStaticRep+  pure env++runHedgehogGenProperty :: ()+  => r <: IOE+  => TMVar (H.PropertyT IO ())+  -> Eff (HedgehogGen : r) a+  -> Eff r a+runHedgehogGenProperty tvAction =+  evalStaticRep (HedgehogGen (HedgehogGenEnv tvAction))
+ components/hedgehog/Effectful/Zoo/Hedgehog/Effect/Run.hs view
@@ -0,0 +1,156 @@+{- HLINT ignore "Eta reduce" -}++{-# OPTIONS_GHC -Wno-orphans #-}++module Effectful.Zoo.Hedgehog.Effect.Run+  ( Hedgehog,+    property,+    unit,+    forAll,+  ) where++import Control.Concurrent qualified as IO+import Control.Concurrent.STM qualified as IO+import Control.Exception qualified as IO+import Control.Exception.Lifted qualified as CEL+import Control.Monad+import Effectful+import Effectful.Concurrent+import Effectful.Concurrent.STM+import Effectful.Concurrent.STM qualified as CC+import Effectful.Environment+import Effectful.FileSystem+import Effectful.Zoo.Core+import Effectful.Zoo.Error.Static+import Effectful.Zoo.Hedgehog.Api.Failure+import Effectful.Zoo.Hedgehog.Api.Journal+import Effectful.Zoo.Hedgehog.Api.MonadAssertion+import Effectful.Zoo.Hedgehog.Effect.Hedgehog+import Effectful.Zoo.Hedgehog.Effect.HedgehogGen+import Effectful.Zoo.Log.Data.LogMessage+import Effectful.Zoo.Log.Dynamic+import Effectful.Zoo.Resource+import HaskellWorks.Control.Monad+import HaskellWorks.Prelude+import HaskellWorks.ToText+import Hedgehog (Gen)+import Hedgehog qualified as H+import Hedgehog.Internal.Property qualified as H++property :: ()+  => Eff+      [ Log Text+      , HedgehogGen+      , Hedgehog+      , Error H.Failure+      , Resource+      , FileSystem+      , Environment+      , Concurrent+      , IOE+      ] ()+  -> H.PropertyT IO ()+property f = do+  tvResult <- liftIO IO.newEmptyTMVarIO+  tvAction <- liftIO IO.newEmptyTMVarIO+  CEL.bracket+    do  liftIO $ IO.forkFinally+          do  f+                & runLog @Text (ConcUnlift Persistent Unlimited) logTextToHedgehog+                & runHedgehogGenProperty tvAction+                & runHedgehogProperty tvAction+                & runError @H.Failure+                & runResource+                & runFileSystem+                & runEnvironment+                & runConcurrent+                & runEff+          (liftIO . IO.atomically . IO.putTMVar tvResult)+    do liftIO . IO.killThread+    do \_ -> do+        whileNothingM do+          mActionOrResult <- liftIO $ IO.atomically do+            mAction <- CC.tryTakeTMVar tvAction+            case mAction of+              Nothing -> do+                mResult <- CC.tryTakeTMVar tvResult+                case mResult of+                  Nothing -> pure Nothing+                  Just a -> pure $ Just $ Right a+              Just action -> pure $ Just $ Left action++          case mActionOrResult of+            Nothing -> pure Nothing+            Just (Left action) -> action >> pure Nothing+            Just (Right (Left e)) -> liftIO $ IO.throwIO e+            Just (Right (Right (Left (_, e)))) -> throwAssertion e+            Just (Right (Right (Right a))) -> pure $ Just a++logTextToHedgehog :: ()+  => r <: Concurrent+  => r <: Hedgehog+  => r <: Error Failure+  => CallStack+  -> LogMessage Text+  -> Eff r ()+logTextToHedgehog callStack msg = do+  let LogMessage severity text = msg+  jotTextWithCallStack callStack $ toText severity <> " " <> text++unit :: ()+  => Eff+      [ Log Text+      , Hedgehog+      , Error H.Failure+      , Resource+      , FileSystem+      , Environment+      , Concurrent+      , IOE+      ] ()+  -> H.TestT IO ()+unit f = do+  tvResult <- liftIO IO.newEmptyTMVarIO+  tvAction <- liftIO IO.newEmptyTMVarIO+  CEL.bracket+    do  liftIO $ IO.forkFinally+          do  f & runLog @Text (ConcUnlift Persistent Unlimited) logTextToHedgehog+                & runHedgehogUnit tvAction+                & runError @H.Failure+                & runResource+                & runFileSystem+                & runEnvironment+                & runConcurrent+                & runEff+          (liftIO . IO.atomically . IO.putTMVar tvResult)+    do liftIO . IO.killThread+    do \_ -> do+        whileNothingM do+          mActionOrResult <- liftIO $ IO.atomically do+            mAction <- CC.tryTakeTMVar tvAction+            case mAction of+              Nothing -> do+                mResult <- CC.tryTakeTMVar tvResult+                case mResult of+                  Nothing -> pure Nothing+                  Just a -> pure $ Just $ Right a+              Just action -> pure $ Just $ Left action++          case mActionOrResult of+            Nothing -> pure Nothing+            Just (Left action) -> action >> pure Nothing+            Just (Right (Left e)) -> liftIO $ IO.throwIO e+            Just (Right (Right (Left (_, e)))) -> throwAssertion e+            Just (Right (Right (Right a))) -> pure $ Just a++forAll :: ()+  => r <: Concurrent+  => r <: HedgehogGen+  => Show a+  => Gen a+  -> Eff r a+forAll gen = do+  HedgehogGenEnv mvAction <- askHedgehogGenEnv+  mvA <- newEmptyTMVarIO+  atomically $ putTMVar mvAction (H.forAll gen >>= liftIO . IO.atomically . IO.putTMVar mvA)+  atomically $ takeTMVar mvA
− components/hedgehog/Effectful/Zoo/Hedgehog/MonadTestProxy.hs 
@@ -1,31 +0,0 @@-module Effectful.Zoo.Hedgehog.MonadTestProxy-  ( MonadTestProxy(..),-  ) where--import Control.Monad.Trans.Writer.Lazy qualified as MTL-import Data.Functor.Identity-import Effectful-import Effectful.Error.Static-import Effectful.Writer.Static.Local-import Effectful.Zoo.Core-import HaskellWorks.Prelude-import Hedgehog (MonadTest(..))-import Hedgehog.Internal.Property (Failure, Journal)-import Hedgehog.Internal.Property qualified as H--class Monad m => MonadTestProxy m where-  liftTestProxy :: H.Test a -> m a--instance MonadTestProxy (H.TestT IO) where-  liftTestProxy = liftTest--instance (r <: Error Failure, r <: Writer Journal) => MonadTestProxy (Eff r) where-  liftTestProxy = \case-    H.TestT m -> do-      let (result, journal) = runIdentity $ MTL.runWriterT $ runExceptT m-      tell journal-      case result of-        Left (H.Failure loc err diff) ->-          throwError (H.Failure loc err diff)-        Right a ->-          pure a
+ components/rds-data-test/Effectful/Zoo/RdsData/Test/Cluster.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE NumericUnderscores  #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++{- HLINT ignore "Redundant id" -}+{- HLINT ignore "Redundant pure" -}+{- HLINT ignore "Use let" -}++module Effectful.Zoo.RdsData.Test.Cluster+  ( RdsClusterDetails(..),+    createRdsDbCluster,+    waitUntilRdsDbClusterAvailable,+  ) where++import Amazonka qualified as AWS+import Amazonka.RDS qualified as AWS+import Amazonka.SecretsManager qualified as AWS+import Data.Aeson ((.=))+import Data.Aeson qualified as J+import Data.ByteString.Base64 qualified as B64+import Data.ByteString.Lazy qualified as LBS+import Data.Function+import Data.Generics.Product.Any+import Data.RdsData.Migration.Types (RdsClusterDetails (RdsClusterDetails))+import Data.Text.Encoding qualified as T+import Data.UUID qualified as UUID+import Data.UUID.V4 qualified as UUID+import Effectful+import Effectful.Concurrent+import Effectful.Zoo.Amazonka.Api.Send+import Effectful.Zoo.Amazonka.Data.AwsError+import Effectful.Zoo.Amazonka.Data.AwsLogEntry+import Effectful.Zoo.Amazonka.Dynamic+import Effectful.Zoo.Core+import Effectful.Zoo.DataLog.Dynamic+import Effectful.Zoo.Error.Static+import Effectful.Zoo.Hedgehog.Api.Assert+import Effectful.Zoo.Hedgehog.Api.Failure+import Effectful.Zoo.Hedgehog.Api.Journal+import Effectful.Zoo.Hedgehog.Effect.Hedgehog+import Effectful.Zoo.TestContainers.LocalStack+import HaskellWorks.Control.Monad+import HaskellWorks.Prelude+import Lens.Micro++createRdsDbCluster :: ()+  => HasCallStack+  => r <: Amazonka+  => r <: Concurrent+  => r <: Error Failure+  => r <: Hedgehog+  => r <: IOE+  => Text+  -> IO Container+  -> Eff r RdsClusterDetails+createRdsDbCluster databaseName getContainer = withFrozenCallStack do+  container <- liftIO getContainer+  jotShowM_ $ getLocalStackEndpoint container+  jotYamlM_ $ inspectContainer container+  masterUsername <- pure "masterUsername"+  masterPassword <- pure "masterPassword"++  let dbClusterId = "my-cluster"++  createDbClusterRequest <-+    pure $+      AWS.newCreateDBCluster dbClusterId "aurora-postgresql"+        & the @"masterUsername" .~ Just masterUsername+        & the @"masterUserPassword" .~ Just masterPassword+        & the @"enableHttpEndpoint" .~ Just True+        & the @"databaseName" .~ Just databaseName++  createDbClusterResponse <-+    sendAws createDbClusterRequest+      & trapFail @AwsError+      & jotShowDataLog @AwsLogEntry+++  -- sendAws :: forall a r. ()+  --   => HasCallStack+  --   => AwsRequest a+  --   => r <: Amazonka+  --   => r <: DataLog AwsLogEntry+  --   => r <: Error AwsError+  --   => r <: IOE+  --   => Typeable (AwsResponse a)+  --   => Typeable a+  --   => a+  --   -> Eff r (AwsResponse a)++  -- jotShowDataLog :: forall i a r. ()+  --   => HasCallStack+  --   => Show i+  --   => r <: Concurrent+  --   => r <: Error Failure+  --   => r <: Hedgehog+  --   => Eff (DataLog i : r) a+  --   -> Eff r a++  let secretName = "my-aurora-cluster"++  secretString <-+    jotYaml $+      J.object+        [ "engine" .= id @Text "aurora-postgresql"+        , "username" .= id @Text masterUsername+        , "password" .= id @Text masterPassword+        , "host" .= id @Text "localhost"+        , "dbname" .= id @Text databaseName+        , "port" .= id @Text "4510"+        ]++  uuid <- liftIO UUID.nextRandom++  let clientRequestToken = T.encodeUtf8 $ UUID.toText uuid++  let secretStringText = T.decodeUtf8 $ LBS.toStrict $ J.encode secretString++  createSecretReq <-+    pure $+      AWS.newCreateSecret secretName+        & the @"secretString" ?~ AWS.Sensitive secretStringText+        & the @"clientRequestToken" ?~ T.decodeUtf8 (B64.encode clientRequestToken)++  createSecetResp <-+    sendAws createSecretReq+      & trapFail+      & jotShowDataLog @AwsLogEntry++  createDbInstanceReq <-+    pure $+      AWS.newCreateDBInstance dbClusterId "my-db-instance" "db.t3.medium"+        & the @"engine" .~ "aurora-postgresql"++  _dbInstanceIdResp <-+    jotShowM $+      sendAws createDbInstanceReq+        & trapFail+        & jotShowDataLog @AwsLogEntry++  pure (RdsClusterDetails createDbClusterResponse createSecetResp)++waitUntilRdsDbClusterAvailable :: ()+  => HasCallStack+  => r <: Amazonka+  => r <: Concurrent+  => r <: DataLog AwsLogEntry+  => r <: Error AWS.Error+  => r <: IOE+  => Text+  -> Eff r ()+waitUntilRdsDbClusterAvailable dbClusterArn =+  withFrozenCallStack do+    repeatNWhileM_ 120 $ \_ -> do+      result <- sendAws $+        AWS.newDescribeDBClusters+          & the @"dbClusterIdentifier" .~ Just dbClusterArn++      let mStatus = result ^? the @"dbClusters" . _Just . each . the @"status" . _Just++      if mStatus == Just "available"+        then threadDelay 1_000_000 >> pure False+        else threadDelay 1_000_000 >> pure True
+ components/rds-data-test/Effectful/Zoo/RdsData/Test/Env.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++{- HLINT ignore "Redundant pure" -}+{- HLINT ignore "Use let" -}++module Effectful.Zoo.RdsData.Test.Env+  ( AwsResourceArn(..),+    AwsSecretArn(..),+    runLocalTestEnv,+    runTestEnv,+    runReaderFromEnvOrFail,+    runReaderStatementContextFromClusterDetails,+  ) where++import Amazonka qualified as AWS+import Data.Generics.Product.Any+import Data.RdsData.Aws+import Data.RdsData.Migration.Types+import Effectful+import Effectful.Concurrent+import Effectful.Zoo.Amazonka.Api.Run+import Effectful.Zoo.Core+import Effectful.Zoo.Environment+import Effectful.Zoo.Error.Static+import Effectful.Zoo.Hedgehog.Api+import Effectful.Zoo.Hedgehog.Effect.Hedgehog+import Effectful.Zoo.Reader.Static+import Effectful.Zoo.TestContainers.LocalStack+import HaskellWorks.Prelude+import Lens.Micro++runTestEnv :: ()+  => HasCallStack+  => r <: Concurrent+  => r <: Environment+  => r <: Error Failure+  => r <: Hedgehog+  => r <: IOE+  => Eff+        ( Reader AWS.Env+        : Reader AwsResourceArn+        : Reader AwsSecretArn+        : r)+      a+  -> Eff r a+runTestEnv f =+  withFrozenCallStack $ f+    & runReaderAwsEnvDiscover+    & runReaderFromEnvOrFail AwsResourceArn "AURORA_RESOURCE_ARN"+    & runReaderFromEnvOrFail AwsSecretArn "AURORA_SECRET_ARN"++runLocalTestEnv :: ()+  => HasCallStack+  => r <: IOE+  => IO Container+  -> Eff+        ( Reader AWS.Env+        : r)+      a+  -> Eff r a+runLocalTestEnv getContainer f =+  withFrozenCallStack $ f+    & runReaderLocalAwsEnvDiscover getContainer++runReaderFromEnvOrFail :: forall i r a. ()+  => r <: Concurrent+  => r <: Environment+  => r <: Error Failure+  => r <: Hedgehog+  => (Text -> i)+  -> Text+  -> Eff (Reader i ': r) a+  -> Eff r a+runReaderFromEnvOrFail f envVar action = do+  env <- lookupEnv envVar+    & trapFail++  runReader (f env) action++runReaderStatementContextFromClusterDetails :: ()+  => r <: Concurrent+  => r <: Error Failure+  => r <: Hedgehog+  => RdsClusterDetails+  -> Eff (Reader StatementContext : r) a+  -> Eff r a+runReaderStatementContextFromClusterDetails details f = do+  resourceArn <- (details ^. the @"createDbClusterResponse" . the @"dbCluster" . _Just . the @"dbClusterArn")+    & onNothingFail++  secretArn <- (details ^. the @"createSecretResponse" ^. the @"arn")+    & onNothingFail++  mDatabase <- pure $ (details ^? the @"createDbClusterResponse" . the @"dbCluster" . _Just . the @"databaseName" . _Just)+    <&> Database++  statementContext <- pure $ newStatementContext (AwsResourceArn resourceArn) (AwsSecretArn secretArn)+    & the @"database" .~ mDatabase+++  f & runReader statementContext
+ components/rds-data-test/Effectful/Zoo/RdsData/Test/Workspace.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}++module Effectful.Zoo.RdsData.Test.Workspace+  ( localWorkspace,+  ) where++import Data.Text qualified as T+import Effectful+import Effectful.Concurrent+import Effectful.Zoo.Core+import Effectful.Zoo.Environment+import Effectful.Zoo.Error.Static+import Effectful.Zoo.FileSystem+import Effectful.Zoo.Hedgehog.Api+import Effectful.Zoo.Hedgehog.Api.Workspace+import Effectful.Zoo.Hedgehog.Effect.Hedgehog+import Effectful.Zoo.Log.Dynamic+import Effectful.Zoo.Reader.Static+import HaskellWorks.Prelude++localWorkspace :: ()+  => HasCallStack+  => r <: Concurrent+  => r <: Environment+  => r <: Error Failure+  => r <: FileSystem+  => r <: Hedgehog+  => r <: Log Text+  => Text+  -> Eff+        ( Reader Workspace+        : Reader ProjectRoot+        : Reader PackagePath+        : r)+        ()+  -> Eff r ()+localWorkspace prefix f =+  withFrozenCallStack $ do+    cabalProjectDir <- findCabalProjectDir "."++    f & moduleWorkspace (T.unpack prefix)+      & runReader (ProjectRoot cabalProjectDir)+      & runReader (PackagePath "rds-data")
components/rds-data/Effectful/Zoo/RdsData/Core.hs view
@@ -24,8 +24,8 @@ import Effectful.Zoo.Amazonka.Data import Effectful.Zoo.Amazonka.Dynamic import Effectful.Zoo.Core-import Effectful.Zoo.Core.Error.Static import Effectful.Zoo.DataLog.Dynamic+import Effectful.Zoo.Error.Static import Effectful.Zoo.Log.Api import Effectful.Zoo.Log.Dynamic import Effectful.Zoo.RdsData.Errors
+ components/testcontainers-localstack/Effectful/Zoo/TestContainers/LocalStack.hs view
@@ -0,0 +1,139 @@+{- HLINT ignore "Use camelCase" -}++module Effectful.Zoo.TestContainers.LocalStack (+    LocalStackEndpoint (..),+    TC.Container,+    setupContainers,+    setupContainers',+    waitForLocalStack,++    runReaderLocalAwsEnvDiscover,+    getLocalStackEndpoint,+    inspectContainer,+) where++import Amazonka qualified as AWS+import Amazonka.Auth qualified as AWS+import Control.Concurrent (threadDelay)+import Control.Concurrent qualified as IO+import Control.Exception  (try)+import Control.Exception qualified as E+import Control.Monad.IO.Class+import Data.Aeson qualified as J+import Data.ByteString.Lazy qualified as LBS+import Data.Function+import Data.Generics.Product.Any+import Data.Text qualified as T+import Data.Time.Clock.POSIX (getPOSIXTime)+import Effectful+import Effectful.Zoo.Core+import Effectful.Zoo.Reader.Static+import Effectful.Zoo.TestContainers.LocalStack.Types (LocalStackEndpoint (LocalStackEndpoint))+import Effectful.Zoo.TestContainers.LocalStack.Types qualified as Z+import HaskellWorks.Prelude+import Lens.Micro+import Network.HTTP.Conduit (HttpException, simpleHttp)+import System.Environment qualified as IO+import System.IO qualified as IO+import TestContainers.Monad qualified as TC+import TestContainers.Tasty qualified as TC++-- | Sets up and runs the containers required for this test suite.+setupContainers ::+    () =>+    (TC.MonadDocker m) =>+    m TC.Container+setupContainers = setupContainers' "localstack/localstack-pro:latest"++-- | Sets up and runs the containers required for this test suite.+setupContainers' ::+    () =>+    (TC.MonadDocker m) =>+    Text ->+    m TC.Container+setupContainers' dockerTag = do+    authToken <- liftIO $ IO.lookupEnv "LOCALSTACK_AUTH_TOKEN"+    -- Launch the container based on the postgres image.+    localstackContainer <-+        TC.run $+            TC.containerRequest (TC.fromTag dockerTag)+                & TC.setEnv [("LOCALSTACK_AUTH_TOKEN", maybe "" T.pack authToken)]+                -- Expose the port 4566 from within the container. The respective port+                -- on the host machine can be looked up using `containerPort` (see below).+                & TC.setExpose+                    ( mconcat+                        [ [4566]+                        ]+                    )+                -- Wait until the container is ready to accept requests. `run` blocks until+                -- readiness can be established.+                & TC.setWaitingFor (TC.waitUntilMappedPortReachable 4566)++    -- Look up the corresponding port on the host machine for the exposed port 4566.+    let localStackPort = TC.containerPort localstackContainer 4566++    liftIO $ waitForLocalStack "localhost" localStackPort 100++    pure localstackContainer++waitForLocalStack :: String -> Int -> Int -> IO ()+waitForLocalStack host port timeout = do+    startTime <- getPOSIXTime+    let url = "http://" <> host <> ":" <> show port+    checkLoop startTime url+  where+    checkLoop startTime url = do+        result <- try $ simpleHttp url :: IO (Either HttpException LBS.ByteString)+        case result of+            Right _ -> do+                IO.threadDelay 1_000_000+                IO.putStrLn ""+            Left e -> do+                currentTime <- getPOSIXTime+                let elapsedTime = currentTime - startTime+                when (elapsedTime < fromIntegral timeout) $ do+                    threadDelay 500_000+                    checkLoop startTime url+                when (elapsedTime >= fromIntegral timeout) $ do+                    IO.putStrLn "Timeout reached. LocalStack is not ready."+                    E.throw e++runReaderLocalAwsEnvDiscover :: forall a r. ()+  => r <: IOE+  => IO TC.Container+  -> Eff (Reader AWS.Env : r) a+  -> Eff r a+runReaderLocalAwsEnvDiscover mk f = do+  container <- liftIO mk+  ep <- getLocalStackEndpoint container++  logger' <- liftIO $ AWS.newLogger AWS.Debug IO.stdout++  let creds = AWS.fromKeys (AWS.AccessKey "test") (AWS.SecretKey "test")++  credEnv <- liftIO $ AWS.newEnv (AWS.runCredentialChain [pure . creds])++  awsEnv <- pure $+    credEnv+      & the @"logger" .~ logger'+      & the @"overrides" %~ (. AWS.setEndpoint False "localhost" ep.port)++  runReader awsEnv f++getLocalStackEndpoint :: ()+  => TC.Container+  -> Eff r LocalStackEndpoint+getLocalStackEndpoint container = do+  let localStackPort = TC.containerPort container 4566++  pure Z.LocalStackEndpoint+    { Z.host = "0.0.0.0"+    , Z.port = localStackPort+    }++inspectContainer :: ()+  => r <: IOE+  => TC.Container+  -> Eff r J.Value+inspectContainer container =+  liftIO $ TC.runTestContainer TC.defaultDockerConfig $ TC.inspect container
+ components/testcontainers-localstack/Effectful/Zoo/TestContainers/LocalStack/Types.hs view
@@ -0,0 +1,10 @@+module Effectful.Zoo.TestContainers.LocalStack.Types+  ( LocalStackEndpoint(..)+  ) where++import HaskellWorks.Prelude++data LocalStackEndpoint = LocalStackEndpoint+  { host :: String+  , port :: Int+  } deriving stock (Eq, Show, Generic)
effectful-zoo.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.4  name:                   effectful-zoo-version:                0.0.2.0+version:                0.0.3.0 synopsis:               Effectful effects for testing description:            See https://hackage.haskell.org/package/effectful-zoo/docs/effectful-zoo.html category:               Development@@ -16,6 +16,11 @@ extra-doc-files:        README.md                         CHANGELOG.md +flag dev+  description: Enable development mode+  manual: True+  default: False+ source-repository head   type: git   location: https://github.com/haskell-works/effectful-zoo@@ -26,31 +31,49 @@ common aeson-pretty               { build-depends: aeson-pretty               >= 0.8.10     && < 1      } common amazonka                   { build-depends: amazonka                   >= 2          && < 3      } common amazonka-core              { build-depends: amazonka-core              >= 2          && < 3      }+common amazonka-rds               { build-depends: amazonka-rds               >= 2          && < 3      } common amazonka-rds-data          { build-depends: amazonka-rds-data          >= 2          && < 3      }+common amazonka-secretsmanager    { build-depends: amazonka-secretsmanager    >= 2          && < 3      }+common base64-bytestring          { build-depends: base64-bytestring          >= 1.2.1      && < 2      }+common binary                     { build-depends: binary                     >= 0.8.9      && < 0.9    } common blockfrost-api             { build-depends: blockfrost-api             >= 0.11       && < 0.12   } common blockfrost-client          { build-depends: blockfrost-client          >= 0.8        && < 0.9    } common bytestring                 { build-depends: bytestring                 >= 0.11       && < 1      }+common directory                  { build-depends: directory                  >= 1.2        && < 2      } common effectful                  { build-depends: effectful                  >= 2.5        && < 3      } common effectful-core             { build-depends: effectful-core             >= 2.5        && < 3      } common effectful-plugin           { build-depends: effectful-plugin           >= 1.1.0.4    && < 2      }+common exceptions                 { build-depends: exceptions                 >= 0.10       && < 0.11   }+common filepath                   { build-depends: filepath                   >= 1.4        && < 2      } common generic-lens               { build-depends: generic-lens               >= 2.2.2      && < 3      } common hedgehog                   { build-depends: hedgehog                   >= 1.5        && < 2      }+common http-conduit               { build-depends: http-conduit               >= 2.3.9.1    && < 3      } common HUnit                      { build-depends: HUnit                      >= 1.6.2      && < 2      }-common hw-prelude                 { build-depends: hw-prelude                 >= 0.0.4.2    && < 0.1    }+common hw-prelude                 { build-depends: hw-prelude                 >= 0.0.4.4    && < 0.1    }+common lifted-base                { build-depends: lifted-base                >= 0.2.3.12   && < 0.3    } common microlens                  { build-depends: microlens                  >= 0.4.13.1   && < 0.5    }+common process                    { build-depends: process                    >= 1.6.19     && < 2      } common rds-data-codecs            { build-depends: rds-data:codecs            >= 0.1.1.1    && < 0.2    } common resourcet                  { build-depends: resourcet                  >= 1.3        && < 2      } common resourcet-effectful        { build-depends: resourcet-effectful        >= 1.0.1      && < 2      }-common tasty                      { build-depends: tasty                      >= 1.4.3      && < 1.5    }+common stm                        { build-depends: stm                        >= 2.5.1      && < 3      }+common tasty                      { build-depends: tasty                      >= 1.5        && < 2      }+common tasty-discover             { build-depends: tasty-discover             >= 5          && < 6      } common tasty-hedgehog             { build-depends: tasty-hedgehog             >= 1.1.0.0    && < 1.5    }+common temporary                  { build-depends: temporary                  >= 1.3        && < 2      }+common testcontainers             { build-depends: testcontainers             >= 0.5        && < 0.6    } common text                       { build-depends: text                       >= 2          && < 3      } common time                       { build-depends: time                       >= 1.12       && < 2      } common transformers               { build-depends: transformers               >= 0.5.6.2    && < 0.7    }+common ulid                       { build-depends: ulid                       >= 0.3.2      && < 0.4    }+common uuid                       { build-depends: uuid                       >= 1.3.16     && < 2      } common yaml                       { build-depends: yaml                       >= 0.11.11.2  && < 1      } -common effectful-zoo-amazonka     { build-depends: effectful-zoo:amazonka                               }-common effectful-zoo-core         { build-depends: effectful-zoo:core                                   }-common effectful-zoo-hedgehog     { build-depends: effectful-zoo:hedgehog                               }+common effectful-zoo-amazonka                   { build-depends: effectful-zoo:amazonka                   }+common effectful-zoo-core                       { build-depends: effectful-zoo:core                       }+common effectful-zoo-hedgehog                   { build-depends: effectful-zoo:hedgehog                   }+common effectful-zoo-rds-data                   { build-depends: effectful-zoo:rds-data                   }+common effectful-zoo-testcontainers-localstack  { build-depends: effectful-zoo:testcontainers-localstack  }  common project-config   default-extensions:   AllowAmbiguousTypes@@ -97,21 +120,28 @@                         -Wredundant-constraints                         -Wunused-packages   default-language:     GHC2021+  if (flag(dev))+    ghc-options:        -Werror  library core   import:               base, project-config,                         aeson,                         bytestring,+                        directory,                         effectful-core,                         effectful-core,                         effectful-plugin,                         effectful,                         hw-prelude,+                        process,+                        resourcet-effectful,                         text,+                        temporary,                         time,                         yaml,   visibility:           public-  exposed-modules:      Effectful.Zoo.Console.Data.Writer+  exposed-modules:      Effectful.Zoo.Aeson+                        Effectful.Zoo.Console.Data.Writer                         Effectful.Zoo.Console.Dynamic                         Effectful.Zoo.Console.Dynamic.Api                         Effectful.Zoo.Console.Dynamic.Effect@@ -119,17 +149,19 @@                         Effectful.Zoo.Console.Effect                         Effectful.Zoo.Console.Static                         Effectful.Zoo.Core-                        Effectful.Zoo.Core.Error.Dynamic-                        Effectful.Zoo.Core.Error.Static-                        Effectful.Zoo.Core.Exception-                        Effectful.Zoo.Core.Function-                        Effectful.Zoo.Core.Prim                         Effectful.Zoo.DataLog.Api                         Effectful.Zoo.DataLog.Data.DataLogger                         Effectful.Zoo.DataLog.Data.LogEntry                         Effectful.Zoo.DataLog.Dynamic                         Effectful.Zoo.DataLog.Static+                        Effectful.Zoo.Environment+                        Effectful.Zoo.Error.Dynamic+                        Effectful.Zoo.Error.Static+                        Effectful.Zoo.Errors.EnvironmentVariableInvalid+                        Effectful.Zoo.Errors.EnvironmentVariableMissing+                        Effectful.Zoo.Exception                         Effectful.Zoo.FileSystem+                        Effectful.Zoo.Function                         Effectful.Zoo.Lazy.Dynamic                         Effectful.Zoo.Log.Api                         Effectful.Zoo.Log.Api.Generic@@ -142,6 +174,10 @@                         Effectful.Zoo.Log.Data.Severity                         Effectful.Zoo.Log.Dynamic                         Effectful.Zoo.Log.Static+                        Effectful.Zoo.Prim+                        Effectful.Zoo.Process+                        Effectful.Zoo.Reader.Static+                        Effectful.Zoo.Resource                         Effectful.Zoo.Unsafe   ghc-options:          -fplugin=Effectful.Plugin   hs-source-dirs:       components/core@@ -220,32 +256,91 @@   ghc-options:          -fplugin=Effectful.Plugin   hs-source-dirs:       components/rds-data -library hedgehog+library rds-data-test   import:               base, project-config,                         aeson,+                        amazonka,+                        amazonka-rds,+                        amazonka-secretsmanager,+                        base64-bytestring,+                        bytestring,+                        effectful,+                        effectful-core,+                        effectful-plugin,+                        effectful-zoo-amazonka,+                        effectful-zoo-core,+                        effectful-zoo-hedgehog,+                        effectful-zoo-testcontainers-localstack,+                        generic-lens,+                        hw-prelude,+                        microlens,+                        rds-data-codecs,+                        text,+                        uuid,+  visibility:           public+  exposed-modules:      Effectful.Zoo.RdsData.Test.Cluster+                        Effectful.Zoo.RdsData.Test.Env+                        Effectful.Zoo.RdsData.Test.Workspace+  ghc-options:          -fplugin=Effectful.Plugin+  hs-source-dirs:       components/rds-data-test++library hedgehog+  import:               base, project-config,                         aeson-pretty,+                        aeson,+                        binary,                         bytestring,                         effectful-core,                         effectful-plugin,                         effectful-zoo-core,+                        effectful,+                        exceptions,+                        filepath,                         hedgehog,                         hw-prelude,+                        lifted-base,+                        resourcet,+                        stm,+                        tasty-discover,                         tasty-hedgehog,                         tasty,                         text,+                        time,                         transformers,+                        ulid,                         yaml,   visibility:           public   exposed-modules:      Effectful.Zoo.Hedgehog                         Effectful.Zoo.Hedgehog.Api                         Effectful.Zoo.Hedgehog.Api.Assert-                        Effectful.Zoo.Hedgehog.Api.Classify-                        Effectful.Zoo.Hedgehog.Api.Eval                         Effectful.Zoo.Hedgehog.Api.Failure+                        Effectful.Zoo.Hedgehog.Api.Gen+                        Effectful.Zoo.Hedgehog.Api.Gen.Time+                        Effectful.Zoo.Hedgehog.Api.Gen.Ulid+                        Effectful.Zoo.Hedgehog.Api.Hedgehog+                        Effectful.Zoo.Hedgehog.Api.Internal.Cabal+                        Effectful.Zoo.Hedgehog.Api.Internal.Cabal.Types+                        Effectful.Zoo.Hedgehog.Api.Internal.FilePath+                        Effectful.Zoo.Hedgehog.Api.Internal.OS                         Effectful.Zoo.Hedgehog.Api.Journal-                        Effectful.Zoo.Hedgehog.Api.Run-                        Effectful.Zoo.Hedgehog.Dynamic-                        Effectful.Zoo.Hedgehog.MonadTestProxy+                        Effectful.Zoo.Hedgehog.Api.MonadAssertion+                        Effectful.Zoo.Hedgehog.Api.Process+                        Effectful.Zoo.Hedgehog.Api.Process.Internal+                        Effectful.Zoo.Hedgehog.Api.Range+                        Effectful.Zoo.Hedgehog.Api.Stack+                        Effectful.Zoo.Hedgehog.Api.Tasty+                        Effectful.Zoo.Hedgehog.Api.Tasty.Orphans+                        Effectful.Zoo.Hedgehog.Api.Workspace+                        Effectful.Zoo.Hedgehog.Data+                        Effectful.Zoo.Hedgehog.Data.PackagePath+                        Effectful.Zoo.Hedgehog.Data.ProjectRoot+                        Effectful.Zoo.Hedgehog.Data.PropertyTest+                        Effectful.Zoo.Hedgehog.Data.TestResult+                        Effectful.Zoo.Hedgehog.Data.UnitTest+                        Effectful.Zoo.Hedgehog.Data.Workspace+                        Effectful.Zoo.Hedgehog.Effect.Hedgehog+                        Effectful.Zoo.Hedgehog.Effect.HedgehogGen+                        Effectful.Zoo.Hedgehog.Effect.Run   ghc-options:          -fplugin=Effectful.Plugin   hs-source-dirs:       components/hedgehog @@ -258,16 +353,38 @@   exposed-modules:      Effectful.Zoo.HUnit   hs-source-dirs:       components/hunit -test-suite effectful-zoo-test-  import:               project-config,+library testcontainers-localstack+  import:               base, project-config,+                        aeson,+                        amazonka,+                        bytestring,                         effectful-core,+                        effectful-plugin,                         effectful-zoo-core,+                        generic-lens,+                        http-conduit,+                        hw-prelude,+                        microlens,+                        testcontainers,+                        text,+                        time,+  visibility:           public+  exposed-modules:      Effectful.Zoo.TestContainers.LocalStack+                        Effectful.Zoo.TestContainers.LocalStack.Types+  ghc-options:          -fplugin=Effectful.Plugin+  hs-source-dirs:       components/testcontainers-localstack++test-suite effectful-zoo-test+  import:               base, project-config,                         effectful-zoo-hedgehog,+                        hedgehog,                         hw-prelude,                         tasty,+                        tasty-discover,   type:                 exitcode-stdio-1.0   main-is:              Main.hs-  other-modules:        Effectful.Zoo.Hedgehog.Test.HedgehogTest+  other-modules:        Effectful.Zoo.Hedgehog.Test.PropertySpec+  build-tool-depends:   tasty-discover:tasty-discover   hs-source-dirs:       components/hedgehog-test   ghc-options:          -threaded                         -rtsopts