diff --git a/GypsFulvus.cabal b/GypsFulvus.cabal index 04c1b4e..cea76c2 100644 --- a/GypsFulvus.cabal +++ b/GypsFulvus.cabal @@ -25,7 +25,8 @@ library text, plugins >= 1.6.0, directory, - hashable + hashable, + monad-parallel ghc-options: -O2 -threaded @@ -40,7 +41,8 @@ executable GypsFulvus text, plugins >= 1.6.0, directory, - hashable + hashable, + monad-parallel ghc-options: -O2 -threaded diff --git a/src/GypsFulvus.hs b/src/GypsFulvus.hs index c84f859..5814861 100644 --- a/src/GypsFulvus.hs +++ b/src/GypsFulvus.hs @@ -6,9 +6,11 @@ import System.Directory import qualified Data.Text as T import Control.Concurrent(ThreadId, forkIO, killThread) import GypsFulvus.PluginStuff -import Control.Monad(liftM) +import Control.Monad(liftM,filterM) import qualified Data.Map.Strict as M import Data.Hashable +import qualified Control.Monad.Parallel as Par +import System.Plugins.Load data Placeholder = Placeholder data CommandMap = CommandMap (M.Map T.Text Placeholder) data CommandWorkspace = CommandWorkspace Placeholder @@ -28,12 +30,15 @@ configPath = getXdgDirectory XdgConfig "gypsfulvus" assCallbackWithManholeInSewer :: Hashable a1 => - TMVar (M.Map Int a2 -> M.Map Int a2) - -> a1 -> a2 -> STM () + TMVar (M.Map Int Manhole) + -> a1 -> Manhole -> STM () assCallbackWithManholeInSewer sewer callback_name callback_manhole = do sewer_old <- takeTMVar sewer h_cname <- return $ hash callback_name - putTMVar sewer $ M.insert h_cname callback_manhole + putTMVar sewer $ M.insert h_cname callback_manhole sewer_old +lookupManholeInSewer s p = do + s_l <- readTMVar s + return $ M.lookup (hash p) s_l dispatchCommands sharedCommandWorkspace sharedTaskQueue = undefined -- broadcast ouputs from routines to all (interested) parties @@ -59,14 +64,35 @@ runForever diediedie = if (isDone) then putStrLn "Exiting cleanly." else error "I escaped my eternal prison somehow." -- it shouldn't be possible for the else to be reached unless something melts down registerComms = undefined -loadIOBackends sewer = undefined +loadIOBackends sewer = do + potentialPlugins <- binPluginPath >>= \pp -> listDirectory pp >>= \xs -> filterM (\sd -> doesDirectoryExist (pp ++ "/" ++ sd)) xs >>= \xs' -> return $ Par.mapM (\sd -> pp ++ "/" ++ sd) xs' + Par.mapM (\pp -> atomically $ tryRegisterIOPlugin sewer pp) potentialPlugins + return () + + +makeInputManhole s p = do + coreManhole <- lookupManholeInSewer s "core" + case coreManhole of + Just cm -> do + coreInputChan <- return $ getInputChan cm + pluginInputChan <- newTChan + return $ Just $ Manhole pluginInputChan coreInputChan + Nothing -> return Nothing + +tryRegisterIOPlugin s p = do + im <- makeInputManhole s p + case im of + Just im' -> do + assCallbackWithManholeInSewer s p im' + return GoodInitStatus + Nothing -> return $ BadInitStatus $ T.pack "Catastrophic failure - core ejected." loadCoreCommands = undefined execMain :: IO () execMain = do collectorChannel <- atomically newTChan -- normal channel for dumping any user input, this is the output channel for all plugins dumperChannel <- atomically newTChan -- uh this doesnt make any sense, every dings needs to have its own channel - + canary <- atomically $ newTMVar False -- simple 'should I exit' canary -- forkIO $ loadCommsPlugins canary collectorChannel