start working on core init
This commit is contained in:
parent
bf46dd0be3
commit
01a0246a4a
@ -25,7 +25,8 @@ library
|
|||||||
text,
|
text,
|
||||||
plugins >= 1.6.0,
|
plugins >= 1.6.0,
|
||||||
directory,
|
directory,
|
||||||
hashable
|
hashable,
|
||||||
|
monad-parallel
|
||||||
ghc-options:
|
ghc-options:
|
||||||
-O2
|
-O2
|
||||||
-threaded
|
-threaded
|
||||||
@ -40,7 +41,8 @@ executable GypsFulvus
|
|||||||
text,
|
text,
|
||||||
plugins >= 1.6.0,
|
plugins >= 1.6.0,
|
||||||
directory,
|
directory,
|
||||||
hashable
|
hashable,
|
||||||
|
monad-parallel
|
||||||
ghc-options:
|
ghc-options:
|
||||||
-O2
|
-O2
|
||||||
-threaded
|
-threaded
|
||||||
|
@ -6,9 +6,11 @@ import System.Directory
|
|||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Control.Concurrent(ThreadId, forkIO, killThread)
|
import Control.Concurrent(ThreadId, forkIO, killThread)
|
||||||
import GypsFulvus.PluginStuff
|
import GypsFulvus.PluginStuff
|
||||||
import Control.Monad(liftM)
|
import Control.Monad(liftM,filterM)
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
import Data.Hashable
|
import Data.Hashable
|
||||||
|
import qualified Control.Monad.Parallel as Par
|
||||||
|
import System.Plugins.Load
|
||||||
data Placeholder = Placeholder
|
data Placeholder = Placeholder
|
||||||
data CommandMap = CommandMap (M.Map T.Text Placeholder)
|
data CommandMap = CommandMap (M.Map T.Text Placeholder)
|
||||||
data CommandWorkspace = CommandWorkspace Placeholder
|
data CommandWorkspace = CommandWorkspace Placeholder
|
||||||
@ -28,12 +30,15 @@ configPath = getXdgDirectory XdgConfig "gypsfulvus"
|
|||||||
|
|
||||||
assCallbackWithManholeInSewer
|
assCallbackWithManholeInSewer
|
||||||
:: Hashable a1 =>
|
:: Hashable a1 =>
|
||||||
TMVar (M.Map Int a2 -> M.Map Int a2)
|
TMVar (M.Map Int Manhole)
|
||||||
-> a1 -> a2 -> STM ()
|
-> a1 -> Manhole -> STM ()
|
||||||
assCallbackWithManholeInSewer sewer callback_name callback_manhole = do
|
assCallbackWithManholeInSewer sewer callback_name callback_manhole = do
|
||||||
sewer_old <- takeTMVar sewer
|
sewer_old <- takeTMVar sewer
|
||||||
h_cname <- return $ hash callback_name
|
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
|
dispatchCommands sharedCommandWorkspace sharedTaskQueue = undefined
|
||||||
-- broadcast ouputs from routines to all (interested) parties
|
-- 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
|
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
|
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
|
loadCoreCommands = undefined
|
||||||
|
|
||||||
execMain :: IO ()
|
execMain :: IO ()
|
||||||
execMain = do
|
execMain = do
|
||||||
collectorChannel <- atomically newTChan -- normal channel for dumping any user input, this is the output channel for all plugins
|
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
|
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
|
canary <- atomically $ newTMVar False -- simple 'should I exit' canary
|
||||||
|
|
||||||
-- forkIO $ loadCommsPlugins canary collectorChannel
|
-- forkIO $ loadCommsPlugins canary collectorChannel
|
||||||
|
Loading…
x
Reference in New Issue
Block a user