diff --git a/forest-common/src/Forest/OrderedMap.hs b/forest-common/src/Forest/OrderedMap.hs index a29f3af..9d5c1d3 100644 --- a/forest-common/src/Forest/OrderedMap.hs +++ b/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. diff --git a/forest-server/forest-server.cabal b/forest-server/forest-server.cabal index 4170bbb..03be485 100644 --- a/forest-server/forest-server.cabal +++ b/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 diff --git a/forest-server/src/Forest/Server/Schema.hs b/forest-server/src/Forest/Server/Schema.hs new file mode 100644 index 0000000..3b7d1cf --- /dev/null +++ b/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