diff --git a/packages/distributed-process-tests/distributed-process-tests.cabal b/packages/distributed-process-tests/distributed-process-tests.cabal index 8f17bb108..3c31522ea 100644 --- a/packages/distributed-process-tests/distributed-process-tests.cabal +++ b/packages/distributed-process-tests/distributed-process-tests.cabal @@ -45,6 +45,7 @@ library exposed-modules: Network.Transport.Test Control.Distributed.Process.Tests.CH Control.Distributed.Process.Tests.Closure + Control.Distributed.Process.Tests.ClosureExplicit Control.Distributed.Process.Tests.Mx Control.Distributed.Process.Tests.Receive Control.Distributed.Process.Tests.Stats @@ -138,6 +139,20 @@ Test-Suite TestClosure ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind HS-Source-Dirs: tests +Test-Suite TestClosureExplicit + import: warnings + Type: exitcode-stdio-1.0 + Main-Is: runInMemory.hs + CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.ClosureExplicit + Build-Depends: base >= 4.14 && < 5, + distributed-process-tests, + network-transport-inmemory >= 0.5, + tasty >= 1.5 && <1.6, + default-extensions: CPP + default-language: Haskell98 + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind + HS-Source-Dirs: tests + Test-Suite TestStats import: warnings Type: exitcode-stdio-1.0 diff --git a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/ClosureExplicit.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/ClosureExplicit.hs new file mode 100644 index 000000000..213ff8eac --- /dev/null +++ b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/ClosureExplicit.hs @@ -0,0 +1,170 @@ +module Control.Distributed.Process.Tests.ClosureExplicit (tests) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar, takeMVar) +import Control.Distributed.Process + ( Closure, + Process, + ProcessId, + RemoteTable, + Static, + expect, + getSelfPid, + liftIO, + send, + spawn, + unClosure, + unStatic, + ) +import Control.Distributed.Process.Closure + ( RemoteRegister, + call', + mkClosureVal, + mkClosureValSingle, + mkStaticVal, + ) +import Control.Distributed.Process.Node + ( LocalNode (localNodeId), + initRemoteTable, + newLocalNode, + runProcess, + ) +import Control.Monad (replicateM) +import Network.Transport.Test (TestTransport (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, testCase, (@?=)) + +tests :: TestTransport -> IO TestTree +tests testtrans = + return $ + testGroup + "ClosureExplicit" + [ testCase "MkStaticVal" (testMkStaticVal testtrans), + testCase "UnClosure" (testUnClosure testtrans), + testCase "SpawnSingle" (testSpawnSingle testtrans), + testCase "SpawnMultiArg" (testSpawnMultiArg testtrans), + testCase "CallSingle" (testCallSingle testtrans), + testCase "CallMultiArg" (testCallMultiArg testtrans) + ] + +testMkStaticVal :: TestTransport -> Assertion +testMkStaticVal TestTransport {..} = do + node <- newLocalNode testTransport rtable + done <- newEmptyMVar + runProcess node $ unStatic staticAnswer >>= liftIO . putMVar done + takeMVar done >>= (@?= answer) + +testUnClosure :: TestTransport -> Assertion +testUnClosure TestTransport {..} = do + node <- newLocalNode testTransport rtable + done <- newEmptyMVar + runProcess node $ unClosure (addIntClosure 17 25) >>= liftIO . putMVar done + takeMVar done >>= (@?= answer) + +testSpawnSingle :: TestTransport -> Assertion +testSpawnSingle TestTransport {..} = do + serverNodeAddr <- newEmptyMVar + clientDone <- newEmptyMVar + + forkIO $ do + node <- newLocalNode testTransport rtable + putMVar serverNodeAddr (localNodeId node) + + forkIO $ do + node <- newLocalNode testTransport rtable + nid <- readMVar serverNodeAddr + runProcess node $ do + us <- getSelfPid + them <- spawn nid (echoPidClosure us) + them' <- expect + liftIO $ putMVar clientDone (them == them') + + takeMVar clientDone >>= (@?= True) + +testSpawnMultiArg :: TestTransport -> Assertion +testSpawnMultiArg TestTransport {..} = do + serverNodeAddr <- newEmptyMVar + clientDone <- newEmptyMVar + + forkIO $ do + node <- newLocalNode testTransport rtable + putMVar serverNodeAddr (localNodeId node) + + forkIO $ do + node <- newLocalNode testTransport rtable + nid <- readMVar serverNodeAddr + runProcess node $ do + us <- getSelfPid + _ <- spawn nid (sendSumClosure 41 us) + n <- expect + liftIO $ putMVar clientDone (n :: Int) + + takeMVar clientDone >>= (@?= answer) + +testCallSingle :: TestTransport -> Assertion +testCallSingle TestTransport {..} = do + [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable + done <- newEmptyMVar + runProcess node1 $ + call' (localNodeId node2) (factorialClosure 5) >>= liftIO . putMVar done + takeMVar done >>= (@?= (120 :: Int)) + +testCallMultiArg :: TestTransport -> Assertion +testCallMultiArg TestTransport {..} = do + [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable + done <- newEmptyMVar + runProcess node1 $ + call' (localNodeId node2) (sendProductClosure 2 3 7) >>= liftIO . putMVar done + takeMVar done >>= (@?= (42 :: Int)) + +staticAnswer :: Static Int +answerRegister :: RemoteRegister +(staticAnswer, answerRegister) = mkStaticVal "answer" answer + +echoPidClosure :: ProcessId -> Closure (Process ()) +echoPidRegister :: RemoteRegister +(echoPidClosure, echoPidRegister) = mkClosureValSingle "echoPid" echoPid + +factorialClosure :: Int -> Closure (Process Int) +factorialRegister :: RemoteRegister +(factorialClosure, factorialRegister) = mkClosureValSingle "factorial" factorial + +sendSumClosure :: Int -> ProcessId -> Closure (Process ()) +sendSumRegister :: RemoteRegister +(sendSumClosure, sendSumRegister) = mkClosureVal "sendSum" sendSum + +sendProductClosure :: Int -> Int -> Int -> Closure (Process Int) +sendProductRegister :: RemoteRegister +(sendProductClosure, sendProductRegister) = mkClosureVal "sendProduct" sendProduct + +addIntClosure :: Int -> Int -> Closure Int +addIntRegister :: RemoteRegister +(addIntClosure, addIntRegister) = mkClosureVal "addInt" addInt + +rtable :: RemoteTable +rtable = + answerRegister + . echoPidRegister + . factorialRegister + . sendSumRegister + . sendProductRegister + . addIntRegister + $ initRemoteTable + +echoPid :: ProcessId -> Process () +echoPid them = getSelfPid >>= send them + +sendSum :: Int -> ProcessId -> Process () +sendSum n them = send them (n + 1 :: Int) + +sendProduct :: Int -> Int -> Int -> Process Int +sendProduct x y z = return (x * y * z) + +factorial :: Int -> Process Int +factorial n = return (product [1 .. n]) + +addInt :: Int -> Int -> Int +addInt = (+) + +answer :: Int +answer = 42 diff --git a/packages/distributed-process/ChangeLog b/packages/distributed-process/ChangeLog index 7055e4aa4..5d8710df1 100644 --- a/packages/distributed-process/ChangeLog +++ b/packages/distributed-process/ChangeLog @@ -2,6 +2,7 @@ Unreleased * Added support for `containers-0.8`. * Reworked benchmarks, which can now be run using `cabal bench distributed-process`. +* Fixed an issue where `mkClosureValSingle` and `mkClosureVal` could not be used due to overlapping that were not declared as such. 2025-02-04 Laurent P. René de Cotret 0.7.8 diff --git a/packages/distributed-process/src/Control/Distributed/Process/Closure.hs b/packages/distributed-process/src/Control/Distributed/Process/Closure.hs index 11b70c912..f0540bfca 100644 --- a/packages/distributed-process/src/Control/Distributed/Process/Closure.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Closure.hs @@ -5,7 +5,9 @@ -- 'Control.Distributed.Static.Static' implementation from -- "Control.Distributed.Static". That module comes with its own extensive -- documentation, which you should read if you want to know the details. Here --- we explain the Template Haskell support only. +-- we explain the Template Haskell support only; for the API that does not need +-- Template Haskell, see /Working with static values and closures (without +-- Template Haskell)/ below. -- -- [Static values] -- @@ -180,6 +182,7 @@ module Control.Distributed.Process.Closure , cpExpect , cpNewChan -- * Working with static values and closures (without Template Haskell) + -- $withoutTH , RemoteRegister , MkTDict(..) , mkStaticVal @@ -198,6 +201,33 @@ module Control.Distributed.Process.Closure #endif ) where +-- $withoutTH +-- +-- Closures can also be built /without/ Template Haskell. Instead of a +-- @remotable@ splice, each of 'mkStaticVal', 'mkClosureValSingle' and +-- 'mkClosureVal' returns the value you asked for paired with a +-- 'RemoteRegister', a @'RemoteTable' -> 'RemoteTable'@ that registers the +-- statics that value depends on: +-- +-- > isPrime :: Integer -> Process Bool +-- > isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..] +-- > where +-- > sieve :: [Integer] -> [Integer] +-- > sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0] +-- > +-- > isPrimeClosure :: Integer -> Closure (Process Bool) +-- > isPrimeRegister :: RemoteRegister +-- > (isPrimeClosure, isPrimeRegister) = mkClosureValSingle "isPrime" isPrime +-- > +-- > rtable :: RemoteTable +-- > rtable = isPrimeRegister $ initRemoteTable +-- > +-- > master :: [NodeId] -> Process () +-- > master [] = liftIO $ putStrLn "no slaves" +-- > master (slave:_) = do +-- > isPrime79 <- call' slave (isPrimeClosure 79) +-- > liftIO $ print isPrime79 + import Control.Distributed.Process.Serializable (SerializableDict(..)) import Control.Distributed.Process.Internal.Closure.BuiltIn ( -- Static dictionaries and associated operations diff --git a/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/Explicit.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/Explicit.hs index 4a7ae88a9..2dcc904d8 100644 --- a/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/Explicit.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/Explicit.hs @@ -32,7 +32,7 @@ import Data.Binary(encode,put,get,Binary) import qualified Data.ByteString.Lazy as B import Data.Kind (Type) --- | A RemoteRegister is a trasformer on a RemoteTable to register additional static values. +-- | A RemoteRegister is a transformer on a RemoteTable to register additional static values. type RemoteRegister = RemoteTable -> RemoteTable -- | This takes an explicit name and a value, and produces both a static reference to the name and a RemoteRegister for it. @@ -43,10 +43,10 @@ mkStaticVal n v = (staticLabel n_s, registerStatic n_s (toDynamic v)) class MkTDict a where mkTDict :: String -> a -> RemoteRegister -instance (Serializable b) => MkTDict (Process b) where +instance {-# OVERLAPPING #-} (Serializable b) => MkTDict (Process b) where mkTDict _ _ = registerStatic (show (typeOf (undefined :: b)) ++ "__staticDict") (toDynamic (SerializableDict :: SerializableDict b)) -instance MkTDict a where +instance {-# OVERLAPPABLE #-} MkTDict a where mkTDict _ _ = id -- | This takes an explicit name, a function of arity one, and creates a creates a function yielding a closure and a remote register for it. @@ -110,10 +110,10 @@ instance Binary EndOfTuple where class Curry a b | a -> b where curryFun :: a -> b -instance Curry ((a, EndOfTuple) -> b) (a -> b) where +instance {-# OVERLAPPING #-} Curry ((a, EndOfTuple) -> b) (a -> b) where curryFun f = \x -> f (x,undefined) -instance Curry (b -> c) r => Curry ((a,b) -> c) (a -> r) where +instance {-# OVERLAPPABLE #-} Curry (b -> c) r => Curry ((a,b) -> c) (a -> r) where curryFun f = \x -> curryFun (\y -> (f (x,y))) @@ -144,6 +144,6 @@ uncurry' Done r _ = r uncurry' (Moar fun) f (x,xs) = uncurry' fun (f x) xs class IsFunction t b | t -> b -instance (b ~ HTrue) => IsFunction (a -> c) b -instance (b ~ HFalse) => IsFunction a b +instance {-# OVERLAPPING #-} (b ~ HTrue) => IsFunction (a -> c) b +instance {-# OVERLAPPABLE #-} (b ~ HFalse) => IsFunction a b