diff --git a/packages/distributed-process-async/CHANGELOG.md b/packages/distributed-process-async/CHANGELOG.md index 3c84ce270..e50944e43 100644 --- a/packages/distributed-process-async/CHANGELOG.md +++ b/packages/distributed-process-async/CHANGELOG.md @@ -1,3 +1,7 @@ +Unreleased + +* Breaking: `remoteTask` takes a `Closure (SerializableDict a)` instead of a `Static (SerializableDict a)`. + 2025-02-04 Laurent P. René de Cotret 0.2.11 * Ported test suite to use `tasty` rather than `test-framework`. diff --git a/packages/distributed-process-async/distributed-process-async.cabal b/packages/distributed-process-async/distributed-process-async.cabal index a20c00eb9..76014b766 100644 --- a/packages/distributed-process-async/distributed-process-async.cabal +++ b/packages/distributed-process-async/distributed-process-async.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: distributed-process-async -version: 0.2.11 +version: 0.3.0 build-type: Simple license: BSD-3-Clause license-file: LICENCE @@ -38,7 +38,7 @@ library import: warnings build-depends: base >= 4.14 && < 5, - distributed-process >= 0.6.1 && < 0.8, + distributed-process >= 0.8 && < 0.9, exceptions >= 0.10 && < 1.0, binary >= 0.8 && < 0.9, stm >= 2.4 && < 2.6, diff --git a/packages/distributed-process-async/src/Control/Distributed/Process/Async.hs b/packages/distributed-process-async/src/Control/Distributed/Process/Async.hs index e013d3814..56cc3b181 100644 --- a/packages/distributed-process-async/src/Control/Distributed/Process/Async.hs +++ b/packages/distributed-process-async/src/Control/Distributed/Process/Async.hs @@ -80,7 +80,7 @@ task :: Process a -> AsyncTask a task = AsyncTask -- | Wraps the components required and builds a remote 'AsyncTask'. -remoteTask :: Static (SerializableDict a) +remoteTask :: Closure (SerializableDict a) -> NodeId -> Closure (Process a) -> AsyncTask a diff --git a/packages/distributed-process-async/src/Control/Distributed/Process/Async/Internal/Types.hs b/packages/distributed-process-async/src/Control/Distributed/Process/Async/Internal/Types.hs index 5887ab469..90fb9e4b0 100644 --- a/packages/distributed-process-async/src/Control/Distributed/Process/Async/Internal/Types.hs +++ b/packages/distributed-process-async/src/Control/Distributed/Process/Async/Internal/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ExistentialQuantification #-} @@ -55,7 +54,7 @@ data AsyncTask a = asyncTask :: Process a -- ^ the task to be performed } | AsyncRemoteTask { - asyncTaskDict :: Static (SerializableDict a) + asyncTaskDict :: Closure (SerializableDict a) -- ^ the serializable dict required to spawn a remote process , asyncTaskNode :: NodeId -- ^ the node on which to spawn the asynchronous task diff --git a/packages/distributed-process-async/tests/TestAsync.hs b/packages/distributed-process-async/tests/TestAsync.hs index 411f434c2..965dcdc1f 100644 --- a/packages/distributed-process-async/tests/TestAsync.hs +++ b/packages/distributed-process-async/tests/TestAsync.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE StaticPointers #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where @@ -12,7 +12,7 @@ import Control.Distributed.Process.Serializable() import Control.Distributed.Process.Async import Control.Distributed.Process.SysTest.Utils import Control.Monad (replicateM_) -import Data.Binary() +import Data.Binary (decode, encode) import Data.Typeable() import Network.Transport.TCP import qualified Network.Transport as NT @@ -139,18 +139,15 @@ testAsyncWaitCancelTimeout result = do p1 <- async $ task expect waitCancelTimeout 1000000 p1 >>= stash result -remotableDecl [ - [d| fib :: (NodeId,Int) -> Process Integer ; - fib (_,0) = return 0 - fib (_,1) = return 1 - fib (myNode,n) = do - let tsk = remoteTask ($(functionTDict 'fib)) myNode ($(mkClosure 'fib) (myNode,n-2)) - future <- async tsk - y <- fib (myNode,n-1) - (AsyncDone z) <- wait future - return $ y + z - |] - ] +fib :: (NodeId,Int) -> Process Integer +fib (_,0) = return 0 +fib (_,1) = return 1 +fib (myNode,n) = do + let tsk = remoteTask (static SerializableDict) myNode (closure (static (fib . decode)) (encode (myNode, n-2))) + future <- async tsk + y <- fib (myNode,n-1) + (AsyncDone z) <- wait future + return $ y + z -- Tests that wait returns when remote actions complete. testAsyncRecursive :: TestResult Integer -> Process () @@ -212,7 +209,7 @@ tests localNode = testGroup "" [ asyncStmTests :: NT.Transport -> IO TestTree asyncStmTests transport = do - localNode <- newLocalNode transport $ __remoteTableDecl initRemoteTable + localNode <- newLocalNode transport let testData = tests localNode return testData diff --git a/packages/distributed-process-client-server/distributed-process-client-server.cabal b/packages/distributed-process-client-server/distributed-process-client-server.cabal index 1bf241c27..e08199f9c 100644 --- a/packages/distributed-process-client-server/distributed-process-client-server.cabal +++ b/packages/distributed-process-client-server/distributed-process-client-server.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: distributed-process-client-server -version: 0.2.8.0 +version: 0.2.9.0 build-type: Simple license: BSD-3-Clause license-file: LICENCE @@ -39,9 +39,9 @@ library import: warnings build-depends: base >= 4.8.2.0 && < 5, - distributed-process >= 0.6.6 && < 0.8, - distributed-process-extras >= 0.3.1 && < 0.4, - distributed-process-async >= 0.2.4 && < 0.3, + distributed-process >= 0.8 && < 0.9, + distributed-process-extras >= 0.4 && < 0.5, + distributed-process-async >= 0.3 && < 0.4, binary >= 0.8 && < 0.9, deepseq >= 1.4 && < 1.7, mtl, diff --git a/packages/distributed-process-client-server/tests/Counter.hs b/packages/distributed-process-client-server/tests/Counter.hs index 3f0a13adb..31698f0ed 100644 --- a/packages/distributed-process-client-server/tests/Counter.hs +++ b/packages/distributed-process-client-server/tests/Counter.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} diff --git a/packages/distributed-process-client-server/tests/SafeCounter.hs b/packages/distributed-process-client-server/tests/SafeCounter.hs index a6ea94514..796444ba4 100644 --- a/packages/distributed-process-client-server/tests/SafeCounter.hs +++ b/packages/distributed-process-client-server/tests/SafeCounter.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} diff --git a/packages/distributed-process-client-server/tests/TestManagedProcess.hs b/packages/distributed-process-client-server/tests/TestManagedProcess.hs index f5be49312..1024931be 100644 --- a/packages/distributed-process-client-server/tests/TestManagedProcess.hs +++ b/packages/distributed-process-client-server/tests/TestManagedProcess.hs @@ -15,7 +15,7 @@ import Control.Exception (SomeException) import Control.Distributed.Process hiding (call, catch) import Control.Distributed.Process.Async (AsyncResult(AsyncDone)) import Control.Distributed.Process.Node -import Control.Distributed.Process.Extras hiding (__remoteTable, monitor, send, nsend) +import Control.Distributed.Process.Extras hiding (monitor, send, nsend) import Control.Distributed.Process.ManagedProcess import Control.Distributed.Process.SysTest.Utils import Control.Distributed.Process.Extras.Time @@ -212,7 +212,7 @@ testCounterExceedsLimit result = do tests :: NT.Transport -> IO TestTree tests transport = do - localNode <- newLocalNode transport initRemoteTable + localNode <- newLocalNode transport scpid <- newEmptyMVar _ <- forkProcess localNode $ SafeCounter.startCounter 5 >>= stash scpid safeCounter <- takeMVar scpid diff --git a/packages/distributed-process-client-server/tests/TestPrioritisedProcess.hs b/packages/distributed-process-client-server/tests/TestPrioritisedProcess.hs index 4ff110ddc..5d0ef9a3b 100644 --- a/packages/distributed-process-client-server/tests/TestPrioritisedProcess.hs +++ b/packages/distributed-process-client-server/tests/TestPrioritisedProcess.hs @@ -15,7 +15,7 @@ import Control.Exception (SomeException) import Control.DeepSeq (NFData) import Control.Distributed.Process hiding (call, send, catch, sendChan, wrapMessage) import Control.Distributed.Process.Node -import Control.Distributed.Process.Extras hiding (__remoteTable, monitor) +import Control.Distributed.Process.Extras hiding (monitor) import Control.Distributed.Process.Async hiding (check) import Control.Distributed.Process.ManagedProcess hiding (reject, Message) import qualified Control.Distributed.Process.ManagedProcess.Server.Priority as P (Message) @@ -536,7 +536,7 @@ testCallPrioritisation result = do tests :: NT.Transport -> IO TestTree tests transport = do - localNode <- newLocalNode transport initRemoteTable + localNode <- newLocalNode transport return $ testGroup "" [ testGroup "basic server functionality matches un-prioritised processes" [ testCase "basic call with explicit server reply" diff --git a/packages/distributed-process-client-server/tests/TestUtils.hs b/packages/distributed-process-client-server/tests/TestUtils.hs index b976cc9fb..7217fb838 100644 --- a/packages/distributed-process-client-server/tests/TestUtils.hs +++ b/packages/distributed-process-client-server/tests/TestUtils.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module TestUtils @@ -38,7 +37,7 @@ waitForExit exitReason = do mkNode :: String -> IO LocalNode mkNode port = do Right (transport1, _) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" port) defaultTCPParameters - newLocalNode transport1 initRemoteTable + newLocalNode transport1 -- | Given a @builder@ function, make and run a test suite on a single transport testMain :: (NT.Transport -> IO TestTree) -> IO () diff --git a/packages/distributed-process-execution/ChangeLog b/packages/distributed-process-execution/ChangeLog index 076a74966..0041fd676 100644 --- a/packages/distributed-process-execution/ChangeLog +++ b/packages/distributed-process-execution/ChangeLog @@ -1,5 +1,6 @@ Unreleased +* Breaking: `__remoteTable` is no longer exported, as `RemoteTable` has been removed from `distributed-process`. * Added support for `containers-0.8`. 2025-02-04 Laurent P. René de Cotret 0.1.5.0 diff --git a/packages/distributed-process-execution/distributed-process-execution.cabal b/packages/distributed-process-execution/distributed-process-execution.cabal index 88cf8049c..b96d1824b 100644 --- a/packages/distributed-process-execution/distributed-process-execution.cabal +++ b/packages/distributed-process-execution/distributed-process-execution.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: distributed-process-execution -version: 0.1.5.0 +version: 0.2.0.0 build-type: Simple license: BSD-3-Clause license-file: LICENCE @@ -40,9 +40,9 @@ library build-depends: base >= 4.14 && < 5, data-accessor >= 0.2.2.3, - distributed-process >= 0.6.6 && < 0.8, - distributed-process-extras >= 0.3.1 && < 0.4, - distributed-process-supervisor >= 0.2.0 && < 0.3, + distributed-process >= 0.8 && < 0.9, + distributed-process-extras >= 0.4 && < 0.5, + distributed-process-supervisor >= 0.3 && < 0.4, distributed-process-client-server >= 0.2.0 && < 0.3, binary >= 0.8 && < 0.9, deepseq >= 1.4 && < 1.7, @@ -85,6 +85,7 @@ test-suite MailboxTests import: warnings type: exitcode-stdio-1.0 build-depends: base >= 4.14 && < 5, + binary >= 0.8 && < 0.9, distributed-process, distributed-process-execution, distributed-process-extras, diff --git a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/EventManager.hs b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/EventManager.hs index 62b83019e..ce714da49 100644 --- a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/EventManager.hs +++ b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/EventManager.hs @@ -4,7 +4,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ImpredicativeTypes #-} ----------------------------------------------------------------------------- diff --git a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Broadcast.hs b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Broadcast.hs index e5b6cd352..d3c4ac9d3 100644 --- a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Broadcast.hs +++ b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Broadcast.hs @@ -6,7 +6,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Internal.hs b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Internal.hs index 6dfe8ee20..0e822cfd6 100644 --- a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Internal.hs +++ b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Internal.hs @@ -6,7 +6,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Router.hs b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Router.hs index efdaeb4f6..ba4a44bbd 100644 --- a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Router.hs +++ b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Router.hs @@ -6,7 +6,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Mailbox.hs b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Mailbox.hs index 6b1d7b296..281146100 100644 --- a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Mailbox.hs +++ b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Mailbox.hs @@ -7,7 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StaticPointers #-} {-# LANGUAGE ImpredicativeTypes #-} ----------------------------------------------------------------------------- @@ -115,8 +115,6 @@ module Control.Distributed.Process.Execution.Mailbox , FilterResult(..) , acceptEverything , acceptMatching - -- * Remote Table - , __remoteTable ) where import Control.Concurrent.STM (atomically) @@ -129,10 +127,6 @@ import Control.Concurrent.STM.TChan ) import Control.Distributed.Process hiding (call, monitor) import qualified Control.Distributed.Process as P (monitor) -import Control.Distributed.Process.Closure - ( remotable - , mkStaticClosure - ) import Control.Distributed.Process.Serializable hiding (SerializableDict) import Control.Distributed.Process.Extras ( ExitReason(..) @@ -547,7 +541,7 @@ matching :: Closure (Message -> Process FilterResult) -> Message -> Process FilterResult matching predicate msg = do - pred' <- unClosure predicate :: Process (Message -> Process FilterResult) + pred' <- unclosure predicate :: Process (Message -> Process FilterResult) res <- handleMessage msg pred' case res of Nothing -> return Skip @@ -632,7 +626,7 @@ type Skipped = Integer sendMail :: State -> Process State sendMail st = do let Active f = st ^. state ^. mode - unCl <- catch (unClosure f >>= return . Just) + unCl <- catch (unclosure f >>= return . Just) (\(_ :: SomeException) -> return Nothing) case unCl of Nothing -> return st -- TODO: Logging!? @@ -721,12 +715,10 @@ stats = accessor getStats (\_ s -> s) -- TODO: use a READ ONLY accessor for this where getStats (State _ (BufferState _ _ lm sz dr op _)) = MailboxStats sz dr lm op -$(remotable ['everything, 'matching]) - -- | A /do-nothing/ filter that accepts all messages (i.e., returns @Keep@ -- for any input). acceptEverything :: Closure (Message -> Process FilterResult) -acceptEverything = $(mkStaticClosure 'everything) +acceptEverything = (static everything) -- | A filter that takes a @Closure (Message -> Process FilterResult)@ holding -- the filter function and applies it remotely (i.e., in the mailbox's own @@ -734,7 +726,7 @@ acceptEverything = $(mkStaticClosure 'everything) -- acceptMatching :: Closure (Closure (Message -> Process FilterResult) -> Message -> Process FilterResult) -acceptMatching = $(mkStaticClosure 'matching) +acceptMatching = (static matching) -- | Instructs the mailbox to deliver all pending messages to the owner. -- diff --git a/packages/distributed-process-execution/tests/MailboxTestFilters.hs b/packages/distributed-process-execution/tests/MailboxTestFilters.hs index ca17ffae5..ef0573ce4 100644 --- a/packages/distributed-process-execution/tests/MailboxTestFilters.hs +++ b/packages/distributed-process-execution/tests/MailboxTestFilters.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE StaticPointers #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} module MailboxTestFilters where @@ -10,7 +10,7 @@ import Control.Monad (forM) import Prelude hiding (drop) import Data.Maybe (catMaybes) -import Control.Distributed.Process.Closure (remotable, mkClosure, mkStaticClosure) +import Data.Binary (decode, encode) filterInputs :: (String, Int, Bool) -> Message -> Process FilterResult filterInputs (s, i, b) msg = do @@ -30,11 +30,9 @@ filterEvens m = do Just fr -> return fr _ -> return Skip -$(remotable ['filterInputs, 'filterEvens]) - intFilter :: Closure (Message -> Process FilterResult) -intFilter = $(mkStaticClosure 'filterEvens) +intFilter = (static filterEvens) myFilter :: (String, Int, Bool) -> Closure (Message -> Process FilterResult) -myFilter = $(mkClosure 'filterInputs) +myFilter x = closure (static (filterInputs . decode)) (encode x) diff --git a/packages/distributed-process-execution/tests/TestExchange.hs b/packages/distributed-process-execution/tests/TestExchange.hs index 9357d81f7..274f57ff9 100644 --- a/packages/distributed-process-execution/tests/TestExchange.hs +++ b/packages/distributed-process-execution/tests/TestExchange.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -9,7 +8,6 @@ module Main where import Control.Distributed.Process hiding (monitor) import Control.Distributed.Process.Node import Control.Distributed.Process.Execution.EventManager hiding (start) -import qualified Control.Distributed.Process.Extras import Control.Distributed.Process.Execution.Exchange import Control.Distributed.Process.Extras.Internal.Types import Control.Distributed.Process.Extras.Internal.Primitives @@ -153,13 +151,9 @@ myHandler :: SendPort (String, String, String) -> Process () myHandler sp s m@(_, _, _) = sendChan sp m >> return s -myRemoteTable :: RemoteTable -myRemoteTable = - Control.Distributed.Process.Extras.__remoteTable initRemoteTable - tests :: NT.Transport -> IO TestTree tests transport = do - localNode <- newLocalNode transport myRemoteTable + localNode <- newLocalNode transport return $ testGroup "" [ testGroup "Event Manager" [ diff --git a/packages/distributed-process-execution/tests/TestMailbox.hs b/packages/distributed-process-execution/tests/TestMailbox.hs index b5f1400ee..e646ba28d 100644 --- a/packages/distributed-process-execution/tests/TestMailbox.hs +++ b/packages/distributed-process-execution/tests/TestMailbox.hs @@ -1,13 +1,11 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import Control.Distributed.Process import Control.Distributed.Process.Node -import qualified Control.Distributed.Process.Extras (__remoteTable) import Control.Distributed.Process.Execution.Mailbox import Control.Distributed.Process.Extras.Time import Control.Distributed.Process.Extras.Timer @@ -20,7 +18,6 @@ import Data.Maybe (catMaybes) import Test.Tasty (defaultMain, testGroup, TestTree) import Test.Tasty.HUnit (assertEqual, testCase) -import qualified MailboxTestFilters (__remoteTable) import MailboxTestFilters (myFilter, intFilter) import Network.Transport.TCP @@ -168,16 +165,10 @@ waitForMailboxReady mbox sz = do True -> return () False -> waitForMailboxReady mbox sz -myRemoteTable :: RemoteTable -myRemoteTable = - Control.Distributed.Process.Execution.Mailbox.__remoteTable $ - Control.Distributed.Process.Extras.__remoteTable $ - MailboxTestFilters.__remoteTable initRemoteTable - tests :: NT.Transport -> IO TestTree tests transport = do {- verboseCheckWithResult stdArgs -} - localNode <- newLocalNode transport myRemoteTable + localNode <- newLocalNode transport return $ testGroup "" [ testGroup "Dequeue/Pop Ordering" [ diff --git a/packages/distributed-process-extras/ChangeLog b/packages/distributed-process-extras/ChangeLog index 119a66161..0620cc367 100644 --- a/packages/distributed-process-extras/ChangeLog +++ b/packages/distributed-process-extras/ChangeLog @@ -1,5 +1,6 @@ Unreleased +* Breaking: `__remoteTable` is no longer exported, as `RemoteTable` has been removed from `distributed-process`. * Added support for `containers-0.8`. 2025-02-04 Laurent P. René de Cotret 0.3.9 diff --git a/packages/distributed-process-extras/distributed-process-extras.cabal b/packages/distributed-process-extras/distributed-process-extras.cabal index c4d54987d..2abf60694 100644 --- a/packages/distributed-process-extras/distributed-process-extras.cabal +++ b/packages/distributed-process-extras/distributed-process-extras.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: distributed-process-extras -version: 0.3.9 +version: 0.4.0 build-type: Simple license: BSD-3-Clause license-file: LICENCE @@ -36,7 +36,7 @@ common warnings library import: warnings build-depends: base >= 4.14 && < 5, - distributed-process >= 0.6.0 && < 0.8, + distributed-process >= 0.8 && < 0.9, binary >= 0.8 && < 0.9, deepseq >= 1.4 && < 1.7, containers >= 0.6 && < 0.9, @@ -87,7 +87,7 @@ test-suite PrimitivesTests x-uses-tf: true build-depends: base >= 4.14 && < 5, - distributed-process >= 0.6.0 && < 0.8, + distributed-process >= 0.8 && < 0.9, distributed-process-extras, distributed-process-systest ^>= 0.4, network-transport >= 0.4 && < 0.6, @@ -106,7 +106,7 @@ test-suite TimerTests build-depends: base >= 4.14 && < 5, deepseq, - distributed-process >= 0.6.0 && < 0.8, + distributed-process >= 0.8 && < 0.9, distributed-process-extras, distributed-process-systest ^>= 0.4, network-transport >= 0.4 && < 0.6, @@ -125,7 +125,7 @@ test-suite LoggerTests -- x-uses-tf: true build-depends: base >= 4.14 && < 5, - distributed-process >= 0.6.0 && < 0.8, + distributed-process >= 0.8 && < 0.9, distributed-process-extras, distributed-process-systest ^>= 0.4, network-transport >= 0.4 && < 0.6, diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras.hs index 16ae71d85..2b918090a 100644 --- a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras.hs +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras.hs @@ -96,12 +96,8 @@ module Control.Distributed.Process.Extras -- * Registration and Process Lookup , whereisOrStart , whereisOrStartRemote - - -- remote call table - , __remoteTable ) where -import Control.Distributed.Process (RemoteTable) import Control.Distributed.Process.Extras.Internal.Types ( NFSerializable , Recipient(..) @@ -116,11 +112,4 @@ import Control.Distributed.Process.Extras.Internal.Types , getTag ) import Control.Distributed.Process.Extras.UnsafePrimitives -import Control.Distributed.Process.Extras.Internal.Primitives hiding (__remoteTable) -import qualified Control.Distributed.Process.Extras.Internal.Primitives (__remoteTable) - --- remote table - -__remoteTable :: RemoteTable -> RemoteTable -__remoteTable = - Control.Distributed.Process.Extras.Internal.Primitives.__remoteTable +import Control.Distributed.Process.Extras.Internal.Primitives diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Primitives.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Primitives.hs index f5d6123fb..06d9f21fb 100644 --- a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Primitives.hs +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Primitives.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StaticPointers #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -51,15 +51,13 @@ module Control.Distributed.Process.Extras.Internal.Primitives , isProcessAlive , forever' , deliver - - -- * Remote Table - , __remoteTable ) where import Control.Concurrent (myThreadId, throwTo) import Control.Distributed.Process hiding (monitor, finally, catch) import qualified Control.Distributed.Process as P (monitor, unmonitor) -import Control.Distributed.Process.Closure (seqCP, remotable, mkClosure) +import Control.Distributed.Process.Closure (seqCP) +import Data.Binary (decode, encode) import Control.Distributed.Process.Serializable (Serializable) import Control.Distributed.Process.Extras.Internal.Types ( Addressable @@ -204,8 +202,6 @@ registerSelf (name,target) = () <- expect return () -$(remotable ['registerSelf]) - -- | A remote equivalent of 'whereisOrStart'. It deals with the -- node registry on the given node, and the process, if it needs to be started, -- will run on that node. If the node is inaccessible, Nothing will be returned. @@ -225,7 +221,7 @@ whereisOrStartRemote nid name proc = Just (Just pid) -> unmonitor mRef >> return (Just pid) Just Nothing -> do self <- getSelfPid - sRef <- spawnAsync nid ($(mkClosure 'registerSelf) (name,self) `seqCP` proc) + sRef <- spawnAsync nid (closure (static (registerSelf . decode)) (encode (name, self)) `seqCP` proc) ret <- receiveWait [ matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef) (\(NodeMonitorNotification _ _ _) -> return Nothing), diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/SystemLog.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/SystemLog.hs index 1c6d597b4..1a17828dc 100644 --- a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/SystemLog.hs +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/SystemLog.hs @@ -279,7 +279,7 @@ systemLog o c l f = go $ LogState o c l f defaultFormatters , (mxSink $ \(SetLevel lvl) -> mxGetLocal >>= \st' -> mxSetLocal st' { level = lvl } >> mxReceive) , (mxSink $ \(AddFormatter f') -> do - fmt <- liftMX $ catch (unClosure f' >>= return . Just) + fmt <- liftMX $ catch (unclosure f' >>= return . Just) (\(_ :: SomeException) -> return Nothing) case fmt of Nothing -> mxReady diff --git a/packages/distributed-process-extras/tests/TestLog.hs b/packages/distributed-process-extras/tests/TestLog.hs index 1a0ee7a1e..c6683e99d 100644 --- a/packages/distributed-process-extras/tests/TestLog.hs +++ b/packages/distributed-process-extras/tests/TestLog.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE StaticPointers #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where @@ -8,9 +8,8 @@ import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, newEmptyMVar) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan import Control.Distributed.Process hiding (monitor) -import Control.Distributed.Process.Closure (remotable, mkStaticClosure) import Control.Distributed.Process.Node -import Control.Distributed.Process.Extras hiding (__remoteTable) +import Control.Distributed.Process.Extras import qualified Control.Distributed.Process.Extras.SystemLog as Log (Logger) import Control.Distributed.Process.Extras.SystemLog hiding (Logger, error) import Control.Distributed.Process.SysTest.Utils @@ -37,10 +36,8 @@ logLevelFormatter m = handleMessage m showLevel showLevel :: LogLevel -> Process String showLevel = return . show -$(remotable ['logLevelFormatter]) - logFormat :: Closure (Message -> Process (Maybe String)) -logFormat = $(mkStaticClosure 'logLevelFormatter) +logFormat = (static logLevelFormatter) testLoggingProcess :: Process (ProcessId, TChan String) testLoggingProcess = do @@ -101,7 +98,7 @@ testHarness levels chan result = do tests :: NT.Transport -> IO TestTree tests transport = do let ch = logChannel - localNode <- newLocalNode transport $ __remoteTable initRemoteTable + localNode <- newLocalNode transport lock <- newMVar () ex <- newEmptyMVar void $ forkProcess localNode $ do (_, chan) <- testLoggingProcess diff --git a/packages/distributed-process-extras/tests/TestPrimitives.hs b/packages/distributed-process-extras/tests/TestPrimitives.hs index 780f54774..ebcf29024 100644 --- a/packages/distributed-process-extras/tests/TestPrimitives.hs +++ b/packages/distributed-process-extras/tests/TestPrimitives.hs @@ -1,7 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} - module Main where import Control.Concurrent (threadDelay) @@ -10,8 +8,7 @@ import Control.Distributed.Process import Control.Distributed.Process.Node import Control.Distributed.Process.Serializable() -import Control.Distributed.Process.Extras hiding (__remoteTable, monitor, send) -import qualified Control.Distributed.Process.Extras (__remoteTable) +import Control.Distributed.Process.Extras hiding (monitor, send) import Control.Distributed.Process.Extras.Call import Control.Distributed.Process.Extras.Monitoring import Control.Distributed.Process.Extras.Time @@ -91,8 +88,8 @@ testMonitorNodeDeath transport result = do nid2 <- liftIO $ newEmptyMVar nid3 <- liftIO $ newEmptyMVar - node2 <- liftIO $ newLocalNode transport initRemoteTable - node3 <- liftIO $ newLocalNode transport initRemoteTable + node2 <- liftIO $ newLocalNode transport + node3 <- liftIO $ newLocalNode transport -- sending to (nodeId, "ignored") is a short cut to force a connection liftIO $ tryForkProcess node2 $ ensureNodeRunning nid2 (nid1, "ignored") @@ -115,7 +112,7 @@ testMonitorNodeDeath transport result = do assertBool mempty $ n2 `elem` [mn1, mn2] nid4 <- liftIO $ newEmptyMVar - node4 <- liftIO $ newLocalNode transport initRemoteTable + node4 <- liftIO $ newLocalNode transport void $ liftIO $ runProcess node4 $ do us <- getSelfNode liftIO $ putMVar nid4 us @@ -134,12 +131,9 @@ testMonitorNodeDeath transport result = do liftIO $ putMVar mvar us sendTo nid "connected" -myRemoteTable :: RemoteTable -myRemoteTable = Control.Distributed.Process.Extras.__remoteTable initRemoteTable - multicallTest :: NT.Transport -> Assertion multicallTest transport = - do node1 <- newLocalNode transport myRemoteTable + do node1 <- newLocalNode transport tryRunProcess node1 $ do pid1 <- whereisOrStart "server1" server1 _ <- whereisOrStart "server2" server2 @@ -203,7 +197,7 @@ tests transport localNode = testGroup "TestPrimitives" [ primitivesTests :: NT.Transport -> IO TestTree primitivesTests transport = do - localNode <- newLocalNode transport initRemoteTable + localNode <- newLocalNode transport let testData = tests transport localNode return testData diff --git a/packages/distributed-process-extras/tests/TestTimer.hs b/packages/distributed-process-extras/tests/TestTimer.hs index 01216eb37..28c157ded 100644 --- a/packages/distributed-process-extras/tests/TestTimer.hs +++ b/packages/distributed-process-extras/tests/TestTimer.hs @@ -175,7 +175,7 @@ tests localNode = testGroup "TestTimer" [ timerTests :: NT.Transport -> IO TestTree timerTests transport = do - localNode <- newLocalNode transport initRemoteTable + localNode <- newLocalNode transport let testData = tests localNode return testData diff --git a/packages/distributed-process-fsm/distributed-process-fsm.cabal b/packages/distributed-process-fsm/distributed-process-fsm.cabal index 8756f66ad..4fa86d9a4 100644 --- a/packages/distributed-process-fsm/distributed-process-fsm.cabal +++ b/packages/distributed-process-fsm/distributed-process-fsm.cabal @@ -34,8 +34,8 @@ library import: warnings default-language: Haskell2010 build-depends: base >= 4.14 && < 5, - distributed-process >= 0.6.6 && < 0.8, - distributed-process-extras >= 0.3.1 && < 0.4, + distributed-process >= 0.8 && < 0.9, + distributed-process-extras >= 0.4 && < 0.5, distributed-process-client-server >= 0.2.5.1 && < 0.3, binary >= 0.8 && < 0.10, mtl >= 2.0 && <2.4, @@ -53,8 +53,8 @@ test-suite FsmTests build-depends: base >= 4.14 && < 5, network-transport >= 0.4 && < 0.6, network-transport-tcp >= 0.4 && <= 0.9, - distributed-process >= 0.6.6 && < 0.8, - distributed-process-extras >= 0.3.1 && < 0.4, + distributed-process >= 0.8 && < 0.9, + distributed-process-extras >= 0.4 && < 0.5, distributed-process-fsm, binary, tasty >= 1.5 && <1.6, diff --git a/packages/distributed-process-fsm/tests/TestFSM.hs b/packages/distributed-process-fsm/tests/TestFSM.hs index 7f5558b38..198d7dc1c 100644 --- a/packages/distributed-process-fsm/tests/TestFSM.hs +++ b/packages/distributed-process-fsm/tests/TestFSM.hs @@ -13,7 +13,6 @@ import Control.Distributed.Process.Extras ( ExitReason(..) , isProcessAlive ) -import qualified Control.Distributed.Process.Extras (__remoteTable) import Control.Distributed.Process.Extras.Time hiding (timeout) import Control.Distributed.Process.Extras.Timer import Control.Distributed.Process.FSM hiding (State, liftIO) @@ -254,10 +253,6 @@ walkingAnFsmTree pid = do alive' <- isProcessAlive pid liftIO $ assertBool mempty (not alive') -myRemoteTable :: RemoteTable -myRemoteTable = - Control.Distributed.Process.Extras.__remoteTable $ initRemoteTable - -- Some tests are flaky due to the CI environment being noticeable -- slower (and therefore exposing some race conditions) flaky :: TestTree -> TestTree @@ -266,7 +261,7 @@ flaky = flakyTest (limitRetries 3) tests :: NT.Transport -> IO TestTree tests transport = do {- verboseCheckWithResult stdArgs -} - localNode <- newLocalNode transport myRemoteTable + localNode <- newLocalNode transport return $ testGroup "Language/DSL" [ testCase "Traversing an FSM definition (operators)" diff --git a/packages/distributed-process-simplelocalnet/ChangeLog b/packages/distributed-process-simplelocalnet/ChangeLog index 36e129004..80ca7dde1 100644 --- a/packages/distributed-process-simplelocalnet/ChangeLog +++ b/packages/distributed-process-simplelocalnet/ChangeLog @@ -1,5 +1,6 @@ Unreleased +* Breaking: `initializeBackend` no longer takes a `RemoteTable`. * Added support for `containers-0.8`. 2025-02-04 Laurent P. René de Cotret 0.3.3 diff --git a/packages/distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabal b/packages/distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabal index 4d84ef043..99b417982 100644 --- a/packages/distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabal +++ b/packages/distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 Name: distributed-process-simplelocalnet -Version: 0.3.3 +Version: 0.4.0 Build-Type: Simple License: BSD-3-Clause License-File: LICENSE @@ -47,7 +47,7 @@ Library containers >= 0.6 && < 0.9, network-transport >= 0.5 && < 0.6, network-transport-tcp >= 0.4 && < 0.9, - distributed-process >= 0.5.0 && < 0.8 + distributed-process >= 0.8 && < 0.9 Exposed-modules: Control.Distributed.Process.Backend.SimpleLocalnet, Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast Default-Language: Haskell2010 @@ -61,7 +61,6 @@ Test-Suite SimpleLocalNet-TestSuite Default-Language: Haskell2010 ghc-options: -threaded -with-rtsopts=-N Build-Depends: base - , distributed-process , distributed-process-simplelocalnet , tasty , tasty-hunit diff --git a/packages/distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs b/packages/distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs index 9215d5f88..00c276847 100644 --- a/packages/distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs +++ b/packages/distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs @@ -12,7 +12,6 @@ -- -- > import System.Environment (getArgs) -- > import Control.Distributed.Process --- > import Control.Distributed.Process.Node (initRemoteTable) -- > import Control.Distributed.Process.Backend.SimpleLocalnet -- > -- > master :: Backend -> [NodeId] -> Process () @@ -28,10 +27,10 @@ -- > -- > case args of -- > ["master", host, port] -> do --- > backend <- initializeBackend host port initRemoteTable +-- > backend <- initializeBackend host port -- > startMaster backend (master backend) -- > ["slave", host, port] -> do --- > backend <- initializeBackend host port initRemoteTable +-- > backend <- initializeBackend host port -- > startSlave backend -- -- [Compiling and Running] @@ -109,8 +108,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Concurrent (forkIO, threadDelay, ThreadId) import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_) import Control.Distributed.Process - ( RemoteTable - , NodeId + ( NodeId , Process , ProcessId , WhereIsReply(..) @@ -171,8 +169,8 @@ data BackendState = BackendState { } -- | Initialize the backend -initializeBackend :: N.HostName -> N.ServiceName -> RemoteTable -> IO Backend -initializeBackend host port rtable = do +initializeBackend :: N.HostName -> N.ServiceName -> IO Backend +initializeBackend host port = do mTransport <- NT.createTransport (NT.Addressable $ NT.TCPAddrInfo host port (\sn -> (host, sn))) NT.defaultTCPParameters (recv, sendp) <- initMulticast "224.0.0.99" 9999 1024 @@ -188,7 +186,7 @@ initializeBackend host port rtable = do Left err -> throw err Right transport -> let backend = Backend { - newLocalNode = apiNewLocalNode transport rtable backendState + newLocalNode = apiNewLocalNode transport backendState , findPeers = apiFindPeers sendp backendState , redirectLogsHere = apiRedirectLogsHere backend } @@ -196,11 +194,10 @@ initializeBackend host port rtable = do -- | Create a new local node apiNewLocalNode :: NT.Transport - -> RemoteTable -> MVar BackendState -> IO Node.LocalNode -apiNewLocalNode transport rtable backendState = do - localNode <- Node.newLocalNode transport rtable +apiNewLocalNode transport backendState = do + localNode <- Node.newLocalNode transport modifyMVar_ backendState $ return . (localNodes ^: (localNode :)) return localNode diff --git a/packages/distributed-process-simplelocalnet/tests/Main.hs b/packages/distributed-process-simplelocalnet/tests/Main.hs index 2d629e1a8..088ab188a 100644 --- a/packages/distributed-process-simplelocalnet/tests/Main.hs +++ b/packages/distributed-process-simplelocalnet/tests/Main.hs @@ -2,7 +2,6 @@ import Control.Concurrent (forkIO, threadDelay) import qualified Control.Concurrent.MVar as MVar -import Control.Distributed.Process.Node (initRemoteTable) import Control.Distributed.Process.Backend.SimpleLocalnet import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) @@ -21,13 +20,13 @@ testDiscoverNodes = testCase "discover nodes" $ do -- Initialize slave nodes forM_ ["10000", "10001", "10002", "10003"] $ \port -> do - backend <- initializeBackend "127.0.0.1" port initRemoteTable + backend <- initializeBackend "127.0.0.1" port _ <- forkIO $ startSlave backend threadDelay 100000 -- initialize master node discoveredNodesSlot <- MVar.newEmptyMVar - backend <- initializeBackend "127.0.0.1" "10004" initRemoteTable + backend <- initializeBackend "127.0.0.1" "10004" startMaster backend $ \nds -> do terminateAllSlaves backend liftIO $ MVar.putMVar discoveredNodesSlot nds diff --git a/packages/distributed-process-supervisor/ChangeLog b/packages/distributed-process-supervisor/ChangeLog index 729a9fb30..86a587fe4 100644 --- a/packages/distributed-process-supervisor/ChangeLog +++ b/packages/distributed-process-supervisor/ChangeLog @@ -1,5 +1,7 @@ Unreleased +* Breaking: the `ToChildStart` instance for `Static (Process ())` is now an instance for `StaticPtr (Process ())`, + and `Static` is no longer re-exported. * Added support for `containers-0.8`. 2025-02-04 Laurent P. René de Cotret 0.2.4 diff --git a/packages/distributed-process-supervisor/distributed-process-supervisor.cabal b/packages/distributed-process-supervisor/distributed-process-supervisor.cabal index e701ef609..f09b3779a 100644 --- a/packages/distributed-process-supervisor/distributed-process-supervisor.cabal +++ b/packages/distributed-process-supervisor/distributed-process-supervisor.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: distributed-process-supervisor -version: 0.2.4 +version: 0.3.0 build-type: Simple license: BSD-3-Clause license-file: LICENSE @@ -44,9 +44,8 @@ library build-depends: base >= 4.14 && < 5, data-accessor >= 0.2.2.3, - distributed-static >= 0.3.4.0 && < 0.4, - distributed-process >= 0.7.3 && < 0.8, - distributed-process-extras >= 0.3.1 && < 0.4, + distributed-process >= 0.8 && < 0.9, + distributed-process-extras >= 0.4 && < 0.5, distributed-process-client-server >= 0.2.0 && < 0.4, binary >= 0.8 && < 0.9, deepseq >= 1.4 && < 1.7, @@ -67,13 +66,10 @@ test-suite SupervisorTests type: exitcode-stdio-1.0 build-depends: base >= 4.14 && < 5, - distributed-static >= 0.3.5.0 && < 0.4, - distributed-process >= 0.7.3 && < 0.8, + distributed-process >= 0.8 && < 0.9, distributed-process-supervisor, - distributed-process-extras >= 0.3 && < 0.4, + distributed-process-extras >= 0.4 && < 0.5, distributed-process-client-server, - distributed-static, - bytestring, random, network-transport >= 0.4 && < 0.6, network-transport-tcp >= 0.4 && < 0.9, @@ -95,13 +91,10 @@ test-suite NonThreadedSupervisorTests type: exitcode-stdio-1.0 build-depends: base >= 4.14 && < 5, - bytestring, - distributed-static >= 0.3.5.0 && < 0.4, - distributed-process >= 0.7.3 && < 0.8, + distributed-process >= 0.8 && < 0.9, distributed-process-supervisor, distributed-process-extras, distributed-process-client-server, - distributed-static, random, network-transport, network-transport-tcp >= 0.4 && < 0.9, diff --git a/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor.hs b/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor.hs index c32b07b0d..18e0fed82 100644 --- a/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor.hs +++ b/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor.hs @@ -194,9 +194,8 @@ -- automatically, but the /handle/ based approach requires that the @Closure@ -- responsible for spawning does the linking itself. -- --- Finally, we provide a simple shortcut to @staticClosure@, for consumers --- who've manually registered with the /remote table/ and don't with to use --- tempate haskell (e.g. users of the Explicit closures API). +-- Finally, we provide a simple shortcut from a @StaticPtr (Process ())@, for +-- consumers who don't wish to use template haskell. -- -- [Supervision Trees & Supervisor Shutdown] -- @@ -288,7 +287,6 @@ import Control.Distributed.Process , Message , ProcessMonitorNotification(..) , Closure - , Static , exit , kill , match @@ -308,7 +306,7 @@ import Control.Distributed.Process , unmonitor , withMonitor_ , expect - , unClosure + , unclosure , receiveWait , receiveTimeout , handleMessageIf @@ -376,10 +374,8 @@ import Control.Distributed.Process.Extras.SystemLog ) import qualified Control.Distributed.Process.Extras.SystemLog as Log import Control.Distributed.Process.Extras.Time -import Control.Distributed.Static - ( staticClosure - ) import Control.Exception (SomeException, throwIO) +import GHC.StaticPtr (StaticPtr, fromStaticPtr) import Control.Monad.Catch (catch, finally, mask) import Control.Monad (void, forM) @@ -435,8 +431,8 @@ instance ToChildStart (Closure (Process ())) where instance ToChildStart (Closure (SupervisorPid -> Process (ChildPid, Message))) where toChildStart = return . CreateHandle -instance ToChildStart (Static (Process ())) where - toChildStart = toChildStart . staticClosure +instance ToChildStart (StaticPtr (Process ())) where + toChildStart p = toChildStart (fromStaticPtr p :: Closure (Process ())) -- internal APIs. The corresponding XxxResult types are in -- Control.Distributed.Process.Supervisor.Types @@ -1251,13 +1247,13 @@ tryStartChild ChildSpec{..} = case childStart of RunClosure proc -> do -- TODO: cache your closures!!! - mProc <- catch (unClosure proc >>= return . Right) + mProc <- catch (unclosure proc >>= return . Right) (\(e :: SomeException) -> return $ Left (show e)) case mProc of Left err -> logStartFailure $ StartFailureBadClosure err Right p -> wrapClosure childKey childRegName p >>= return . Right CreateHandle fn -> do - mFn <- catch (unClosure fn >>= return . Right) + mFn <- catch (unclosure fn >>= return . Right) (\(e :: SomeException) -> return $ Left (show e)) case mFn of Left err -> logStartFailure $ StartFailureBadClosure err @@ -1315,7 +1311,7 @@ tryStartChild ChildSpec{..} = maybeRegister (Just (LocalName n)) pid = register n pid maybeRegister (Just (CustomRegister clj)) pid = do -- TODO: cache your closures!!! - mProc <- catch (unClosure clj >>= return . Right) + mProc <- catch (unclosure clj >>= return . Right) (\(e :: SomeException) -> return $ Left (show e)) case mProc of Left err -> die $ ExitOther (show err) diff --git a/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor/Types.hs b/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor/Types.hs index e330fc14c..d27b41aee 100644 --- a/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor/Types.hs +++ b/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor/Types.hs @@ -384,7 +384,7 @@ data MxSupervisor = instance Binary MxSupervisor where instance NFData MxSupervisor where --- | Static labels (in the remote table) are strings. +-- | The reason why a closure could not be resolved. type StaticLabel = String -- | Provides failure information when (re-)start failure is indicated. diff --git a/packages/distributed-process-supervisor/tests/TestSupervisor.hs b/packages/distributed-process-supervisor/tests/TestSupervisor.hs index f2ce52d6b..907cfd8ba 100644 --- a/packages/distributed-process-supervisor/tests/TestSupervisor.hs +++ b/packages/distributed-process-supervisor/tests/TestSupervisor.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE StaticPointers #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE Rank2Types #-} @@ -23,7 +23,6 @@ import Control.Concurrent.MVar import qualified Control.Exception as Ex import Control.Exception (throwIO) import Control.Distributed.Process hiding (call, monitor, finally) -import Control.Distributed.Process.Closure import Control.Distributed.Process.Node import Control.Distributed.Process.Extras.Internal.Types import Control.Distributed.Process.Extras.Internal.Primitives @@ -47,11 +46,11 @@ import Control.Distributed.Process.Supervisor.Management import Control.Distributed.Process.ManagedProcess.Client (shutdown) import Control.Distributed.Process.Serializable() -import Control.Distributed.Static (staticLabel) +import Data.Binary (decode, encode) +import Data.Word (Word64) import Control.Monad (void, unless, forM_, forM) import Control.Monad.Catch (finally) -import Data.ByteString.Lazy (empty) import Data.Maybe (catMaybes, isNothing, isJust) import Test.Tasty (TestTree, testGroup) @@ -328,6 +327,9 @@ blockIndefinitely = runTestProcess noOp notifyMe :: ProcessId -> Process () notifyMe me = getSelfPid >>= send me >> obedient +notifyMeClosure :: ProcessId -> Closure (Process ()) +notifyMeClosure me = closure (static (notifyMe . decode)) (encode me) + sleepy :: Process () sleepy = (sleepFor 5 Minutes) `catchExit` (\_ (_ :: ExitReason) -> return ()) >> sleepy @@ -358,16 +360,6 @@ formatMxSupervisor msg = do Nothing -> return Nothing Just m' -> return $ Just (show m') -$(remotable [ 'exitIgnore - , 'noOp - , 'blockIndefinitely - , 'sleepy - , 'obedient - , 'notifyMe - , 'runCore - , 'runApp - , 'formatMxSupervisor ]) - -- test cases start here... normalStartStop :: ProcessId -> Process () @@ -382,8 +374,8 @@ sequentialShutdown result = do (sp, rp) <- newChan (sg, rg) <- newChan - core' <- toChildStart $ $(mkClosure 'runCore) sp - app' <- toChildStart $ $(mkClosure 'runApp) sg + core' <- toChildStart $ closure (static (runCore . decode)) (encode sp) + app' <- toChildStart $ closure (static (runApp . decode)) (encode sg) let core = (permChild core') { childRegName = Just (LocalName "core") , childStop = StopTimeout (Delay $ within 2 Seconds) , childKey = "child-1" @@ -508,13 +500,18 @@ startDuplicateChild cs sup = do dup <- startNewChild sup spec liftIO $ assertEqual mempty dup (ChildFailedToStart $ StartFailureDuplicateChild ref) +-- | A closure that cannot be resolved, because it refers to a static pointer +-- that does not exist +unresolvableClosure :: Closure (Process ()) +unresolvableClosure = decode (encode (0 :: Word64, 0 :: Word64, 0 :: Word64)) + startBadClosure :: ChildStart -> ProcessId -> Process () startBadClosure cs sup = do let spec = tempWorker cs child <- startNewChild sup spec liftIO $ assertEqual mempty child (ChildFailedToStart $ StartFailureBadClosure - "user error (Could not resolve closure: Invalid static label 'non-existing')") + "user error (Could not resolve closure: static pointer 00000000000000000000000000000000 not found. The closure was probably sent by a different executable: all nodes that exchange closures must run the same binary.)") -- configuredBadClosure withSupervisor = do -- let spec = permChild (closure (staticLabel "non-existing") empty) @@ -676,7 +673,7 @@ stopChildImmediately cs sup = do stoppingChildExceedsDelay :: ProcessId -> Process () stoppingChildExceedsDelay sup = do - let spec = (tempWorker (RunClosure $(mkStaticClosure 'sleepy))) + let spec = (tempWorker (RunClosure (static sleepy))) { childStop = StopTimeout (Delay $ within 500 Millis) } ChildAdded ref <- startNewChild sup spec -- Just pid <- resolve ref @@ -687,7 +684,7 @@ stoppingChildExceedsDelay sup = do stoppingChildObeysDelay :: ProcessId -> Process () stoppingChildObeysDelay sup = do - let spec = (tempWorker (RunClosure $(mkStaticClosure 'obedient))) + let spec = (tempWorker (RunClosure (static obedient))) { childStop = StopTimeout (Delay $ within 1 Seconds) } ChildAdded child <- startNewChild sup spec Just pid <- resolve child @@ -716,7 +713,7 @@ delayedRestartAfterThreeAttempts :: (RestartStrategy -> [ChildSpec] -> (Context -> Process ()) -> Assertion) -> Assertion delayedRestartAfterThreeAttempts withSupervisor = do - let spec = (permChild $ RunClosure $ $(mkStaticClosure 'blockIndefinitely)) + let spec = (permChild $ RunClosure $ (static blockIndefinitely)) { childRestartDelay = Just (seconds 3) } let strategy = RestartOne $ limit (maxRestarts 2) (seconds 2) withSupervisor strategy [spec] $ \ctx@Context{..} -> do @@ -878,7 +875,7 @@ restartAllWithLeftToRightRestarts :: ProcessId -> Process () restartAllWithLeftToRightRestarts sup = do let (lSz, _) = randomIshSizes self <- getSelfPid - let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self) + let templ = permChild $ RunClosure (notifyMeClosure self) let specs = [templ { childKey = (show i) } | i <- [1..lSz :: Int]] -- add the specs one by one forM_ specs $ \s -> void $ startNewChild sup s @@ -918,7 +915,7 @@ restartAllWithLeftToRightRestarts sup = do restartAllWithRightToLeftSeqRestarts :: Context -> Process () restartAllWithRightToLeftSeqRestarts ctx@Context{..} = do self <- getSelfPid - let templ = permChild $ RunClosure $(mkStaticClosure 'obedient) + let templ = permChild $ RunClosure (static obedient) let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] -- add the specs one by one @@ -954,7 +951,7 @@ restartAllWithRightToLeftSeqRestarts ctx@Context{..} = do expectLeftToRightRestarts :: Context -> Process () expectLeftToRightRestarts ctx@Context{..} = do - let templ = permChild $ RunClosure $(mkStaticClosure 'obedient) + let templ = permChild $ RunClosure (static obedient) let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] -- add the specs one by one forM_ specs $ \s -> void $ startNewChild sup s @@ -985,7 +982,7 @@ expectLeftToRightRestarts ctx@Context{..} = do expectRightToLeftRestarts :: Bool -> Context -> Process () expectRightToLeftRestarts rev ctx@Context{..} = do self <- getSelfPid - let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self) + let templ = permChild $ RunClosure (notifyMeClosure self) let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] -- add the specs one by one forM_ specs $ \s -> do @@ -1058,7 +1055,7 @@ restartRightWhenRightmostChildDies cs sup = do restartLeftWithLeftToRightRestarts :: Bool -> Context -> Process () restartLeftWithLeftToRightRestarts rev ctx@Context{..} = do self <- getSelfPid - let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self) + let templ = permChild $ RunClosure (notifyMeClosure self) let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] forM_ specs $ \s -> void $ startNewChild sup s @@ -1089,7 +1086,7 @@ restartLeftWithLeftToRightRestarts rev ctx@Context{..} = do restartRightWithLeftToRightRestarts :: Bool -> Context -> Process () restartRightWithLeftToRightRestarts rev ctx@Context{..} = do - let templ = permChild $ RunClosure $(mkStaticClosure 'obedient) + let templ = permChild $ RunClosure (static obedient) let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] forM_ specs $ \s -> void $ startNewChild sup s @@ -1120,7 +1117,7 @@ restartRightWithLeftToRightRestarts rev ctx@Context{..} = do restartRightWithRightToLeftRestarts :: Bool -> Context -> Process () restartRightWithRightToLeftRestarts rev ctx@Context{..} = do - let templ = permChild $ RunClosure $(mkStaticClosure 'obedient) + let templ = permChild $ RunClosure (static obedient) let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] forM_ specs $ \s -> void $ startNewChild sup s @@ -1152,7 +1149,7 @@ restartRightWithRightToLeftRestarts rev ctx@Context{..} = do restartLeftWithRightToLeftRestarts :: Bool -> Context -> Process () restartLeftWithRightToLeftRestarts rev ctx@Context{..} = do - let templ = permChild $ RunClosure $(mkStaticClosure 'obedient) + let templ = permChild $ RunClosure (static obedient) let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] forM_ specs $ \s -> void $ startNewChild sup s @@ -1186,9 +1183,6 @@ restartLeftWithRightToLeftRestarts rev ctx@Context{..} = do -- remote table definition and main -myRemoteTable :: RemoteTable -myRemoteTable = Main.__remoteTable initRemoteTable - withClosure :: (ChildStart -> ProcessId -> Process ()) -> (Closure (Process ())) -> ProcessId -> Process () @@ -1208,13 +1202,13 @@ tests :: NT.Transport -> IO TestTree tests transport = do putStrLn $ concat [ "NOTICE: Branch Tests (Relying on Non-Guaranteed Message Order) " , "Can Fail Intermittently" ] - localNode <- newLocalNode transport myRemoteTable + localNode <- newLocalNode transport singleTestLock <- newMVar () runProcess localNode $ do void $ supervisionMonitor {- slog <- systemLogFile "supervisor.test.log" Debug return - addFormatter slog $(mkStaticClosure 'formatMxSupervisor) + addFormatter slog (static formatMxSupervisor) -} let withSup sm = runInTestContext localNode singleTestLock sm @@ -1231,63 +1225,63 @@ tests transport = do , testCase "Add Child Without Starting" (withSupervisor restartOne [] (withClosure addChildWithoutRestart - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Start Previously Added Child" (withSupervisor restartOne [] (withClosure addChildThenStart - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Start Unknown Child" (withSupervisor restartOne [] (withClosure startUnknownChild - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Add Duplicate Child" (withSupervisor restartOne [] (withClosure addDuplicateChild - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Start Duplicate Child" (withSupervisor restartOne [] (withClosure startDuplicateChild - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Started Temporary Child Exits With Ignore" (withSupervisor restartOne [] (withClosure startTemporaryChildExitsWithIgnore - $(mkStaticClosure 'exitIgnore))) + (static exitIgnore))) , testCase "Configured Temporary Child Exits With Ignore" (configuredTemporaryChildExitsWithIgnore - (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor) + (RunClosure (static exitIgnore)) withSupervisor) , testCase "Start Bad Closure" (withSupervisor restartOne [] (withClosure startBadClosure - (closure (staticLabel "non-existing") empty))) + unresolvableClosure)) , testCase "Configured Bad Closure" (configuredTemporaryChildExitsWithIgnore - (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor) + (RunClosure (static exitIgnore)) withSupervisor) , testCase "Started Non-Temporary Child Exits With Ignore" (withSupervisor restartOne [] $ (withClosure startNonTemporaryChildExitsWithIgnore - $(mkStaticClosure 'exitIgnore))) + (static exitIgnore))) , testCase "Configured Non-Temporary Child Exits With Ignore" (configuredNonTemporaryChildExitsWithIgnore - (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor) + (RunClosure (static exitIgnore)) withSupervisor) ] , testGroup "Stopping And Deleting Children" [ testCase "Delete Existing Child Fails" (withSupervisor restartOne [] (withClosure deleteExistingChild - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Delete Stopped Temporary Child (Doesn't Exist)" (withSupervisor restartOne [] (withClosure deleteStoppedTempChild - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Delete Stopped Child Succeeds" (withSupervisor restartOne [] (withClosure deleteStoppedChild - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Restart Minus Dropped (Temp) Child" (withSupervisor restartAll [] (withClosure restartWithoutTempChildren - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Sequential Shutdown Ordering" (delayedAssertion "expected the shutdown order to hold" @@ -1298,51 +1292,51 @@ tests transport = do testCase "Permanent Children Always Restart (Closure)" (withSupervisor restartOne [] (withClosure permanentChildrenAlwaysRestart - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Temporary Children Never Restart (Closure)" (withSupervisor restartOne [] (withClosure temporaryChildrenNeverRestart - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Transient Children Do Not Restart When Exiting Normally (Closure)" (withSupervisor restartOne [] (withClosure transientChildrenNormalExit - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Transient Children Do Restart When Exiting Abnormally (Closure)" (withSupervisor restartOne [] (withClosure transientChildrenAbnormalExit - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , flaky $ testCase "ExitShutdown Is Considered Normal" (withSupervisor' restartOne [] (withClosure' transientChildrenExitShutdown - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Intrinsic Children Do Restart When Exiting Abnormally (Closure)" (withSupervisor restartOne [] (withClosure intrinsicChildrenAbnormalExit - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase (concat [ "Intrinsic Children Cause Supervisor Exits " , "When Exiting Normally (Closure)"]) (withSupervisor restartOne [] (withClosure intrinsicChildrenNormalExit - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Explicit Restart Of Running Child Fails (Closure)" (withSupervisor restartOne [] (withClosure explicitRestartRunningChild - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Explicit Restart Of Unknown Child Fails" (withSupervisor restartOne [] explicitRestartUnknownChild) , testCase "Explicit Restart Whilst Child Restarting Fails (Closure)" (withSupervisor (RestartOne (limit (maxRestarts 500000000) (milliSeconds 1))) [] - (withClosure explicitRestartRestartingChild $(mkStaticClosure 'noOp))) + (withClosure explicitRestartRestartingChild (static noOp))) , testCase "Explicit Restart Stopped Child (Closure)" (withSupervisor restartOne [] (withClosure explicitRestartStoppedChild - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Immediate Child Stop (Brutal Kill) (Closure)" (withSupervisor restartOne [] (withClosure stopChildImmediately - $(mkStaticClosure 'blockIndefinitely))) + (static blockIndefinitely))) , testCase "Child Stop Exceeds Timeout/Delay (Becomes Brutal Kill)" (withSupervisor restartOne [] stoppingChildExceedsDelay) , testCase "Child Stop Within Timeout/Delay" @@ -1355,11 +1349,11 @@ tests transport = do [ testCase "Stop Child Ignores Siblings" (stopChildIgnoresSiblings - (RunClosure $(mkStaticClosure 'blockIndefinitely)) + (RunClosure (static blockIndefinitely)) withSupervisor) , testCase "Restart All, Left To Right (Sequential) Restarts" (restartAllWithLeftToRightSeqRestarts - (RunClosure $(mkStaticClosure 'blockIndefinitely)) + (RunClosure (static blockIndefinitely)) withSupervisor') , testCase "Restart All, Right To Left (Sequential) Restarts" (withSupervisor' @@ -1393,12 +1387,12 @@ tests transport = do [ testCase "Restart Left, Left To Right (Sequential) Restarts" (restartLeftWithLeftToRightSeqRestarts - (RunClosure $(mkStaticClosure 'blockIndefinitely)) + (RunClosure (static blockIndefinitely)) withSupervisor') , testCase "Restart Left, Leftmost Child Dies" (withSupervisor restartLeft [] $ restartLeftWhenLeftmostChildDies - (RunClosure $(mkStaticClosure 'blockIndefinitely))) + (RunClosure (static blockIndefinitely))) , testCase "Restart Left, Left To Right Stop, Left To Right Start" (withSupervisor' (RestartLeft defaultLimits (RestartInOrder LeftToRight)) [] @@ -1420,12 +1414,12 @@ tests transport = do [ testCase "Restart Right, Left To Right (Sequential) Restarts" (restartRightWithLeftToRightSeqRestarts - (RunClosure $(mkStaticClosure 'blockIndefinitely)) + (RunClosure (static blockIndefinitely)) withSupervisor) , testCase "Restart Right, Rightmost Child Dies" (withSupervisor restartRight [] $ restartRightWhenRightmostChildDies - (RunClosure $(mkStaticClosure 'blockIndefinitely))) + (RunClosure (static blockIndefinitely))) , testCase "Restart Right, Left To Right Stop, Left To Right Start" (withSupervisor' (RestartRight defaultLimits (RestartInOrder LeftToRight)) [] @@ -1448,10 +1442,10 @@ tests transport = do [ testCase "Three Attempts Before Successful Restart" (restartAfterThreeAttempts - (RunClosure $(mkStaticClosure 'blockIndefinitely)) withSupervisor) + (RunClosure (static blockIndefinitely)) withSupervisor) , testCase "Permanent Child Exceeds Restart Limits" (permanentChildExceedsRestartsIntensity - (RunClosure $(mkStaticClosure 'noOp)) withSupervisor) + (RunClosure (static noOp)) withSupervisor) , testCase "Permanent Child Delayed Restart" (delayedRestartAfterThreeAttempts withSupervisor') ] diff --git a/packages/distributed-process-supervisor/tests/TestUtils.hs b/packages/distributed-process-supervisor/tests/TestUtils.hs index cd4eb3526..7fa37ca11 100644 --- a/packages/distributed-process-supervisor/tests/TestUtils.hs +++ b/packages/distributed-process-supervisor/tests/TestUtils.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} module TestUtils @@ -93,7 +92,7 @@ mkNode :: String -> IO LocalNode mkNode port = do Right (transport1, _) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" port) defaultTCPParameters - newLocalNode transport1 initRemoteTable + newLocalNode transport1 -- | Run the supplied @testProc@ using an @MVar@ to collect and assert -- against its result. Uses the supplied @note@ if the assertion fails. diff --git a/packages/distributed-process-systest/distributed-process-systest.cabal b/packages/distributed-process-systest/distributed-process-systest.cabal index a02d4e94c..960c3e50f 100644 --- a/packages/distributed-process-systest/distributed-process-systest.cabal +++ b/packages/distributed-process-systest/distributed-process-systest.cabal @@ -34,7 +34,7 @@ library exposed-modules: Control.Distributed.Process.SysTest.Utils Build-Depends: base >= 4.14 && < 5, binary >= 0.8 && < 1.0, - distributed-process >= 0.6.1 && < 0.8, + distributed-process >= 0.8 && < 0.9, HUnit >= 1.2 && < 2, exceptions < 0.11, stm < 2.6 diff --git a/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs b/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs index 5e8b451e1..6e6ee97f2 100644 --- a/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs +++ b/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs @@ -1,7 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} - ----------------------------------------------------------------------------- -- | -- Module : Control.Distributed.Process.SysTest.Utils diff --git a/packages/distributed-process-tests/distributed-process-tests.cabal b/packages/distributed-process-tests/distributed-process-tests.cabal index ef09311f1..11703d837 100644 --- a/packages/distributed-process-tests/distributed-process-tests.cabal +++ b/packages/distributed-process-tests/distributed-process-tests.cabal @@ -52,9 +52,7 @@ library Control.Distributed.Process.Tests.Internal.Utils Build-Depends: base >= 4.14 && < 5, binary >= 0.8 && < 0.9, - bytestring >= 0.10 && < 0.13, - distributed-process >= 0.6.0 && < 0.8, - distributed-static, + distributed-process >= 0.8 && < 0.9, exceptions >= 0.10, network-transport >= 0.4.1.0 && < 0.6, random >= 1.0 && < 1.4, @@ -201,7 +199,7 @@ Test-Suite TestDeathKeys Build-Depends: base >= 4.14 && < 5, bytestring >= 0.10 && < 0.13, containers >= 0.6 && < 0.9, - distributed-process >= 0.7.10 && < 0.8, + distributed-process ^>=0.8, network-transport >= 0.4.1.0 && < 0.6, tasty >= 1.5 && <1.6, tasty-hunit >=0.10 && <0.11, diff --git a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs index 469eb9aea..5e9565f88 100644 --- a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs +++ b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs @@ -209,13 +209,13 @@ testPing TestTransport{..} = do -- Server forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport addr <- forkProcess localNode ping putMVar serverAddr addr -- Client forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport pingServer <- readMVar serverAddr let numPings = 10000 @@ -240,13 +240,13 @@ testMonitorUnreachable TestTransport{..} mOrL un = do done <- newEmptyMVar forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport addr <- forkProcess localNode expect closeLocalNode localNode putMVar deadProcess addr forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport theirAddr <- readMVar deadProcess runProcess localNode $ monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done @@ -261,13 +261,13 @@ testMonitorNormalTermination TestTransport{..} mOrL un = do done <- newEmptyMVar forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport addr <- forkProcess localNode $ liftIO $ readMVar monitorSetup putMVar monitoredProcess addr forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport theirAddr <- readMVar monitoredProcess runProcess localNode $ monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done @@ -284,14 +284,14 @@ testMonitorAbnormalTermination TestTransport{..} mOrL un = do let err = userError "Abnormal termination" forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport addr <- forkProcess localNode . liftIO $ do readMVar monitorSetup throwIO err putMVar monitoredProcess addr forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport theirAddr <- readMVar monitoredProcess runProcess localNode $ monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done @@ -302,7 +302,7 @@ testMonitorAbnormalTermination TestTransport{..} mOrL un = do testMonitorLocalDeadProcess :: TestTransport -> Bool -> Bool -> Assertion testMonitorLocalDeadProcess TestTransport{..} mOrL un = do processAddr <- newEmptyMVar - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport done <- newEmptyMVar forkIO $ do @@ -327,12 +327,12 @@ testMonitorRemoteDeadProcess TestTransport{..} mOrL un = do done <- newEmptyMVar forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport addr <- forkProcess localNode . liftIO $ putMVar processDead () putMVar processAddr addr forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport theirAddr <- readMVar processAddr readMVar processDead runProcess localNode $ do @@ -349,7 +349,7 @@ testMonitorDisconnect TestTransport{..} mOrL un = do done <- newEmptyMVar forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport addr <- forkProcess localNode $ expect addr2 <- forkProcess localNode $ return () putMVar processAddr addr @@ -359,7 +359,7 @@ testMonitorDisconnect TestTransport{..} mOrL un = do putMVar processAddr2 addr2 forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport theirAddr <- readMVar processAddr forkProcess localNode $ do lc <- liftIO $ readMVar processAddr2 @@ -377,13 +377,13 @@ testMath TestTransport{..} = do -- Server forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport addr <- forkProcess localNode math putMVar serverAddr addr -- Client forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport mathServer <- readMVar serverAddr runProcess localNode $ do @@ -412,7 +412,7 @@ testSendToTerminated TestTransport{..} = do forkIO $ do terminated <- newEmptyMVar - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport addr1 <- forkProcess localNode $ liftIO $ putMVar terminated () addr2 <- forkProcess localNode $ ping readMVar terminated @@ -420,7 +420,7 @@ testSendToTerminated TestTransport{..} = do putMVar serverAddr2 addr2 forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport server1 <- readMVar serverAddr1 server2 <- readMVar serverAddr2 runProcess localNode $ do @@ -434,7 +434,7 @@ testSendToTerminated TestTransport{..} = do -- | Test (non-zero) timeout testTimeout :: TestTransport -> Assertion testTimeout TestTransport{..} = do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport done <- newEmptyMVar runProcess localNode $ do @@ -450,7 +450,7 @@ testTimeout0 TestTransport{..} = do clientDone <- newEmptyMVar forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport addr <- forkProcess localNode $ do -- Variation on the venerable ping server which uses a zero timeout partner <- fix $ \loop -> @@ -461,7 +461,7 @@ testTimeout0 TestTransport{..} = do putMVar serverAddr addr forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport server <- readMVar serverAddr runProcess localNode $ do pid <- getSelfPid @@ -480,7 +480,7 @@ testTypedChannels TestTransport{..} = do clientDone <- newEmptyMVar forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport forkProcess localNode $ do (serverSendPort, rport) <- newChan liftIO $ putMVar serverChannel serverSendPort @@ -489,7 +489,7 @@ testTypedChannels TestTransport{..} = do return () forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport serverSendPort <- readMVar serverChannel runProcess localNode $ do (clientSendPort, rport) <- newChan @@ -502,7 +502,7 @@ testTypedChannels TestTransport{..} = do -- | Test merging receive ports testMergeChannels :: TestTransport -> Assertion testMergeChannels TestTransport{..} = do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport testFlat localNode True "aaabbbccc" testFlat localNode False "abcabcabc" testNested localNode True True "aaabbbcccdddeeefffggghhhiii" @@ -595,7 +595,7 @@ testMergeChannels TestTransport{..} = do testTerminate :: TestTransport -> Assertion testTerminate TestTransport{..} = do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport runProcess localNode $ do e <- try terminate :: Process (Either ProcessTerminationException ()) if either show show e == show ProcessTerminationException @@ -604,7 +604,7 @@ testTerminate TestTransport{..} = do testMonitorNode :: TestTransport -> Assertion testMonitorNode TestTransport{..} = do - [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable + [node1, node2] <- replicateM 2 $ newLocalNode testTransport done <- newEmptyMVar closeLocalNode node1 @@ -620,7 +620,7 @@ testMonitorNode TestTransport{..} = do testMonitorLiveNode :: TestTransport -> Assertion testMonitorLiveNode TestTransport{..} = do - [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable + [node1, node2] <- replicateM 2 $ newLocalNode testTransport ready <- newEmptyMVar readyr <- newEmptyMVar done <- newEmptyMVar @@ -648,7 +648,7 @@ testMonitorLiveNode TestTransport{..} = do testMonitorChannel :: TestTransport -> Assertion testMonitorChannel TestTransport{..} = do - [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable + [node1, node2] <- replicateM 2 $ newLocalNode testTransport gotNotification <- newEmptyMVar ready <- newEmptyMVar @@ -676,7 +676,7 @@ testMonitorChannel TestTransport{..} = do testRegistry :: TestTransport -> Assertion testRegistry TestTransport{..} = do - node <- newLocalNode testTransport initRemoteTable + node <- newLocalNode testTransport done <- newEmptyMVar pingServer <- forkProcess node ping @@ -708,8 +708,8 @@ testRegistry TestTransport{..} = do testRegistryRemoteProcess :: TestTransport -> Assertion testRegistryRemoteProcess TestTransport{..} = do - node1 <- newLocalNode testTransport initRemoteTable - node2 <- newLocalNode testTransport initRemoteTable + node1 <- newLocalNode testTransport + node2 <- newLocalNode testTransport done <- newEmptyMVar pingServer <- forkProcess node1 ping @@ -728,8 +728,8 @@ testRegistryRemoteProcess TestTransport{..} = do testRemoteRegistry :: TestTransport -> Assertion testRemoteRegistry TestTransport{..} = do - node1 <- newLocalNode testTransport initRemoteTable - node2 <- newLocalNode testTransport initRemoteTable + node1 <- newLocalNode testTransport + node2 <- newLocalNode testTransport pingServer <- forkProcess node1 ping deadProcess <- forkProcess node1 (return ()) @@ -773,8 +773,8 @@ testRemoteRegistry TestTransport{..} = do testRemoteRegistryRemoteProcess :: TestTransport -> Assertion testRemoteRegistryRemoteProcess TestTransport{..} = do - node1 <- newLocalNode testTransport initRemoteTable - node2 <- newLocalNode testTransport initRemoteTable + node1 <- newLocalNode testTransport + node2 <- newLocalNode testTransport done <- newEmptyMVar pingServer <- forkProcess node2 ping @@ -797,7 +797,7 @@ testRemoteRegistryRemoteProcess TestTransport{..} = do testSpawnLocal :: TestTransport -> Assertion testSpawnLocal TestTransport{..} = do - node <- newLocalNode testTransport initRemoteTable + node <- newLocalNode testTransport done <- newEmptyMVar runProcess node $ do @@ -818,7 +818,7 @@ testSpawnLocal TestTransport{..} = do testSpawnAsyncStrictness :: TestTransport -> Assertion testSpawnAsyncStrictness TestTransport{..} = do - node <- newLocalNode testTransport initRemoteTable + node <- newLocalNode testTransport done <- newEmptyMVar runProcess node $ do @@ -833,7 +833,7 @@ testSpawnAsyncStrictness TestTransport{..} = do testReconnect :: TestTransport -> Assertion testReconnect TestTransport{..} = do - [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable + [node1, node2] <- replicateM 2 $ newLocalNode testTransport let nid1 = localNodeId node1 processA <- newEmptyMVar [sendTestOk, registerTestOk] <- replicateM 2 newEmptyMVar @@ -911,7 +911,7 @@ testReconnect TestTransport{..} = do testUSend :: (ProcessId -> Int -> Process ()) -> TestTransport -> Int -> Assertion testUSend usendPrim TestTransport{..} numMessages = do - [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable + [node1, node2] <- replicateM 2 $ newLocalNode testTransport let nid1 = localNodeId node1 nid2 = localNodeId node2 processA <- newEmptyMVar @@ -964,7 +964,7 @@ testMatchAny TestTransport{..} = do -- Math server forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport mathServer <- forkProcess localNode math proxyServer <- forkProcess localNode $ forever $ do msg <- receiveWait [ matchAny return ] @@ -973,7 +973,7 @@ testMatchAny TestTransport{..} = do -- Client forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport mathServer <- readMVar proxyAddr runProcess localNode $ do @@ -1000,7 +1000,7 @@ testMatchAnyHandle TestTransport{..} = do -- Math server forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport mathServer <- forkProcess localNode math proxyServer <- forkProcess localNode $ forever $ do receiveWait [ @@ -1010,7 +1010,7 @@ testMatchAnyHandle TestTransport{..} = do -- Client forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport mathServer <- readMVar proxyAddr runProcess localNode $ do @@ -1035,7 +1035,7 @@ testMatchAnyNoHandle TestTransport{..} = do -- Math server forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport server <- forkProcess localNode $ forever $ do receiveWait [ matchAnyIf @@ -1058,7 +1058,7 @@ testMatchAnyNoHandle TestTransport{..} = do -- Client forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport server <- readMVar addr runProcess localNode $ do @@ -1080,7 +1080,7 @@ testMatchAnyIf TestTransport{..} = do -- echo server forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport echoServer <- forkProcess localNode $ forever $ do receiveWait [ matchAnyIf (\(_ :: ProcessId, (s :: String)) -> s /= "bar") @@ -1090,7 +1090,7 @@ testMatchAnyIf TestTransport{..} = do -- Client forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport server <- readMVar echoAddr runProcess localNode $ do @@ -1123,7 +1123,7 @@ testMatchMessageWithUnwrap TestTransport{..} = do -- echo server forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport echoServer <- forkProcess localNode $ forever $ do msg <- receiveWait [ matchMessage (\(m :: Message) -> do @@ -1137,7 +1137,7 @@ testMatchMessageWithUnwrap TestTransport{..} = do -- Client forkIO $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport server <- readMVar echoAddr runProcess localNode $ do @@ -1159,7 +1159,7 @@ testReceiveChanTimeout TestTransport{..} = do sendPort <- newEmptyMVar forkTry $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport runProcess localNode $ do -- Create a typed channel (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool) @@ -1195,7 +1195,7 @@ testReceiveChanTimeout TestTransport{..} = do liftIO $ putMVar done () forkTry $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport runProcess localNode $ do sp <- liftIO $ readMVar sendPort @@ -1214,7 +1214,7 @@ testReceiveChanFeatures TestTransport{..} = do done <- newEmptyMVar forkTry $ do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport runProcess localNode $ do (spInt, rpInt) <- newChan :: Process (SendPort Int, ReceivePort Int) (spBool, rpBool) <- newChan :: Process (SendPort Bool, ReceivePort Bool) @@ -1271,7 +1271,7 @@ testChanLifecycle :: TestTransport -> Assertion testChanLifecycle TestTransport{..} = let delay = 3000000 in do result <- newEmptyMVar tchMV <- newEmptyMVar - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport runProcess localNode $ do pid <- spawnLocal $ do tCh <- newChan :: Process (SendPort (), ReceivePort ()) @@ -1339,7 +1339,7 @@ testChanLifecycle TestTransport{..} = let delay = 3000000 in do testKillLocal :: TestTransport -> Assertion testKillLocal TestTransport{..} = do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport pid <- forkProcess localNode $ do liftIO $ threadDelay 1000000 @@ -1358,8 +1358,8 @@ testKillLocal TestTransport{..} = do testKillRemote :: TestTransport -> Assertion testKillRemote TestTransport{..} = do - node1 <- newLocalNode testTransport initRemoteTable - node2 <- newLocalNode testTransport initRemoteTable + node1 <- newLocalNode testTransport + node2 <- newLocalNode testTransport pid <- forkProcess node1 $ do liftIO $ threadDelay 1000000 @@ -1382,7 +1382,7 @@ testKillRemote TestTransport{..} = do testCatchesExit :: TestTransport -> Assertion testCatchesExit TestTransport{..} = do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport done <- newEmptyMVar _ <- forkProcess localNode $ do @@ -1398,7 +1398,7 @@ testCatchesExit TestTransport{..} = do testHandleMessageIf :: TestTransport -> Assertion testHandleMessageIf TestTransport{..} = do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport done <- newEmptyMVar _ <- forkProcess localNode $ do self <- getSelfPid @@ -1417,7 +1417,7 @@ testHandleMessageIf TestTransport{..} = do testCatches :: TestTransport -> Assertion testCatches TestTransport{..} = do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport done <- newEmptyMVar _ <- forkProcess localNode $ do @@ -1431,7 +1431,7 @@ testCatches TestTransport{..} = do testMaskRestoreScope :: TestTransport -> Assertion testMaskRestoreScope TestTransport{..} = do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport parentPid <- newEmptyMVar :: IO (MVar ProcessId) spawnedPid <- newEmptyMVar :: IO (MVar ProcessId) @@ -1445,7 +1445,7 @@ testMaskRestoreScope TestTransport{..} = do testDie :: TestTransport -> Assertion testDie TestTransport{..} = do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport done <- newEmptyMVar _ <- forkProcess localNode $ do @@ -1462,7 +1462,7 @@ testDie TestTransport{..} = do testPrettyExit :: TestTransport -> Assertion testPrettyExit TestTransport{..} = do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport done <- newEmptyMVar _ <- forkProcess localNode $ do @@ -1480,7 +1480,7 @@ testPrettyExit TestTransport{..} = do testExitLocal :: TestTransport -> Assertion testExitLocal TestTransport{..} = do - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport supervisedDone <- newEmptyMVar supervisorDone <- newEmptyMVar -- XXX: we guarantee that exception handler will be set up @@ -1516,8 +1516,8 @@ testExitLocal TestTransport{..} = do testExitRemote :: TestTransport -> Assertion testExitRemote TestTransport{..} = do - node1 <- newLocalNode testTransport initRemoteTable - node2 <- newLocalNode testTransport initRemoteTable + node1 <- newLocalNode testTransport + node2 <- newLocalNode testTransport supervisedDone <- newEmptyMVar supervisorDone <- newEmptyMVar @@ -1549,8 +1549,8 @@ testExitRemote TestTransport{..} = do testRegistryMonitoring :: TestTransport -> Assertion testRegistryMonitoring TestTransport{..} = do - node1 <- newLocalNode testTransport initRemoteTable - node2 <- newLocalNode testTransport initRemoteTable + node1 <- newLocalNode testTransport + node2 <- newLocalNode testTransport let nid = localNodeId node2 pid <- forkProcess node1 $ do @@ -1622,7 +1622,7 @@ testUnsafeSend TestTransport{..} = do serverAddr <- newEmptyMVar clientDone <- newEmptyMVar - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport void $ forkProcess localNode $ do self <- getSelfPid liftIO $ putMVar serverAddr self @@ -1641,7 +1641,7 @@ testUnsafeUSend TestTransport{..} = do serverAddr <- newEmptyMVar clientDone <- newEmptyMVar - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport void $ forkProcess localNode $ do self <- getSelfPid liftIO $ putMVar serverAddr self @@ -1659,7 +1659,7 @@ testUnsafeNSend :: TestTransport -> Assertion testUnsafeNSend TestTransport{..} = do clientDone <- newEmptyMVar - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport pid <- forkProcess localNode $ do expect >>= liftIO . putMVar clientDone @@ -1674,8 +1674,8 @@ testUnsafeNSendRemote :: TestTransport -> Assertion testUnsafeNSendRemote TestTransport{..} = do clientDone <- newEmptyMVar - localNode1 <- newLocalNode testTransport initRemoteTable - localNode2 <- newLocalNode testTransport initRemoteTable + localNode1 <- newLocalNode testTransport + localNode2 <- newLocalNode testTransport _ <- forkProcess localNode1 $ do getSelfPid >>= register "foobar" @@ -1693,7 +1693,7 @@ testUnsafeSendChan TestTransport{..} = do serverAddr <- newEmptyMVar clientDone <- newEmptyMVar - localNode <- newLocalNode testTransport initRemoteTable + localNode <- newLocalNode testTransport void $ forkProcess localNode $ do self <- getSelfPid liftIO $ putMVar serverAddr self @@ -1711,7 +1711,7 @@ testUnsafeSendChan TestTransport{..} = do testCallLocal :: TestTransport -> Assertion testCallLocal TestTransport{..} = do - node <- newLocalNode testTransport initRemoteTable + node <- newLocalNode testTransport -- Testing that (/=) <$> getSelfPid <*> callLocal getSelfPid. result <- newEmptyMVar diff --git a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs index 96fdab778..e81653ebc 100644 --- a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs +++ b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs @@ -1,15 +1,16 @@ {-# OPTIONS_GHC -Wno-unused-top-binds #-} +{-# LANGUAGE StaticPointers #-} {-# LANGUAGE TemplateHaskell, KindSignatures #-} module Control.Distributed.Process.Tests.Closure (tests) where import Network.Transport.Test (TestTransport(..)) -import Data.ByteString.Lazy (empty) import Data.IORef import Data.Typeable (Typeable) import Data.Maybe import Control.Monad (join, replicateM, forever, replicateM_, void, when, unless) import Control.Exception (IOException, throw) +import qualified Control.Monad.Catch as Catch import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar ( MVar @@ -28,7 +29,9 @@ import Control.Distributed.Process.Internal.Types ( createMessage , messageToPayload ) -import Control.Distributed.Static (staticLabel, staticClosure) +import Data.Binary (decode, encode) +import Data.Word (Word64) +import GHC.StaticPtr (StaticPtr) import qualified Network.Transport as NT import Test.Tasty (TestTree, testGroup) @@ -81,44 +84,28 @@ typedPingServer () rport = forever $ do signal :: ProcessId -> Process () signal pid = send pid () -remotable [ 'factorial - , 'addInt - , 'putInt - , 'sendPid - , 'sdictInt - , 'wait - , 'expectUnit - , 'typedPingServer - , 'isPrime - , 'quintuple - , 'signal - ] - randomElement :: [a] -> IO a randomElement xs = do ix <- randomIO return (xs !! (ix `mod` length xs)) -remotableDecl [ - [d| dfib :: ([NodeId], SendPort Integer, Integer) -> Process () ; - dfib (_, reply, 0) = sendChan reply 0 - dfib (_, reply, 1) = sendChan reply 1 - dfib (nids, reply, n) = do - nid1 <- liftIO $ randomElement nids - nid2 <- liftIO $ randomElement nids - (sport, rport) <- newChan - spawn nid1 $ $(mkClosure 'dfib) (nids, sport, n - 2) - spawn nid2 $ $(mkClosure 'dfib) (nids, sport, n - 1) - n1 <- receiveChan rport - n2 <- receiveChan rport - sendChan reply $ n1 + n2 - |] - ] +dfib :: ([NodeId], SendPort Integer, Integer) -> Process () +dfib (_, reply, 0) = sendChan reply 0 +dfib (_, reply, 1) = sendChan reply 1 +dfib (nids, reply, n) = do + nid1 <- liftIO $ randomElement nids + nid2 <- liftIO $ randomElement nids + (sport, rport) <- newChan + spawn nid1 $ $(mkClosure 'dfib) (nids, sport, n - 2) + spawn nid2 $ $(mkClosure 'dfib) (nids, sport, n - 1) + n1 <- receiveChan rport + n2 <- receiveChan rport + sendChan reply $ n1 + n2 -- Just try creating a static polymorphic value staticQuintuple :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) - => Static (a -> b -> c -> d -> e -> (a, b, c, d, e)) -staticQuintuple = $(mkStatic 'quintuple) + => StaticPtr (a -> b -> c -> d -> e -> (a, b, c, d, e)) +staticQuintuple = (static quintuple) factorialClosure :: Int -> Closure (Process Int) factorialClosure = $(mkClosure 'factorial) @@ -133,13 +120,13 @@ sendPidClosure :: ProcessId -> Closure (Process ()) sendPidClosure = $(mkClosure 'sendPid) sendFac :: Int -> ProcessId -> Closure (Process ()) -sendFac n pid = factorialClosure n `bindCP` cpSend $(mkStatic 'sdictInt) pid +sendFac n pid = factorialClosure n `bindCP` cpSend (static sdictInt) pid factorialOf :: Closure (Int -> Process Int) -factorialOf = staticClosure $(mkStatic 'factorial) +factorialOf = (static factorial) factorial' :: Int -> Closure (Process Int) -factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf +factorial' n = returnCP (static sdictInt) n `bindCP` factorialOf waitClosure :: Int -> Closure (Process ()) waitClosure = $(mkClosure 'wait) @@ -162,25 +149,25 @@ simulateNetworkFailure TestTransport{..} from to = liftIO $ do -- The tests proper -- -------------------------------------------------------------------------------- -testUnclosure :: TestTransport -> RemoteTable -> Assertion -testUnclosure TestTransport{..} rtable = do - node <- newLocalNode testTransport rtable +testUnclosure :: TestTransport -> Assertion +testUnclosure TestTransport{..} = do + node <- newLocalNode testTransport done <- newEmptyMVar forkProcess node $ do - i <- join . unClosure $ factorialClosure 5 + i <- join . unclosure $ factorialClosure 5 liftIO $ putMVar done () if i == 720 then return () else error "Something went horribly wrong" takeMVar done -testBind :: TestTransport -> RemoteTable -> Assertion -testBind TestTransport{..} rtable = do - node <- newLocalNode testTransport rtable +testBind :: TestTransport -> Assertion +testBind TestTransport{..} = do + node <- newLocalNode testTransport done <- newEmptyMVar runProcess node $ do us <- getSelfPid - join . unClosure $ sendFac 6 us + join . unclosure $ sendFac 6 us (i :: Int) <- expect liftIO $ putMVar done () if i == 720 @@ -188,37 +175,37 @@ testBind TestTransport{..} rtable = do else error "Something went horribly wrong" takeMVar done -testSendPureClosure :: TestTransport -> RemoteTable -> Assertion -testSendPureClosure TestTransport{..} rtable = do +testSendPureClosure :: TestTransport -> Assertion +testSendPureClosure TestTransport{..} = do serverAddr <- newEmptyMVar serverDone <- newEmptyMVar forkIO $ do - node <- newLocalNode testTransport rtable + node <- newLocalNode testTransport addr <- forkProcess node $ do cl <- expect - fn <- unClosure cl :: Process (Int -> Int) + fn <- unclosure cl :: Process (Int -> Int) (_ :: Int) <- return $ fn 6 liftIO $ putMVar serverDone () putMVar serverAddr addr forkIO $ do - node <- newLocalNode testTransport rtable + node <- newLocalNode testTransport theirAddr <- readMVar serverAddr runProcess node $ send theirAddr (addIntClosure 7) takeMVar serverDone -testSendIOClosure :: TestTransport -> RemoteTable -> Assertion -testSendIOClosure TestTransport{..} rtable = do +testSendIOClosure :: TestTransport -> Assertion +testSendIOClosure TestTransport{..} = do serverAddr <- newEmptyMVar serverDone <- newEmptyMVar forkIO $ do - node <- newLocalNode testTransport rtable + node <- newLocalNode testTransport addr <- forkProcess node $ do cl <- expect - io <- unClosure cl :: Process (MVar Int -> IO ()) + io <- unclosure cl :: Process (MVar Int -> IO ()) liftIO $ do someMVar <- newEmptyMVar io someMVar @@ -230,31 +217,31 @@ testSendIOClosure TestTransport{..} rtable = do putMVar serverAddr addr forkIO $ do - node <- newLocalNode testTransport rtable + node <- newLocalNode testTransport theirAddr <- readMVar serverAddr runProcess node $ send theirAddr (putIntClosure 5) takeMVar serverDone -testSendProcClosure :: TestTransport -> RemoteTable -> Assertion -testSendProcClosure TestTransport{..} rtable = do +testSendProcClosure :: TestTransport -> Assertion +testSendProcClosure TestTransport{..} = do serverAddr <- newEmptyMVar clientDone <- newEmptyMVar forkIO $ do - node <- newLocalNode testTransport rtable + node <- newLocalNode testTransport addr <- forkProcess node $ do cl <- expect - pr <- unClosure cl :: Process (Int -> Process ()) + pr <- unclosure cl :: Process (Int -> Process ()) pr 5 putMVar serverAddr addr forkIO $ do - node <- newLocalNode testTransport rtable + node <- newLocalNode testTransport theirAddr <- readMVar serverAddr runProcess node $ do pid <- getSelfPid - send theirAddr (cpSend $(mkStatic 'sdictInt) pid) + send theirAddr (cpSend (static sdictInt) pid) i <- expect :: Process Int if i == 5 then liftIO $ putMVar clientDone () @@ -262,17 +249,17 @@ testSendProcClosure TestTransport{..} rtable = do takeMVar clientDone -testSpawn :: TestTransport -> RemoteTable -> Assertion -testSpawn TestTransport{..} rtable = do +testSpawn :: TestTransport -> Assertion +testSpawn TestTransport{..} = do serverNodeAddr <- newEmptyMVar clientDone <- newEmptyMVar forkIO $ do - node <- newLocalNode testTransport rtable + node <- newLocalNode testTransport putMVar serverNodeAddr (localNodeId node) forkIO $ do - node <- newLocalNode testTransport rtable + node <- newLocalNode testTransport nid <- readMVar serverNodeAddr runProcess node $ do pid <- getSelfPid @@ -294,10 +281,10 @@ testSpawn TestTransport{..} rtable = do -- remote peer the message that it is waiting to stop monitoring the caller, -- namely @()@. -- -testSpawnRace :: TestTransport -> RemoteTable -> Assertion -testSpawnRace TestTransport{..} rtable = do - node1 <- newLocalNode (wrapTransport testTransport) rtable - node2 <- newLocalNode testTransport rtable +testSpawnRace :: TestTransport -> Assertion +testSpawnRace TestTransport{..} = do + node1 <- newLocalNode (wrapTransport testTransport) + node2 <- newLocalNode testTransport runProcess node1 $ do pid <- getSelfPid @@ -330,53 +317,53 @@ testSpawnRace TestTransport{..} rtable = do if isHealthy then s msg else return $ Left $ NT.TransportError NT.SendFailed "" -testCall :: TestTransport -> RemoteTable -> Assertion -testCall TestTransport{..} rtable = do +testCall :: TestTransport -> Assertion +testCall TestTransport{..} = do serverNodeAddr <- newEmptyMVar clientDone <- newEmptyMVar forkIO $ do - node <- newLocalNode testTransport rtable + node <- newLocalNode testTransport putMVar serverNodeAddr (localNodeId node) forkIO $ do - node <- newLocalNode testTransport rtable + node <- newLocalNode testTransport nid <- readMVar serverNodeAddr runProcess node $ do - (a :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5) + (a :: Int) <- call (static sdictInt) nid (factorialClosure 5) if a == 120 then liftIO $ putMVar clientDone () else error "something went horribly wrong" takeMVar clientDone -testCallBind :: TestTransport -> RemoteTable -> Assertion -testCallBind TestTransport{..} rtable = do +testCallBind :: TestTransport -> Assertion +testCallBind TestTransport{..} = do serverNodeAddr <- newEmptyMVar clientDone <- newEmptyMVar forkIO $ do - node <- newLocalNode testTransport rtable + node <- newLocalNode testTransport putMVar serverNodeAddr (localNodeId node) forkIO $ do - node <- newLocalNode testTransport rtable + node <- newLocalNode testTransport nid <- readMVar serverNodeAddr runProcess node $ do - (a :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5) + (a :: Int) <- call (static sdictInt) nid (factorial' 5) if a == 120 then liftIO $ putMVar clientDone () else error "Something went horribly wrong" takeMVar clientDone -testSeq :: TestTransport -> RemoteTable -> Assertion -testSeq TestTransport{..} rtable = do - node <- newLocalNode testTransport rtable +testSeq :: TestTransport -> Assertion +testSeq TestTransport{..} = do + node <- newLocalNode testTransport done <- newEmptyMVar runProcess node $ do us <- getSelfPid - join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us + join . unclosure $ sendFac 5 us `seqCP` sendFac 6 us a :: Int <- expect b :: Int <- expect if a == 120 && b == 720 @@ -390,9 +377,9 @@ testSeq TestTransport{..} rtable = do -- child. The supervisor then throws an exception, the child dies because it -- was linked to the supervisor, and the third process notices that the child -- dies. -testSpawnSupervised :: TestTransport -> RemoteTable -> Assertion -testSpawnSupervised TestTransport{..} rtable = do - [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable +testSpawnSupervised :: TestTransport -> Assertion +testSpawnSupervised TestTransport{..} = do + [node1, node2] <- replicateM 2 $ newLocalNode testTransport [superPid, childPid] <- replicateM 2 $ newEmptyMVar thirdProcessDone <- newEmptyMVar linkUp <- newEmptyMVar @@ -401,7 +388,7 @@ testSpawnSupervised TestTransport{..} rtable = do us <- getSelfPid liftIO $ putMVar superPid us (child, _ref) <- spawnSupervised (localNodeId node2) - (sendPidClosure us `seqCP` $(mkStaticClosure 'expectUnit)) + (sendPidClosure us `seqCP` (static expectUnit)) _ <- expect :: Process ProcessId liftIO $ do putMVar childPid child @@ -443,28 +430,31 @@ testSpawnSupervised TestTransport{..} rtable = do supervisorDeath :: IOException supervisorDeath = userError "Supervisor died" -testSpawnInvalid :: TestTransport -> RemoteTable -> Assertion -testSpawnInvalid TestTransport{..} rtable = do - node <- newLocalNode testTransport rtable +-- | A closure that cannot be resolved, because it refers to a static pointer +-- that does not exist +unresolvableClosure :: Closure (Process ()) +unresolvableClosure = decode (encode (0 :: Word64, 0 :: Word64, 0 :: Word64)) + +-- A closure can only be unresolvable if it comes from a different executable, +-- so we can only test that resolving one fails cleanly. +testSpawnInvalid :: TestTransport -> Assertion +testSpawnInvalid TestTransport{..} = do + node <- newLocalNode testTransport done <- newEmptyMVar forkProcess node $ do - (pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty) - ProcessMonitorNotification ref' pid' _reason <- expect - -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure - res <- return $ ref' == ref && pid == pid' - if res == True - then liftIO $ putMVar done () - else error "Something went horribly wrong" - takeMVar done - -testClosureExpect :: TestTransport -> RemoteTable -> Assertion -testClosureExpect TestTransport{..} rtable = do - node <- newLocalNode testTransport rtable + r <- Catch.try (unclosure unresolvableClosure) + liftIO $ putMVar done (either (\(_ :: IOException) -> True) (const False) r) + failed <- takeMVar done + unless failed $ error "Something went horribly wrong" + +testClosureExpect :: TestTransport -> Assertion +testClosureExpect TestTransport{..} = do + node <- newLocalNode testTransport done <- newEmptyMVar runProcess node $ do nodeId <- getSelfNode us <- getSelfPid - them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us + them <- spawn nodeId $ cpExpect (static sdictInt) `bindCP` cpSend (static sdictInt) us send them (1234 :: Int) (res :: Int) <- expect if res == 1234 @@ -472,14 +462,14 @@ testClosureExpect TestTransport{..} rtable = do else error "Something went horribly wrong" takeMVar done -testSpawnChannel :: TestTransport -> RemoteTable -> Assertion -testSpawnChannel TestTransport{..} rtable = do +testSpawnChannel :: TestTransport -> Assertion +testSpawnChannel TestTransport{..} = do done <- newEmptyMVar - [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable + [node1, node2] <- replicateM 2 $ newLocalNode testTransport forkProcess node1 $ do pingServer <- spawnChannel - (sdictSendPort sdictUnit) + (static SerializableDict) (localNodeId node2) ($(mkClosure 'typedPingServer) ()) (sendReply, receiveReply) <- newChan @@ -489,10 +479,10 @@ testSpawnChannel TestTransport{..} rtable = do takeMVar done -testTDict :: TestTransport -> RemoteTable -> Assertion -testTDict TestTransport{..} rtable = do +testTDict :: TestTransport -> Assertion +testTDict TestTransport{..} = do done <- newEmptyMVar - [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable + [node1, node2] <- replicateM 2 $ newLocalNode testTransport forkProcess node1 $ do res <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer)) if res == True @@ -500,9 +490,9 @@ testTDict TestTransport{..} rtable = do else error "Something went horribly wrong..." takeMVar done -testFib :: TestTransport -> RemoteTable -> Assertion -testFib TestTransport{..} rtable = do - nodes <- replicateM 4 $ newLocalNode testTransport rtable +testFib :: TestTransport -> Assertion +testFib TestTransport{..} = do + nodes <- replicateM 4 $ newLocalNode testTransport done <- newEmptyMVar forkProcess (head nodes) $ do @@ -516,9 +506,9 @@ testFib TestTransport{..} rtable = do takeMVar done -testSpawnReconnect :: TestTransport -> RemoteTable -> Assertion -testSpawnReconnect testtrans@TestTransport{..} rtable = do - [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable +testSpawnReconnect :: TestTransport -> Assertion +testSpawnReconnect testtrans@TestTransport{..} = do + [node1, node2] <- replicateM 2 $ newLocalNode testTransport let nid1 = localNodeId node1 -- nid2 = localNodeId node2 done <- newEmptyMVar @@ -548,10 +538,10 @@ testSpawnReconnect testtrans@TestTransport{..} rtable = do -- | 'spawn' used to ave a race condition which would be triggered if the -- spawning process terminates immediately after spawning -testSpawnTerminate :: TestTransport -> RemoteTable -> Assertion -testSpawnTerminate TestTransport{..} rtable = do - slave <- newLocalNode testTransport rtable - master <- newLocalNode testTransport rtable +testSpawnTerminate :: TestTransport -> Assertion +testSpawnTerminate TestTransport{..} = do + slave <- newLocalNode testTransport + master <- newLocalNode testTransport masterDone <- newEmptyMVar runProcess master $ do @@ -564,24 +554,5 @@ testSpawnTerminate TestTransport{..} rtable = do tests :: TestTransport -> IO TestTree tests testtrans = do - let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable return $ testGroup "Closure" - [ testCase "Unclosure" (testUnclosure testtrans rtable) - , testCase "Bind" (testBind testtrans rtable) - , testCase "SendPureClosure" (testSendPureClosure testtrans rtable) - , testCase "SendIOClosure" (testSendIOClosure testtrans rtable) - , testCase "SendProcClosure" (testSendProcClosure testtrans rtable) - , testCase "Spawn" (testSpawn testtrans rtable) - , testCase "SpawnRace" (testSpawnRace testtrans rtable) - , testCase "Call" (testCall testtrans rtable) - , testCase "CallBind" (testCallBind testtrans rtable) - , testCase "Seq" (testSeq testtrans rtable) - , testCase "SpawnSupervised" (testSpawnSupervised testtrans rtable) - , testCase "SpawnInvalid" (testSpawnInvalid testtrans rtable) - , testCase "ClosureExpect" (testClosureExpect testtrans rtable) - , testCase "SpawnChannel" (testSpawnChannel testtrans rtable) - , testCase "TDict" (testTDict testtrans rtable) - , testCase "Fib" (testFib testtrans rtable) - , testCase "SpawnTerminate" (testSpawnTerminate testtrans rtable) - , testCase "SpawnReconnect" (testSpawnReconnect testtrans rtable) - ] + [ testCase "Unclosure" (testUnclosure testtrans) , testCase "Bind" (testBind testtrans) , testCase "SendPureClosure" (testSendPureClosure testtrans) , testCase "SendIOClosure" (testSendIOClosure testtrans) , testCase "SendProcClosure" (testSendProcClosure testtrans) , testCase "Spawn" (testSpawn testtrans) , testCase "SpawnRace" (testSpawnRace testtrans) , testCase "Call" (testCall testtrans) , testCase "CallBind" (testCallBind testtrans) , testCase "Seq" (testSeq testtrans) , testCase "SpawnSupervised" (testSpawnSupervised testtrans) , testCase "SpawnInvalid" (testSpawnInvalid testtrans) , testCase "ClosureExpect" (testClosureExpect testtrans) , testCase "SpawnChannel" (testSpawnChannel testtrans) , testCase "TDict" (testTDict testtrans) , testCase "Fib" (testFib testtrans) , testCase "SpawnTerminate" (testSpawnTerminate testtrans) , testCase "SpawnReconnect" (testSpawnReconnect testtrans) ] diff --git a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs index f5d534b88..30684971c 100644 --- a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs +++ b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- diff --git a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs index 5b1dec370..5b2eee68b 100644 --- a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs +++ b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs @@ -459,8 +459,8 @@ testMxSend mNode label test = do tests :: TestTransport -> IO TestTree tests TestTransport{..} = do - node1 <- newLocalNode testTransport initRemoteTable - node2 <- newLocalNode testTransport initRemoteTable + node1 <- newLocalNode testTransport + node2 <- newLocalNode testTransport return $ testGroup "Mx" [ testGroup "MxAgents" [ testCase "EventHandling" diff --git a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs index 32cb12c87..90c012356 100644 --- a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs +++ b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall #-} -- | XXX test doesn't work, because failure exceptions don't get propagated. The @@ -141,13 +140,12 @@ master = do terminate -testReceive :: Transport -> RemoteTable -> Assertion -testReceive transport rtable = do - node <- newLocalNode transport rtable +testReceive :: Transport -> Assertion +testReceive transport = do + node <- newLocalNode transport runProcess node $ master tests :: TestTransport -> IO TestTree tests TestTransport{..} = do - let rtable = initRemoteTable return $ testGroup "Receive" - [ testCase "testReceive" (testReceive testTransport rtable) ] + [ testCase "testReceive" (testReceive testTransport) ] diff --git a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs index 494ec5616..2971b03eb 100644 --- a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs +++ b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs @@ -84,7 +84,7 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do where launchRemote :: MVar ProcessId -> IO () launchRemote locMV = do - node2 <- liftIO $ newLocalNode testTransport initRemoteTable + node2 <- liftIO $ newLocalNode testTransport _ <- liftIO $ forkProcess node2 $ do self <- getSelfPid liftIO $ putMVar locMV self @@ -105,7 +105,7 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do tests :: TestTransport -> IO TestTree tests testtrans@TestTransport{..} = do - node1 <- newLocalNode testTransport initRemoteTable + node1 <- newLocalNode testTransport return $ testGroup "Stats" [ testGroup "Process Info" [ testCase "testLocalDeadProcessInfo" diff --git a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs index e91bfa73a..334d3a067 100644 --- a/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs +++ b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs @@ -232,7 +232,7 @@ testRemoteTraceRelay :: TestTransport -> TestResult Bool -> Process () testRemoteTraceRelay TestTransport{..} result = let flags = defaultTraceFlags { traceSpawned = traceOn } in do - node2 <- liftIO $ newLocalNode testTransport initRemoteTable + node2 <- liftIO $ newLocalNode testTransport mvNid <- liftIO $ newEmptyMVar -- As well as needing node2's NodeId, we want to @@ -311,7 +311,7 @@ testSystemLoggerMsg :: TestTransport testSystemLoggerMsg t action interestingMessage = withEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" "yes" $ withEnv "DISTRIBUTED_PROCESS_TRACE_FLAGS" "pdnusrl" $ do - n <- newLocalNode (testTransport t) initRemoteTable + n <- newLocalNode (testTransport t) runProcess n $ do self <- getSelfPid @@ -374,7 +374,7 @@ testSystemLoggerMxUnRegistered t = testSystemLoggerMsg t tests :: TestTransport -> IO TestTree tests testtrans@TestTransport{..} = do - node1 <- newLocalNode testTransport initRemoteTable + node1 <- newLocalNode testTransport -- if we execute the test cases in parallel, the -- various tracers will race with one another and -- we'll get garbage results (or worse, deadlocks) diff --git a/packages/distributed-process/ChangeLog b/packages/distributed-process/ChangeLog index 4c88a52c1..9e577d56b 100644 --- a/packages/distributed-process/ChangeLog +++ b/packages/distributed-process/ChangeLog @@ -1,3 +1,13 @@ +Unreleased + +* Breaking: closures are now based on `StaticPtr` (see `Control.Distributed.Static`), + and the `RemoteTable` concept has been removed. +* Functions that took a `Static (SerializableDict a)` (`call`, `spawnChannel`, + `cpSend`, `cpExpect`, `cpNewChan`, `returnCP`, `remoteTask`) now take a + `Closure (SerializableDict a)`. +* `unClosure` has been replaced by `unclosure` from `distributed-static-0.4.0` +* Dropped the dependencies on `syb` and `rank1dynamic`. + 2026-10-13 Laurent P. René de Cotret 0.7.10 * Improved the performance of a process death, as it were, to not scale with the diff --git a/packages/distributed-process/benchmarks/Main.hs b/packages/distributed-process/benchmarks/Main.hs index 179c6152f..878097c4e 100644 --- a/packages/distributed-process/benchmarks/Main.hs +++ b/packages/distributed-process/benchmarks/Main.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE StaticPointers #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module Main (main) where @@ -15,7 +15,9 @@ import Control.Concurrent.STM writeTQueue, ) import Control.Distributed.Process - ( Handler (Handler), + ( Closure, + closure, + Handler (Handler), MonitorRef, NodeId, Process, @@ -87,16 +89,13 @@ import Control.Distributed.Process wrapMessage, ) import Control.Distributed.Process.Closure - ( functionTDict, - mkClosure, - remotable, + ( SerializableDict (..), sdictUnit, ) import Control.Distributed.Process.Node ( LocalNode (..), closeLocalNode, forkProcess, - initRemoteTable, newLocalNode, runProcess, ) @@ -104,7 +103,7 @@ import Control.Distributed.Process.Serializable (Serializable) import qualified Control.Exception as E import Control.Monad (forM_, forever, replicateM, replicateM_, void, when) import qualified Control.Monad.Catch as Catch -import Data.Binary (Binary) +import Data.Binary (Binary, decode, encode) import qualified Data.ByteString.Char8 as BS import GHC.Generics (Generic) import qualified Network.Transport as NT @@ -122,28 +121,28 @@ import Test.Tasty.Bench whnfIO, ) --- A top-level splice only brings names into scope for later declaration --- groups, so these must precede 'main' and every use of 'mkClosure'. - remoteSignal :: ProcessId -> Process () remoteSignal them = send them () +remoteSignalClosure :: ProcessId -> Closure (Process ()) +remoteSignalClosure them = closure (static (remoteSignal . decode)) (encode them) + remoteChanEcho :: ProcessId -> ReceivePort () -> Process () remoteChanEcho them rp = receiveChan rp >> send them () +remoteChanEchoClosure :: ProcessId -> Closure (ReceivePort () -> Process ()) +remoteChanEchoClosure them = closure (static (remoteChanEcho . decode)) (encode them) + remoteAnswer :: () -> Process Int remoteAnswer () = return 42 -remotable ['remoteSignal, 'remoteChanEcho, 'remoteAnswer] - main :: IO () main = do - let rtable = __remoteTable initRemoteTable transport <- either E.throwIO return =<< createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters - ( E.bracket (newLocalNode transport rtable) closeLocalNode $ \node1 -> - E.bracket (newLocalNode transport rtable) closeLocalNode $ \node2 -> do + ( E.bracket (newLocalNode transport) closeLocalNode $ \node1 -> + E.bracket (newLocalNode transport) closeLocalNode $ \node2 -> do fx <- setup node1 node2 defaultMain (benchmarks fx) ) @@ -547,24 +546,24 @@ remote fx = ], repsBench fx "spawn" 100 $ do us <- getSelfPid - _ <- spawn nid ($(mkClosure 'remoteSignal) us) + _ <- spawn nid (remoteSignalClosure us) expect :: Process (), repsBench fx "spawnMonitor + notification" 100 $ do us <- getSelfPid - (_, ref) <- spawnMonitor nid ($(mkClosure 'remoteSignal) us) + (_, ref) <- spawnMonitor nid (remoteSignalClosure us) expect :: Process () awaitDown ref, repsBench fx "spawnChannel" 100 $ do us <- getSelfPid - sp <- spawnChannel sdictUnit nid ($(mkClosure 'remoteChanEcho) us) + sp <- spawnChannel sdictUnit nid (remoteChanEchoClosure us) sendChan sp () expect :: Process (), repsBench fx "call" 100 $ void ( call - $(functionTDict 'remoteAnswer) + (static SerializableDict) nid - ($(mkClosure 'remoteAnswer) ()) + (closure (static (remoteAnswer . decode)) (encode ())) ), repsBench fx "getNodeStats" 100 $ void (getNodeStats nid), diff --git a/packages/distributed-process/benchmarks/remote/Latency.hs b/packages/distributed-process/benchmarks/remote/Latency.hs index 7a11c37c0..cdef82443 100644 --- a/packages/distributed-process/benchmarks/remote/Latency.hs +++ b/packages/distributed-process/benchmarks/remote/Latency.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} import Control.Monad import Control.Applicative diff --git a/packages/distributed-process/benchmarks/remote/Throughput.hs b/packages/distributed-process/benchmarks/remote/Throughput.hs index 280ec49ed..78876d2e1 100644 --- a/packages/distributed-process/benchmarks/remote/Throughput.hs +++ b/packages/distributed-process/benchmarks/remote/Throughput.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} import Control.Monad import Control.Applicative diff --git a/packages/distributed-process/distributed-process.cabal b/packages/distributed-process/distributed-process.cabal index a08237b5d..4c7906c43 100644 --- a/packages/distributed-process/distributed-process.cabal +++ b/packages/distributed-process/distributed-process.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 Name: distributed-process -Version: 0.7.10 +Version: 0.8.0 Build-Type: Simple License: BSD-3-Clause License-File: LICENSE @@ -56,9 +56,7 @@ Library data-accessor >= 0.2 && < 0.3, bytestring >= 0.10 && < 0.13, random >= 1.0 && < 1.4, - distributed-static >= 0.2 && < 0.4, - rank1dynamic >= 0.1 && < 0.5, - syb >= 0.3 && < 0.8, + distributed-static ^>= 0.4, exceptions >= 0.10, containers >= 0.6 && < 0.9, deepseq >= 1.4 && < 1.7, @@ -68,7 +66,6 @@ Library Control.Distributed.Process.Debug Control.Distributed.Process.Internal.BiMultiMap Control.Distributed.Process.Internal.Closure.BuiltIn - Control.Distributed.Process.Internal.Closure.Explicit Control.Distributed.Process.Internal.CQueue Control.Distributed.Process.Internal.Messaging Control.Distributed.Process.Internal.Primitives diff --git a/packages/distributed-process/src/Control/Distributed/Process.hs b/packages/distributed-process/src/Control/Distributed/Process.hs index ba6650516..8e5dbd1df 100644 --- a/packages/distributed-process/src/Control/Distributed/Process.hs +++ b/packages/distributed-process/src/Control/Distributed/Process.hs @@ -114,10 +114,7 @@ module Control.Distributed.Process -- * Closures , Closure , closure - , Static - , unStatic - , unClosure - , RemoteTable + , unclosure -- * Logging , say -- * Registry @@ -173,8 +170,7 @@ import Control.Concurrent.MVar import Control.Distributed.Static ( Closure , closure - , Static - , RemoteTable + , unclosure ) import Control.Distributed.Process.Internal.Types ( NodeId(..) @@ -284,9 +280,6 @@ import Control.Distributed.Process.Internal.Primitives , unregisterRemoteAsync , whereisRemoteAsync , nsendRemote - -- Closures - , unStatic - , unClosure -- Exception handling , catch , Handler(..) diff --git a/packages/distributed-process/src/Control/Distributed/Process/Closure.hs b/packages/distributed-process/src/Control/Distributed/Process/Closure.hs index 11b70c912..eba9e46ac 100644 --- a/packages/distributed-process/src/Control/Distributed/Process/Closure.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Closure.hs @@ -1,11 +1,14 @@ {-# LANGUAGE CPP #-} -- | /Towards Haskell in the Cloud/ (Epstein et al., Haskell Symposium 2011) -- proposes a new type construct called 'static' that characterizes values that --- are known statically. Cloud Haskell uses the --- '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. +-- are known statically. Cloud Haskell uses the 'GHC.StaticPtr.StaticPtr' +-- implementation provided by GHC, and the 'Control.Distributed.Static.Closure' +-- type from "Control.Distributed.Static". That module comes with its own +-- documentation, which you should read if you want to know the details. Here +-- we explain the Template Haskell support, which is a convenience: nothing in +-- Cloud Haskell requires it. Every module which uses the Template Haskell +-- functions below, or which uses @static@ directly, must enable the +-- @StaticPointers@ language extension. -- -- [Static values] -- @@ -14,67 +17,36 @@ -- > f :: forall a1 .. an. T -- > f = ... -- --- you can use a Template Haskell splice to create a static version of 'f': +-- you can create a static version of 'f' with a @static@ form: -- --- > $(mkStatic 'f) :: forall a1 .. an. (Typeable a1, .., Typeable an) => Static T +-- > static f :: forall a1 .. an. (Typeable a1, .., Typeable an) => StaticPtr T -- --- Every module that you write that contains calls to 'mkStatic' needs to --- have a call to 'remotable': +-- A @static@ form can also be given the type of a closure, with an empty +-- environment: -- --- > remotable [ 'f, 'g, ... ] --- --- where you must pass every function (or other value) that you pass as an --- argument to 'mkStatic'. The call to 'remotable' will create a definition --- --- > __remoteTable :: RemoteTable -> RemoteTable --- --- which can be used to construct the 'RemoteTable' used to initialize --- Cloud Haskell. You should have (at most) one call to 'remotable' per module, --- and compose all created functions when initializing Cloud Haskell: --- --- > let rtable :: RemoteTable --- > rtable = M1.__remoteTable --- > . M2.__remoteTable --- > . ... --- > . Mn.__remoteTable --- > $ initRemoteTable --- --- NOTE: If you get a type error from ghc along these lines --- --- > The exact Name `a_a30k' is not in scope --- > Probable cause: you used a unique name (NameU) in Template Haskell but did not bind it --- --- then you need to enable the @ScopedTypeVariables@ language extension. +-- > static f :: forall a1 .. an. (Typeable a1, .., Typeable an) => Closure T -- -- [Static serialization dictionaries] -- --- Some Cloud Haskell primitives require static serialization dictionaries (**): +-- Some Cloud Haskell primitives require static serialization dictionaries (**), +-- as a 'Closure': -- --- > call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a +-- > call :: Serializable a => Closure (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a -- -- Given some serializable type 'T' you can define -- --- > sdictT :: SerializableDict T --- > sdictT = SerializableDict --- --- and then have --- --- > $(mkStatic 'sdictT) :: Static (SerializableDict T) +-- > sdictT :: Closure (SerializableDict T) +-- > sdictT = static SerializableDict -- -- However, since these dictionaries are so frequently required Cloud Haskell --- provides special support for them. When you call 'remotable' on a --- /monomorphic/ function @f :: T1 -> T2@ --- --- > remotable ['f] +-- provides special support for them. If @f :: T1 -> T2@ is a /monomorphic/ +-- function, then -- --- then a serialization dictionary is automatically created for you, which you --- can access with +-- > $(functionSDict 'f) :: Closure (SerializableDict T1) -- --- > $(functionSDict 'f) :: Static (SerializableDict T1) +-- In addition, if @f :: T1 -> Process T2@, then -- --- In addition, if @f :: T1 -> Process T2@, then a second dictionary is created --- --- > $(functionTDict 'f) :: Static (SerializableDict T2) +-- > $(functionTDict 'f) :: Closure (SerializableDict T2) -- -- [Closures] -- @@ -97,7 +69,7 @@ -- -- > $(mkClosure 'f) :: T1 -> Closure T2 -- --- provided that 'T1' is serializable (*) (remember to pass 'f' to 'remotable'). +-- provided that 'T1' is serializable (*). -- -- (You can also create closures manually--see the documentation of -- "Control.Distributed.Static" for examples.) @@ -108,12 +80,11 @@ -- dictionaries. It makes use of the Control.Distributed.Process.SimpleLocalnet -- Cloud Haskell backend. -- --- > {-# LANGUAGE TemplateHaskell #-} +-- > {-# LANGUAGE TemplateHaskell, StaticPointers #-} -- > import System.Environment (getArgs) -- > import Control.Distributed.Process -- > import Control.Distributed.Process.Closure -- > import Control.Distributed.Process.Backend.SimpleLocalnet --- > import Control.Distributed.Process.Node (initRemoteTable) -- > -- > isPrime :: Integer -> Process Bool -- > isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..] @@ -121,8 +92,6 @@ -- > sieve :: [Integer] -> [Integer] -- > sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0] -- > --- > remotable ['isPrime] --- > -- > master :: [NodeId] -> Process () -- > master [] = liftIO $ putStrLn "no slaves" -- > master (slave:_) = do @@ -134,37 +103,27 @@ -- > args <- getArgs -- > case args of -- > ["master", host, port] -> do --- > backend <- initializeBackend host port rtable +-- > backend <- initializeBackend host port -- > startMaster backend master -- > ["slave", host, port] -> do --- > backend <- initializeBackend host port rtable +-- > backend <- initializeBackend host port -- > startSlave backend --- > where --- > rtable :: RemoteTable --- > rtable = __remoteTable initRemoteTable -- -- [Notes] -- -- (*) If 'T1' is not serializable you will get a type error in the generated --- code. Unfortunately, the Template Haskell infrastructure cannot check --- a priori if 'T1' is serializable or not due to a bug in the Template --- Haskell libraries () +-- code. -- -- (**) Even though 'call' is passed an explicit serialization -- dictionary, we still need the 'Serializable' constraint because --- 'Static' is not the /true/ static. If it was, we could 'unstatic' --- the dictionary and pattern match on it to bring the 'Typeable' --- instance into scope, but unless proper 'static' support is added to --- ghc we need both the type class argument and the explicit dictionary. +-- a 'StaticPtr' cannot be inspected to bring the 'Typeable' instance into +-- scope. module Control.Distributed.Process.Closure ( -- * Serialization dictionaries (and their static versions) SerializableDict(..) - , staticDecode , sdictUnit , sdictProcessId , sdictSendPort - , sdictStatic - , sdictClosure -- * The CP type and associated combinators , CP , idCP @@ -179,20 +138,9 @@ module Control.Distributed.Process.Closure , cpSend , cpExpect , cpNewChan - -- * Working with static values and closures (without Template Haskell) - , RemoteRegister - , MkTDict(..) - , mkStaticVal - , mkClosureValSingle - , mkClosureVal - , call' #ifdef TemplateHaskellSupport - -- * Template Haskell support for creating static values and closures - , remotable - , remotableDecl - , mkStatic + -- * Template Haskell support for creating closures and dictionaries , mkClosure - , mkStaticClosure , functionSDict , functionTDict #endif @@ -201,12 +149,9 @@ module Control.Distributed.Process.Closure import Control.Distributed.Process.Serializable (SerializableDict(..)) import Control.Distributed.Process.Internal.Closure.BuiltIn ( -- Static dictionaries and associated operations - staticDecode - , sdictUnit + sdictUnit , sdictProcessId , sdictSendPort - , sdictStatic - , sdictClosure -- The CP type and associated combinators , CP , idCP @@ -222,23 +167,10 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn , cpExpect , cpNewChan ) -import Control.Distributed.Process.Internal.Closure.Explicit - ( - RemoteRegister - , MkTDict(..) - , mkStaticVal - , mkClosureValSingle - , mkClosureVal - , call' - ) #ifdef TemplateHaskellSupport import Control.Distributed.Process.Internal.Closure.TH - ( remotable - , remotableDecl - , mkStatic - , functionSDict + ( functionSDict , functionTDict , mkClosure - , mkStaticClosure ) #endif diff --git a/packages/distributed-process/src/Control/Distributed/Process/Debug.hs b/packages/distributed-process/src/Control/Distributed/Process/Debug.hs index 990f5df06..cf6c38e4e 100644 --- a/packages/distributed-process/src/Control/Distributed/Process/Debug.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Debug.hs @@ -131,7 +131,6 @@ module Control.Distributed.Process.Debug , traceLogFmt , traceMessage -- * Working with remote nodes - , Remote.remoteTable , Remote.startTraceRelay , Remote.setTraceFlagsRemote -- * Built in tracers diff --git a/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs index e3cdbdce2..34ea7b97f 100644 --- a/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs @@ -1,15 +1,11 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StaticPointers #-} module Control.Distributed.Process.Internal.Closure.BuiltIn - ( -- * Remote table - remoteTable - -- * Static dictionaries and associated operations - , staticDecode - , sdictUnit + ( -- * Static dictionaries and associated operations + sdictUnit , sdictProcessId , sdictSendPort - , sdictStatic - , sdictClosure -- * Some static values , sndStatic -- * The CP type and associated combinators @@ -29,30 +25,21 @@ module Control.Distributed.Process.Internal.Closure.BuiltIn , cpNewChan -- * Support for some CH operations , cpDelayed - , cpEnableTraceRemote ) where import Data.ByteString.Lazy (ByteString) import Data.Binary (decode, encode) -import Data.Rank1Typeable (Typeable, ANY, ANY1, ANY2, ANY3, ANY4) -import Data.Rank1Dynamic (toDynamic) +import Data.Typeable (Typeable) +import GHC.StaticPtr (StaticPtr) import Control.Distributed.Static - ( RemoteTable - , registerStatic - , Static - , staticLabel - , staticApply - , Closure + ( Closure , closure , closureApplyStatic , closureApply - , staticCompose - , staticClosure ) import Control.Distributed.Process.Serializable ( SerializableDict(..) , Serializable - , TypeableDict(..) ) import Control.Distributed.Process.Internal.Types ( Process @@ -76,99 +63,53 @@ import Control.Distributed.Process.Internal.Primitives ) -------------------------------------------------------------------------------- --- Remote table -- +-- Helpers for static values -- -------------------------------------------------------------------------------- -remoteTable :: RemoteTable -> RemoteTable -remoteTable = - registerStatic "$decodeDict" (toDynamic (decodeDict :: SerializableDict ANY -> ByteString -> ANY)) - . registerStatic "$sdictUnit" (toDynamic (SerializableDict :: SerializableDict ())) - . registerStatic "$sdictProcessId" (toDynamic (SerializableDict :: SerializableDict ProcessId)) - . registerStatic "$sdictSendPort_" (toDynamic (sdictSendPort_ :: SerializableDict ANY -> SerializableDict (SendPort ANY))) - . registerStatic "$sdictStatic" (toDynamic (sdictStatic_ :: TypeableDict ANY -> SerializableDict (Static ANY))) - . registerStatic "$sdictClosure" (toDynamic (sdictClosure_ :: TypeableDict ANY -> SerializableDict (Closure ANY))) - . registerStatic "$returnProcess" (toDynamic (return :: ANY -> Process ANY)) - . registerStatic "$seqProcess" (toDynamic ((>>) :: Process ANY1 -> Process ANY2 -> Process ANY2)) - . registerStatic "$bindProcess" (toDynamic ((>>=) :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2)) - . registerStatic "$decodeProcessId" (toDynamic (decode :: ByteString -> ProcessId)) - . registerStatic "$link" (toDynamic link) - . registerStatic "$unlink" (toDynamic unlink) - . registerStatic "$relay" (toDynamic relay) - . registerStatic "$sendDict" (toDynamic (sendDict :: SerializableDict ANY -> ProcessId -> ANY -> Process ())) - . registerStatic "$expectDict" (toDynamic (expectDict :: SerializableDict ANY -> Process ANY)) - . registerStatic "$newChanDict" (toDynamic (newChanDict :: SerializableDict ANY -> Process (SendPort ANY, ReceivePort ANY))) - . registerStatic "$cpSplit" (toDynamic (cpSplit :: (ANY1 -> Process ANY3) -> (ANY2 -> Process ANY4) -> (ANY1, ANY2) -> Process (ANY3, ANY4))) - . registerStatic "$snd" (toDynamic (snd :: (ANY1, ANY2) -> ANY2)) - . registerStatic "$delay" (toDynamic delay) - where - decodeDict :: forall a. SerializableDict a -> ByteString -> a - decodeDict SerializableDict = decode - - sdictSendPort_ :: forall a. SerializableDict a -> SerializableDict (SendPort a) - sdictSendPort_ SerializableDict = SerializableDict - - sdictStatic_ :: forall a. TypeableDict a -> SerializableDict (Static a) - sdictStatic_ TypeableDict = SerializableDict +sdictSendPort_ :: forall a. SerializableDict a -> SerializableDict (SendPort a) +sdictSendPort_ SerializableDict = SerializableDict - sdictClosure_ :: forall a. TypeableDict a -> SerializableDict (Closure a) - sdictClosure_ TypeableDict = SerializableDict +returnDict :: forall a. SerializableDict a -> ByteString -> Process a +returnDict SerializableDict = return . decode - sendDict :: forall a. SerializableDict a -> ProcessId -> a -> Process () - sendDict SerializableDict = send +sendDict :: forall a. SerializableDict a -> ProcessId -> a -> Process () +sendDict SerializableDict = send - expectDict :: forall a. SerializableDict a -> Process a - expectDict SerializableDict = expect +expectDict :: forall a. SerializableDict a -> Process a +expectDict SerializableDict = expect - newChanDict :: forall a. SerializableDict a -> Process (SendPort a, ReceivePort a) - newChanDict SerializableDict = newChan +newChanDict :: forall a. SerializableDict a -> Process (SendPort a, ReceivePort a) +newChanDict SerializableDict = newChan - cpSplit :: forall a b c d. (a -> Process c) -> (b -> Process d) -> (a, b) -> Process (c, d) - cpSplit f g (a, b) = do - c <- f a - d <- g b - return (c, d) +cpSplit :: forall a b c d. (a -> Process c) -> (b -> Process d) -> (a, b) -> Process (c, d) +cpSplit f g (a, b) = do + c <- f a + d <- g b + return (c, d) -------------------------------------------------------------------------------- -- Static dictionaries and associated operations -- -------------------------------------------------------------------------------- --- | Static decoder, given a static serialization dictionary. --- --- See module documentation of "Control.Distributed.Process.Closure" for an --- example. -staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a) -staticDecode dict = decodeDictStatic `staticApply` dict - where - decodeDictStatic :: Typeable a => Static (SerializableDict a -> ByteString -> a) - decodeDictStatic = staticLabel "$decodeDict" - -- | Serialization dictionary for '()' -sdictUnit :: Static (SerializableDict ()) -sdictUnit = staticLabel "$sdictUnit" +sdictUnit :: Closure (SerializableDict ()) +sdictUnit = static SerializableDict -- | Serialization dictionary for 'ProcessId' -sdictProcessId :: Static (SerializableDict ProcessId) -sdictProcessId = staticLabel "$sdictProcessId" +sdictProcessId :: Closure (SerializableDict ProcessId) +sdictProcessId = static SerializableDict -- | Serialization dictionary for 'SendPort' sdictSendPort :: Typeable a - => Static (SerializableDict a) -> Static (SerializableDict (SendPort a)) -sdictSendPort = staticApply (staticLabel "$sdictSendPort_") - --- | Serialization dictionary for 'Static'. -sdictStatic :: Typeable a => Static (TypeableDict a) -> Static (SerializableDict (Static a)) -sdictStatic = staticApply (staticLabel "$sdictStatic") - --- | Serialization dictionary for 'Closure'. -sdictClosure :: Typeable a => Static (TypeableDict a) -> Static (SerializableDict (Closure a)) -sdictClosure = staticApply (staticLabel "$sdictClosure") + => Closure (SerializableDict a) -> Closure (SerializableDict (SendPort a)) +sdictSendPort = closureApplyStatic (static sdictSendPort_) -------------------------------------------------------------------------------- -- Static values -- -------------------------------------------------------------------------------- -sndStatic :: Static ((a, b) -> b) -sndStatic = staticLabel "$snd" +sndStatic :: (Typeable a, Typeable b) => StaticPtr ((a, b) -> b) +sndStatic = static snd -------------------------------------------------------------------------------- -- The CP type and associated combinators -- @@ -177,116 +118,67 @@ sndStatic = staticLabel "$snd" -- | @CP a b@ is a process with input of type @a@ and output of type @b@ type CP a b = Closure (a -> Process b) -returnProcessStatic :: Typeable a => Static (a -> Process a) -returnProcessStatic = staticLabel "$returnProcess" - -- | 'CP' version of 'Control.Category.id' idCP :: Typeable a => CP a a -idCP = staticClosure returnProcessStatic +idCP = static return -- | 'CP' version of ('Control.Arrow.***') splitCP :: (Typeable a, Typeable b, Typeable c, Typeable d) => CP a c -> CP b d -> CP (a, b) (c, d) -splitCP p q = cpSplitStatic `closureApplyStatic` p `closureApply` q - where - cpSplitStatic :: Static ((a -> Process c) -> (b -> Process d) -> (a, b) -> Process (c, d)) - cpSplitStatic = staticLabel "$cpSplit" +splitCP p q = static cpSplit `closureApplyStatic` p `closureApply` q -- | 'CP' version of 'Control.Monad.return' -returnCP :: forall a. Serializable a - => Static (SerializableDict a) -> a -> Closure (Process a) -returnCP dict x = closure decoder (encode x) - where - decoder :: Static (ByteString -> Process a) - decoder = returnProcessStatic - `staticCompose` - staticDecode dict +returnCP :: Serializable a + => Closure (SerializableDict a) -> a -> Closure (Process a) +returnCP dict x = + closureApplyStatic (static returnDict) dict + `closureApply` closure (static id) (encode x) -- | 'CP' version of ('Control.Monad.>>') seqCP :: (Typeable a, Typeable b) => Closure (Process a) -> Closure (Process b) -> Closure (Process b) -seqCP p q = seqProcessStatic `closureApplyStatic` p `closureApply` q - where - seqProcessStatic :: (Typeable a, Typeable b) - => Static (Process a -> Process b -> Process b) - seqProcessStatic = staticLabel "$seqProcess" +seqCP p q = static (>>) `closureApplyStatic` p `closureApply` q -- | (Not quite the) 'CP' version of ('Control.Monad.>>=') bindCP :: forall a b. (Typeable a, Typeable b) => Closure (Process a) -> CP a b -> Closure (Process b) -bindCP x f = bindProcessStatic `closureApplyStatic` x `closureApply` f - where - bindProcessStatic :: (Typeable a, Typeable b) - => Static (Process a -> (a -> Process b) -> Process b) - bindProcessStatic = staticLabel "$bindProcess" +bindCP x f = static (>>=) `closureApplyStatic` x `closureApply` f -------------------------------------------------------------------------------- -- CP versions of Cloud Haskell primitives -- -------------------------------------------------------------------------------- -decodeProcessIdStatic :: Static (ByteString -> ProcessId) -decodeProcessIdStatic = staticLabel "$decodeProcessId" +decodeProcessIdStatic :: StaticPtr (ByteString -> ProcessId) +decodeProcessIdStatic = static decode -- | 'CP' version of 'link' cpLink :: ProcessId -> Closure (Process ()) -cpLink = closure (linkStatic `staticCompose` decodeProcessIdStatic) . encode - where - linkStatic :: Static (ProcessId -> Process ()) - linkStatic = staticLabel "$link" +cpLink = closure (static (link . decode)) . encode -- | 'CP' version of 'unlink' cpUnlink :: ProcessId -> Closure (Process ()) -cpUnlink = closure (unlinkStatic `staticCompose` decodeProcessIdStatic) . encode - where - unlinkStatic :: Static (ProcessId -> Process ()) - unlinkStatic = staticLabel "$unlink" +cpUnlink = closure (static (unlink . decode)) . encode -- | 'CP' version of 'send' cpSend :: forall a. Typeable a - => Static (SerializableDict a) -> ProcessId -> CP a () -cpSend dict pid = closure decoder (encode pid) - where - decoder :: Static (ByteString -> a -> Process ()) - decoder = (sendDictStatic `staticApply` dict) - `staticCompose` - decodeProcessIdStatic - - sendDictStatic :: Typeable a - => Static (SerializableDict a -> ProcessId -> a -> Process ()) - sendDictStatic = staticLabel "$sendDict" + => Closure (SerializableDict a) -> ProcessId -> CP a () +cpSend dict pid = + closureApplyStatic (static sendDict) dict + `closureApply` closure decodeProcessIdStatic (encode pid) -- | 'CP' version of 'expect' -cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a) -cpExpect dict = staticClosure (expectDictStatic `staticApply` dict) - where - expectDictStatic :: Typeable a => Static (SerializableDict a -> Process a) - expectDictStatic = staticLabel "$expectDict" +cpExpect :: Typeable a => Closure (SerializableDict a) -> Closure (Process a) +cpExpect = closureApplyStatic (static expectDict) -- | 'CP' version of 'newChan' cpNewChan :: Typeable a - => Static (SerializableDict a) + => Closure (SerializableDict a) -> Closure (Process (SendPort a, ReceivePort a)) -cpNewChan dict = staticClosure (newChanDictStatic `staticApply` dict) - where - newChanDictStatic :: Typeable a - => Static (SerializableDict a -> Process (SendPort a, ReceivePort a)) - newChanDictStatic = staticLabel "$newChanDict" +cpNewChan = closureApplyStatic (static newChanDict) -- | 'CP' version of 'relay' cpRelay :: ProcessId -> Closure (Process ()) -cpRelay = closure (relayStatic `staticCompose` decodeProcessIdStatic) . encode - where - relayStatic :: Static (ProcessId -> Process ()) - relayStatic = staticLabel "$relay" - --- TODO: move cpEnableTraceRemote into Trace/Primitives.hs - -cpEnableTraceRemote :: ProcessId -> Closure (Process ()) -cpEnableTraceRemote = - closure (enableTraceStatic `staticCompose` decodeProcessIdStatic) . encode - where - enableTraceStatic :: Static (ProcessId -> Process ()) - enableTraceStatic = staticLabel "$enableTraceRemote" +cpRelay = closure (static (relay . decode)) . encode -------------------------------------------------------------------------------- -- Support for spawn -- @@ -311,10 +203,4 @@ cpDelayed :: ProcessId -> Closure (Process ()) -> Closure (Process ()) cpDelayed = closureApply . cpDelay' where cpDelay' :: ProcessId -> Closure (Process () -> Process ()) - cpDelay' pid = closure decoder (encode pid) - - decoder :: Static (ByteString -> Process () -> Process ()) - decoder = delayStatic `staticCompose` decodeProcessIdStatic - - delayStatic :: Static (ProcessId -> Process () -> Process ()) - delayStatic = staticLabel "$delay" + cpDelay' = closure (static (delay . decode)) . encode 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 deleted file mode 100644 index 4a7ae88a9..000000000 --- a/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/Explicit.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables - , MultiParamTypeClasses - , FlexibleInstances - , FunctionalDependencies - , FlexibleContexts - , UndecidableInstances - , KindSignatures - , GADTs - , EmptyDataDecls - , TypeOperators - , DeriveDataTypeable #-} -module Control.Distributed.Process.Internal.Closure.Explicit - ( - RemoteRegister - , MkTDict(..) - , mkStaticVal - , mkClosureValSingle - , mkClosureVal - , call' - ) where - -import Control.Distributed.Static -import Control.Distributed.Process.Serializable -import Control.Distributed.Process.Internal.Closure.BuiltIn - ( -- Static dictionaries and associated operations - staticDecode - ) -import Control.Distributed.Process -import Data.Rank1Dynamic -import Data.Rank1Typeable -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. -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. -mkStaticVal :: Serializable a => String -> a -> (Static a, RemoteRegister) -mkStaticVal n v = (staticLabel n_s, registerStatic n_s (toDynamic v)) - where n_s = n - -class MkTDict a where - mkTDict :: String -> a -> RemoteRegister - -instance (Serializable b) => MkTDict (Process b) where - mkTDict _ _ = registerStatic (show (typeOf (undefined :: b)) ++ "__staticDict") (toDynamic (SerializableDict :: SerializableDict b)) - -instance 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. -mkClosureValSingle :: forall a b. (Serializable a, Typeable b, MkTDict b) => String -> (a -> b) -> (a -> Closure b, RemoteRegister) -mkClosureValSingle n v = (c, registerStatic n_s (toDynamic v) . - registerStatic n_sdict (toDynamic sdict) . - mkTDict n_tdict (undefined :: b) - ) where - n_s = n - n_sdict = n ++ "__sdict" - n_tdict = n ++ "__tdict" - - c = closure decoder . encode - - decoder = (staticLabel n_s :: Static (a -> b)) `staticCompose` staticDecode (staticLabel n_sdict :: Static (SerializableDict a)) - - sdict :: (SerializableDict a) - sdict = SerializableDict - --- | This takes an explict name, a function of any arity, and creates a function yielding a closure and a remote register for it. -mkClosureVal :: forall func argTuple result closureFunction. - (Curry (argTuple -> Closure result) closureFunction, - MkTDict result, - Uncurry HTrue argTuple func result, - Typeable result, Serializable argTuple, IsFunction func HTrue) => - String -> func -> (closureFunction, RemoteRegister) -mkClosureVal n v = (curryFun c, rtable) - where - uv :: argTuple -> result - uv = uncurry' reify v - - n_s = n - n_sdict = n ++ "__sdict" - n_tdict = n ++ "__tdict" - - c :: argTuple -> Closure result - c = closure decoder . encode - - decoder :: Static (B.ByteString -> result) - decoder = (staticLabel n_s :: Static (argTuple -> result)) `staticCompose` staticDecode (staticLabel n_sdict :: Static (SerializableDict argTuple)) - - rtable = registerStatic n_s (toDynamic uv) . - registerStatic n_sdict (toDynamic sdict) . - mkTDict n_tdict (undefined :: result) - - - sdict :: (SerializableDict argTuple) - sdict = SerializableDict - --- | Works just like standard call, but with a simpler signature. -call' :: forall a. Serializable a => NodeId -> Closure (Process a) -> Process a -call' = call (staticLabel $ (show $ typeOf $ (undefined :: a)) ++ "__staticDict") - - -data EndOfTuple deriving Typeable -instance Binary EndOfTuple where - put _ = return () - get = return undefined - --- This generic curry is straightforward -class Curry a b | a -> b where - curryFun :: a -> b - -instance 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 - curryFun f = \x -> curryFun (\y -> (f (x,y))) - - --- This generic uncurry courtesy Andrea Vezzosi -data HTrue -data HFalse -data Fun :: Type -> Type -> Type -> Type where - Done :: Fun EndOfTuple r r - Moar :: Fun xs f r -> Fun (x,xs) (x -> f) r - -class Uncurry'' args func result | func -> args, func -> result, args result -> func where - reify :: Fun args func result - -class Uncurry flag args func result | flag func -> args, flag func -> result, args result -> func where - reify' :: flag -> Fun args func result - -instance Uncurry'' rest f r => Uncurry HTrue (a,rest) (a -> f) r where - reify' _ = Moar reify - -instance Uncurry HFalse EndOfTuple a a where - reify' _ = Done - -instance (IsFunction func b, Uncurry b args func result) => Uncurry'' args func result where - reify = reify' (undefined :: b) - -uncurry' :: Fun args func result -> func -> args -> result -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 - diff --git a/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs index 01fc6268c..50eb5e680 100644 --- a/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs @@ -1,356 +1,48 @@ -- | Template Haskell support -{-# LANGUAGE TemplateHaskell, CPP #-} +{-# LANGUAGE TemplateHaskell #-} module Control.Distributed.Process.Internal.Closure.TH ( -- * User-level API - remotable - , remotableDecl - , mkStatic - , functionSDict + functionSDict , functionTDict , mkClosure - , mkStaticClosure + -- * Used by the generated code + , argOf + , argDict + , resultDict ) where -import Prelude hiding (succ, any) -import Language.Haskell.TH - ( -- Q monad and operations - Q - , reify - , Loc(loc_module) - , location - -- Names - , Name - , mkName - , nameBase - -- Algebraic data types - , Dec(SigD) - , Exp - , Type(AppT, ForallT, VarT, ArrowT) - , Info(VarI) -#if MIN_VERSION_template_haskell(2,17,0) - , Specificity -#endif - , TyVarBndr(PlainTV, KindedTV) - , Pred -#if MIN_VERSION_template_haskell(2,10,0) - , conT - , appT -#else - , classP -#endif - , varT - -- Lifted constructors - -- .. Literals - , stringL - -- .. Patterns - , normalB - , clause - -- .. Expressions - , varE - , litE - -- .. Top-level declarations - , funD - , sigD - ) -import Data.Maybe (catMaybes) -import Data.Binary (encode) -import Data.Generics (everywhereM, mkM, gmapM) -import Data.Rank1Dynamic (toDynamic) -import Data.Rank1Typeable - ( Zero - , Succ - , TypVar - ) -import Control.Distributed.Static - ( RemoteTable - , registerStatic - , Static - , staticLabel - , closure - , staticCompose - , staticClosure - ) +import Language.Haskell.TH (Q, Exp, Name, varE, staticE) +import Data.Binary (decode, encode) +import Control.Distributed.Static (closure) import Control.Distributed.Process.Internal.Types (Process) import Control.Distributed.Process.Serializable - ( SerializableDict(SerializableDict) + ( Serializable + , SerializableDict(SerializableDict) ) -import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode) - --------------------------------------------------------------------------------- --- User-level API -- --------------------------------------------------------------------------------- - --- | Create the closure, decoder, and metadata definitions for the given list --- of functions -remotable :: [Name] -> Q [Dec] -remotable ns = do - types <- mapM getType ns - (closures, inserts) <- unzip <$> mapM generateDefs types - rtable <- createMetaData (mkName "__remoteTable") (concat inserts) - return $ concat closures ++ rtable - --- | Like 'remotable', but parameterized by the declaration of a function --- instead of the function name. So where for 'remotable' you'd do --- --- > f :: T1 -> T2 --- > f = ... --- > --- > remotable ['f] --- --- with 'remotableDecl' you would instead do --- --- > remotableDecl [ --- > [d| f :: T1 -> T2 ; --- > f = ... --- > |] --- > ] --- --- 'remotableDecl' creates the function specified as well as the various --- dictionaries and static versions that 'remotable' also creates. --- 'remotableDecl' is sometimes necessary when you want to refer to, say, --- @$(mkClosure 'f)@ within the definition of @f@ itself. --- --- NOTE: 'remotableDecl' creates @__remoteTableDecl@ instead of @__remoteTable@ --- so that you can use both 'remotable' and 'remotableDecl' within the same --- module. -remotableDecl :: [Q [Dec]] -> Q [Dec] -remotableDecl qDecs = do - decs <- concat <$> sequence qDecs - let types = catMaybes (map typeOf decs) - (closures, inserts) <- unzip <$> mapM generateDefs types - rtable <- createMetaData (mkName "__remoteTableDecl") (concat inserts) - return $ decs ++ concat closures ++ rtable - where - typeOf :: Dec -> Maybe (Name, Type) - typeOf (SigD name typ) = Just (name, typ) - typeOf _ = Nothing - --- | Construct a static value. --- --- If @f : forall a1 .. an. T@ --- then @$(mkStatic 'f) :: forall a1 .. an. Static T@. --- Be sure to pass 'f' to 'remotable'. -mkStatic :: Name -> Q Exp -mkStatic = varE . staticName -- | If @f : T1 -> T2@ is a monomorphic function --- then @$(functionSDict 'f) :: Static (SerializableDict T1)@. --- --- Be sure to pass 'f' to 'remotable'. +-- then @$(functionSDict 'f) :: Closure (SerializableDict T1)@. functionSDict :: Name -> Q Exp -functionSDict = varE . sdictName +functionSDict n = staticE [| argDict $(varE n) |] -- | If @f : T1 -> Process T2@ is a monomorphic function --- then @$(functionTDict 'f) :: Static (SerializableDict T2)@. --- --- Be sure to pass 'f' to 'remotable'. +-- then @$(functionTDict 'f) :: Closure (SerializableDict T2)@. functionTDict :: Name -> Q Exp -functionTDict = varE . tdictName +functionTDict n = staticE [| resultDict $(varE n) |] -- | If @f : T1 -> T2@ then @$(mkClosure 'f) :: T1 -> Closure T2@. -- --- TODO: The current version of mkClosure is too polymorphic --- (@forall a. Binary a => a -> Closure T2). +-- The argument type is pinned down by 'argOf' so that the generated code is not +-- overloaded: otherwise GHC specializes it, which duplicates the @static@ form. mkClosure :: Name -> Q Exp mkClosure n = - [| closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n)) - . encode - |] - --- | Make a 'Closure' from a static function. This is useful for --- making a closure for a top-level @Process ()@ function, because --- using 'mkClosure' would require adding a dummy @()@ argument. --- -mkStaticClosure :: Name -> Q Exp -mkStaticClosure n = [| staticClosure $( mkStatic n ) |] - --------------------------------------------------------------------------------- --- Internal (Template Haskell) -- --------------------------------------------------------------------------------- - --- | Generate the code to add the metadata to the CH runtime -createMetaData :: Name -> [Q Exp] -> Q [Dec] -createMetaData name is = - sequence [ sigD name [t| RemoteTable -> RemoteTable |] - , sfnD name (compose is) - ] - -generateDefs :: (Name, Type) -> Q ([Dec], [Q Exp]) -generateDefs (origName, fullType) = do - proc <- [t| Process |] - let (typVars, typ') = case fullType of ForallT vars [] mono -> (vars, mono) - _ -> ([], fullType) - - -- The main "static" entry - (static, register) <- makeStatic typVars typ' + [| \x -> closure $(staticE [| $(varE n) . decode |]) (encode (argOf $(varE n) x)) |] - -- If n :: T1 -> T2, static serializable dictionary for T1 - -- TODO: we should check if arg is an instance of Serializable, but we cannot - -- http://hackage.haskell.org/trac/ghc/ticket/7066 - (sdict, registerSDict) <- case (typVars, typ') of - ([], ArrowT `AppT` arg `AppT` _res) -> - makeDict (sdictName origName) arg - _ -> - return ([], []) +argOf :: (a -> b) -> a -> a +argOf _ x = x - -- If n :: T1 -> Process T2, static serializable dictionary for T2 - -- TODO: check if T2 is serializable (same as above) - (tdict, registerTDict) <- case (typVars, typ') of - ([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc -> - makeDict (tdictName origName) res - _ -> - return ([], []) +argDict :: Serializable a => (a -> b) -> SerializableDict a +argDict _ = SerializableDict - return ( concat [static, sdict, tdict] - , concat [register, registerSDict, registerTDict] - ) - where -#if MIN_VERSION_template_haskell(2,17,0) - makeStatic :: [TyVarBndr Specificity] -> Type -> Q ([Dec], [Q Exp]) -#else - makeStatic :: [TyVarBndr] -> Type -> Q ([Dec], [Q Exp]) -#endif - makeStatic typVars typ = do - static <- generateStatic origName typVars typ - let dyn = case typVars of - [] -> [| toDynamic $(varE origName) |] - _ -> [| toDynamic ($(varE origName) :: $(monomorphize typVars typ)) |] - return ( static - , [ [| registerStatic $(showFQN origName) $dyn |] ] - ) - - makeDict :: Name -> Type -> Q ([Dec], [Q Exp]) - makeDict dictName typ = do - sdict <- generateDict dictName typ - let dyn = [| toDynamic (SerializableDict :: SerializableDict $(return typ)) |] - return ( sdict - , [ [| registerStatic $(showFQN dictName) $dyn |] ] - ) - --- | Turn a polymorphic type into a monomorphic type using ANY and co -#if MIN_VERSION_template_haskell(2,17,0) -monomorphize :: [TyVarBndr Specificity] -> Type -> Q Type -#else -monomorphize :: [TyVarBndr] -> Type -> Q Type -#endif - -monomorphize tvs = - let subst = zip (map tyVarBndrName tvs) anys - in everywhereM (mkM (applySubst subst)) - where - anys :: [Q Type] - anys = map typVar (iterate succ zero) - - typVar :: Q Type -> Q Type - typVar t = [t| TypVar $t |] - - zero :: Q Type - zero = [t| Zero |] - - succ :: Q Type -> Q Type - succ t = [t| Succ $t |] - - applySubst :: [(Name, Q Type)] -> Type -> Q Type - applySubst s (VarT n) = - case lookup n s of - Nothing -> return (VarT n) - Just t -> t - applySubst s t = gmapM (mkM (applySubst s)) t - --- | Generate a static value -#if MIN_VERSION_template_haskell(2,17,0) -generateStatic :: Name -> [TyVarBndr Specificity] -> Type -> Q [Dec] -#else -generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec] -#endif -generateStatic n xs typ = do - staticTyp <- [t| Static |] - sequence - [ sigD (staticName n) $ do - txs <- sequence $ map typeable xs - return (ForallT xs - txs - (staticTyp `AppT` typ)) - , sfnD (staticName n) [| staticLabel $(showFQN n) |] - ] - where -#if MIN_VERSION_template_haskell(2,17,0) - typeable :: TyVarBndr Specificity -> Q Pred -#else - typeable :: TyVarBndr -> Q Pred -#endif - typeable tv = -#if MIN_VERSION_template_haskell(2,10,0) - conT (mkName "Typeable") `appT` varT (tyVarBndrName tv) -#else - classP (mkName "Typeable") [varT (tyVarBndrName tv)] -#endif - --- | Generate a serialization dictionary with name 'n' for type 'typ' -generateDict :: Name -> Type -> Q [Dec] -generateDict n typ = do - sequence - [ sigD n $ [t| Static (SerializableDict $(return typ)) |] - , sfnD n [| staticLabel $(showFQN n) |] - ] - -staticName :: Name -> Name -staticName n = mkName $ nameBase n ++ "__static" - -sdictName :: Name -> Name -sdictName n = mkName $ nameBase n ++ "__sdict" - -tdictName :: Name -> Name -tdictName n = mkName $ nameBase n ++ "__tdict" - --------------------------------------------------------------------------------- --- Generic Template Haskell auxiliary functions -- --------------------------------------------------------------------------------- - --- | Compose a set of expressions -compose :: [Q Exp] -> Q Exp -compose [] = [| id |] -compose [e] = e -compose (e:es) = [| $e . $(compose es) |] - --- | Literal string as an expression -stringE :: String -> Q Exp -stringE = litE . stringL - --- | Look up the "original name" (module:name) and type of a top-level function -getType :: Name -> Q (Name, Type) -getType name = do - info <- reify name - case info of -#if MIN_VERSION_template_haskell(2,11,0) - VarI origName typ _ -> return (origName, typ) -#else - VarI origName typ _ _ -> return (origName, typ) -#endif - _ -> fail $ show name ++ " not found" - --- | Variation on 'funD' which takes a single expression to define the function -sfnD :: Name -> Q Exp -> Q Dec -sfnD n e = funD n [clause [] (normalB e) []] - --- | The name of a type variable binding occurrence -#if MIN_VERSION_template_haskell(2,17,0) -tyVarBndrName :: TyVarBndr Specificity -> Name -tyVarBndrName (PlainTV n _) = n -tyVarBndrName (KindedTV n _ _) = n -#else -tyVarBndrName :: TyVarBndr -> Name -tyVarBndrName (PlainTV n) = n -tyVarBndrName (KindedTV n _) = n -#endif - - --- | Fully qualified name; that is, the name and the _current_ module --- --- We ignore the module part of the Name argument (which may or may not exist) --- because we construct various names (`staticName`, `sdictName`, `tdictName`) --- and those names certainly won't have Module components. -showFQN :: Name -> Q Exp -showFQN n = do - loc <- location - stringE (loc_module loc ++ "." ++ nameBase n) +resultDict :: Serializable b => (a -> Process b) -> SerializableDict b +resultDict _ = SerializableDict diff --git a/packages/distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs index be07075af..ac222edb6 100644 --- a/packages/distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs @@ -94,8 +94,6 @@ module Control.Distributed.Process.Internal.Primitives , whereisRemoteAsync , nsendRemote -- * Closures - , unClosure - , unStatic -- * Exception handling , catch , Handler(..) @@ -162,12 +160,8 @@ import Control.Distributed.Process.Internal.CQueue ) import Control.Distributed.Process.Serializable (Serializable, fingerprint) import Data.Accessor ((^.), (^:), (^=)) -import Control.Distributed.Static - ( Static - , Closure - ) -import Data.Rank1Typeable (Typeable) -import qualified Control.Distributed.Static as Static (unstatic, unclosure) +import Control.Distributed.Static (Closure) +import Data.Typeable (Typeable) import qualified Control.Distributed.Process.UnsafePrimitives as Unsafe import Control.Distributed.Process.Internal.Types ( NodeId(..) @@ -1262,26 +1256,6 @@ nsendRemote nid label msg = do unsafeNSendRemote :: Serializable a => NodeId -> String -> a -> Process () unsafeNSendRemote = Unsafe.nsendRemote --------------------------------------------------------------------------------- --- Closures -- --------------------------------------------------------------------------------- - --- | Resolve a static value -unStatic :: Typeable a => Static a -> Process a -unStatic static = do - rtable <- remoteTable . processNode <$> ask - case Static.unstatic rtable static of - Left err -> fail $ "Could not resolve static value: " ++ err - Right x -> return x - --- | Resolve a closure -unClosure :: Typeable a => Closure a -> Process a -unClosure closure = do - rtable <- remoteTable . processNode <$> ask - case Static.unclosure rtable closure of - Left err -> fail $ "Could not resolve closure: " ++ err - Right x -> return x - -------------------------------------------------------------------------------- -- Reconnecting -- -------------------------------------------------------------------------------- diff --git a/packages/distributed-process/src/Control/Distributed/Process/Internal/Spawn.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/Spawn.hs index c75d4da20..848c8e2c1 100644 --- a/packages/distributed-process/src/Control/Distributed/Process/Internal/Spawn.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Internal/Spawn.hs @@ -9,11 +9,10 @@ module Control.Distributed.Process.Internal.Spawn ) where import Control.Distributed.Static - ( Static - , Closure + ( Closure , closureCompose - , staticClosure ) +import GHC.StaticPtr (fromStaticPtr) import Control.Distributed.Process.Internal.Types ( NodeId(..) , ProcessId(..) @@ -100,15 +99,15 @@ spawnMonitor nid proc = do -- We monitor the remote process: if it dies before it can send a reply, we die -- too. -- --- For more information about 'Static', 'SerializableDict', and 'Closure', see +-- For more information about 'SerializableDict' and 'Closure', see -- "Control.Distributed.Process.Closure". -- -- See also 'spawn'. call :: Serializable a - => Static (SerializableDict a) - -> NodeId - -> Closure (Process a) - -> Process a + => Closure (SerializableDict a) + -> NodeId + -> Closure (Process a) + -> Process a call dict nid proc = do us <- getSelfPid (pid, mRef) <- spawnMonitor nid (proc `bindCP` @@ -148,7 +147,7 @@ spawnSupervised nid proc = do -- | Spawn a new process, supplying it with a new 'ReceivePort' and return -- the corresponding 'SendPort'. -spawnChannel :: forall a. Serializable a => Static (SerializableDict a) +spawnChannel :: forall a. Serializable a => Closure (SerializableDict a) -> NodeId -> Closure (ReceivePort a -> Process ()) -> Process (SendPort a) @@ -162,4 +161,4 @@ spawnChannel dict nid proc = do `bindCP` (cpSend (sdictSendPort dict) pid `splitCP` proc) `bindCP` - (idCP `closureCompose` staticClosure sndStatic) + (idCP `closureCompose` fromStaticPtr sndStatic) diff --git a/packages/distributed-process/src/Control/Distributed/Process/Internal/Types.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/Types.hs index 21fcc7069..541551bdd 100644 --- a/packages/distributed-process/src/Control/Distributed/Process/Internal/Types.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Internal/Types.hs @@ -138,7 +138,7 @@ import Control.Distributed.Process.Internal.StrictMVar , modifyMVar_ ) import Control.Distributed.Process.Internal.WeakTQueue (TQueue) -import Control.Distributed.Static (RemoteTable, Closure) +import Control.Distributed.Static (Closure) import qualified Control.Distributed.Process.Internal.StrictContainerAccessors as DAC (mapMaybe) import Data.Hashable @@ -270,9 +270,6 @@ data LocalNode = LocalNode , localCtrlChan :: !(Chan NCMsg) -- | Internal management event bus , localEventBus :: !MxEventBus - -- | Runtime lookup table for supporting closures - -- TODO: this should be part of the CH state, not the local endpoint state - , remoteTable :: !RemoteTable } data ImplicitReconnect = WithImplicitReconnect | NoImplicitReconnect diff --git a/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs b/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs index 224983077..751bf3fe9 100644 --- a/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs @@ -3,8 +3,7 @@ -- | Keeps the tracing API calls separate from the Tracer implementation, -- which allows us to avoid a nasty import cycle between tracing and -- the messaging primitives that rely on it, and also between the node --- controller (which requires access to the tracing related elements of --- our RemoteTable) and the Debug module, which requires @forkProcess@. +-- controller and the Debug module, which requires @forkProcess@. -- This module is also used by the management agent, which relies on the -- tracing infrastructure's messaging fabric. module Control.Distributed.Process.Management.Internal.Trace.Primitives diff --git a/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Remote.hs b/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Remote.hs index 9e4618e8a..ac9fb5930 100644 --- a/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Remote.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Remote.hs @@ -1,14 +1,10 @@ +{-# LANGUAGE StaticPointers #-} module Control.Distributed.Process.Management.Internal.Trace.Remote ( -- * Configuring A Remote Tracer setTraceFlagsRemote , startTraceRelay - -- * Remote Table - , remoteTable ) where -import Control.Distributed.Process.Internal.Closure.BuiltIn - ( cpEnableTraceRemote - ) import Control.Distributed.Process.Internal.Primitives ( getSelfPid , relay @@ -32,14 +28,13 @@ import Control.Distributed.Process.Internal.Types , NodeId ) import Control.Distributed.Static - ( RemoteTable - , registerStatic + ( Closure + , closure ) -import Data.Rank1Dynamic (toDynamic) +import Data.Binary (decode, encode) --- | Remote Table. -remoteTable :: RemoteTable -> RemoteTable -remoteTable = registerStatic "$enableTraceRemote" (toDynamic enableTraceRemote) +cpEnableTraceRemote :: ProcessId -> Closure (Process ()) +cpEnableTraceRemote = closure (static (enableTraceRemote . decode)) . encode enableTraceRemote :: ProcessId -> Process () enableTraceRemote pid = diff --git a/packages/distributed-process/src/Control/Distributed/Process/Node.hs b/packages/distributed-process/src/Control/Distributed/Process/Node.hs index c527e47dd..d4a721c7a 100644 --- a/packages/distributed-process/src/Control/Distributed/Process/Node.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Node.hs @@ -15,7 +15,6 @@ module Control.Distributed.Process.Node , closeLocalNode , forkProcess , runProcess - , initRemoteTable , localNodeId ) where @@ -114,11 +113,7 @@ import qualified Network.Transport as NT ) import Data.Accessor (Accessor, accessor, (^.), (^=), (^:)) import System.Random (randomIO) -import Control.Distributed.Static (RemoteTable, Closure) -import qualified Control.Distributed.Static as Static - ( unclosure - , initRemoteTable - ) +import Control.Distributed.Static (Closure, unclosure) import Control.Distributed.Process.Internal.Types ( NodeId(..) , LocalProcessId(..) @@ -180,9 +175,6 @@ import Control.Distributed.Process.Management.Internal.Agent import Control.Distributed.Process.Management.Internal.Types ( MxEvent(..) ) -import qualified Control.Distributed.Process.Management.Internal.Trace.Remote as Trace - ( remoteTable - ) import Control.Distributed.Process.Management.Internal.Trace.Tracer ( defaultTracer ) @@ -210,7 +202,6 @@ import Control.Distributed.Process.Internal.Primitives , SayMessage(..) ) import Control.Distributed.Process.Internal.Types (SendPort, Tracer(..)) -import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable) import Control.Distributed.Process.Internal.WeakTQueue (TQueue, writeTQueue) import qualified Control.Distributed.Process.Internal.StrictContainerAccessors as DAC ( mapMaybe @@ -235,23 +226,20 @@ unblock = unsafeUnmask -- Initialization -- -------------------------------------------------------------------------------- -initRemoteTable :: RemoteTable -initRemoteTable = Trace.remoteTable $ BuiltIn.remoteTable Static.initRemoteTable - -- | Initialize a new local node. -newLocalNode :: NT.Transport -> RemoteTable -> IO LocalNode -newLocalNode transport rtable = do +newLocalNode :: NT.Transport -> IO LocalNode +newLocalNode transport = do mEndPoint <- NT.newEndPoint transport case mEndPoint of Left ex -> throwIO ex Right endPoint -> do - localNode <- createBareLocalNode endPoint rtable + localNode <- createBareLocalNode endPoint startServiceProcesses localNode return localNode -- | Create a new local node (without any service processes running) -createBareLocalNode :: NT.EndPoint -> RemoteTable -> IO LocalNode -createBareLocalNode endPoint rtable = do +createBareLocalNode :: NT.EndPoint -> IO LocalNode +createBareLocalNode endPoint = do unq <- randomIO state <- newMVar $ LocalNodeValid $ ValidLocalNodeState { _localProcesses = Map.empty @@ -265,7 +253,6 @@ createBareLocalNode endPoint rtable = do , localState = state , localCtrlChan = ctrlChan , localEventBus = MxEventBusInitialising - , remoteTable = rtable } tracedNode <- startMxAgent node @@ -929,13 +916,9 @@ ncEffectDied ident reason = do -- [Unified: Table 13] ncEffectSpawn :: ProcessId -> Closure (Process ()) -> SpawnRef -> NC () ncEffectSpawn pid cProc ref = do - mProc <- unClosure cProc - -- If the closure does not exist, we spawn a process that throws an exception + -- If the closure does not exist, the spawned process fails when it starts. -- This allows the remote node to find out what's happening - -- TODO: - let proc = case mProc of - Left err -> fail $ "Error: Could not resolve closure: " ++ err - Right p -> p + let proc = unclosure cProc >>= id node <- ask pid' <- liftIO $ forkProcess node proc ncSendToProcess pid $ unsafeCreateUnencodedMessage $ DidSpawn ref pid' @@ -1183,12 +1166,6 @@ destNid (SigShutdown) = Nothing isLocal :: LocalNode -> Identifier -> Bool isLocal nid ident = nodeOf ident == localNodeId nid --- | Lookup a local closure -unClosure :: Typeable a => Closure a -> NC (Either String a) -unClosure closure = do - rtable <- remoteTable <$> ask - return (Static.unclosure rtable closure) - -- | Check if an identifier refers to a valid local object isValidLocalIdentifier :: Identifier -> NC Bool isValidLocalIdentifier ident = do diff --git a/packages/distributed-process/src/Control/Distributed/Process/Serializable.hs b/packages/distributed-process/src/Control/Distributed/Process/Serializable.hs index 4ca804370..f188a8031 100644 --- a/packages/distributed-process/src/Control/Distributed/Process/Serializable.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Serializable.hs @@ -13,7 +13,6 @@ module Control.Distributed.Process.Serializable , Fingerprint , showFingerprint , SerializableDict(SerializableDict) - , TypeableDict(TypeableDict) ) where import Data.Binary (Binary) @@ -35,11 +34,6 @@ data SerializableDict a where SerializableDict :: Serializable a => SerializableDict a deriving (Typeable) --- | Reification of 'Typeable'. -data TypeableDict a where - TypeableDict :: Typeable a => TypeableDict a - deriving (Typeable) - -- | Objects that can be sent across the network type Serializable a = (Binary a, Typeable a) diff --git a/packages/distributed-static/ChangeLog b/packages/distributed-static/ChangeLog index 81bc107be..c932a1c96 100644 --- a/packages/distributed-static/ChangeLog +++ b/packages/distributed-static/ChangeLog @@ -1,6 +1,17 @@ Unreleased -* Added support for `containers-0.8`. +* Breaking: `Closure` now follows the definition from /Towards Haskell in the Cloud/: + it is a `StaticPtr (ByteString -> a)` together with an encoded environment. + As a consequence: + * The concept of `RemoteTable` and `Static` is gone + * `Closure`'s internals have changed. Combining closures (`closureApply`, `closureCompose`, `closureSplit`) builds + a tree, which is serialized as is, without encoding the closures being + combined into an environment. + * `unclosure` no longer takes a `RemoteTable`. + * `closureApplyStatic` takes a `StaticPtr`. + * `Closure` is an instance of `IsStatic`, so that `static f :: Closure a`. + * `closureCompose` and `closureSplit` require `Typeable` constraints on the types of the closures. +* Dropped the dependencies on `containers` and `rank1dynamic`. 2024-09-03 Laurent P. René de Cotret 0.3.11 diff --git a/packages/distributed-static/distributed-static.cabal b/packages/distributed-static/distributed-static.cabal index ed6f6f229..cfb46062a 100644 --- a/packages/distributed-static/distributed-static.cabal +++ b/packages/distributed-static/distributed-static.cabal @@ -1,20 +1,16 @@ cabal-version: 3.0 Name: distributed-static -Version: 0.3.11 +Version: 0.4.0 Synopsis: Compositional, type-safe, polymorphic static values and closures Description: /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011) introduces the concept of /static/ values: values that are known at compile time. In a distributed setting where all nodes are running the same executable, static values can be serialized simply by transmitting a - code pointer to the value. This however requires special - compiler support, which is not yet available in ghc. We - can mimick the behaviour by keeping an explicit mapping - ('RemoteTable') from labels to values (and making sure - that all distributed nodes are using the same - 'RemoteTable'). In this module we implement this mimickry - and various extensions: type safety (including for - polymorphic static values) and compositionality. + code pointer to the value. This package builds on GHC's + 'StaticPtr' to provide various extensions: type safety + (including for polymorphic static values) and + compositionality. Homepage: https://haskell-distributed.github.io License: BSD-3-Clause License-File: LICENSE @@ -47,8 +43,6 @@ Library import: warnings Exposed-Modules: Control.Distributed.Static Build-Depends: base >= 4.14 && < 5, - rank1dynamic >= 0.1 && < 0.5, - containers >= 0.6 && < 0.9, bytestring >= 0.10 && < 0.13, binary >= 0.8 && < 0.9, deepseq >= 1.4 && < 1.7 @@ -56,3 +50,18 @@ Library Default-Language: Haskell2010 Default-Extensions: DeriveDataTypeable ScopedTypeVariables + +Test-Suite distributed-static-tests + import: warnings + Type: exitcode-stdio-1.0 + Main-Is: Main.hs + HS-Source-Dirs: tests + Default-Language: Haskell2010 + ghc-options: -rtsopts + Build-Depends: base >= 4.14 && < 5, + binary >= 0.8 && < 0.9, + bytestring >= 0.10 && < 0.13, + deepseq >= 1.4 && < 1.7, + distributed-static, + tasty >= 1.5 && < 1.6, + tasty-hunit >= 0.10 && < 0.11 diff --git a/packages/distributed-static/src/Control/Distributed/Static.hs b/packages/distributed-static/src/Control/Distributed/Static.hs index df8330227..f1fd2c951 100644 --- a/packages/distributed-static/src/Control/Distributed/Static.hs +++ b/packages/distributed-static/src/Control/Distributed/Static.hs @@ -2,30 +2,9 @@ -- introduces the concept of /static/ values: values that are known at compile -- time. In a distributed setting where all nodes are running the same -- executable, static values can be serialized simply by transmitting a code --- pointer to the value. This however requires special compiler support, which --- is not yet available in ghc. We can mimick the behaviour by keeping an --- explicit mapping ('RemoteTable') from labels to values (and making sure that --- all distributed nodes are using the same 'RemoteTable'). In this module --- we implement this mimickry and various extensions. --- --- [Compositionality] --- --- Static values as described in the paper are not compositional: there is no --- way to combine two static values and get a static value out of it. This --- makes sense when interpreting static strictly as /known at compile time/, --- but it severely limits expressiveness. However, the main motivation for --- 'static' is not that they are known at compile time but rather that --- /they provide a free/ 'Binary' /instance/. We therefore provide two basic --- constructors for 'Static' values: --- --- > staticLabel :: String -> Static a --- > staticApply :: Static (a -> b) -> Static a -> Static b --- --- The first constructor refers to a label in a 'RemoteTable'. The second --- allows to apply a static function to a static argument, and makes 'Static' --- compositional: once we have 'staticApply' we can implement numerous derived --- combinators on 'Static' values (we define a few in this module; see --- 'staticCompose', 'staticSplit', and 'staticConst'). +-- pointer to the value. GHC supports this through 'StaticPtr' (the @static@ +-- form, enabled by the @StaticPointers@ extension). In this module we build +-- closures on top of it. -- -- [Closures] -- @@ -34,456 +13,188 @@ -- represents the value of the free variables of the function. A 'Closure' -- represents these closures explicitly so that they can be serialized: -- --- > data Closure a = Closure (Static (ByteString -> a)) ByteString +-- > data Closure a = Closure (StaticPtr (ByteString -> a)) ByteString -- -- See /Towards Haskell in the Cloud/ for the rationale behind representing --- the function closure environment in serialized ('ByteString') form. Any --- static value can trivially be turned into a 'Closure' ('staticClosure'). --- Moreover, since 'Static' is now compositional, we can also define derived --- operators on 'Closure' values ('closureApplyStatic', 'closureApply', --- 'closureCompose', 'closureSplit'). --- --- [Monomorphic example] --- --- Suppose we are working in the context of some distributed environment, with --- a monadic type 'Process' representing processes, 'NodeId' representing node --- addresses and 'ProcessId' representing process addresses. Suppose further --- that we have a primitive --- --- > sendInt :: ProcessId -> Int -> Process () --- --- We might want to define --- --- > sendIntClosure :: ProcessId -> Closure (Int -> Process ()) --- --- In order to do that, we need a static version of 'send', and a static --- decoder for 'ProcessId': --- --- > sendIntStatic :: Static (ProcessId -> Int -> Process ()) --- > sendIntStatic = staticLabel "$send" --- --- > decodeProcessIdStatic :: Static (ByteString -> Int) --- > decodeProcessIdStatic = staticLabel "$decodeProcessId" --- --- where of course we have to make sure to use an appropriate 'RemoteTable': --- --- > rtable :: RemoteTable --- > rtable = registerStatic "$send" (toDynamic sendInt) --- > . registerStatic "$decodeProcessId" (toDynamic (decode :: ByteString -> Int)) --- > $ initRemoteTable --- --- We can now define 'sendIntClosure': --- --- > sendIntClosure :: ProcessId -> Closure (Int -> Process ()) --- > sendIntClosure pid = closure decoder (encode pid) --- > where --- > decoder :: Static (ByteString -> Int -> Process ()) --- > decoder = sendIntStatic `staticCompose` decodeProcessIdStatic --- --- [Polymorphic example] --- --- Suppose we wanted to define a primitive --- --- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ()) --- --- which turns a process that computes an integer into a process that computes --- the integer and then sends it someplace else. --- --- We can define --- --- > bindStatic :: (Typeable a, Typeable b) => Static (Process a -> (a -> Process b) -> Process b) --- > bindStatic = staticLabel "$bind" --- --- provided that we register this label: --- --- > rtable :: RemoteTable --- > rtable = ... --- > . registerStatic "$bind" ((>>=) :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2) --- > $ initRemoteTable --- --- (Note that we are using the special 'Data.Rank1Typeable.ANY1' and --- 'Data.Rank1Typeable.ANY2' types from "Data.Rank1Typeable" to represent this --- polymorphic value.) Once we have a static bind we can define +-- the function closure environment in serialized ('ByteString') form. For +-- example: -- --- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ()) --- > sendIntResult pid cl = bindStatic `closureApplyStatic` cl `closureApply` sendIntClosure pid --- --- [Dealing with qualified types] --- --- In the above we were careful to avoid qualified types. Suppose that we have --- instead --- --- > send :: Binary a => ProcessId -> a -> Process () --- --- If we now want to define 'sendClosure', analogous to 'sendIntClosure' above, --- we somehow need to include the 'Binary' instance in the closure -- after --- all, we can ship this closure someplace else, where it needs to accept an --- 'a', /then encode it/, and send it off. In order to do this, we need to turn --- the Binary instance into an explicit dictionary: --- --- > data BinaryDict a where --- > BinaryDict :: Binary a => BinaryDict a +-- > addClosure :: Int -> Closure (Int -> Int) +-- > addClosure x = closure (static add) (encode x) -- > --- > sendDict :: BinaryDict a -> ProcessId -> a -> Process () --- > sendDict BinaryDict = send --- --- Now 'sendDict' is a normal polymorphic value: --- --- > sendDictStatic :: Static (BinaryDict a -> ProcessId -> a -> Process ()) --- > sendDictStatic = staticLabel "$sendDict" --- > --- > rtable :: RemoteTable --- > rtable = ... --- > . registerStatic "$sendDict" (sendDict :: BinaryDict ANY -> ProcessId -> ANY -> Process ()) --- > $ initRemoteTable --- --- so that we can define --- --- > sendClosure :: Static (BinaryDict a) -> Process a -> Closure (a -> Process ()) --- > sendClosure dict pid = closure decoder (encode pid) --- > where --- > decoder :: Static (ByteString -> a -> Process ()) --- > decoder = (sendDictStatic `staticApply` dict) `staticCompose` decodeProcessIdStatic --- --- [Word of Caution] --- --- You should not /define/ functions on 'ANY' and co. For example, the following --- definition of 'rtable' is incorrect: --- --- > rtable :: RemoteTable --- > rtable = registerStatic "$sdictSendPort" sdictSendPort --- > $ initRemoteTable --- > where --- > sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY) --- > sdictSendPort SerializableDict = SerializableDict --- --- This definition of 'sdictSendPort' ignores its argument completely, and --- constructs a 'SerializableDict' for the /monomorphic/ type @SendPort ANY@, --- which isn't what you want. Instead, you should do --- --- > rtable :: RemoteTable --- > rtable = registerStatic "$sdictSendPort" (sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY)) --- > $ initRemoteTable --- > where --- > sdictSendPort :: forall a. SerializableDict a -> SerializableDict (SendPort a) --- > sdictSendPort SerializableDict = SerializableDict +-- > add :: ByteString -> Int -> Int +-- > add bs y = decode bs + y +-- +-- Any static value can trivially be used as a 'Closure': see 'Closure'. +-- Closures can also be combined ('closureApplyStatic', 'closureApply', +-- 'closureCompose', 'closureSplit'). Since a 'StaticPtr' can only be created +-- by a @static@ form at compile time, combining closures does not create new +-- pointers: the result remembers the closures that it was built from, and +-- these are serialized together with it. +{-# LANGUAGE GADTs #-} {-# LANGUAGE StaticPointers #-} {-# LANGUAGE RoleAnnotations #-} module Control.Distributed.Static - ( -- * Static values - Static - , staticLabel - , staticApply - , staticPtr - , staticApplyPtr - -- * Derived static combinators - , staticCompose - , staticSplit - , staticConst - , staticFlip - -- * Closures - , Closure + ( -- * Closures + Closure , closure + , unclosure -- * Derived closure combinators - , staticClosure , closureApplyStatic , closureApply , closureCompose , closureSplit - -- * Resolution - , RemoteTable - , initRemoteTable - , registerStatic - , unstatic - , unclosure ) where import Data.Binary ( Binary(get, put) - , Put , Get - , putWord8 - , getWord8 + , Put , encode - , decode - ) -import Data.ByteString.Lazy (ByteString, empty) -import Data.Map (Map) -import qualified Data.Map as Map (lookup, empty, insert) -import Control.Arrow as Arrow ((***), app) -import Control.DeepSeq (NFData(rnf), force) -import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply) -import Data.Rank1Typeable - ( Typeable - , ANY1 - , ANY2 - , ANY3 - , ANY4 - , TypeRep - , typeOf + , getWord8 + , putWord8 ) - --- Imports necessary to support StaticPtr +import Data.ByteString.Lazy (ByteString) +import Control.Arrow ((***)) +import Control.DeepSeq (NFData(rnf)) import qualified GHC.Exts as GHC (Any) -import GHC.StaticPtr import GHC.Fingerprint.Type (Fingerprint(..)) -import System.IO.Unsafe (unsafePerformIO) -import Data.Rank1Dynamic (unsafeToDynamic) -import Unsafe.Coerce (unsafeCoerce) - --------------------------------------------------------------------------------- --- Introducing static values -- --------------------------------------------------------------------------------- +import GHC.StaticPtr +import Data.Typeable (Typeable) +import Control.Monad.IO.Class (MonadIO (liftIO)) --- | Static dynamic values +-- | A closure is a code pointer together with an encoded environment, or an +-- application of closures -- --- In the new proposal for static, the SPT contains these 'TypeRep's. --- In the current implemnentation however they do not, so we need to carry --- them ourselves. This is the TypeRep of @a@, /NOT/ of @StaticPtr a@. -data SDynamic = SDynamic TypeRep (StaticPtr GHC.Any) - deriving (Typeable) - -instance Show SDynamic where - show (SDynamic typ ptr) = - let spi = staticPtrInfo ptr - (line, col) = spInfoSrcLoc spi - in concat [ "<>" - ] - -instance Eq SDynamic where - SDynamic _ ptr1 == SDynamic _ ptr2 = - staticKey ptr1 == staticKey ptr2 - -instance Ord SDynamic where - SDynamic _ ptr1 `compare` SDynamic _ ptr2 = - staticKey ptr1 `compare` staticKey ptr2 - -data StaticLabel = - StaticLabel String - | StaticApply !StaticLabel !StaticLabel - | StaticPtr SDynamic - deriving (Eq, Ord, Typeable, Show) - -instance NFData StaticLabel where - rnf (StaticLabel s) = rnf s - rnf (StaticApply a b) = rnf a `seq` rnf b - -- There are no NFData instances for TypeRep or for StaticPtr :/ - rnf (StaticPtr (SDynamic _a _b)) = () - --- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'. -newtype Static a = Static StaticLabel - deriving (Eq, Ord, Typeable, Show) - --- Trying to 'coerce' static values will lead to unification errors -type role Static nominal - -instance NFData (Static a) where - rnf (Static s) = rnf s - -instance Binary (Static a) where - put (Static label) = putStaticLabel label - get = Static <$> getStaticLabel - --- We don't want StaticLabel to be its own Binary instance -putStaticLabel :: StaticLabel -> Put -putStaticLabel (StaticLabel string) = - putWord8 0 >> put string -putStaticLabel (StaticApply label1 label2) = - putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2 -putStaticLabel (StaticPtr (SDynamic typ ptr)) = - let Fingerprint hi lo = staticKey ptr - in putWord8 2 >> put typ >> put hi >> put lo - -getStaticLabel :: Get StaticLabel -getStaticLabel = do - header <- getWord8 - case header of - 0 -> StaticLabel <$> get - 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel - 2 -> do typ <- get - hi <- get - lo <- get - let key = Fingerprint hi lo - case unsaferLookupStaticPtr key of - Nothing -> fail "StaticLabel.get: invalid pointer" - Just ptr -> return $ StaticPtr (SDynamic typ ptr) - _ -> fail "StaticLabel.get: invalid" - --- | We need to be able to lookup keys outside of the IO monad so that we --- can provide a 'Get' instance. -unsaferLookupStaticPtr :: StaticKey -> Maybe (StaticPtr a) -unsaferLookupStaticPtr = unsafePerformIO . unsafeLookupStaticPtr - --- | Create a primitive static value. +-- Code pointers are stored as 'StaticKey's, and only looked up when the closure +-- is resolved ('unclosure'). This way, decoding a closure with an unknown key +-- does not fail: the error is raised when the closure is resolved instead, +-- which allows the receiver of a bad closure to handle it as a failure of the +-- process that runs it. -- --- It is the responsibility of the client code to make sure the corresponding --- entry in the 'RemoteTable' has the appropriate type. -staticLabel :: String -> Static a -staticLabel = Static . StaticLabel . force - --- | Apply two static values -staticApply :: Static (a -> b) -> Static a -> Static b -staticApply (Static f) (Static x) = Static (StaticApply f x) - --- | Construct a static value from a static pointer +-- Closures are created with 'closure', by combining other closures, or from +-- @static@ forms: 'Closure' is an instance of 'IsStatic', so that -- --- Since 0.3.4.0. -staticPtr :: forall a. Typeable a => StaticPtr a -> Static a -staticPtr x = Static . StaticPtr - $ SDynamic (typeOf (undefined :: a)) (unsafeCoerce x) - --- | Apply a static pointer to a static value +-- > static f :: Closure a -- --- Since 0.3.4.0. -staticApplyPtr :: (Typeable a, Typeable b) - => StaticPtr (a -> b) -> Static a -> Static b -staticApplyPtr = staticApply . staticPtr - --------------------------------------------------------------------------------- --- Eliminating static values -- --------------------------------------------------------------------------------- - --- | Runtime dictionary for 'unstatic' lookups -newtype RemoteTable = RemoteTable (Map String Dynamic) +-- is a closure with an empty environment, for any @f :: a@ (there is no +-- separate function to convert a static value into a closure). To convert an +-- existing 'StaticPtr', use 'fromStaticPtr'. +-- +-- @since 0.4.0 +data Closure a where + Pointer :: !StaticKey -> Closure a + Decoder :: !StaticKey -> !ByteString -> Closure a + Apply :: Closure (b -> a) -> Closure b -> Closure a --- | Initial remote table -initRemoteTable :: RemoteTable -initRemoteTable = - registerStatic "$compose" (toDynamic ((.) :: (ANY2 -> ANY3) -> (ANY1 -> ANY2) -> ANY1 -> ANY3)) - . registerStatic "$const" (toDynamic (const :: ANY1 -> ANY2 -> ANY1)) - . registerStatic "$split" (toDynamic ((***) :: (ANY1 -> ANY3) -> (ANY2 -> ANY4) -> (ANY1, ANY2) -> (ANY3, ANY4))) - . registerStatic "$app" (toDynamic (app :: (ANY1 -> ANY2, ANY1) -> ANY2)) - . registerStatic "$decodeEnvPair" (toDynamic (decode :: ByteString -> (ByteString, ByteString))) - . registerStatic "$flip" (toDynamic (flip :: (ANY1 -> ANY2 -> ANY3) -> ANY2 -> ANY1 -> ANY3)) - $ RemoteTable Map.empty +-- | A @static@ form can be used as a 'Closure' +-- +-- @since 0.4.0 +instance IsStatic Closure where + fromStaticPtr = staticClosure --- | Register a static label -registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable -registerStatic label dyn (RemoteTable rtable) - = RemoteTable (Map.insert label dyn rtable) +type role Closure nominal --- Pseudo-type: RemoteTable -> Static a -> a -resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic -resolveStaticLabel (RemoteTable rtable) (StaticLabel label) = - case Map.lookup label rtable of - Nothing -> Left $ "Invalid static label '" ++ label ++ "'" - Just d -> Right d -resolveStaticLabel rtable (StaticApply label1 label2) = do - f <- resolveStaticLabel rtable label1 - x <- resolveStaticLabel rtable label2 - f `dynApply` x -resolveStaticLabel _ (StaticPtr (SDynamic typ ptr)) = - return $ unsafeToDynamic typ (deRefStaticPtr ptr) +instance Eq (Closure a) where + c1 == c2 = encode c1 == encode c2 --- | Resolve a static value -unstatic :: Typeable a => RemoteTable -> Static a -> Either String a -unstatic rtable (Static label) = do - dyn <- resolveStaticLabel rtable label - fromDynamic dyn +instance Ord (Closure a) where + c1 `compare` c2 = encode c1 `compare` encode c2 --------------------------------------------------------------------------------- --- Closures -- --------------------------------------------------------------------------------- +instance Show (Closure a) where + show (Pointer key) = concat ["<>"] + show (Decoder key env) = concat ["<>"] + show (Apply f x) = concat ["<>"] --- | A closure is a static value and an encoded environment -data Closure a = Closure !(Static (ByteString -> a)) !ByteString - deriving (Eq, Ord, Typeable, Show) +instance NFData (Closure a) where + rnf (Pointer _) = () + rnf (Decoder _ env) = rnf env + rnf (Apply f x) = rnf f `seq` rnf x instance Binary (Closure a) where - put (Closure st env) = put st >> put env - get = Closure <$> get <*> get - -instance NFData (Closure a) where rnf (Closure f b) = rnf f `seq` rnf b - -closure :: Static (ByteString -> a) -- ^ Decoder - -> ByteString -- ^ Encoded closure environment + put (Pointer key) = putWord8 0 >> putKey key + put (Decoder key env) = putWord8 1 >> putKey key >> put env + put (Apply f x) = putWord8 2 >> put f >> put x + get = do + tag <- getWord8 + case tag of + 0 -> Pointer <$> getKey + 1 -> Decoder <$> getKey <*> get + 2 -> getApply + _ -> fail "Closure.get: invalid" + +getApply :: forall a. Get (Closure a) +getApply = Apply <$> (get :: Get (Closure (GHC.Any -> a))) + <*> (get :: Get (Closure GHC.Any)) + +putKey :: StaticKey -> Put +putKey (Fingerprint hi lo) = put hi >> put lo + +getKey :: Get StaticKey +getKey = Fingerprint <$> get <*> get + +closure :: StaticPtr (ByteString -> a) -- ^ Decoder + -> ByteString -- ^ Encoded closure environment -> Closure a -closure = Closure +closure = Decoder . staticKey +-- Do not inline the functions which take a 'StaticPtr': GHC then creates a new +-- binding for the pointer, which is not the one that the static pointer table +-- knows about, and fails to link ("symbol not found" at startup). +-- This should be fixed in GHC 10 +{-# NOINLINE closure #-} -- | Resolve a closure -unclosure :: Typeable a => RemoteTable -> Closure a -> Either String a -unclosure rtable (Closure dec env) = do - f <- unstatic rtable dec - return (f env) - --- | Convert a static value into a closure. -staticClosure :: Static a -> Closure a -staticClosure dec = closure (staticConst dec) empty - --------------------------------------------------------------------------------- --- Predefined static values -- --------------------------------------------------------------------------------- - --- | Static version of ('Prelude..') -composeStatic :: Static ((b -> c) -> (a -> b) -> a -> c) -composeStatic = staticLabel "$compose" - --- | Static version of 'const' -constStatic :: Static (a -> b -> a) -constStatic = staticLabel "$const" - --- | Static version of ('Arrow.***') -splitStatic :: Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b')) -splitStatic = staticLabel "$split" - --- | Static version of 'Arrow.app' -appStatic :: Static ((a -> b, a) -> b) -appStatic = staticLabel "$app" - --- | Static version of 'flip' -flipStatic :: Static ((a -> b -> c) -> b -> a -> c) -flipStatic = staticLabel "$flip" +-- +-- Fails if the closure refers to a static pointer which does not exist in this +-- executable, which happens if the closure was decoded from a message that was +-- sent by a different binary. +-- +-- @since 0.4.0 +unclosure :: (MonadIO m, MonadFail m) => Closure a -> m a +unclosure c = do + result <- liftIO (resolve c) + case result of + Left err -> fail $ concat + [ "Could not resolve closure: ", err, ". The closure was probably sent by a " + , "different executable: all nodes that exchange closures must run the same binary." + ] + Right x -> pure x + +resolve :: Closure a -> IO (Either String a) +resolve (Pointer key) = fmap deRefStaticPtr <$> lookupStaticPtr key +resolve (Decoder key env) = fmap (`deRefStaticPtr` env) <$> lookupStaticPtr key +resolve (Apply f x) = do + resolvedF <- resolve f + resolvedX <- resolve x + pure (resolvedF <*> resolvedX) + +lookupStaticPtr :: StaticKey -> IO (Either String (StaticPtr a)) +lookupStaticPtr key = + maybe (Left ("static pointer " ++ show key ++ " not found")) Right <$> unsafeLookupStaticPtr key -------------------------------------------------------------------------------- --- Combinators on static values -- +-- Combinators on closures -- -------------------------------------------------------------------------------- --- | Static version of ('Prelude..') -staticCompose :: Static (b -> c) -> Static (a -> b) -> Static (a -> c) -staticCompose g f = composeStatic `staticApply` g `staticApply` f - --- | Static version of ('Control.Arrow.***') -staticSplit :: Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b')) -staticSplit f g = splitStatic `staticApply` f `staticApply` g - --- | Static version of 'Prelude.const' -staticConst :: Static a -> Static (b -> a) -staticConst x = constStatic `staticApply` x - --- | Static version of 'Prelude.flip' -staticFlip :: Static (a -> b -> c) -> Static (b -> a -> c) -staticFlip f = flipStatic `staticApply` f - --------------------------------------------------------------------------------- --- Combinators on Closures -- --------------------------------------------------------------------------------- +staticClosure :: StaticPtr a -> Closure a +staticClosure = Pointer . staticKey +{-# NOINLINE staticClosure #-} -- | Apply a static function to a closure -closureApplyStatic :: Static (a -> b) -> Closure a -> Closure b -closureApplyStatic f (Closure decoder env) = - closure (f `staticCompose` decoder) env - -decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString)) -decodeEnvPairStatic = staticLabel "$decodeEnvPair" +closureApplyStatic :: StaticPtr (a -> b) -> Closure a -> Closure b +closureApplyStatic f = closureApply (staticClosure f) +{-# NOINLINE closureApplyStatic #-} -- | Closure application -closureApply :: forall a b . - Closure (a -> b) -> Closure a -> Closure b -closureApply (Closure fdec fenv) (Closure xdec xenv) = - closure decoder (encode (fenv, xenv)) - where - decoder :: Static (ByteString -> b) - decoder = appStatic - `staticCompose` - (fdec `staticSplit` xdec) - `staticCompose` - decodeEnvPairStatic +closureApply :: Closure (a -> b) -> Closure a -> Closure b +closureApply = Apply -- | Closure composition -closureCompose :: Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c) -closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f - --- | Closure version of ('Arrow.***') -closureSplit :: Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b')) -closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g +closureCompose :: (Typeable a, Typeable b, Typeable c) + => Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c) +closureCompose g f = closureApplyStatic (static (.)) g `closureApply` f + +-- | Closure version of ('Control.Arrow.***') +closureSplit :: (Typeable a, Typeable b, Typeable a', Typeable b') + => Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b')) +closureSplit f g = closureApplyStatic (static (***)) f `closureApply` g diff --git a/packages/distributed-static/tests/Main.hs b/packages/distributed-static/tests/Main.hs new file mode 100644 index 000000000..f516ce7b0 --- /dev/null +++ b/packages/distributed-static/tests/Main.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StaticPointers #-} +module Main (main) where + +import Control.DeepSeq (force) +import Control.Distributed.Static + ( Closure, + closure, + unclosure, + closureApplyStatic, + closureApply, + closureCompose, + closureSplit ) +import Control.Exception (IOException, evaluate, try) +import Data.Binary (decode, encode) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BL +import Data.List (isInfixOf) +import Data.Typeable (Typeable) +import Data.Word (Word64) +import GHC.StaticPtr (IsStatic (fromStaticPtr), StaticPtr) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +-- The closures below are deliberately not point-free: until GHC 10, there were +-- syntactically-valid uses of `static` that were meaningless. See GHC proposal 732 + +-- The example from /Towards Haskell in the Cloud/ +addEnv :: ByteString -> Int -> Int +addEnv bs y = decode bs + y + +addClosure :: Int -> Closure (Int -> Int) +addClosure x = closure (static addEnv) (encode x) + +intClosure :: Int -> Closure Int +intClosure x = closure (static decode) (encode x) + +-- Same type as 'addEnv', but a different pointer +subEnv :: ByteString -> Int -> Int +subEnv bs y = y - decode bs + +subClosure :: Int -> Closure (Int -> Int) +subClosure x = closure (static subEnv) (encode x) + +succInt :: Int -> Int +succInt = (+ 1) + +plus :: Int -> Int -> Int +plus = (+) + +addIO :: Int -> Int -> IO Int +addIO a b = return (a + b) + +-- A polymorphic static pointer +idPtr :: Typeable a => StaticPtr (a -> a) +idPtr = static id + +roundTrip :: Closure a -> Closure a +roundTrip = decode . encode + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "distributed-static" + [ testGroup "closure" + [ testCase "unclosure" $ do + f <- unclosure (addClosure 3) + f 4 @?= 7 + , testCase "binary round trip" $ do + f <- unclosure (roundTrip (addClosure 3)) + f 4 @?= 7 + ] + , testGroup "combinators" + [ testCase "closureApplyStatic" $ do + x <- unclosure (roundTrip (closureApplyStatic (static succInt) (intClosure 1))) + x @?= 2 + , testCase "closureApply" $ do + x <- unclosure (roundTrip (closureApply (addClosure 3) (intClosure 4))) + x @?= 7 + , testCase "closureCompose" $ do + f <- unclosure (roundTrip (closureCompose (addClosure 1) (addClosure 10))) + f 100 @?= 111 + , testCase "closureSplit" $ do + f <- unclosure (roundTrip (closureSplit (addClosure 1) (addClosure 2))) + f (10, 20) @?= (11, 22) + , testCase "nested combinators" $ do + let plusOne = closureApplyStatic (static plus) (intClosure 1) + two = closureApplyStatic (static succInt) (intClosure 1) + composed = closureCompose plusOne (addClosure 10) + x <- unclosure (roundTrip (closureApply composed two)) + x @?= 13 + , testCase "closures returning IO actions" $ do + -- Regression test: the combinators erase types internally, and GHC + -- miscompiled this with -O if the erased type was an empty data type. + let c = closureApplyStatic (static addIO) (intClosure 1) `closureApply` intClosure 2 + action <- unclosure (roundTrip c) + r <- action + r @?= 3 + ] + , testGroup "IsStatic" + [ testCase "a static form is a closure" $ do + let c = static (42 :: Int) :: Closure Int + x <- unclosure (roundTrip c) + x @?= 42 + , testCase "a static form as an argument to a combinator" $ do + let c = closureApply (static succInt) (intClosure 1) + x <- unclosure (roundTrip c) + x @?= 2 + , testCase "polymorphic pointer at several types" $ do + f <- unclosure (roundTrip (fromStaticPtr (idPtr :: StaticPtr (Int -> Int)))) + f 1 @?= 1 + g <- unclosure (roundTrip (fromStaticPtr (idPtr :: StaticPtr (String -> String)))) + g "a" @?= "a" + ] + , testGroup "wire format" + [ testCase "a pointer is a tag and a key" $ + BL.length (encode (static (42 :: Int) :: Closure Int)) @?= 1 + 16 + , testCase "an application is serialized in place" $ do + -- Not as an encoded environment, which would add a length prefix + let f = addClosure 1 + x = intClosure 2 + BL.length (encode (closureApply f x)) @?= 1 + BL.length (encode f) + BL.length (encode x) + ] + , testGroup "instances" + [ testCase "Eq and Ord" $ do + addClosure 1 @?= addClosure 1 + assertBool "different environments" (addClosure 1 /= addClosure 2) + assertBool "different pointers" (addClosure 1 /= subClosure 1) + assertBool "ordering" (compare (addClosure 1) (addClosure 2) /= EQ) + roundTrip (addClosure 1) @?= addClosure 1 + , testCase "Show" $ + assertBool "constructor" ("closure" `isInfixOf` show (addClosure 1)) + , testCase "NFData" $ do + _ <- evaluate (force (addClosure 1)) + return () + ] + , testGroup "invalid pointers" + [ testCase "decoding succeeds but resolving fails" $ do + let bad = decode (encode (0 :: Word64, 0 :: Word64, 0 :: Word64)) :: Closure Int + _ <- evaluate bad + r <- try (unclosure bad) + case r of + Left (e :: IOException) -> do + -- The message names the key and the likely cause + assertBool "mentions the key" ("00000000000000000000000000000000" `isInfixOf` show e) + assertBool "mentions the cause" ("different executable" `isInfixOf` show e) + Right (_ :: Int) -> assertFailure "resolved an invalid pointer" + , testCase "an invalid pointer inside an application" $ do + let bad = decode (encode (0 :: Word64, 0 :: Word64, 0 :: Word64)) :: Closure Int + r <- try (unclosure (closureApply (addClosure 1) bad)) + case r of + Left (_ :: IOException) -> return () + Right (_ :: Int) -> assertFailure "resolved an invalid pointer" + ] + ]