From d2c6efd6c4e35f1a4312c8216795ce18b9dff5a7 Mon Sep 17 00:00:00 2001 From: Joscha Date: Mon, 17 Feb 2020 23:34:02 +0000 Subject: [PATCH] [server] Implement API changes --- client/Main.hs | 10 +- server/Main.hs | 34 +++--- src/Forest/Client/Node.hs | 21 ++-- src/Forest/Client/Tree.hs | 10 +- src/Forest/Node.hs | 190 ++++++++++++++++++++-------------- src/Forest/TreeModule/Fork.hs | 69 +++++++----- 6 files changed, 191 insertions(+), 143 deletions(-) diff --git a/client/Main.hs b/client/Main.hs index d6d1e19..d54b2ae 100644 --- a/client/Main.hs +++ b/client/Main.hs @@ -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 diff --git a/server/Main.hs b/server/Main.hs index a5e6141..836d28a 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -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 ] diff --git a/src/Forest/Client/Node.hs b/src/Forest/Client/Node.hs index f4e6e1e..5cbb0f9 100644 --- a/src/Forest/Client/Node.hs +++ b/src/Forest/Client/Node.hs @@ -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 diff --git a/src/Forest/Client/Tree.hs b/src/Forest/Client/Tree.hs index 8fc7329..8891bd0 100644 --- a/src/Forest/Client/Tree.hs +++ b/src/Forest/Client/Tree.hs @@ -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 diff --git a/src/Forest/Node.hs b/src/Forest/Node.hs index fc54f54..4a40c79 100644 --- a/src/Forest/Node.hs +++ b/src/Forest/Node.hs @@ -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 qualified Data.Map.Strict as Map import Data.Maybe -import qualified Data.Set as Set -import qualified Data.Text as T -import GHC.Generics +import qualified Data.Set as Set +import qualified Data.Text as T -{- 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 diff --git a/src/Forest/TreeModule/Fork.hs b/src/Forest/TreeModule/Fork.hs index 3384eb4..1c4f612 100644 --- a/src/Forest/TreeModule/Fork.hs +++ b/src/Forest/TreeModule/Fork.hs @@ -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) @@ -27,53 +29,66 @@ instance TreeModule ForkModule () where edit _ (Path []) _ = pure Nothing edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of Just (Prong a) -> Just () <$ edit a (Path xs) text - Nothing -> pure Nothing + Nothing -> pure Nothing delete _ (Path []) = pure Nothing delete (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of Just (Prong a) -> Just () <$ delete a (Path xs) - Nothing -> pure Nothing + Nothing -> pure Nothing reply _ (Path []) _ = pure Nothing reply (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of Just (Prong a) -> Just () <$ reply a (Path xs) text - Nothing -> pure Nothing + Nothing -> pure Nothing act _ (Path []) = pure Nothing act (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of Just (Prong a) -> Just () <$ act a (Path xs) - Nothing -> pure Nothing + 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)