Fixed an issue where mkClosureVal and similar functions could not be used due to overlapping instances

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

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

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 <laurent.decotret@outlook.com> 0.7.8
 

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

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