hw-polysemy 0.2.3.0 → 0.2.4.0

raw patch · 18 files changed

+585/−337 lines, 18 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• core/HaskellWorks/Error.hs +20/−0
• core/HaskellWorks/Error/Types.hs +18/−0
• core/HaskellWorks/IO/Process.hs +15/−5
• core/HaskellWorks/Polysemy.hs +85/−1
• core/HaskellWorks/Polysemy/Data/ByteString/Strict.hs +0/−25
• core/HaskellWorks/Polysemy/Error.hs +14/−16
• core/HaskellWorks/Polysemy/Error/Types.hs +2/−11
• core/HaskellWorks/Polysemy/File.hs +1/−2
• core/HaskellWorks/Polysemy/Prelude.hs +2/−166
• core/HaskellWorks/Polysemy/System/Process.hs +19/−0
• core/HaskellWorks/Prelude.hs +169/−0
• hedgehog/HaskellWorks/Polysemy/Hedgehog.hs +53/−38
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Golden.hs +12/−8
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Jot.hs +78/−25
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Process.hs +19/−28
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Workspace.hs +39/−10
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Workspace/Types.hs +25/−0
• hw-polysemy.cabal +14/−2

@@ -0,0 +1,20 @@+module HaskellWorks.Error+  ( onLeft+  , onNothing+  , onLeftM+  , onNothingM+  ) where++import           HaskellWorks.Polysemy.Prelude++onLeft :: forall e m a. Monad m => (e -> m a) -> Either e a -> m a+onLeft f = either f pure++onNothing :: forall a m. Monad m => m a -> Maybe a -> m a+onNothing h = maybe h return++onLeftM :: forall e m a. Monad m => (e -> m a) -> m (Either e a) -> m a+onLeftM f action = onLeft f =<< action++onNothingM :: forall a m. Monad m => m a -> m (Maybe a) -> m a+onNothingM h f = onNothing h =<< f

@@ -0,0 +1,18 @@+{-# LANGUAGE DeriveGeneric #-}++module HaskellWorks.Error.Types+  ( GenericError(..)+  , TimedOut(..)+  ) where++import           HaskellWorks.Polysemy.Prelude++newtype GenericError = GenericError+  { message :: Text+  }+  deriving (Generic, Eq, Show)++newtype TimedOut = TimedOut+  { message :: Text+  }+  deriving (Generic, Eq, Show)

@@ -1,20 +1,21 @@ module HaskellWorks.IO.Process   ( maybeWaitForProcess+  , waitSecondsForProcess   ) where -import qualified Control.Concurrent       as IO-import           Control.Concurrent.Async-import qualified Control.Concurrent.Async as IO+import           Control.Concurrent       as IO+import           Control.Concurrent.Async as IO import qualified Control.Exception        as IO import           Data.Maybe import           System.Exit import           System.IO-import qualified System.Process           as IO  import           Control.Applicative import           Data.Function import           Data.Functor-import           GHC.Stack                (HasCallStack, withFrozenCallStack)+import           HaskellWorks.Error.Types+import           HaskellWorks.Prelude+import qualified System.Process           as IO import           System.Process  maybeWaitForProcess :: ()@@ -22,3 +23,12 @@   -> IO (Maybe ExitCode) maybeWaitForProcess hProcess =   IO.catch (fmap Just (IO.waitForProcess hProcess)) $ \(_ :: AsyncCancelled) -> pure Nothing++waitSecondsForProcess :: ()+  => Int+  -> ProcessHandle+  -> IO (Either TimedOut (Maybe ExitCode))+waitSecondsForProcess seconds hProcess =+  IO.race+    (IO.threadDelay (seconds * 1000000) >> pure (TimedOut "Timed out waiting for process"))+    (maybeWaitForProcess hProcess)

@@ -1,1 +1,85 @@-module HaskellWorks.Polysemy () where+module HaskellWorks.Polysemy+  ( Member,+    Members,+    Sem,+    send,+    makeSem,+    makeSem_,++    Final,+    runFinal,++    Async,+    async,+    await,+    cancel,+    sequenceConcurrently,++    DataLog,+    Log,+    LogEntry,+    Logger,+    LogMessage,+    Severity,+    dataLog,+    log,+    trace,+    debug,+    info,+    warn,+    error,+    crit,+    formatLogEntry,+    parseSeverity,+    setLogLevel,+    setLogLevelWith,++    Embed,+    embed,+    embedToFinal,+    runEmbedded,++    Error,+    throw,+    catch,+    trap,+    trap_,+    fromEither,+    fromEitherM,+    fromException,+    fromExceptionVia,+    note,+    try,+    tryJust,+    catchJust,+    mapError,+    onLeft,+    onNothing,+    onLeftM,+    onNothingM,+    runError,++    Reader,+    ask,+    asks,+    inputToReader,+    runReader,++    Resource,+    bracket,+    bracket_,+    bracketOnError,+    finally,+    onException,+    runResource,++  ) where++import           HaskellWorks.Polysemy.Error+import           Polysemy+import           Polysemy.Async+import           Polysemy.Embed+import           Polysemy.Error+import           Polysemy.Log+import           Polysemy.Reader+import           Polysemy.Resource

@@ -150,7 +150,6 @@     -- * I\/O with 'ByteString's      -- ** Standard input and output-    getLine,     getContents,     putStr,     interact,@@ -161,7 +160,6 @@     appendFile,      -- ** I\/O with Handles-    hGetLine,     hGetContents,     hGet,     hGetSome,@@ -241,17 +239,6 @@   r <- embed $ CE.try @IOException BS.getContents   fromEither r -getLine :: ()-  => HasCallStack-  => Member (Error IOException) r-  => Member (Embed IO) r-  => Member Log r-  => Sem r ByteString-getLine = withFrozenCallStack $ do-  debug "Call to: getLine"-  r <- embed $ CE.try @IOException BS.getLine-  fromEither r- putStr :: ()   => HasCallStack   => Member (Error IOException) r@@ -312,18 +299,6 @@ appendFile filePath bs = withFrozenCallStack $ do   info $ "Appending bytestring to file: " <> Text.pack filePath   r <- embed $ CE.try @IOException $ BS.appendFile filePath bs-  fromEither r--hGetLine :: ()-  => HasCallStack-  => Member (Error IOException) r-  => Member (Embed IO) r-  => Member Log r-  => Handle-  -> Sem r ByteString-hGetLine h = withFrozenCallStack $ do-  debug "Call to: hGetLine"-  r <- embed $ CE.try @IOException $ BS.hGetLine h   fromEither r  hGetContents :: ()

@@ -1,30 +1,28 @@ module HaskellWorks.Polysemy.Error-  ( onLeft-  , onNothing-  , onLeftM-  , onNothingM+  ( module HaskellWorks.Error   , trap+  , trap_   ) where +import           HaskellWorks.Error import           HaskellWorks.Polysemy.Prelude import           Polysemy import           Polysemy.Error -onLeft :: Monad m => (e -> m a) -> Either e a -> m a-onLeft f = either f pure--onNothing :: Monad m => m b -> Maybe b -> m b-onNothing h = maybe h return--onLeftM :: Monad m => (e -> m a) -> m (Either e a) -> m a-onLeftM f action = onLeft f =<< action--onNothingM :: Monad m => m b -> m (Maybe b) -> m b-onNothingM h f = onNothing h =<< f-+-- | Run a computation that may fail, and handle the error case.+-- Unlike 'catch' from 'Polysemy.Error' this function removes the 'Error'+-- effect from the stack. trap :: forall e r a. ()   => (e -> Sem r a)   -> Sem (Error e ': r) a   -> Sem r a trap h f =   runError f >>= either h pure++-- | Like 'trap', but the error is not passed to the handler.+trap_ :: forall e r a. ()+  => Sem r a+  -> Sem (Error e ': r) a+  -> Sem r a+trap_ h =+  trap (const h)

@@ -1,14 +1,5 @@ module HaskellWorks.Polysemy.Error.Types-  ( GenericError(..)-  , TimedOut(..)+  ( module HaskellWorks.Error.Types   ) where -import           HaskellWorks.Polysemy.Prelude--newtype GenericError = GenericError-  { message :: Text-  }-  deriving (Eq, Show)--data TimedOut = TimedOut-  deriving (Generic, Eq, Show)+import           HaskellWorks.Error.Types

@@ -1,5 +1,4 @@-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE DeriveGeneric #-}  module HaskellWorks.Polysemy.File   ( JsonDecodeError(..)

@@ -1,169 +1,5 @@ module HaskellWorks.Polysemy.Prelude-  ( Bool(..)-  , Char(..)-  , Maybe(..)-  , Either(..)--  , String-  , Text-  , ByteString-  , Int-  , Int8-  , Int16-  , Int32-  , Int64-  , Integer-  , Word-  , Word8-  , Word16-  , Word32-  , Word64-  , Float-  , Double-  , FilePath-  , Void--  , Eq(..)-  , Ord(..)-  , Num(..)-  , Show(..)-  , IsString(..)-  , tshow--  , bool-  , const--  , absurd-  , vacuous--  , either-  , lefts-  , rights-  , isLeft-  , isRight-  , fromLeft-  , fromRight--  , maybe-  , isJust-  , isNothing-  , fromMaybe-  , listToMaybe-  , maybeToList-  , catMaybes-  , mapMaybe--  , fst-  , flip-  , snd-  , id-  , seq-  , curry-  , uncurry-  , ($!)-  , ($)-  , (&)-  , (&&)-  , (||)-  , (.)-  , (</>)--  , void-  , mapM_-  , forM-  , forM_-  , sequence_-  , (=<<)-  , (>=>)-  , (<=<)-  , forever-  , join-  , msum-  , mfilter-  , filterM-  , foldM-  , foldM_-  , replicateM-  , replicateM_-  , guard-  , when-  , unless-  , liftM-  , liftM2-  , liftM3-  , liftM4-  , liftM5-  , ap-  , (<$!>)--  , (<$>)--  , (<**>)-  , liftA-  , liftA3-  , optional-  , asum--  , for_--  , Monad(..)-  , MonadFail(..)-  , MonadPlus(..)-  , Applicative(..)-  , Alternative(..)-  , Contravariant(..)-  , Divisible(..)-  , Functor(..)-  , Bifunctor(..)-  , Semigroup(..)-  , Monoid(..)-  , Foldable(..)-  , Traversable(..)--  , IO--  , CallStack-  , HasCallStack-  , withFrozenCallStack--  , Generic--  , IOException-  , SomeException(..)+  ( module HaskellWorks.Prelude   ) where -import           Control.Applicative-import           Control.Exception-import           Control.Monad-import           Data.Bifunctor-import           Data.Bool-import           Data.ByteString-import           Data.Char-import           Data.Either-import           Data.Eq-import           Data.Foldable-import           Data.Function-import           Data.Functor.Contravariant-import           Data.Functor.Contravariant.Divisible-import           Data.Int-import           Data.Maybe-import           Data.Monoid-import           Data.Ord-import           Data.Semigroup-import           Data.String-import           Data.Text-import           Data.Traversable-import           Data.Tuple-import           Data.Void-import           Data.Word-import           GHC.Base-import           GHC.Generics-import           GHC.Num-import           GHC.Stack-import           System.FilePath-import           Text.Show--import qualified Data.Text                            as T--tshow :: Show a => a -> Text-tshow = T.pack . show+import           HaskellWorks.Prelude

@@ -32,12 +32,18 @@     system,     rawSystem, +    waitSecondsForProcess,+   ) where  import qualified Control.Exception             as CE+import           HaskellWorks.Error+import           HaskellWorks.Error.Types+import qualified HaskellWorks.IO.Process       as IO import           HaskellWorks.Polysemy.Prelude import           Polysemy import           Polysemy.Error+import           Polysemy.Log import           System.Exit                   (ExitCode (..)) import           System.IO                     (Handle) import           System.Posix.Internals        (FD)@@ -257,3 +263,16 @@ rawSystem cmd args = do   r <- embed $ CE.try @IOException $ IO.rawSystem cmd args   fromEither r++waitSecondsForProcess :: ()+  => Member (Embed IO) r+  => Member (Error GenericError) r+  => Member (Error IOException) r+  => Member (Error TimedOut) r+  => Member Log r+  => Int+  -> ProcessHandle+  -> Sem r (Maybe ExitCode)+waitSecondsForProcess seconds hProcess =+  embed (IO.waitSecondsForProcess seconds hProcess)+    & onLeftM @TimedOut throw

@@ -0,0 +1,169 @@+module HaskellWorks.Prelude+  ( Bool(..)+  , Char(..)+  , Maybe(..)+  , Either(..)++  , String+  , Text+  , ByteString+  , Int+  , Int8+  , Int16+  , Int32+  , Int64+  , Integer+  , Word+  , Word8+  , Word16+  , Word32+  , Word64+  , Float+  , Double+  , FilePath+  , Void++  , Eq(..)+  , Ord(..)+  , Num(..)+  , Show(..)+  , IsString(..)+  , tshow++  , bool+  , const++  , absurd+  , vacuous++  , either+  , lefts+  , rights+  , isLeft+  , isRight+  , fromLeft+  , fromRight++  , maybe+  , isJust+  , isNothing+  , fromMaybe+  , listToMaybe+  , maybeToList+  , catMaybes+  , mapMaybe++  , fst+  , flip+  , snd+  , id+  , seq+  , curry+  , uncurry+  , ($!)+  , ($)+  , (&)+  , (&&)+  , (||)+  , (.)+  , (</>)++  , void+  , mapM_+  , forM+  , forM_+  , sequence_+  , (=<<)+  , (>=>)+  , (<=<)+  , forever+  , join+  , msum+  , mfilter+  , filterM+  , foldM+  , foldM_+  , replicateM+  , replicateM_+  , guard+  , when+  , unless+  , liftM+  , liftM2+  , liftM3+  , liftM4+  , liftM5+  , ap+  , (<$!>)++  , (<$>)++  , (<**>)+  , liftA+  , liftA3+  , optional+  , asum++  , for_++  , Monad(..)+  , MonadFail(..)+  , MonadPlus(..)+  , Applicative(..)+  , Alternative(..)+  , Contravariant(..)+  , Divisible(..)+  , Functor(..)+  , Bifunctor(..)+  , Semigroup(..)+  , Monoid(..)+  , Foldable(..)+  , Traversable(..)++  , IO++  , CallStack+  , HasCallStack+  , withFrozenCallStack++  , Generic++  , IOException+  , SomeException(..)+  ) where++import           Control.Applicative+import           Control.Exception+import           Control.Monad+import           Data.Bifunctor+import           Data.Bool+import           Data.ByteString+import           Data.Char+import           Data.Either+import           Data.Eq+import           Data.Foldable+import           Data.Function+import           Data.Functor.Contravariant+import           Data.Functor.Contravariant.Divisible+import           Data.Int+import           Data.Maybe+import           Data.Monoid+import           Data.Ord+import           Data.Semigroup+import           Data.String+import           Data.Text+import           Data.Traversable+import           Data.Tuple+import           Data.Void+import           Data.Word+import           GHC.Base+import           GHC.Generics+import           GHC.Num+import           GHC.Stack+import           System.FilePath+import           Text.Show++import qualified Data.Text                            as T++tshow :: Show a => a -> Text+tshow = T.pack . show

@@ -1,51 +1,65 @@  module HaskellWorks.Polysemy.Hedgehog-  ( propertyOnce+  ( propertyOnce, -  , Hedgehog+    Hedgehog, -  , hedgehogToIntegrationFinal-  , interpretDataLogHedgehog+    hedgehogToIntegrationFinal,+    interpretDataLogHedgehog, -  , leftFail-  , leftFailM-  , catchFail+    leftFail,+    leftFailM,+    catchFail, -  , failure-  , failMessage-  , (===)+    failure,+    failMessage,+    (===), -  , eval-  , evalIO-  , evalM-  , evalIO_-  , evalM_+    eval,+    evalM,+    evalIO,+    writeLog,+    failWith,+    failWithCustom,+    evalIO_,+    evalM_, -  , jotShow-  , jotShow_-  , jotWithCallstack-  , jot-  , jot_-  , jotText_-  , jotM-  , jotM_-  , jotBsUtf8M-  , jotLbsUtf8M-  , jotIO-  , jotIO_-  , jotShowM-  , jotShowM_-  , jotShowIO-  , jotShowIO_-  , jotEach-  , jotEach_-  , jotEachM-  , jotEachM_-  , jotEachIO-  , jotEachIO_+    jotShow,+    jotShow_,+    jotWithCallstack,+    jot,+    jot_,+    jotText_,+    jotM,+    jotM_,+    jotBsUtf8M,+    jotLbsUtf8M,+    jotIO,+    jotIO_,+    jotShowM,+    jotShowM_,+    jotShowIO,+    jotShowIO_,+    jotEach,+    jotEach_,+    jotEachM,+    jotEachM_,+    jotEachIO,+    jotEachIO_,+    jotPkgInputFile,+    jotPkgGoldenFile,+    jotRootInputFile,+    jotTempFile, -  , Property+    Property, +    Workspace(..),+    ProjectRoot(..),+    PackagePath(..),+    workspace,+    moduleWorkspace,+    findCabalProjectDir,+   ) where  import           HaskellWorks.Polysemy.Hedgehog.Assert@@ -54,3 +68,4 @@ import           HaskellWorks.Polysemy.Hedgehog.Eval import           HaskellWorks.Polysemy.Hedgehog.Jot import           HaskellWorks.Polysemy.Hedgehog.Property+import           HaskellWorks.Polysemy.Hedgehog.Workspace

@@ -126,7 +126,6 @@   => HasCallStack   => Member Hedgehog r   => Member (Embed IO) r-  => Member (Error IOException) r   => Member Resource r   => Member Log r   => String   -- ^ Actual content@@ -134,15 +133,18 @@   -> Sem r () diffVsGoldenFile actualContent goldenFile = withFrozenCallStack $ do   forM_ mGoldenFileLogFile $ \logFile ->-    PIO.bracketQSem sem $ PIO.appendFile logFile $ goldenFile <> "\n"+    PIO.bracketQSem sem $+      PIO.appendFile logFile (goldenFile <> "\n")+        & trapFail @IOException    fileExists <- PIO.doesFileExist goldenFile+    & trapFail @IOException    if-    | recreateGoldenFiles -> writeGoldenFile goldenFile actualContent-    | fileExists          -> checkAgainstGoldenFile goldenFile actualLines-    | createGoldenFiles   -> writeGoldenFile goldenFile actualContent-    | otherwise           -> reportGoldenFileMissing goldenFile+    | recreateGoldenFiles -> writeGoldenFile goldenFile actualContent       & trapFail @IOException+    | fileExists          -> checkAgainstGoldenFile goldenFile actualLines  & trapFail @IOException+    | createGoldenFiles   -> writeGoldenFile goldenFile actualContent       & trapFail @IOException+    | otherwise           -> reportGoldenFileMissing goldenFile             & trapFail @IOException    where     actualLines = List.lines actualContent@@ -160,9 +162,8 @@ -- files are never overwritten. diffFileVsGoldenFile :: ()   => HasCallStack-  => Member Hedgehog r   => Member (Embed IO) r-  => Member (Error IOException) r+  => Member Hedgehog r   => Member Log r   => Member Resource r   => FilePath -- ^ Actual file@@ -170,4 +171,7 @@   -> Sem r () diffFileVsGoldenFile actualFile referenceFile = withFrozenCallStack $ do   contents <- PIO.readFile actualFile+    & trapFail @IOException+   diffVsGoldenFile contents referenceFile+    & trapFail @IOException

@@ -1,28 +1,32 @@ module HaskellWorks.Polysemy.Hedgehog.Jot-  ( jotShow-  , jotShow_-  , jotWithCallstack+  ( jotShow,+    jotShow_,+    jotWithCallstack, -  , jot-  , jot_-  , jotText_-  , jotM-  , jotM_-  , jotBsUtf8M-  , jotLbsUtf8M-  , jotIO-  , jotIO_-  , jotShowM-  , jotShowM_-  , jotShowIO-  , jotShowIO_-  , jotEach-  , jotEach_-  , jotEachM-  , jotEachM_-  , jotEachIO-  , jotEachIO_+    jot,+    jot_,+    jotText_,+    jotM,+    jotM_,+    jotBsUtf8M,+    jotLbsUtf8M,+    jotIO,+    jotIO_,+    jotShowM,+    jotShowM_,+    jotShowIO,+    jotShowIO_,+    jotEach,+    jotEach_,+    jotEachM,+    jotEachM_,+    jotEachIO,+    jotEachIO_, +    jotPkgGoldenFile,+    jotPkgInputFile,+    jotRootInputFile,+    jotTempFile,   ) where  @@ -37,9 +41,10 @@ import qualified Hedgehog.Internal.Property                     as H import qualified Hedgehog.Internal.Source                       as H +import           HaskellWorks.Polysemy import           HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog+import           HaskellWorks.Polysemy.Hedgehog.Workspace.Types import           HaskellWorks.Polysemy.String-import           Polysemy  -- | Annotate the given string at the context supplied by the callstack. jotWithCallstack :: ()@@ -65,9 +70,10 @@ jot_ :: ()   => Member Hedgehog r   => GHC.HasCallStack-  => String+  => ToString s+  => s   -> Sem r ()-jot_ a = GHC.withFrozenCallStack $ jotWithCallstack GHC.callStack a+jot_ a = GHC.withFrozenCallStack $ jotWithCallstack GHC.callStack $ toString a  -- | Annotate the given text returning unit. jotText_ :: ()@@ -282,3 +288,50 @@ jotEachIO_ f = GHC.withFrozenCallStack $ do   !as <- evalIO f   for_ as $ jotWithCallstack GHC.callStack . show++-- | Return the input file path after annotating it relative to the package directory+jotPkgInputFile :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Reader PackagePath) r+  => FilePath+  -> Sem r FilePath+jotPkgInputFile filePath = withFrozenCallStack $ do+  PackagePath { filePath = pkgPath } <- ask+  jot_ $ pkgPath <> "/" <> filePath+  return filePath++-- | Return the golden file path after annotating it relative to the package directory+jotPkgGoldenFile :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Reader PackagePath) r+  => FilePath+  -> Sem r FilePath+jotPkgGoldenFile filePath = withFrozenCallStack $ do+  PackagePath { filePath = pkgPath } <- ask+  jot_ $ pkgPath <> "/" <> filePath+  return filePath++jotRootInputFile :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Reader ProjectRoot) r+  => FilePath+  -> Sem r FilePath+jotRootInputFile filePath = withFrozenCallStack $ do+  ProjectRoot { filePath = pkgPath } <- ask+  jot $ pkgPath <> "/" <> filePath++-- | Return the test file path after annotating it relative to the project root directory+jotTempFile :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Reader Workspace) r+  => FilePath+  -> Sem r FilePath+jotTempFile filePath = withFrozenCallStack $ do+  Workspace { filePath = workspace } <- ask+  let relPath = workspace <> "/" <> filePath+  jot_ $ workspace <> "/" <> relPath+  return relPath

@@ -15,11 +15,8 @@    ) where -import qualified Control.Concurrent                              as IO-import qualified Control.Concurrent.Async                        as IO import           Data.Monoid                                     (Last (..)) import           GHC.Stack                                       (callStack)-import qualified HaskellWorks.IO.Process                         as IO import           HaskellWorks.Polysemy.Cabal import           HaskellWorks.Polysemy.Error.Types import           HaskellWorks.Polysemy.Hedgehog.Assert@@ -56,6 +53,7 @@ -- When running outside a nix environment, the `pkgBin` describes the name of the binary -- to launch via cabal exec. execFlexOk :: ()+  => HasCallStack   => Member (Embed IO) r   => Member Hedgehog r   => Member (Error GenericError) r@@ -68,6 +66,7 @@ execFlexOk = execFlexOk' defaultExecConfig  execFlexOk' :: ()+  => HasCallStack   => Member (Embed IO) r   => Member Hedgehog r   => Member (Error GenericError) r@@ -93,6 +92,7 @@ -- 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   => Member (Embed IO) r   => Member Hedgehog r   => Member (Error GenericError) r@@ -113,6 +113,7 @@  -- | Execute a process, returning '()'. execOk_ :: ()+  => HasCallStack   => Member (Embed IO) r   => Member Hedgehog r   => Member (Error GenericError) r@@ -128,6 +129,7 @@ -- with a non-zero exit code. For a version that doesn't fail upon receiving -- a non-zero exit code, see 'execAny'. execOk :: ()+  => HasCallStack   => Member (Embed IO) r   => Member Hedgehog r   => Member (Error GenericError) r@@ -148,6 +150,7 @@  -- | Execute a process, returning the error code, the stdout, and the stderr. exec :: ()+  => HasCallStack   => Member (Embed IO) r   => Member Hedgehog r   => Member (Error GenericError) r@@ -165,21 +168,9 @@   jot_ . ( "━━━━ command ━━━━\n" <>) $ bin <> " " <> L.unwords (argQuote <$> arguments)   readCreateProcessWithExitCode cp "" -waitSecondsForProcess :: ()-  => Member (Embed IO) r-  => Member (Error GenericError) r-  => Member (Error IOException) r-  => Member Log r-  => Int-  -> ProcessHandle-  -> Sem r (Either TimedOut (Maybe ExitCode))-waitSecondsForProcess seconds hProcess = embed $-  IO.race-    (IO.threadDelay (seconds * 1000000) >> return TimedOut)-    (IO.maybeWaitForProcess hProcess)- -- | Wait a maximum of 'seconds' secons for process to exit. waitSecondsForProcessOk :: ()+  => HasCallStack   => Member Hedgehog r   => Member (Embed IO) r   => Member (Error GenericError) r@@ -187,22 +178,20 @@   => Member Log r   => Int   -> ProcessHandle-  -> Sem r (Either TimedOut ExitCode)+  -> Sem r ExitCode waitSecondsForProcessOk seconds hProcess = withFrozenCallStack $ do-  result <- waitSecondsForProcess seconds hProcess-  case result of-    Left TimedOut -> do-      jot_ "Timed out waiting for process to exit"-      return (Left TimedOut)-    Right maybeExitCode -> do-      case maybeExitCode of-        Nothing -> failMessage callStack "No exit code for process"-        Just exitCode -> do-          jot_ $ "Process exited " <> show exitCode-          return (Right exitCode)+  maybeExitCode <- waitSecondsForProcess seconds hProcess+    & trapFail @TimedOut +  case maybeExitCode of+    Nothing -> failMessage callStack "No exit code for process"+    Just exitCode -> do+      jot_ $ "Process exited " <> show exitCode+      return exitCode+ -- | Compute the path to the binary given a package name or an environment variable override. binFlex :: ()+  => HasCallStack   => Member (Embed IO) r   => Member (Error GenericError) r   => Member (Error IOException) r@@ -228,6 +217,7 @@ -- "plan.json" generated by cabal.  It is assumed that the project has already been -- configured and the executable has been built. procFlex :: ()+  => HasCallStack   => Member (Embed IO) r   => Member (Error GenericError) r   => Member (Error IOException) r@@ -243,6 +233,7 @@ procFlex = procFlex' defaultExecConfig  procFlex' :: ()+  => HasCallStack   => Member (Embed IO) r   => Member (Error GenericError) r   => Member (Error IOException) r

@@ -1,20 +1,27 @@ module HaskellWorks.Polysemy.Hedgehog.Workspace-  ( workspace-  , moduleWorkspace+  ( PackagePath(..),+    ProjectRoot(..),+    Workspace(..),+    workspace,+    moduleWorkspace,+    findCabalProjectDir,   ) where -import           HaskellWorks.Polysemy.Hedgehog+import           HaskellWorks.Polysemy.Error+import           HaskellWorks.Polysemy.Hedgehog.Assert+import           HaskellWorks.Polysemy.Hedgehog.Jot+import           HaskellWorks.Polysemy.Hedgehog.Workspace.Types import           HaskellWorks.Polysemy.Prelude import           HaskellWorks.Polysemy.Stack import           HaskellWorks.Polysemy.System.Directory import           HaskellWorks.Polysemy.System.Environment import           HaskellWorks.Polysemy.System.IO.Temp import           Polysemy-import           Polysemy.Error import           Polysemy.Log+import           Polysemy.Reader import           System.Info -import qualified HaskellWorks.Polysemy.System.IO          as PIO+import qualified HaskellWorks.Polysemy.System.IO                as PIO  -- | Create a workspace directory which will exist for at least the duration of -- the supplied block.@@ -28,10 +35,9 @@   => Member Hedgehog r   => Member Log r   => Member (Embed IO) r-  => Member (Error IOException) r   => HasCallStack   => FilePath-  -> (FilePath -> Sem r ())+  -> Sem (Reader Workspace : r) ()   -> Sem r () workspace prefixPath f = withFrozenCallStack $ do   systemTemp <- getCanonicalTemporaryDirectory@@ -39,9 +45,11 @@   ws <- createTempDirectory systemTemp $ prefixPath <> "-test"   jot_ $ "Workspace: " <> ws   PIO.writeFile (ws </> "module") callerModuleName-  f ws+    & 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.@@ -57,9 +65,30 @@   => Member Hedgehog r   => Member Log r   => Member (Embed IO) r-  => Member (Error IOException) r   => String-  -> (FilePath -> Sem r ())+  -> Sem (Reader Workspace : r) ()   -> Sem 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 :: ()+  => Member Hedgehog r+  => Member (Embed IO) r+  => Member Log r+  => FilePath+  -> Sem 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 embed $ fail "Could not detect project base directory (containing cabal.project)"

@@ -0,0 +1,25 @@+{-# LANGUAGE DeriveGeneric #-}++module HaskellWorks.Polysemy.Hedgehog.Workspace.Types+  ( PackagePath(..),+    ProjectRoot(..),+    Workspace(..),+  ) where++import           GHC.Generics+import           HaskellWorks.Polysemy.Prelude++newtype Workspace = Workspace+  { filePath :: FilePath+  }+  deriving (Eq, Show, Generic)++newtype ProjectRoot = ProjectRoot+  { filePath :: FilePath+  }+  deriving (Eq, Show)++newtype PackagePath = PackagePath+  { filePath :: FilePath+  }+  deriving (Eq, Show)

@@ -1,6 +1,6 @@ cabal-version:          3.4 name:                   hw-polysemy-version:                0.2.3.0+version:                0.2.4.0 synopsis:               Opinionated polysemy library description:            Opinionated polysemy library. license:                Apache-2.0@@ -50,11 +50,17 @@ common hw-polysemy-core           { build-depends: hw-polysemy:core                                     } common hw-polysemy-hedgehog       { build-depends: hw-polysemy:hedgehog                                 } +flag werror+  description: Enable -Werror+  manual: True+  default: False+ common project-config   import:               polysemy,                         polysemy-plugin,   default-extensions:   BlockArguments                         DataKinds+                        DuplicateRecordFields                         FlexibleContexts                         FlexibleInstances                         LambdaCase@@ -63,6 +69,8 @@                         TypeApplications   ghc-options:          -Wall                         -fplugin=Polysemy.Plugin+  if flag(werror)+    ghc-options:        -Werror  library core   import:               base, project-config,@@ -93,7 +101,9 @@   if os(windows)     exposed-modules:    HaskellWorks.IO.Win32.NamedPipe -  exposed-modules:      HaskellWorks.IO.Network+  exposed-modules:      HaskellWorks.Error+                        HaskellWorks.Error.Types+                        HaskellWorks.IO.Network                         HaskellWorks.IO.Network.NamedPipe                         HaskellWorks.IO.Network.Port                         HaskellWorks.IO.Network.Socket@@ -125,6 +135,7 @@                         HaskellWorks.Polysemy.System.IO                         HaskellWorks.Polysemy.System.IO.Temp                         HaskellWorks.Polysemy.System.Process+                        HaskellWorks.Prelude   hs-source-dirs:       core   default-language:     GHC2021 @@ -159,6 +170,7 @@                         HaskellWorks.Polysemy.Hedgehog.Process.Internal                         HaskellWorks.Polysemy.Hedgehog.Property                         HaskellWorks.Polysemy.Hedgehog.Workspace+                        HaskellWorks.Polysemy.Hedgehog.Workspace.Types   hs-source-dirs:       hedgehog   default-language:     GHC2021