[server] Add schema for tree-like node structures

forest-common/src/Forest/OrderedMap.hs

@@ -70,6 +70,12 @@ data OrderedMap k a = OrderedMap
 instance (Ord k, Show k, Show a) => Show (OrderedMap k a) where
   show m = "fromList " ++ show (toList m)
 
+instance Functor (OrderedMap k) where
+  fmap = Forest.OrderedMap.map
+
+instance (Ord k) => Foldable (OrderedMap k) where
+  foldMap f = foldMap f . elems
+
 -- Invariants of this data type:
 --
 -- 1. The 'omOrder' list contains each key from 'omMap' exactly once.

forest-server/forest-server.cabal

@@ -28,6 +28,7 @@ library
   exposed-modules:
       Forest.Server
       Forest.Server.Broadcast
+      Forest.Server.Schema
       Forest.Server.TreeApp
       Forest.Server.TreeModule
       Forest.Server.TreeModule.Animate

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

@@ -0,0 +1,46 @@
+module Forest.Server.Schema
+  ( Schema
+  , fork
+  , fork'
+  , leaf
+  , collect
+  , collectWith
+  , dispatch
+  ) where
+
+import qualified Data.Text         as T
+
+import           Forest.Node
+import qualified Forest.OrderedMap as OMap
+
+data Schema a
+  = Fork T.Text (OMap.OrderedMap NodeId (Schema a))
+  | Leaf a
+
+instance Functor Schema where
+  fmap f (Leaf a)             = Leaf $ f a
+  fmap f (Fork text children) = Fork text $ fmap (fmap f) children
+
+fork :: T.Text -> [(NodeId, Schema a)] -> Schema a
+fork text = Fork text . OMap.fromList
+
+fork' :: T.Text -> [Schema a] -> Schema a
+fork' text = fork text . zip keys
+  where
+    keys :: [NodeId]
+    keys = map (T.pack . show) [0::Int ..]
+
+leaf :: a -> Schema a
+leaf = Leaf
+
+collect :: Schema Node -> Node
+collect (Leaf node)          = node
+collect (Fork text children) = Node text mempty $ OMap.map collect children
+
+collectWith :: (a -> Node) -> Schema a -> Node
+collectWith f = collect . fmap f
+
+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