LogicGrowsOnTrees-network 1.0.0.0.1 → 1.0.0.1
raw patch · 4 files changed
+113/−52 lines, 4 filesdep ~LogicGrowsOnTreesdep ~cerealdep ~cmdthelinenew-component:exe:count-all-trivial-tree-leaves
Dependency ranges changed: LogicGrowsOnTrees, cereal, cmdtheline, lens
Files
- LogicGrowsOnTrees-network.cabal +23/−7
- examples/count-all-trivial-tree-leaves.hs +24/−0
- sources/LogicGrowsOnTrees/Parallel/Adapter/Network.hs +61/−33
- tests/tests.hs +5/−12
LogicGrowsOnTrees-network.cabal view
@@ -1,5 +1,5 @@ Name: LogicGrowsOnTrees-network-Version: 1.0.0.0.1+Version: 1.0.0.1 License: BSD3 License-file: LICENSE Author: Gregory Crosswhite@@ -22,19 +22,19 @@ Source-Repository this Type: git Location: git://github.com/gcross/LogicGrowsOnTrees-network.git- Tag: 1.0.0.0.1+ Tag: 1.0.0.1 Library Build-depends:- LogicGrowsOnTrees == 1.0.*,+ LogicGrowsOnTrees >= 1.0 && < 1.2, base > 4 && < 5,- cereal >= 0.3.5 && < 0.3.6,+ cereal >= 0.3 && < 0.5, cmdtheline >= 0.2.2 && < 0.3, composition >= 1.0.1 && < 1.1, containers >= 0.4 && < 0.6, hslogger == 1.2.*, hslogger-template == 2.0.*,- lens >= 3.8.5 && < 3.10,+ lens >= 3.8.5 && < 3.11, MonadCatchIO-transformers == 0.3.*, mtl >= 2.1.2 && < 2.2, network >= 2.3 && < 2.5,@@ -59,7 +59,7 @@ Hs-source-dirs: examples Build-depends: LogicGrowsOnTrees-network,- LogicGrowsOnTrees == 1.0.*,+ LogicGrowsOnTrees >= 1.0 && < 1.2, base > 4 && < 5, cmdtheline == 0.2.* if flag(examples)@@ -69,13 +69,29 @@ if flag(warnings) GHC-Options: -Wall -fno-warn-name-shadowing +Executable count-all-trivial-tree-leaves+ Main-is: count-all-trivial-tree-leaves.hs+ Hs-source-dirs: examples+ Build-depends:+ LogicGrowsOnTrees-network,+ LogicGrowsOnTrees >= 1.0 && < 1.2,+ base > 4 && < 5,+ cereal >= 0.3 && < 0.5,+ cmdtheline == 0.2.*+ if flag(examples)+ Buildable: True+ else+ Buildable: False+ if flag(warnings)+ GHC-Options: -Wall -fno-warn-name-shadowing+ Test-Suite tests Type: exitcode-stdio-1.0 Main-is: tests.hs Hs-source-dirs: tests Build-depends: LogicGrowsOnTrees-network,- LogicGrowsOnTrees == 1.0.*,+ LogicGrowsOnTrees >= 1.0 && < 1.2, base > 4 && < 5, hslogger == 1.2.*, hslogger-template == 2.0.*,
+ examples/count-all-trivial-tree-leaves.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UnicodeSyntax #-}++import Control.Applicative++import System.Console.CmdTheLine++import LogicGrowsOnTrees.Parallel.Main+import LogicGrowsOnTrees.Parallel.Adapter.Network+import LogicGrowsOnTrees.Utils.PerfectTree+import LogicGrowsOnTrees.Utils.WordSum++main =+ mainForExploreTree+ driver+ (makeArityAndDepthTermAtPositions 0 1)+ (defTI { termDoc = "count the leaves of a tree" })+ (\_ (RunOutcome _ termination_reason) → do+ case termination_reason of+ Aborted _ → error "search aborted"+ Completed (WordSum count) → print count+ Failure _ message → error $ "error: " ++ message+ )+ (trivialPerfectTree <$> arity <*> depth)
sources/LogicGrowsOnTrees/Parallel/Adapter/Network.hs view
@@ -1,9 +1,12 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -21,10 +24,9 @@ ( -- * Driver driver- , driverNetwork -- * Network- , Network(..)- , runNetwork+ , Network()+ , withNetwork -- * Controller , NetworkRequestQueueMonad(..) , NetworkControllerMonad@@ -32,6 +34,8 @@ , fork , getCurrentProgressAsync , getCurrentProgress+ , getCurrentStatisticsAsync+ , getCurrentStatistics , getNumberOfWorkersAsync , getNumberOfWorkers , requestProgressUpdateAsync@@ -87,7 +91,7 @@ import System.Console.CmdTheLine import System.IO (Handle) import qualified System.Log.Logger as Logger-import System.Log.Logger (Priority(DEBUG,INFO))+import System.Log.Logger (Priority(DEBUG,INFO,NOTICE)) import System.Log.Logger.TH import Text.PrettyPrint (text)@@ -96,7 +100,14 @@ import LogicGrowsOnTrees.Parallel.Common.Message import qualified LogicGrowsOnTrees.Parallel.Common.Process as Process import LogicGrowsOnTrees.Parallel.Common.RequestQueue-import LogicGrowsOnTrees.Parallel.Common.Supervisor hiding (runSupervisor,getCurrentProgress,getNumberOfWorkers,setWorkloadBufferSize)+import LogicGrowsOnTrees.Parallel.Common.Supervisor+ hiding+ (runSupervisor+ ,getCurrentProgress+ ,getCurrentStatistics+ ,getNumberOfWorkers+ ,setWorkloadBufferSize+ ) import LogicGrowsOnTrees.Parallel.ExplorationMode import LogicGrowsOnTrees.Parallel.Main import LogicGrowsOnTrees.Parallel.Purity@@ -106,24 +117,26 @@ ----------------------------------- Loggers ------------------------------------ -------------------------------------------------------------------------------- -deriveLoggers "Logger" [DEBUG,INFO]+deriveLoggers "Logger" [DEBUG,INFO,NOTICE] -------------------------------------------------------------------------------- ----------------------------------- Network ------------------------------------ -------------------------------------------------------------------------------- -{-| This monad exists due to the quirk that on Windows one needs to initialize- the network system before using it via. 'withSocketsDo'; to ensure that this- happens, all computations that use the network are run in the 'Network'- monad which itself is then run using the 'runNetwork' function that is- equivalent to calling 'withSocketsDo'.+data NetworkSecret = NetworkSecret {- This is *not* meant to be exported. -}++{-| This constraint exists due to the quirk that on Windows one needs to+ initialize the network system before using it via. 'withSocketsDo'; to+ ensure that this happens, all computations that use the network have the+ 'Network' constrant and must be run by calling 'withNetwork'. -}-newtype Network α = Network { unsafeRunNetwork :: IO α }- deriving (Applicative,Functor,Monad,MonadIO)+type Network = ?network_secret :: NetworkSecret {-| Initializes the network subsystem where required (e.g., on Windows). -}-runNetwork :: Network α → IO α-runNetwork = withSocketsDo . unsafeRunNetwork+withNetwork :: (Network ⇒ IO α) → IO α+withNetwork action =+ let ?network_secret = NetworkSecret+ in withSocketsDo action -------------------------------------------------------------------------------- ---------------------------- Mostly internal types -----------------------------@@ -177,13 +190,11 @@ type ExplorationModeFor (NetworkControllerMonad exploration_mode) = exploration_mode instance NetworkRequestQueueMonad (NetworkControllerMonad result) where- disconnectWorker worker_id = C $ ask >>= (enqueueRequest $+ disconnectWorker worker_id = C $ ask >>= (enqueueRequest $ do debugM ("Disconnecting worker " ++ show worker_id)- >>- Map.lookup worker_id <$> use workers- >>=- maybe (pending_add %= Set.delete worker_id)- (liftIO . flip send QuitWorker . workerHandle)+ Map.lookup worker_id <$> use workers >>=+ maybe (pending_add %= Set.delete worker_id)+ (liftIO . flip send QuitWorker . workerHandle) ) --------------------------------------------------------------------------------@@ -268,6 +279,7 @@ ∀ exploration_mode. ( Serialize (ProgressFor exploration_mode) , Serialize (WorkerFinishedProgressFor exploration_mode)+ , Network ) ⇒ ExplorationMode exploration_mode {-^ the exploration mode -} → (Handle → IO ()) {-^ an action that writes any information needed by the worker to the given handle -} →@@ -275,7 +287,7 @@ PortID {-^ the port id on which to listen for connections -} → ProgressFor exploration_mode {-^ the initial progress of the run -} → NetworkControllerMonad exploration_mode () {-^ the controller of the supervisor -} →- Network (RunOutcomeFor exploration_mode) {-^ the outcome of the run -}+ IO (RunOutcomeFor exploration_mode) {-^ the outcome of the run -} runSupervisor exploration_mode initializeWorker@@ -283,7 +295,7 @@ port_id starting_progress (C controller)- = liftIO $ do+ = do request_queue ← newRequestQueue let receiveStolenWorkloadFromWorker = flip enqueueRequest request_queue .* receiveStolenWorkload@@ -304,7 +316,7 @@ pending_quit %= Set.delete worker_id workers %= Map.delete worker_id removeWorkerIfPresent worker_id- liftIO $ notifyDisconnected worker_id+ liftIO $ notifyDisconnected_ worker_id sendMessageToWorker message worker_id = do use workers@@ -331,6 +343,10 @@ infoM $ "Activating worker " ++ show worker_id ++ " with workload " ++ show workload sendMessageToWorker (StartWorkload workload) worker_id + notifyDisconnected_ worker_id@WorkerId{..} = do+ noticeM $ "Worker " ++ workerHostName ++ ":" ++ show workerPortNumber ++ " has disconnected"+ notifyDisconnected worker_id+ let port_id_description = showPortID port_id supervisor_thread_id ← myThreadId acceptor_thread_id ← forkIO $@@ -349,6 +365,7 @@ if allowed_to_connect then do debugM $ identifier ++ " is allowed to connect."+ noticeM $ "Received connection from " ++ identifier initializeWorker workerHandle workerThreadId ← forkIO ( receiveAndProcessMessagesFromWorkerUsingHandle@@ -361,7 +378,7 @@ Just UserInterrupt → sendToWorker QuitWorker _ → do enqueueRequest (removeWorker worker_id) request_queue sendToWorker QuitWorker `catch` (\(_::SomeException) → return ())- liftIO $ notifyDisconnected worker_id+ liftIO $ notifyDisconnected_ worker_id ) ) flip enqueueRequest request_queue $ do@@ -372,6 +389,7 @@ addWorker worker_id else do debugM $ identifier ++ " is *not* allowed to connect."+ noticeM $ "Rejected connections from " ++ identifier sendToWorker QuitWorker ) `catch`@@ -391,6 +409,7 @@ liftIO $ killThread acceptor_thread_id killControllerThreads request_queue return $ extractRunOutcomeFromSupervisorOutcome supervisor_outcome+{-# INLINE runSupervisor #-} {-| Explores the given tree using multiple processes to achieve parallelism. @@ -407,6 +426,7 @@ ( Serialize shared_configuration , Serialize (ProgressFor exploration_mode) , Serialize (WorkerFinishedProgressFor exploration_mode)+ , Network ) ⇒ (shared_configuration → ExplorationMode exploration_mode) {-^ a function that constructs the exploration mode given the shared@@ -436,7 +456,7 @@ {-^ a function that constructs the controller for the supervisor (called only on the supervisor) -} →- Network (Maybe ((shared_configuration,supervisor_configuration),RunOutcomeFor exploration_mode))+ IO (Maybe ((shared_configuration,supervisor_configuration),RunOutcomeFor exploration_mode)) {-^ if this process is the supervisor, then the outcome of the run as well as the configuration information wrapped in 'Just'; otherwise 'Nothing'@@ -474,21 +494,24 @@ handle handle return Nothing+{-# INLINE runExplorer #-} {-| Runs a worker that connects to the supervisor via. the given address and port id. -} runWorker :: ( Serialize (ProgressFor exploration_mode) , Serialize (WorkerFinishedProgressFor exploration_mode)+ , Network ) ⇒ ExplorationMode exploration_mode {-^ the mode in to explore the tree -} → Purity m n {-^ the purity of the tree -} → TreeT m (ResultFor exploration_mode) {-^ the tree -} → HostName {-^ the address of the supervisor -} → PortID {-^ the port id on which the supervisor is listening -} →- Network ()+ IO () runWorker exploration_mode purity tree host_name port_id = liftIO $ do handle ← connectTo host_name port_id Process.runWorkerUsingHandles exploration_mode purity tree handle handle+{-# INLINE runWorker #-} -------------------------------------------------------------------------------- ------------------------------- Utility funtions -------------------------------@@ -509,6 +532,7 @@ [(supervisorConfigurationTermFor shared_configuration_term supervisor_configuration_term,defTI { termName = "supervisor" , termDoc = "Run the program in supervisor mode, waiting for network connections from workers on the specified port."+ , man = mainMan } ) ,(worker_configuration_term,defTI@@ -554,20 +578,23 @@ ) ⇒ Driver IO shared_configuration supervisor_configuration m n exploration_mode driver =- case (driverNetwork :: Driver Network shared_configuration supervisor_configuration m n exploration_mode) of- Driver runDriver → Driver (runNetwork . runDriver)+ let ?network_secret = NetworkSecret+ in case (driverNetwork :: Driver IO shared_configuration supervisor_configuration m n exploration_mode) of+ Driver runDriver → Driver runDriver+{-# INLINE driver #-} -{-| This is the same as 'driver', but runs in the 'Network' monad. Use this- driver if you want to do other things with the network (such as starting- a subseqent parallel exploration) after the run completes.+{-| This is the same as 'driver', but it has the 'Network' constraint. Use this + driver if you want to do other things with the network (such as starting a+ subseqent parallel exploration) after the run completes. -} driverNetwork :: ∀ shared_configuration supervisor_configuration m n exploration_mode. ( Serialize shared_configuration , Serialize (ProgressFor exploration_mode) , Serialize (WorkerFinishedProgressFor exploration_mode)+ , Network ) ⇒- Driver Network shared_configuration supervisor_configuration m n exploration_mode+ Driver IO shared_configuration supervisor_configuration m n exploration_mode driverNetwork = Driver $ \DriverParameters{..} → do runExplorer constructExplorationMode@@ -579,6 +606,7 @@ constructController >>= maybe (return ()) (liftIO . (notifyTerminated <$> fst . fst <*> snd . fst <*> snd))+{-# INLINE driverNetwork #-} -------------------------------------------------------------------------------- ----------------------------------- Internal -----------------------------------
tests/tests.hs view
@@ -1,7 +1,7 @@ -- Language extensions {{{+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE ViewPatterns #-}@@ -22,8 +22,7 @@ import Network (PortID(..)) -import qualified System.Log.Logger as Logger-import System.Log.Logger (Priority(DEBUG,INFO),rootLoggerName,setLevel,updateGlobalLogger)+import System.Log.Logger (Priority(DEBUG),rootLoggerName,setLevel,updateGlobalLogger) import System.Log.Logger.TH import System.Random (randomRIO) @@ -39,10 +38,6 @@ import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) -- }}} --- Logging Functions {{{-deriveLoggers "Logger" [DEBUG,INFO]--- }}}- -- Helper Functions {{{ remdups :: (Eq a) => [a] -> [a] -- {{{ remdups [] = []@@ -53,10 +48,11 @@ -- }}} -- }}} -main = do+main = withNetwork $ do -- updateGlobalLogger rootLoggerName (setLevel DEBUG) defaultMain tests +tests :: Network ⇒ [Test] tests = -- {{{ [testCase "one process" . runTest $ \changeNumberOfWorkers → do changeNumberOfWorkers (const 0)@@ -68,7 +64,7 @@ 1 → changeNumberOfWorkers (+1) ] where- runTest generateNoise = do+ runTest generateNoise = withNetwork $ do let tree = nqueensCount 15 port_id = PortNumber 54210 progresses_ref ← newIORef []@@ -83,8 +79,6 @@ replicateM_ (new_number_of_workers-old_number_of_workers) . forkIO- .- unsafeRunNetwork $ runWorker AllMode@@ -112,7 +106,6 @@ return True notifyDisconnected _ = return () RunOutcome _ termination_reason ←- unsafeRunNetwork $ runSupervisor AllMode (const $ return ())