Skip to content

Commit 858e896

Browse files
newhoggynewhoggy
authored
Hedgehog process support (#15)
* Tidy up * New hedgehog Range and Gen modules * Hedgehog process support
1 parent 4d9d88b commit 858e896

File tree

15 files changed

+905
-13
lines changed

15 files changed

+905
-13
lines changed

‎components/core/Effectful/Zoo/FileSystem.hs

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,8 @@ module Effectful.Zoo.FileSystem
1515
doesDirectoryExist,
1616

1717
runFileSystem,
18+
19+
getCurrentDirectory,
1820
) where
1921

2022
import Data.Aeson (FromJSON)
@@ -180,3 +182,13 @@ doesDirectoryExist fp = withFrozenCallStack $ do
180182

181183
unsafeFileSystemEff_ (D.doesDirectoryExist fp)
182184
& trapIO @IOException throw
185+
186+
getCurrentDirectory :: ()
187+
=> HasCallStack
188+
=> r <: Error IOException
189+
=> r <: FileSystem
190+
=> Eff r FilePath
191+
getCurrentDirectory = withFrozenCallStack do
192+
unsafeFileSystemEff_ D.getCurrentDirectory
193+
& trapIO @IOException throw
194+
{-# INLINE getCurrentDirectory #-}

‎components/core/Effectful/Zoo/Process.hs

Lines changed: 273 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,273 @@
1+
module Effectful.Zoo.Process
2+
( IO.CreateProcess(..),
3+
IO.CmdSpec(..),
4+
IO.StdStream(..),
5+
Handle,
6+
ProcessHandle,
7+
ExitCode(..),
8+
FD,
9+
Pid,
10+
createProcess,
11+
createProcess_,
12+
IO.shell,
13+
IO.proc,
14+
callProcess,
15+
callCommand,
16+
spawnProcess,
17+
spawnCommand,
18+
readCreateProcess,
19+
readProcess,
20+
readCreateProcessWithExitCode,
21+
readProcessWithExitCode,
22+
cleanupProcess,
23+
getPid,
24+
getCurrentPid,
25+
interruptProcessGroupOf,
26+
createPipe,
27+
createPipeFd,
28+
runProcess,
29+
runCommand,
30+
runInteractiveProcess,
31+
runInteractiveCommand,
32+
system,
33+
rawSystem,
34+
35+
waitSecondsForProcess,
36+
) where
37+
38+
import Control.Exception qualified as CE
39+
import HaskellWorks.Error
40+
import HaskellWorks.Error.Types
41+
import HaskellWorks.IO.Process qualified as IO
42+
import HaskellWorks.Prelude
43+
import Effectful
44+
import Effectful.Zoo.Core
45+
import Effectful.Zoo.Error.Static
46+
import System.Exit (ExitCode (..))
47+
import System.Posix.Internals (FD)
48+
import System.Process (Pid, ProcessHandle)
49+
import System.Process qualified as IO
50+
51+
createProcess :: ()
52+
=> r <: Error IOException
53+
=> r <: IOE
54+
=> IO.CreateProcess
55+
-> Eff r (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
56+
createProcess cp = do
57+
r <- liftIO $ CE.try @IOException $ IO.createProcess cp
58+
fromEither r
59+
60+
createProcess_ :: ()
61+
=> r <: Error IOException
62+
=> r <: IOE
63+
=> String
64+
-> IO.CreateProcess
65+
-> Eff r (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
66+
createProcess_ cmd cp = do
67+
r <- liftIO $ CE.try @IOException $ IO.createProcess_ cmd cp
68+
fromEither r
69+
70+
callProcess :: ()
71+
=> r <: Error IOException
72+
=> r <: IOE
73+
=> String
74+
-> [String]
75+
-> Eff r ()
76+
callProcess cmd args = do
77+
r <- liftIO $ CE.try @IOException $ IO.callProcess cmd args
78+
fromEither r
79+
80+
callCommand :: ()
81+
=> r <: Error IOException
82+
=> r <: IOE
83+
=> String
84+
-> Eff r ()
85+
callCommand cmd = do
86+
r <- liftIO $ CE.try @IOException $ IO.callCommand cmd
87+
fromEither r
88+
89+
spawnProcess :: ()
90+
=> r <: Error IOException
91+
=> r <: IOE
92+
=> String
93+
-> [String]
94+
-> Eff r ProcessHandle
95+
spawnProcess cmd args = do
96+
r <- liftIO $ CE.try @IOException $ IO.spawnProcess cmd args
97+
fromEither r
98+
99+
spawnCommand :: ()
100+
=> r <: Error IOException
101+
=> r <: IOE
102+
=> String
103+
-> Eff r ProcessHandle
104+
spawnCommand cmd = do
105+
r <- liftIO $ CE.try @IOException $ IO.spawnCommand cmd
106+
fromEither r
107+
108+
readCreateProcess :: ()
109+
=> r <: Error IOException
110+
=> r <: IOE
111+
=> IO.CreateProcess
112+
-> String
113+
-> Eff r String
114+
readCreateProcess cp input = do
115+
r <- liftIO $ CE.try @IOException $ IO.readCreateProcess cp input
116+
fromEither r
117+
118+
readProcess :: ()
119+
=> r <: Error IOException
120+
=> r <: IOE
121+
=> String
122+
-> [String]
123+
-> String
124+
-> Eff r String
125+
readProcess cmd args input = do
126+
r <- liftIO $ CE.try @IOException $ IO.readProcess cmd args input
127+
fromEither r
128+
129+
readCreateProcessWithExitCode :: ()
130+
=> r <: Error IOException
131+
=> r <: IOE
132+
=> IO.CreateProcess
133+
-> String
134+
-> Eff r (ExitCode, String, String)
135+
readCreateProcessWithExitCode cp input = do
136+
r <- liftIO $ CE.try @IOException $ IO.readCreateProcessWithExitCode cp input
137+
fromEither r
138+
139+
readProcessWithExitCode :: ()
140+
=> r <: Error IOException
141+
=> r <: IOE
142+
=> String
143+
-> [String]
144+
-> String
145+
-> Eff r (ExitCode, String, String)
146+
readProcessWithExitCode cmd args input = do
147+
r <- liftIO $ CE.try @IOException $ IO.readProcessWithExitCode cmd args input
148+
fromEither r
149+
150+
cleanupProcess :: ()
151+
=> r <: Error IOException
152+
=> r <: IOE
153+
=> (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
154+
-> Eff r ()
155+
cleanupProcess (mIn, mOut, mErr, ph) = do
156+
r <- liftIO $ CE.try @IOException $ IO.cleanupProcess (mIn, mOut, mErr, ph)
157+
fromEither r
158+
159+
getPid :: ()
160+
=> r <: Error IOException
161+
=> r <: IOE
162+
=> ProcessHandle
163+
-> Eff r (Maybe Pid)
164+
getPid ph = do
165+
r <- liftIO $ CE.try @IOException $ IO.getPid ph
166+
fromEither r
167+
168+
getCurrentPid :: ()
169+
=> r <: Error IOException
170+
=> r <: IOE
171+
=> Eff r Pid
172+
getCurrentPid = do
173+
r <- liftIO $ CE.try @IOException $ IO.getCurrentPid
174+
fromEither r
175+
176+
interruptProcessGroupOf :: ()
177+
=> r <: Error IOException
178+
=> r <: IOE
179+
=> ProcessHandle
180+
-> Eff r ()
181+
interruptProcessGroupOf ph = do
182+
r <- liftIO $ CE.try @IOException $ IO.interruptProcessGroupOf ph
183+
fromEither r
184+
185+
createPipe :: ()
186+
=> r <: Error IOException
187+
=> r <: IOE
188+
=> Eff r (Handle, Handle)
189+
createPipe = do
190+
r <- liftIO $ CE.try @IOException $ IO.createPipe
191+
fromEither r
192+
193+
createPipeFd :: ()
194+
=> r <: Error IOException
195+
=> r <: IOE
196+
=> Eff r (FD, FD)
197+
createPipeFd = do
198+
r <- liftIO $ CE.try @IOException $ IO.createPipeFd
199+
fromEither r
200+
201+
runProcess :: ()
202+
=> r <: Error IOException
203+
=> r <: IOE
204+
=> FilePath
205+
-> [String]
206+
-> Maybe FilePath
207+
-> Maybe [(String, String)]
208+
-> Maybe Handle
209+
-> Maybe Handle
210+
-> Maybe Handle
211+
-> Eff r ProcessHandle
212+
runProcess cmd args mbStdIn mbEnv mbCwd mbStdOut mbStdErr = do
213+
r <- liftIO $ CE.try @IOException $ IO.runProcess cmd args mbStdIn mbEnv mbCwd mbStdOut mbStdErr
214+
fromEither r
215+
216+
runCommand :: ()
217+
=> r <: Error IOException
218+
=> r <: IOE
219+
=> String
220+
-> Eff r ProcessHandle
221+
runCommand cmd = do
222+
r <- liftIO $ CE.try @IOException $ IO.runCommand cmd
223+
fromEither r
224+
225+
runInteractiveProcess :: ()
226+
=> r <: Error IOException
227+
=> r <: IOE
228+
=> FilePath
229+
-> [String]
230+
-> Maybe FilePath
231+
-> Maybe [(String, String)]
232+
-> Eff r (Handle, Handle, Handle, ProcessHandle)
233+
runInteractiveProcess cmd args mbCwd mbEnv = do
234+
r <- liftIO $ CE.try @IOException $ IO.runInteractiveProcess cmd args mbCwd mbEnv
235+
fromEither r
236+
237+
runInteractiveCommand :: ()
238+
=> r <: Error IOException
239+
=> r <: IOE
240+
=> String
241+
-> Eff r (Handle, Handle, Handle, ProcessHandle)
242+
runInteractiveCommand cmd = do
243+
r <- liftIO $ CE.try @IOException $ IO.runInteractiveCommand cmd
244+
fromEither r
245+
246+
system :: ()
247+
=> r <: Error IOException
248+
=> r <: IOE
249+
=> String
250+
-> Eff r ExitCode
251+
system cmd = do
252+
r <- liftIO $ CE.try @IOException $ IO.system cmd
253+
fromEither r
254+
255+
rawSystem :: ()
256+
=> r <: Error IOException
257+
=> r <: IOE
258+
=> String
259+
-> [String]
260+
-> Eff r ExitCode
261+
rawSystem cmd args = do
262+
r <- liftIO $ CE.try @IOException $ IO.rawSystem cmd args
263+
fromEither r
264+
265+
waitSecondsForProcess :: ()
266+
=> r <: Error TimedOut
267+
=> r <: IOE
268+
=> Int
269+
-> ProcessHandle
270+
-> Eff r (Maybe ExitCode)
271+
waitSecondsForProcess seconds hProcess =
272+
liftIO (IO.waitSecondsForProcess seconds hProcess)
273+
& onLeftM @TimedOut throw

‎components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen.hs

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
module Effectful.Zoo.Hedgehog.Api.Gen
2+
( module Hedgehog.Gen,
3+
module Effectful.Zoo.Hedgehog.Api.Gen.Ulid,
4+
) where
5+
6+
import Effectful.Zoo.Hedgehog.Api.Gen.Ulid
7+
import Hedgehog.Gen

‎components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen/Time.hs

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
module Effectful.Zoo.Hedgehog.Api.Gen.Time
2+
( genPosixTime,
3+
) where
4+
5+
import Data.Time.Clock.POSIX (POSIXTime)
6+
import HaskellWorks.Prelude
7+
import Hedgehog
8+
import Hedgehog.Gen qualified as Gen
9+
import Hedgehog.Range qualified as Range
10+
11+
genPosixTime :: Gen POSIXTime
12+
genPosixTime = do
13+
-- Generate a random integer within a reasonable range for POSIX time
14+
-- POSIXTime is a type synonym for NominalDiffTime, which is in seconds
15+
-- We'll use a range from 0 to a large number of seconds to cover a wide time span
16+
seconds <- Gen.integral (Range.linear 0 4_102_444_800) -- Up to year 2100
17+
18+
pure $ fromIntegral @Word64 seconds

‎components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen/Ulid.hs

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,32 @@
1+
module Effectful.Zoo.Hedgehog.Api.Gen.Ulid (
2+
genUlid,
3+
genUlidRandom,
4+
genUlidTimeStamp,
5+
) where
6+
7+
import Data.Binary (decodeOrFail)
8+
import Data.ByteString.Lazy qualified as LBS
9+
import Data.ULID (ULID (..))
10+
import Data.ULID.Random (ULIDRandom)
11+
import Data.ULID.TimeStamp (ULIDTimeStamp, mkULIDTimeStamp)
12+
import Effectful.Zoo.Hedgehog.Api.Gen.Time
13+
import HaskellWorks.Prelude
14+
import Hedgehog
15+
import Hedgehog.Gen qualified as Gen
16+
import Hedgehog.Range qualified as Range
17+
18+
genUlidRandom :: Gen ULIDRandom
19+
genUlidRandom = do
20+
bytes <- Gen.bytes (Range.singleton 10) -- 80 bits
21+
let lazyBytes = LBS.fromStrict bytes
22+
case decodeOrFail lazyBytes of
23+
Left (_, _, err) -> fail $ "Failed to decode ULIDRandom: " <> err -- This shouldn't happen.
24+
Right (_, _, ulid) -> pure ulid
25+
26+
genUlidTimeStamp :: Gen ULIDTimeStamp
27+
genUlidTimeStamp =
28+
mkULIDTimeStamp <$> genPosixTime
29+
30+
genUlid :: Gen ULID
31+
genUlid =
32+
ULID <$> genUlidTimeStamp <*> genUlidRandom

0 commit comments

Comments
 (0)