[server] Extract shared editing logic into a branch

forest-server/src/Forest/Server/Branch/SharedEdit.hs

@@ -0,0 +1,80 @@
+module Forest.Server.Branch.SharedEdit
+  ( SharedEditGlobal
+  , sharedEditGlobal
+  , SharedEditLocal
+  , sharedEditLocal
+  , sharedEditDraw
+  , sharedEditUpdate
+  , sharedEditHandleEvent
+  , sharedEditBranch
+  ) where
+
+import           Control.Concurrent
+import           Control.Monad
+import qualified Data.Text             as T
+
+import           Forest.Node
+import           Forest.Server.Schema
+import           Forest.Server.TreeApp
+
+data SharedEditGlobal = SharedEditGlobal
+  { seOnUpdate :: IO ()
+  , seNodeVar  :: MVar Node
+  }
+
+sharedEditGlobal :: IO () -> T.Text -> IO SharedEditGlobal
+sharedEditGlobal onUpdate initialText = do
+  nodeVar <- newMVar $ txtNode "r" initialText
+  pure SharedEditGlobal
+    { seOnUpdate = onUpdate
+    , seNodeVar  = nodeVar
+    }
+
+data SharedEditLocal = SharedEditLocal
+  { seGlobal :: SharedEditGlobal
+  , seNode   :: Node
+  }
+
+sharedEditLocal :: SharedEditGlobal -> IO SharedEditLocal
+sharedEditLocal seg = do
+  node <- readMVar $ seNodeVar seg
+  pure SharedEditLocal
+    { seGlobal = seg
+    , seNode   = node
+    }
+
+sharedEditDraw :: SharedEditLocal -> Node
+sharedEditDraw = seNode
+
+sharedEditUpdate :: SharedEditLocal -> IO SharedEditLocal
+sharedEditUpdate sel = do
+  node <- readMVar $ seNodeVar $ seGlobal sel
+  pure sel{seNode = node}
+
+updateNode :: SharedEditLocal -> (Node -> Node) -> IO SharedEditLocal
+updateNode sel f = do
+  let seg = seGlobal sel
+      nodeVar = seNodeVar seg
+  node <- takeMVar nodeVar
+  let node' = f node
+  putMVar nodeVar node'
+  when (node /= node') $ seOnUpdate seg
+  pure sel{seNode = node'}
+
+sharedEditHandleEvent :: SharedEditLocal -> Path -> Event e -> IO SharedEditLocal
+-- Ignore edits to the top node since it's only reply-able, not edit-able
+sharedEditHandleEvent sel (Path []) (Edit _ _) = pure sel
+sharedEditHandleEvent sel (Path []) (Delete _) = pure sel
+sharedEditHandleEvent sel path (Edit _ text) =
+  updateNode sel $ adjustAt (\n -> n {nodeText = text}) path
+sharedEditHandleEvent sel path (Delete _) =
+  updateNode sel $ deleteAt path
+sharedEditHandleEvent sel path (Reply _ text) =
+  updateNode sel $ appendAt (txtNode "edr" text) path
+sharedEditHandleEvent sel _ _ = pure sel
+
+sharedEditBranch :: SharedEditLocal -> Branch SharedEditLocal e
+sharedEditBranch sel = Branch
+  { branchNode        = sharedEditDraw sel
+  , branchHandleEvent = sharedEditHandleEvent sel
+  }

forest-server/src/Forest/Server/Schema.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE RankNTypes #-}
+
 module Forest.Server.Schema
   ( Schema
   , fork
@@ -6,12 +8,19 @@ module Forest.Server.Schema
   , collect
   , collectWith
   , dispatch
+  -- * Useful type
+  , Branch(..)
+  , schemaDraw
+  , schemaHandleEvent
+  , schemaLift
   ) where
 
-import qualified Data.Text         as T
+import qualified Data.Text             as T
+import           Lens.Micro
 
 import           Forest.Node
-import qualified Forest.OrderedMap as OMap
+import qualified Forest.OrderedMap     as OMap
+import           Forest.Server.TreeApp
 
 data Schema a
   = Fork T.Text (OMap.OrderedMap NodeId (Schema a))
@@ -44,3 +53,33 @@ dispatch :: Path -> Schema a -> Maybe (Path, a)
 dispatch path          (Leaf a)      = Just (path, a)
 dispatch (Path (x:xs)) (Fork _ omap) = dispatch (Path xs) =<< (omap OMap.!? x)
 dispatch (Path [])     (Fork _ _   ) = Nothing -- More specfic than required
+
+data Branch s e = Branch
+  { branchNode        :: Node
+  , branchHandleEvent :: Path -> Event e -> IO s
+  }
+
+schemaDraw :: Schema (Branch s e) -> Node
+schemaDraw = collectWith branchNode
+
+schemaHandleEvent :: Schema (Branch s e) -> Event e -> Maybe (IO s)
+schemaHandleEvent schema event = do
+  path <- getPath event
+  (relPath, branch) <- dispatch path schema
+  pure $ branchHandleEvent branch relPath event
+  where
+    getPath (Edit path _)  = Just path
+    getPath (Delete path)  = Just path
+    getPath (Reply path _) = Just path
+    getPath (Act path)     = Just path
+    getPath _              = Nothing
+
+schemaLift :: Lens' s t -> (t -> Branch t e) -> s -> Branch s e
+schemaLift l f s = Branch
+  { branchNode = branchNode branch
+  , branchHandleEvent = \path event -> do
+      t' <- branchHandleEvent branch path event
+      pure $ s & l .~ t'
+  }
+  where
+    branch = f $ s ^. l