git.iko.soy/effectful
on master help sign in
Add Environment effect (#32)
da56557Mann mit Hut
effectful/effectful.cabal+2
compare with master
unifiedsplit
@@ -73,6 +73,7 @@ library
73
73
74 exposed-modules: Effectful
74 exposed-modules: Effectful
75 Effectful.Async
75 Effectful.Async
76+ Effectful.Environment
76 Effectful.Process
77 Effectful.Process
77 Effectful.Resource
78 Effectful.Resource
78 Effectful.Temporary
79 Effectful.Temporary
@@ -113,6 +114,7 @@ test-suite test
113
114
114 other-modules: AsyncTests
115 other-modules: AsyncTests
115 ConcurrencyTests
116 ConcurrencyTests
117+ EnvironmentTests
116 ErrorTests
118 ErrorTests
117 StateTests
119 StateTests
118 Utils
120 Utils
effectful/src/Effectful/Environment.hsnew file+75
@@ -0,0 +1,75 @@
1+module Effectful.Environment
2+ ( -- * Environment effect
3+ Environment
4+ , runEnvironment
5+
6+ -- * Querying the environment
7+ , getArgs
8+ , getProgName
9+ , getExecutablePath
10+ , getEnv
11+ , getEnvironment
12+ , lookupEnv
13+
14+ -- * Modifying the environment
15+ , setEnv
16+ , unsetEnv
17+ , withArgs
18+ , withProgName
19+ ) where
20+
21+import qualified System.Environment as E
22+
23+import Effectful.Internal.Effect
24+import Effectful.Internal.Monad
25+
26+-- | An effect for querying and modifying the system environment.
27+data Environment :: Effect where
28+ Environment :: Environment m r
29+
30+runEnvironment :: IOE :> es => Eff (Environment : es) a -> Eff es a
31+runEnvironment = evalEffect (IdE Environment)
32+
33+-- | Lifted 'E.getArgs'.
34+getArgs :: Environment :> es => Eff es [String]
35+getArgs = unsafeEff_ E.getArgs
36+
37+-- | Lifted 'E.getEnv'.
38+getEnv :: Environment :> es => String -> Eff es String
39+getEnv = unsafeEff_ . E.getEnv
40+
41+-- | Lifted 'E.getEnvironment'.
42+getEnvironment :: Environment :> es => Eff es [(String, String)]
43+getEnvironment = unsafeEff_ E.getEnvironment
44+
45+-- | Lifted 'E.getExecutablePath'.
46+getExecutablePath :: Environment :> es => Eff es FilePath
47+getExecutablePath = unsafeEff_ E.getExecutablePath
48+
49+-- | Lifted 'E.getProgName'.
50+getProgName :: Environment :> es => Eff es String
51+getProgName = unsafeEff_ E.getProgName
52+
53+-- | Lifted 'E.lookupEnv'.
54+lookupEnv :: Environment :> es => String -> Eff es (Maybe String)
55+lookupEnv = unsafeEff_ . E.lookupEnv
56+
57+-- | Lifted 'E.setEnv'.
58+setEnv :: Environment :> es => String -> String -> Eff es ()
59+setEnv n = unsafeEff_ . E.setEnv n
60+
61+-- | Lifted 'E.unsetEnv'.
62+unsetEnv :: Environment :> es => String -> Eff es ()
63+unsetEnv = unsafeEff_ . E.unsetEnv
64+
65+-- | Lifted 'E.withArgs'.
66+withArgs :: Environment :> es => [String] -> Eff es a -> Eff es a
67+withArgs env k = unsafeEff $ \es -> do
68+ seqUnliftEff es $ \runInIO -> do
69+ E.withArgs env (runInIO k)
70+
71+-- | Lifted 'E.withProgName'.
72+withProgName :: Environment :> es => String -> Eff es a -> Eff es a
73+withProgName n k = unsafeEff $ \es -> do
74+ seqUnliftEff es $ \runInIO -> do
75+ E.withProgName n (runInIO k)
effectful/tests/EnvironmentTests.hsnew file+42
@@ -0,0 +1,42 @@
1+module EnvironmentTests (environmentTests) where
2+
3+import Test.Tasty
4+import Test.Tasty.HUnit
5+import System.IO.Error (isDoesNotExistError)
6+
7+import Effectful
8+import Effectful.Environment
9+import qualified Utils as U
10+
11+environmentTests :: TestTree
12+environmentTests = testGroup "Environment"
13+ [ testCase "set and get an environment variable" test_setAndGet
14+ , testCase "unset and try to get an environment variable" test_unsetAndGet
15+ , testCase "execute effects with custom arguments" test_withArgs
16+ , testCase "execute effects with custom program name" test_withProg
17+ ]
18+
19+test_setAndGet :: Assertion
20+test_setAndGet = runEff . runEnvironment $ do
21+ let n = "EFFECTFUL_TEST1"
22+ setEnv n "value"
23+ v <- getEnv n
24+ U.assertEqual "environment variable not set" v "value"
25+
26+test_unsetAndGet :: Assertion
27+test_unsetAndGet = runEff . runEnvironment $ do
28+ let n = "EFFECTFUL_TEST2"
29+ unsetEnv n
30+ U.assertThrows "environment variable is set" isDoesNotExistError (getEnv n)
31+
32+test_withArgs :: Assertion
33+test_withArgs = runEff . runEnvironment $ do
34+ let expected = ["effectful-test"]
35+ args <- withArgs expected getArgs
36+ U.assertEqual "correct arguments" args expected
37+
38+test_withProg :: Assertion
39+test_withProg = runEff . runEnvironment $ do
40+ let expected = "effectful-test"
41+ n <- withProgName expected getProgName
42+ U.assertEqual "correct program name" n expected
effectful/tests/Main.hs+2
@@ -4,6 +4,7 @@ import Test.Tasty
4
4
5import AsyncTests
5import AsyncTests
6import ConcurrencyTests
6import ConcurrencyTests
7+import EnvironmentTests
7import ErrorTests
8import ErrorTests
8import StateTests
9import StateTests
9
10
@@ -11,6 +12,7 @@ main :: IO ()
11main = defaultMain $ testGroup "effectful"
12main = defaultMain $ testGroup "effectful"
12 [ asyncTests
13 [ asyncTests
13 , concurrencyTests
14 , concurrencyTests
15+ , environmentTests
14 , errorTests
16 , errorTests
15 , stateTests
17 , stateTests
16 ]
18 ]
effectful/tests/Utils.hs+17
@@ -2,10 +2,12 @@ module Utils
2 ( assertBool
2 ( assertBool
3 , assertEqual
3 , assertEqual
4 , assertFailure
4 , assertFailure
5+ , assertThrows
5 , Ex(..)
6 , Ex(..)
6 ) where
7 ) where
7
8
8import Control.Exception
9import Control.Exception
10+import Control.Monad
9import GHC.Stack
11import GHC.Stack
10import qualified Test.Tasty.HUnit as T
12import qualified Test.Tasty.HUnit as T
11
13
@@ -25,5 +27,20 @@ assertEqual msg expected given = liftIO $ T.assertEqual msg expected given
25assertFailure :: (HasCallStack, IOE :> es) => String -> Eff es a
27assertFailure :: (HasCallStack, IOE :> es) => String -> Eff es a
26assertFailure msg = liftIO $ T.assertFailure msg
28assertFailure msg = liftIO $ T.assertFailure msg
27
29
30+assertThrows
31+ :: (Exception e, IOE :> es)
32+ => String
33+ -> (e -> Bool)
34+ -> Eff es a
35+ -> Eff es ()
36+assertThrows msg p k = withEffToIO $ \runInIO -> do
37+ let k' = do
38+ void $ runInIO k
39+ T.assertFailure msg
40+
41+ k' `catch` \e -> if p e
42+ then return ()
43+ else throwIO e
44+
28data Ex = Ex deriving (Eq, Show)
45data Ex = Ex deriving (Eq, Show)
29instance Exception Ex
46instance Exception Ex