[server] Implement API changes
This commit is contained in:
parent
964b13739a
commit
d2c6efd6c4
6 changed files with 191 additions and 143 deletions
|
|
@ -37,7 +37,7 @@ data ClientState = ClientState
|
|||
|
||||
newClientState :: BChan Event -> Node -> WS.Connection -> ClientState
|
||||
newClientState eventChan node conn = ClientState
|
||||
{ csTree = newTree node localPath Set.empty
|
||||
{ csTree = newTree node mempty Set.empty
|
||||
, csEditor = Nothing
|
||||
, csConn = conn
|
||||
, csEventChan = eventChan
|
||||
|
|
@ -67,21 +67,21 @@ withCurrent f cs = f cs (getCurrent tree) (getCurrentPath tree)
|
|||
editAction :: ClientState -> ClientM (Next ClientState)
|
||||
editAction = withCurrent $ \cs node _ -> do
|
||||
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 = withCurrent $ \cs node path -> do
|
||||
when (nodeDelete node) $
|
||||
when (flagDelete $ nodeFlags node) $
|
||||
liftIO $ sendPacket (csConn cs) $ ClientDelete path
|
||||
continue cs
|
||||
|
||||
replyAction :: ClientState -> ClientM (Next ClientState)
|
||||
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 = withCurrent $ \cs node path -> do
|
||||
when (nodeAct node) $
|
||||
when (flagAct $ nodeFlags node) $
|
||||
liftIO $ sendPacket (csConn cs) $ ClientAct path
|
||||
continue cs
|
||||
|
||||
|
|
|
|||
|
|
@ -25,22 +25,22 @@ main :: IO ()
|
|||
main = do
|
||||
putStrLn "Starting server"
|
||||
WS.runServerWithOptions options $ serverApp pingDelay $ forkModule "Forest"
|
||||
[ ProngConstructor $ constModule $ newNode "" "Test" [txtNode "" "Bla"]
|
||||
, ProngConstructor $ animateModule 200000
|
||||
[ newNode "" "Animate" [txtNode "" "|> |", txtNode "" "Ping!"]
|
||||
, newNode "" "Animate" [txtNode "" "|-> |", txtNode "" "Ping!"]
|
||||
, newNode "" "Animate" [txtNode "" "| -> |", txtNode "" "Ping!"]
|
||||
, newNode "" "Animate" [txtNode "" "| -> |", txtNode "" "Ping!"]
|
||||
, newNode "" "Animate" [txtNode "" "| ->|", txtNode "" "Ping!"]
|
||||
, newNode "" "Animate" [txtNode "" "| -|", txtNode "" "Ping!"]
|
||||
, newNode "" "Animate" [txtNode "" "| |", txtNode "" "Ping!"]
|
||||
, newNode "" "Animate" [txtNode "" "| <|", txtNode "" "Pong!"]
|
||||
, newNode "" "Animate" [txtNode "" "| <-|", txtNode "" "Pong!"]
|
||||
, newNode "" "Animate" [txtNode "" "| <- |", txtNode "" "Pong!"]
|
||||
, newNode "" "Animate" [txtNode "" "| <- |", txtNode "" "Pong!"]
|
||||
, newNode "" "Animate" [txtNode "" "|<- |", txtNode "" "Pong!"]
|
||||
, newNode "" "Animate" [txtNode "" "|- |", txtNode "" "Pong!"]
|
||||
, newNode "" "Animate" [txtNode "" "| |", txtNode "" "Pong!"]
|
||||
[ ProngConstructor "Test" $ constModule $ newNode "" "" [txtNode "" "Bla"]
|
||||
, ProngConstructor "Animation" $ animateModule 200000 $ map (newNode "" "")
|
||||
[ [txtNode "" "|> |", txtNode "" "Ping!"]
|
||||
, [txtNode "" "|-> |", txtNode "" "Ping!"]
|
||||
, [txtNode "" "| -> |", txtNode "" "Ping!"]
|
||||
, [txtNode "" "| -> |", txtNode "" "Ping!"]
|
||||
, [txtNode "" "| ->|", txtNode "" "Ping!"]
|
||||
, [txtNode "" "| -|", txtNode "" "Ping!"]
|
||||
, [txtNode "" "| |", txtNode "" "Ping!"]
|
||||
, [txtNode "" "| <|", txtNode "" "Pong!"]
|
||||
, [txtNode "" "| <-|", txtNode "" "Pong!"]
|
||||
, [txtNode "" "| <- |", txtNode "" "Pong!"]
|
||||
, [txtNode "" "| <- |", txtNode "" "Pong!"]
|
||||
, [txtNode "" "|<- |", txtNode "" "Pong!"]
|
||||
, [txtNode "" "|- |", txtNode "" "Pong!"]
|
||||
, [txtNode "" "| |", txtNode "" "Pong!"]
|
||||
]
|
||||
, ProngConstructor $ constModule projectDescriptionNode
|
||||
, ProngConstructor "About" $ constModule projectDescriptionNode
|
||||
]
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ import Forest.Client.NodeEditor
|
|||
import Forest.Client.ResourceName
|
||||
import Forest.Client.WidgetTree
|
||||
import Forest.Node
|
||||
import qualified Forest.OrderedMap as OMap
|
||||
|
||||
data DrawState = DrawState
|
||||
{ dsEditor :: Maybe NodeEditor
|
||||
|
|
@ -20,10 +21,10 @@ data DrawState = DrawState
|
|||
}
|
||||
|
||||
isFocused :: DrawState -> Bool
|
||||
isFocused ds = (isLocalPath <$> dsFocused ds) == Just True
|
||||
isFocused ds = dsFocused ds == Just mempty
|
||||
|
||||
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 True widget = withDefAttr "expand" widget
|
||||
|
|
@ -33,19 +34,19 @@ decorateFocus :: Bool -> Widget n -> Widget n
|
|||
decorateFocus True widget = visible $ withDefAttr "focus" widget
|
||||
decorateFocus False widget = withDefAttr "nofocus" widget
|
||||
|
||||
decorateFlags :: Node -> Widget n -> Widget n
|
||||
decorateFlags :: NodeFlags -> Widget n -> Widget n
|
||||
decorateFlags node widget =
|
||||
let e = if nodeEdit node then "e" else "-"
|
||||
d = if nodeDelete node then "d" else "-"
|
||||
r = if nodeReply node then "r" else "-"
|
||||
a = if nodeAct node then "a" else "-"
|
||||
let e = if flagEdit node then "e" else "-"
|
||||
d = if flagDelete node then "d" else "-"
|
||||
r = if flagReply node then "r" else "-"
|
||||
a = if flagAct node then "a" else "-"
|
||||
flags = "(" <> e <> d <> r <> a <> ")"
|
||||
in widget <+> txt " " <+> withDefAttr "flags" (txt flags)
|
||||
|
||||
narrowDrawState :: NodeId -> DrawState -> DrawState
|
||||
narrowDrawState nodeId ds = ds
|
||||
{ dsUnfolded = narrowSet nodeId $ dsUnfolded ds
|
||||
, dsFocused = narrowPath nodeId =<< dsFocused ds
|
||||
, dsFocused = narrow nodeId =<< dsFocused ds
|
||||
}
|
||||
|
||||
nodeToWidget :: Node -> Widget ResourceName
|
||||
|
|
@ -57,7 +58,7 @@ subnodeToTree ds nodeId node =
|
|||
in nodeToTree newDs node
|
||||
|
||||
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 ds node = case dsEditor ds of
|
||||
|
|
@ -71,7 +72,7 @@ nodeToTree ds node = case dsEditor ds of
|
|||
folded = isFolded ds
|
||||
expand = decorateExpand $ hasChildren node
|
||||
nodeWidget =
|
||||
decorateFlags node $
|
||||
decorateFlags (nodeFlags node) $
|
||||
decorateFocus focused $
|
||||
expand $ nodeToWidget node
|
||||
subnodeWidgets = if folded then [] else subnodesToTrees ds node
|
||||
|
|
|
|||
|
|
@ -16,7 +16,6 @@ module Forest.Client.Tree
|
|||
) where
|
||||
|
||||
import Brick
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
|
@ -25,6 +24,7 @@ import Forest.Client.NodeEditor
|
|||
import Forest.Client.ResourceName
|
||||
import Forest.Client.WidgetTree
|
||||
import Forest.Node
|
||||
import qualified Forest.OrderedMap as OMap
|
||||
import Forest.Util
|
||||
|
||||
data Tree = Tree
|
||||
|
|
@ -135,8 +135,8 @@ toggleFold tree
|
|||
-- | Remove all nodes that would not be visible due to the folding.
|
||||
applyFolds :: Set.Set Path -> Node -> Node
|
||||
applyFolds unfolded node
|
||||
| localPath `Set.member` unfolded = node {nodeChildren = foldedChildren}
|
||||
| otherwise = node {nodeChildren = Map.empty}
|
||||
| mempty `Set.member` unfolded = node {nodeChildren = foldedChildren}
|
||||
| otherwise = node {nodeChildren = OMap.empty}
|
||||
where
|
||||
foldedChildren = Map.fromList $ mapChildren applyFoldsToChild node
|
||||
applyFoldsToChild nid n = (nid, applyFolds (narrowSet nid unfolded) n)
|
||||
foldedChildren = OMap.mapWithKey applyFoldsToChild $ nodeChildren node
|
||||
applyFoldsToChild nid = applyFolds $ narrowSet nid unfolded
|
||||
|
|
|
|||
|
|
@ -1,108 +1,150 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Forest.Node
|
||||
(
|
||||
-- * Node
|
||||
NodeId
|
||||
( NodeId
|
||||
, enumerateIds
|
||||
, NodeFlags(..)
|
||||
, readFlags
|
||||
, Node(..)
|
||||
, newNode
|
||||
, txtNode
|
||||
, getChild
|
||||
, hasChildren
|
||||
, mapChildren
|
||||
, applyId
|
||||
, applyPath
|
||||
, alterAt
|
||||
, editAt
|
||||
, adjustAt
|
||||
, replaceAt
|
||||
, diffNodes
|
||||
-- * Path
|
||||
, Path(..)
|
||||
, localPath
|
||||
, isLocalPath
|
||||
, isValidPath
|
||||
, narrowPath
|
||||
, narrow
|
||||
, narrowSet
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Aeson
|
||||
import Data.Char
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
|
||||
{- Node -}
|
||||
import qualified Forest.OrderedMap as OMap
|
||||
|
||||
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
|
||||
{ nodeText :: !T.Text
|
||||
, nodeEdit :: !Bool
|
||||
, nodeDelete :: !Bool
|
||||
, nodeReply :: !Bool
|
||||
, nodeAct :: !Bool
|
||||
, nodeChildren :: !(Map.Map NodeId Node)
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
nodeOptions :: Options
|
||||
nodeOptions = defaultOptions{fieldLabelModifier = map toLower . drop 4}
|
||||
, nodeFlags :: !NodeFlags
|
||||
, nodeChildren :: !(OMap.OrderedMap NodeId Node)
|
||||
} deriving (Show)
|
||||
|
||||
instance ToJSON Node where
|
||||
toJSON = genericToJSON nodeOptions
|
||||
toEncoding = genericToEncoding nodeOptions
|
||||
toJSON node = object
|
||||
[ "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
|
||||
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 flags text children =
|
||||
let edit = 'e' `elem` flags
|
||||
delete = 'd' `elem` flags
|
||||
reply = 'r' `elem` flags
|
||||
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
|
||||
newNode flags text children = Node
|
||||
{ nodeText = text
|
||||
, nodeFlags = readFlags flags
|
||||
, nodeChildren = OMap.fromList $ zip enumerateIds children
|
||||
}
|
||||
|
||||
txtNode :: String -> T.Text -> Node
|
||||
txtNode flags text = newNode flags text []
|
||||
|
||||
getChild :: NodeId -> Node -> Maybe Node
|
||||
getChild nodeId node = nodeChildren node Map.!? nodeId
|
||||
|
||||
hasChildren :: Node -> Bool
|
||||
hasChildren = not . Map.null . nodeChildren
|
||||
hasChildren = not . OMap.null . nodeChildren
|
||||
|
||||
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 = nodeChildren node Map.!? nodeId
|
||||
applyId nid node = nodeChildren node OMap.!? nid
|
||||
|
||||
applyPath :: Path -> Node -> Maybe Node
|
||||
applyPath (Path ids) node = foldM (flip applyId) node ids
|
||||
|
||||
alterChild :: (Maybe Node -> Maybe Node) -> NodeId -> Node -> Node
|
||||
alterChild f nodeId node = node{nodeChildren = Map.alter f nodeId (nodeChildren node)}
|
||||
|
||||
alterAt :: (Maybe Node -> Maybe Node) -> Path -> Node -> Maybe 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
|
||||
adjustAt :: (Node -> Node) -> Path -> Node -> Node
|
||||
adjustAt f (Path []) node = f node
|
||||
adjustAt f (Path (x:xs)) node =
|
||||
node {nodeChildren = OMap.adjust (adjustAt f $ Path xs) x $ nodeChildren node}
|
||||
|
||||
replaceAt :: Node -> Path -> Node -> Node
|
||||
replaceAt child = editAt (const child)
|
||||
replaceAt node = adjustAt $ const node
|
||||
|
||||
diffNodes :: Node -> Node -> Maybe (Path, Node)
|
||||
diffNodes a b
|
||||
|
|
@ -112,33 +154,23 @@ diffNodes a b
|
|||
[(x, Path xs, node)] -> Just (Path (x:xs), node)
|
||||
_ -> Just (Path [], b)
|
||||
where
|
||||
nodesDiffer = nodeText a /= nodeText b
|
||||
|| any (\f -> f a /= f b) [nodeEdit, nodeDelete, nodeReply, nodeAct]
|
||||
nodesDiffer = nodeText a /= nodeText b || nodeFlags a /= nodeFlags b
|
||||
aChildren = nodeChildren a
|
||||
bChildren = nodeChildren b
|
||||
childrenChanged = Map.keysSet aChildren /= Map.keysSet bChildren
|
||||
diffedChildren = Map.toList $ Map.intersectionWith diffNodes aChildren bChildren
|
||||
childrenChanged = OMap.keys aChildren /= OMap.keys bChildren
|
||||
diffedChildren = Map.toList $ Map.intersectionWith diffNodes (OMap.toMap aChildren) (OMap.toMap bChildren)
|
||||
differingChildren = [(key, path, node) | (key, Just (path, node)) <- diffedChildren]
|
||||
|
||||
{- Path -}
|
||||
|
||||
newtype Path = Path
|
||||
{ pathElements :: [NodeId]
|
||||
} deriving (Show, Eq, Ord, Semigroup, Monoid, ToJSON, FromJSON)
|
||||
|
||||
localPath :: Path
|
||||
localPath = Path []
|
||||
|
||||
isLocalPath :: Path -> Bool
|
||||
isLocalPath = (== localPath)
|
||||
|
||||
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
|
||||
-- | Try to remove a 'NodeId' from the beginning of a 'Path'.
|
||||
narrow :: NodeId -> Path -> Maybe Path
|
||||
narrow nid (Path (x:xs))
|
||||
| nid == x = Just (Path xs)
|
||||
narrow _ _ = Nothing
|
||||
|
||||
-- | Narrow a whole set of paths, discarding those that could not be narrowed.
|
||||
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
|
||||
|
|
|
|||
|
|
@ -15,11 +15,13 @@ import qualified Data.Map as Map
|
|||
import qualified Data.Text as T
|
||||
|
||||
import Forest.Node
|
||||
import qualified Forest.OrderedMap as OMap
|
||||
import Forest.TreeModule
|
||||
|
||||
data Prong = forall r a . TreeModule a r => Prong (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)
|
||||
|
||||
|
|
@ -44,36 +46,49 @@ instance TreeModule ForkModule () where
|
|||
Just (Prong a) -> Just () <$ act a (Path xs)
|
||||
Nothing -> pure Nothing
|
||||
|
||||
sendNodeFromProng
|
||||
:: T.Text
|
||||
-> MVar (Map.Map NodeId Node)
|
||||
-> (Node -> IO ())
|
||||
-> NodeId
|
||||
-> Node
|
||||
-> IO ()
|
||||
sendNodeFromProng text nodesVar sendNode nodeId node = do
|
||||
nodes <- takeMVar nodesVar
|
||||
let newNodes = Map.insert nodeId node nodes
|
||||
newTopNode = Node text False False False False newNodes
|
||||
sendNode newTopNode
|
||||
putMVar nodesVar newNodes
|
||||
data ProngInfo = ProngInfo
|
||||
{ piTopName :: T.Text
|
||||
, piNames :: Map.Map NodeId T.Text
|
||||
, piNodes :: Map.Map NodeId Node
|
||||
, piOrder :: [NodeId]
|
||||
}
|
||||
|
||||
renderProngInfo :: ProngInfo -> Node
|
||||
renderProngInfo pInfo =
|
||||
let childMap = Map.intersectionWith
|
||||
(\name node -> node{nodeText = name})
|
||||
(piNames pInfo)
|
||||
(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
|
||||
:: T.Text
|
||||
-> MVar (Map.Map NodeId Node)
|
||||
:: MVar ProngInfo
|
||||
-> (Node -> IO ())
|
||||
-> Map.Map NodeId ProngConstructor
|
||||
-> Cont (IO ()) (Map.Map NodeId Prong)
|
||||
constructProngs text nodesVar sendNode =
|
||||
constructProngs piVar sendNode =
|
||||
Map.traverseWithKey constructProng
|
||||
where
|
||||
constructProng nodeId (ProngConstructor constructor) =
|
||||
Prong <$> cont (constructor $ sendNodeFromProng text nodesVar sendNode nodeId)
|
||||
constructProng nodeId (ProngConstructor _ constructor) =
|
||||
Prong <$> cont (constructor $ sendNodeFromProng piVar sendNode nodeId)
|
||||
|
||||
forkModule :: T.Text -> [ProngConstructor] -> ModuleConstructor (ForkModule ())
|
||||
forkModule text prongs sendNode continue = do
|
||||
nodesVar <- newMVar Map.empty
|
||||
let digits = length $ show $ length prongs
|
||||
numbers = map (T.justifyRight digits '0' . T.pack . show) [(0::Integer)..]
|
||||
let namePairs = zip enumerateIds $ map (\(ProngConstructor name _) -> name) prongs
|
||||
nodesVar <- newMVar ProngInfo
|
||||
{ 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
|
||||
runCont (constructProngs text nodesVar sendNode prongMap) (continue . ForkModule)
|
||||
runCont (constructProngs nodesVar sendNode prongMap) (continue . ForkModule)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue