Hedgehog process support

components/core/Effectful/Zoo/FileSystem.hs

@@ -15,6 +15,8 @@ module Effectful.Zoo.FileSystem
     doesDirectoryExist,
 
     runFileSystem,
+
+    getCurrentDirectory,
   ) where
 
 import Data.Aeson (FromJSON)
@@ -180,3 +182,13 @@ doesDirectoryExist fp = withFrozenCallStack $ do
 
   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 #-}

components/core/Effectful/Zoo/Process.hs

@@ -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/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen.hs

@@ -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

@@ -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

@@ -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