Garmelon/forest
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[server] Implement API changes

Browse source
This commit is contained in:
Joscha 2020-02-17 23:34:02 +00:00
parent 964b13739a
commit d2c6efd6c4
6 changed files with 191 additions and 143 deletions
Download patch file Download diff file Expand all files Collapse all files

10
client/Main.hs
View file

@ -37,7 +37,7 @@ data ClientState = ClientState
newClientState :: BChan Event -> Node -> WS.Connection -> ClientState newClientState :: BChan Event -> Node -> WS.Connection -> ClientState
newClientState eventChan node conn = ClientState newClientState eventChan node conn = ClientState
{ csTree = newTree node localPath Set.empty { csTree = newTree node mempty Set.empty
, csEditor = Nothing , csEditor = Nothing
, csConn = conn , csConn = conn
, csEventChan = eventChan , csEventChan = eventChan
@ -67,21 +67,21 @@ withCurrent f cs = f cs (getCurrent tree) (getCurrentPath tree)
editAction :: ClientState -> ClientM (Next ClientState) editAction :: ClientState -> ClientM (Next ClientState)
editAction = withCurrent $ \cs node _ -> do editAction = withCurrent $ \cs node _ -> do
let editor = editNode $ nodeText node let editor = editNode $ nodeText node
continue $ if nodeEdit node then cs{csEditor = Just editor} else cs continue $ if flagEdit (nodeFlags node) then cs{csEditor = Just editor} else cs
deleteAction :: ClientState -> ClientM (Next ClientState) deleteAction :: ClientState -> ClientM (Next ClientState)
deleteAction = withCurrent $ \cs node path -> do deleteAction = withCurrent $ \cs node path -> do
when (nodeDelete node) $ when (flagDelete $ nodeFlags node) $
liftIO $ sendPacket (csConn cs) $ ClientDelete path liftIO $ sendPacket (csConn cs) $ ClientDelete path
continue cs continue cs
replyAction :: ClientState -> ClientM (Next ClientState) replyAction :: ClientState -> ClientM (Next ClientState)
replyAction = withCurrent $ \cs node _ -> replyAction = withCurrent $ \cs node _ ->
continue $ if nodeReply node then cs{csEditor = Just replyToNode} else cs continue $ if flagReply (nodeFlags node) then cs{csEditor = Just replyToNode} else cs
actAction :: ClientState -> ClientM (Next ClientState) actAction :: ClientState -> ClientM (Next ClientState)
actAction = withCurrent $ \cs node path -> do actAction = withCurrent $ \cs node path -> do
when (nodeAct node) $ when (flagAct $ nodeFlags node) $
liftIO $ sendPacket (csConn cs) $ ClientAct path liftIO $ sendPacket (csConn cs) $ ClientAct path
continue cs continue cs

34
server/Main.hs
View file

@ -25,22 +25,22 @@ main :: IO ()
main = do main = do
putStrLn "Starting server" putStrLn "Starting server"
WS.runServerWithOptions options $ serverApp pingDelay $ forkModule "Forest" WS.runServerWithOptions options $ serverApp pingDelay $ forkModule "Forest"
[ ProngConstructor $ constModule $ newNode "" "Test" [txtNode "" "Bla"] [ ProngConstructor "Test" $ constModule $ newNode "" "" [txtNode "" "Bla"]
, ProngConstructor $ animateModule 200000 , ProngConstructor "Animation" $ animateModule 200000 $ map (newNode "" "")
[ newNode "" "Animate" [txtNode "" "|> |", txtNode "" "Ping!"] [ [txtNode "" "|> |", txtNode "" "Ping!"]
, newNode "" "Animate" [txtNode "" "|-> |", txtNode "" "Ping!"] , [txtNode "" "|-> |", txtNode "" "Ping!"]
, newNode "" "Animate" [txtNode "" "| -> |", txtNode "" "Ping!"] , [txtNode "" "| -> |", txtNode "" "Ping!"]
, newNode "" "Animate" [txtNode "" "| -> |", txtNode "" "Ping!"] , [txtNode "" "| -> |", txtNode "" "Ping!"]
, newNode "" "Animate" [txtNode "" "| ->|", txtNode "" "Ping!"] , [txtNode "" "| ->|", txtNode "" "Ping!"]
, newNode "" "Animate" [txtNode "" "| -|", txtNode "" "Ping!"] , [txtNode "" "| -|", txtNode "" "Ping!"]
, newNode "" "Animate" [txtNode "" "| |", txtNode "" "Ping!"] , [txtNode "" "| |", txtNode "" "Ping!"]
, newNode "" "Animate" [txtNode "" "| <|", txtNode "" "Pong!"] , [txtNode "" "| <|", txtNode "" "Pong!"]
, newNode "" "Animate" [txtNode "" "| <-|", txtNode "" "Pong!"] , [txtNode "" "| <-|", txtNode "" "Pong!"]
, newNode "" "Animate" [txtNode "" "| <- |", txtNode "" "Pong!"] , [txtNode "" "| <- |", txtNode "" "Pong!"]
, newNode "" "Animate" [txtNode "" "| <- |", txtNode "" "Pong!"] , [txtNode "" "| <- |", txtNode "" "Pong!"]
, newNode "" "Animate" [txtNode "" "|<- |", txtNode "" "Pong!"] , [txtNode "" "|<- |", txtNode "" "Pong!"]
, newNode "" "Animate" [txtNode "" "|- |", txtNode "" "Pong!"] , [txtNode "" "|- |", txtNode "" "Pong!"]
, newNode "" "Animate" [txtNode "" "| |", txtNode "" "Pong!"] , [txtNode "" "| |", txtNode "" "Pong!"]
] ]
, ProngConstructor $ constModule projectDescriptionNode , ProngConstructor "About" $ constModule projectDescriptionNode
] ]

21
src/Forest/Client/Node.hs
View file

@ -12,6 +12,7 @@ import Forest.Client.NodeEditor
import Forest.Client.ResourceName import Forest.Client.ResourceName
import Forest.Client.WidgetTree import Forest.Client.WidgetTree
import Forest.Node import Forest.Node
import qualified Forest.OrderedMap as OMap
data DrawState = DrawState data DrawState = DrawState
{ dsEditor :: Maybe NodeEditor { dsEditor :: Maybe NodeEditor
@ -20,10 +21,10 @@ data DrawState = DrawState
} }
isFocused :: DrawState -> Bool isFocused :: DrawState -> Bool
isFocused ds = (isLocalPath <$> dsFocused ds) == Just True isFocused ds = dsFocused ds == Just mempty
isFolded :: DrawState -> Bool isFolded :: DrawState -> Bool
isFolded ds = not $ localPath `Set.member` dsUnfolded ds isFolded ds = not $ mempty `Set.member` dsUnfolded ds
decorateExpand :: Bool -> Widget n -> Widget n decorateExpand :: Bool -> Widget n -> Widget n
decorateExpand True widget = withDefAttr "expand" widget decorateExpand True widget = withDefAttr "expand" widget
@ -33,19 +34,19 @@ decorateFocus :: Bool -> Widget n -> Widget n
decorateFocus True widget = visible $ withDefAttr "focus" widget decorateFocus True widget = visible $ withDefAttr "focus" widget
decorateFocus False widget = withDefAttr "nofocus" widget decorateFocus False widget = withDefAttr "nofocus" widget
decorateFlags :: Node -> Widget n -> Widget n decorateFlags :: NodeFlags -> Widget n -> Widget n
decorateFlags node widget = decorateFlags node widget =
let e = if nodeEdit node then "e" else "-" let e = if flagEdit node then "e" else "-"
d = if nodeDelete node then "d" else "-" d = if flagDelete node then "d" else "-"
r = if nodeReply node then "r" else "-" r = if flagReply node then "r" else "-"
a = if nodeAct node then "a" else "-" a = if flagAct node then "a" else "-"
flags = "(" <> e <> d <> r <> a <> ")" flags = "(" <> e <> d <> r <> a <> ")"
in widget <+> txt " " <+> withDefAttr "flags" (txt flags) in widget <+> txt " " <+> withDefAttr "flags" (txt flags)
narrowDrawState :: NodeId -> DrawState -> DrawState narrowDrawState :: NodeId -> DrawState -> DrawState
narrowDrawState nodeId ds = ds narrowDrawState nodeId ds = ds
{ dsUnfolded = narrowSet nodeId $ dsUnfolded ds { dsUnfolded = narrowSet nodeId $ dsUnfolded ds
, dsFocused = narrowPath nodeId =<< dsFocused ds , dsFocused = narrow nodeId =<< dsFocused ds
} }
nodeToWidget :: Node -> Widget ResourceName nodeToWidget :: Node -> Widget ResourceName
@ -57,7 +58,7 @@ subnodeToTree ds nodeId node =
in nodeToTree newDs node in nodeToTree newDs node
subnodesToTrees :: DrawState -> Node -> [WidgetTree ResourceName] subnodesToTrees :: DrawState -> Node -> [WidgetTree ResourceName]
subnodesToTrees ds = mapChildren (subnodeToTree ds) subnodesToTrees ds = map (uncurry $ subnodeToTree ds) . OMap.toList . nodeChildren
nodeToTree :: DrawState -> Node -> WidgetTree ResourceName nodeToTree :: DrawState -> Node -> WidgetTree ResourceName
nodeToTree ds node = case dsEditor ds of nodeToTree ds node = case dsEditor ds of
@ -71,7 +72,7 @@ nodeToTree ds node = case dsEditor ds of
folded = isFolded ds folded = isFolded ds
expand = decorateExpand $ hasChildren node expand = decorateExpand $ hasChildren node
nodeWidget = nodeWidget =
decorateFlags node $ decorateFlags (nodeFlags node) $
decorateFocus focused $ decorateFocus focused $
expand $ nodeToWidget node expand $ nodeToWidget node
subnodeWidgets = if folded then [] else subnodesToTrees ds node subnodeWidgets = if folded then [] else subnodesToTrees ds node

10
src/Forest/Client/Tree.hs
View file

@ -16,7 +16,6 @@ module Forest.Client.Tree
) where ) where
import Brick import Brick
import qualified Data.Map as Map
import Data.Maybe import Data.Maybe
import qualified Data.Set as Set import qualified Data.Set as Set
@ -25,6 +24,7 @@ import Forest.Client.NodeEditor
import Forest.Client.ResourceName import Forest.Client.ResourceName
import Forest.Client.WidgetTree import Forest.Client.WidgetTree
import Forest.Node import Forest.Node
import qualified Forest.OrderedMap as OMap
import Forest.Util import Forest.Util
data Tree = Tree data Tree = Tree
@ -135,8 +135,8 @@ toggleFold tree
-- | Remove all nodes that would not be visible due to the folding. -- | Remove all nodes that would not be visible due to the folding.
applyFolds :: Set.Set Path -> Node -> Node applyFolds :: Set.Set Path -> Node -> Node
applyFolds unfolded node applyFolds unfolded node
| localPath `Set.member` unfolded = node {nodeChildren = foldedChildren} | mempty `Set.member` unfolded = node {nodeChildren = foldedChildren}
| otherwise = node {nodeChildren = Map.empty} | otherwise = node {nodeChildren = OMap.empty}
where where
foldedChildren = Map.fromList $ mapChildren applyFoldsToChild node foldedChildren = OMap.mapWithKey applyFoldsToChild $ nodeChildren node
applyFoldsToChild nid n = (nid, applyFolds (narrowSet nid unfolded) n) applyFoldsToChild nid = applyFolds $ narrowSet nid unfolded

190
src/Forest/Node.hs
View file

@ -1,108 +1,150 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-}
module Forest.Node module Forest.Node
( ( NodeId
-- * Node , enumerateIds
NodeId , NodeFlags(..)
, readFlags
, Node(..) , Node(..)
, newNode , newNode
, txtNode , txtNode
, getChild
, hasChildren , hasChildren
, mapChildren , mapChildren
, applyId , applyId
, applyPath , applyPath
, alterAt , adjustAt
, editAt
, replaceAt , replaceAt
, diffNodes , diffNodes
-- * Path
, Path(..) , Path(..)
, localPath , narrow
, isLocalPath
, isValidPath
, narrowPath
, narrowSet , narrowSet
) where ) where
import Control.Monad import Control.Monad
import Data.Aeson import Data.Aeson
import Data.Char import qualified Data.Map.Strict as Map
import qualified Data.Map.Strict as Map
import Data.Maybe import Data.Maybe
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as T import qualified Data.Text as T
import GHC.Generics
{- Node -} import qualified Forest.OrderedMap as OMap
type NodeId = T.Text type NodeId = T.Text
enumerateIds :: [NodeId]
enumerateIds = map (T.pack . show) [(0::Integer)..]
data NodeFlags = NodeFlags
{ flagEdit :: !Bool
, flagDelete :: !Bool
, flagReply :: !Bool
, flagAct :: !Bool
} deriving (Show, Eq)
instance Semigroup NodeFlags where
f1 <> f2 = NodeFlags
{ flagEdit = flagEdit f1 || flagEdit f2
, flagDelete = flagEdit f1 || flagEdit f2
, flagReply = flagReply f1 || flagReply f2
, flagAct = flagAct f1 || flagAct f2
}
instance Monoid NodeFlags where
mempty = NodeFlags
{ flagEdit = False
, flagDelete = False
, flagReply = False
, flagAct = False
}
readFlags :: String -> NodeFlags
readFlags s = NodeFlags
{ flagEdit = 'e' `elem` s
, flagDelete = 'd' `elem` s
, flagReply = 'r' `elem` s
, flagAct = 'a' `elem` s
}
-- | A node and its children.
data Node = Node data Node = Node
{ nodeText :: !T.Text { nodeText :: !T.Text
, nodeEdit :: !Bool , nodeFlags :: !NodeFlags
, nodeDelete :: !Bool , nodeChildren :: !(OMap.OrderedMap NodeId Node)
, nodeReply :: !Bool } deriving (Show)
, nodeAct :: !Bool
, nodeChildren :: !(Map.Map NodeId Node)
}
deriving (Show, Generic)
nodeOptions :: Options
nodeOptions = defaultOptions{fieldLabelModifier = map toLower . drop 4}
instance ToJSON Node where instance ToJSON Node where
toJSON = genericToJSON nodeOptions toJSON node = object
toEncoding = genericToEncoding nodeOptions [ "text" .= nodeText node
, "edit" .= flagEdit flags
, "delete" .= flagDelete flags
, "reply" .= flagReply flags
, "act" .= flagAct flags
, "children" .= OMap.toMap children
, "order" .= OMap.keys children
]
where
flags = nodeFlags node
children = nodeChildren node
toEncoding node = pairs
( "text" .= nodeText node
<> "edit" .= flagEdit flags
<> "delete" .= flagDelete flags
<> "reply" .= flagReply flags
<> "act" .= flagAct flags
<> "children" .= OMap.toMap children
<> "order" .= OMap.keys children
)
where
flags = nodeFlags node
children = nodeChildren node
instance FromJSON Node where instance FromJSON Node where
parseJSON = genericParseJSON nodeOptions parseJSON v = parseJSON v >>= \o -> do
text <- o .: "text"
flags <- NodeFlags
<$> o .: "edit"
<*> o .: "delete"
<*> o .: "reply"
<*> o .: "act"
children <- o .: "children"
order <- o .: "order"
pure Node
{ nodeText = text
, nodeFlags = flags
, nodeChildren = OMap.fromMapWithOrder children order
}
newNode :: String -> T.Text -> [Node] -> Node newNode :: String -> T.Text -> [Node] -> Node
newNode flags text children = newNode flags text children = Node
let edit = 'e' `elem` flags { nodeText = text
delete = 'd' `elem` flags , nodeFlags = readFlags flags
reply = 'r' `elem` flags , nodeChildren = OMap.fromList $ zip enumerateIds children
act = 'a' `elem` flags }
digits = length $ show $ length children
formatId :: Integer -> T.Text
formatId = T.justifyRight digits '0' . T.pack . show
pairedChildren = zip (map formatId [0..]) children
in Node text edit delete reply act $ Map.fromList pairedChildren
txtNode :: String -> T.Text -> Node txtNode :: String -> T.Text -> Node
txtNode flags text = newNode flags text [] txtNode flags text = newNode flags text []
getChild :: NodeId -> Node -> Maybe Node
getChild nodeId node = nodeChildren node Map.!? nodeId
hasChildren :: Node -> Bool hasChildren :: Node -> Bool
hasChildren = not . Map.null . nodeChildren hasChildren = not . OMap.null . nodeChildren
mapChildren :: (NodeId -> Node -> a) -> Node -> [a] mapChildren :: (NodeId -> Node -> a) -> Node -> [a]
mapChildren f node = map (uncurry f) $ Map.toAscList $ nodeChildren node mapChildren f = map (uncurry f) . OMap.toList . nodeChildren
applyId :: NodeId -> Node -> Maybe Node applyId :: NodeId -> Node -> Maybe Node
applyId nodeId node = nodeChildren node Map.!? nodeId applyId nid node = nodeChildren node OMap.!? nid
applyPath :: Path -> Node -> Maybe Node applyPath :: Path -> Node -> Maybe Node
applyPath (Path ids) node = foldM (flip applyId) node ids applyPath (Path ids) node = foldM (flip applyId) node ids
alterChild :: (Maybe Node -> Maybe Node) -> NodeId -> Node -> Node adjustAt :: (Node -> Node) -> Path -> Node -> Node
alterChild f nodeId node = node{nodeChildren = Map.alter f nodeId (nodeChildren node)} adjustAt f (Path []) node = f node
adjustAt f (Path (x:xs)) node =
alterAt :: (Maybe Node -> Maybe Node) -> Path -> Node -> Maybe Node node {nodeChildren = OMap.adjust (adjustAt f $ Path xs) x $ nodeChildren node}
alterAt f (Path []) node = f (Just node)
alterAt f (Path (x:xs)) node = Just $ alterChild (>>= alterAt f (Path xs)) x node
editAt :: (Node -> Node) -> Path -> Node -> Node
editAt f (Path []) = f
editAt f (Path (x:xs)) = alterChild (fmap $ editAt f (Path xs)) x
replaceAt :: Node -> Path -> Node -> Node replaceAt :: Node -> Path -> Node -> Node
replaceAt child = editAt (const child) replaceAt node = adjustAt $ const node
diffNodes :: Node -> Node -> Maybe (Path, Node) diffNodes :: Node -> Node -> Maybe (Path, Node)
diffNodes a b diffNodes a b
@ -112,33 +154,23 @@ diffNodes a b
[(x, Path xs, node)] -> Just (Path (x:xs), node) [(x, Path xs, node)] -> Just (Path (x:xs), node)
_ -> Just (Path [], b) _ -> Just (Path [], b)
where where
nodesDiffer = nodeText a /= nodeText b nodesDiffer = nodeText a /= nodeText b || nodeFlags a /= nodeFlags b
|| any (\f -> f a /= f b) [nodeEdit, nodeDelete, nodeReply, nodeAct]
aChildren = nodeChildren a aChildren = nodeChildren a
bChildren = nodeChildren b bChildren = nodeChildren b
childrenChanged = Map.keysSet aChildren /= Map.keysSet bChildren childrenChanged = OMap.keys aChildren /= OMap.keys bChildren
diffedChildren = Map.toList $ Map.intersectionWith diffNodes aChildren bChildren diffedChildren = Map.toList $ Map.intersectionWith diffNodes (OMap.toMap aChildren) (OMap.toMap bChildren)
differingChildren = [(key, path, node) | (key, Just (path, node)) <- diffedChildren] differingChildren = [(key, path, node) | (key, Just (path, node)) <- diffedChildren]
{- Path -}
newtype Path = Path newtype Path = Path
{ pathElements :: [NodeId] { pathElements :: [NodeId]
} deriving (Show, Eq, Ord, Semigroup, Monoid, ToJSON, FromJSON) } deriving (Show, Eq, Ord, Semigroup, Monoid, ToJSON, FromJSON)
localPath :: Path -- | Try to remove a 'NodeId' from the beginning of a 'Path'.
localPath = Path [] narrow :: NodeId -> Path -> Maybe Path
narrow nid (Path (x:xs))
isLocalPath :: Path -> Bool | nid == x = Just (Path xs)
isLocalPath = (== localPath) narrow _ _ = Nothing
isValidPath :: Node -> Path -> Bool
isValidPath node path = isJust $ applyPath path node
narrowPath :: NodeId -> Path -> Maybe Path
narrowPath x (Path (y:ys))
| x == y = Just (Path ys)
narrowPath _ _ = Nothing
-- | Narrow a whole set of paths, discarding those that could not be narrowed.
narrowSet :: NodeId -> Set.Set Path -> Set.Set Path narrowSet :: NodeId -> Set.Set Path -> Set.Set Path
narrowSet x s = Set.fromList [Path ys | Path (y:ys) <- Set.toList s, x == y] narrowSet nid = Set.fromList . mapMaybe (narrow nid) . Set.toList

69
src/Forest/TreeModule/Fork.hs
View file

@ -15,11 +15,13 @@ import qualified Data.Map as Map
import qualified Data.Text as T import qualified Data.Text as T
import Forest.Node import Forest.Node
import qualified Forest.OrderedMap as OMap
import Forest.TreeModule import Forest.TreeModule
data Prong = forall r a . TreeModule a r => Prong (a r) data Prong = forall r a . TreeModule a r => Prong (a r)
data ProngConstructor = forall r a . TreeModule a r => data ProngConstructor = forall r a . TreeModule a r =>
ProngConstructor (ModuleConstructor (a r)) ProngConstructor T.Text (ModuleConstructor (a r))
newtype ForkModule r = ForkModule (Map.Map NodeId Prong) newtype ForkModule r = ForkModule (Map.Map NodeId Prong)
@ -27,53 +29,66 @@ instance TreeModule ForkModule () where
edit _ (Path []) _ = pure Nothing edit _ (Path []) _ = pure Nothing
edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
Just (Prong a) -> Just () <$ edit a (Path xs) text Just (Prong a) -> Just () <$ edit a (Path xs) text
Nothing -> pure Nothing Nothing -> pure Nothing
delete _ (Path []) = pure Nothing delete _ (Path []) = pure Nothing
delete (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of delete (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
Just (Prong a) -> Just () <$ delete a (Path xs) Just (Prong a) -> Just () <$ delete a (Path xs)
Nothing -> pure Nothing Nothing -> pure Nothing
reply _ (Path []) _ = pure Nothing reply _ (Path []) _ = pure Nothing
reply (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of reply (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
Just (Prong a) -> Just () <$ reply a (Path xs) text Just (Prong a) -> Just () <$ reply a (Path xs) text
Nothing -> pure Nothing Nothing -> pure Nothing
act _ (Path []) = pure Nothing act _ (Path []) = pure Nothing
act (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of act (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
Just (Prong a) -> Just () <$ act a (Path xs) Just (Prong a) -> Just () <$ act a (Path xs)
Nothing -> pure Nothing Nothing -> pure Nothing
sendNodeFromProng data ProngInfo = ProngInfo
:: T.Text { piTopName :: T.Text
-> MVar (Map.Map NodeId Node) , piNames :: Map.Map NodeId T.Text
-> (Node -> IO ()) , piNodes :: Map.Map NodeId Node
-> NodeId , piOrder :: [NodeId]
-> Node }
-> IO ()
sendNodeFromProng text nodesVar sendNode nodeId node = do renderProngInfo :: ProngInfo -> Node
nodes <- takeMVar nodesVar renderProngInfo pInfo =
let newNodes = Map.insert nodeId node nodes let childMap = Map.intersectionWith
newTopNode = Node text False False False False newNodes (\name node -> node{nodeText = name})
sendNode newTopNode (piNames pInfo)
putMVar nodesVar newNodes (piNodes pInfo)
children = OMap.fromMapWithOrder childMap $ piOrder pInfo
in Node {nodeText = piTopName pInfo, nodeFlags = mempty, nodeChildren = children}
sendNodeFromProng :: MVar ProngInfo -> (Node -> IO ()) -> NodeId -> Node -> IO ()
sendNodeFromProng piVar sendNode nodeId node =
modifyMVar_ piVar $ \pInfo -> do
let newPInfo = pInfo {piNodes = Map.insert nodeId node $ piNodes pInfo}
sendNode $ renderProngInfo pInfo
pure newPInfo
constructProngs constructProngs
:: T.Text :: MVar ProngInfo
-> MVar (Map.Map NodeId Node)
-> (Node -> IO ()) -> (Node -> IO ())
-> Map.Map NodeId ProngConstructor -> Map.Map NodeId ProngConstructor
-> Cont (IO ()) (Map.Map NodeId Prong) -> Cont (IO ()) (Map.Map NodeId Prong)
constructProngs text nodesVar sendNode = constructProngs piVar sendNode =
Map.traverseWithKey constructProng Map.traverseWithKey constructProng
where where
constructProng nodeId (ProngConstructor constructor) = constructProng nodeId (ProngConstructor _ constructor) =
Prong <$> cont (constructor $ sendNodeFromProng text nodesVar sendNode nodeId) Prong <$> cont (constructor $ sendNodeFromProng piVar sendNode nodeId)
forkModule :: T.Text -> [ProngConstructor] -> ModuleConstructor (ForkModule ()) forkModule :: T.Text -> [ProngConstructor] -> ModuleConstructor (ForkModule ())
forkModule text prongs sendNode continue = do forkModule text prongs sendNode continue = do
nodesVar <- newMVar Map.empty let namePairs = zip enumerateIds $ map (\(ProngConstructor name _) -> name) prongs
let digits = length $ show $ length prongs nodesVar <- newMVar ProngInfo
numbers = map (T.justifyRight digits '0' . T.pack . show) [(0::Integer)..] { piTopName = text
, piNames = Map.fromList namePairs
, piNodes = Map.empty
, piOrder = map fst namePairs
}
let numbers = map (T.pack . show) [(0::Integer)..]
prongMap = Map.fromList $ zip numbers prongs prongMap = Map.fromList $ zip numbers prongs
runCont (constructProngs text nodesVar sendNode prongMap) (continue . ForkModule) runCont (constructProngs nodesVar sendNode prongMap) (continue . ForkModule)