[server] Implement API changes

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
 

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 "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
     ]

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 "-"
+  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 <> ")"
   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

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}
+  | mempty `Set.member` unfolded = node {nodeChildren = foldedChildren}
-  | otherwise                       = node {nodeChildren = Map.empty}
+  | otherwise                    = node {nodeChildren = OMap.empty}
   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

src/Forest/Node.hs

@@ -1,108 +1,150 @@
-{-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE OverloadedStrings          #-}
 
 module Forest.Node
-  (
+  ( NodeId
-  -- * Node
+  , enumerateIds
-    NodeId
+  , NodeFlags(..)
+  , readFlags
   , Node(..)
   , newNode
   , txtNode
-  , getChild
   , hasChildren
   , mapChildren
   , applyId
   , applyPath
-  , alterAt
+  , adjustAt
-  , editAt
   , replaceAt
   , diffNodes
-  -- * Path
   , Path(..)
-  , localPath
+  , narrow
-  , isLocalPath
-  , isValidPath
-  , narrowPath
   , 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
+  , 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
-  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
-  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 =
+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 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
+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 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
+    nodesDiffer = nodeText a /= nodeText b || nodeFlags a /= nodeFlags b
-      || any (\f -> f a /= f b) [nodeEdit, nodeDelete, nodeReply, nodeAct]
     aChildren = nodeChildren a
     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]
 
-{- Path -}
-
 newtype Path = Path
   { pathElements :: [NodeId]
   } 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 x s = Set.fromList [Path ys | Path (y:ys) <- Set.toList s, x == y]
+narrowSet nid = Set.fromList . mapMaybe (narrow nid) . Set.toList

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)
 
@@ -44,36 +46,49 @@ instance TreeModule ForkModule () where
     Just (Prong a) -> Just () <$ act a (Path xs)
     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
-  :: T.Text
+  :: MVar ProngInfo
-  -> MVar (Map.Map NodeId Node)
   -> (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) =
+    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 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
-  runCont (constructProngs text nodesVar sendNode prongMap) (continue . ForkModule)
+  runCont (constructProngs nodesVar sendNode prongMap) (continue . ForkModule)