[all] Reorganize haskell code into multiple packages

forest-common/README.md

@@ -0,0 +1 @@
+# forest-common

forest-common/forest-common.cabal

@@ -0,0 +1,44 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.2.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: e59723e563cf364a74b1032409ed7a9d3ecbec3a6baa34554771cb5c1a5689d9
+
+name:           forest-common
+version:        0.1.0.0
+synopsis:       A tree-based multi-user interaction thing
+description:    Please see the README at <https://github.com/Garmelon/forest#readme>
+homepage:       https://github.com/Garmelon/forest#readme
+bug-reports:    https://github.com/Garmelon/forest/issues
+author:         Garmelon <joscha@plugh.de>
+maintainer:     Garmelon <joscha@plugh.de>
+copyright:      2020 Garmelon
+license:        MIT
+build-type:     Simple
+extra-source-files:
+    README.md
+
+source-repository head
+  type: git
+  location: https://github.com/Garmelon/forest
+
+library
+  exposed-modules:
+      Forest.Api
+      Forest.Node
+      Forest.OrderedMap
+      Forest.Util
+  other-modules:
+      Paths_forest_common
+  hs-source-dirs:
+      src
+  build-depends:
+      aeson
+    , async
+    , base >=4.7 && <5
+    , containers
+    , text
+    , websockets
+  default-language: Haskell2010

forest-common/package.yaml

@@ -0,0 +1,23 @@
+name: forest-common
+version: 0.1.0.0
+license: MIT
+author: Garmelon <joscha@plugh.de>
+copyright: 2020 Garmelon
+
+synopsis: A tree-based multi-user interaction thing
+description: Please see the README at <https://github.com/Garmelon/forest#readme>
+github: Garmelon/forest
+
+extra-source-files:
+  - README.md
+
+dependencies:
+  - base >= 4.7 && < 5
+  - aeson
+  - async
+  - containers
+  - text
+  - websockets
+
+library:
+  source-dirs: src

forest-common/src/Forest/Api.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module contains all the types found in the API.
+
+module Forest.Api
+  ( ClientPacket(..)
+  , ServerPacket(..)
+  ) where
+
+import           Control.Applicative
+import           Control.Monad
+import           Data.Aeson
+import           Data.Aeson.Types
+import qualified Data.Text           as T
+
+import           Forest.Node
+
+parsePacket :: Value -> T.Text -> (Object -> Parser a) -> Parser a
+parsePacket value packetType parser = parseJSON value >>= \o -> do
+  parsedPacketType <- o .: "type"
+  guard $ parsedPacketType == packetType
+  parser o
+
+{- Client -}
+
+data ClientPacket
+  = ClientHello ![T.Text]
+  | ClientAct !Path
+  | ClientEdit !Path !T.Text
+  | ClientDelete !Path
+  | ClientReply !Path !T.Text
+  deriving (Show)
+
+instance ToJSON ClientPacket where
+  toJSON (ClientHello extensions) =
+    object ["type" .= ("hello" :: T.Text), "extensions" .= extensions]
+  toJSON (ClientAct path) = object ["type" .= ("act" :: T.Text), "path" .= path]
+  toJSON (ClientEdit path text) =
+    object ["type" .= ("edit" :: T.Text), "path" .= path, "text" .= text]
+  toJSON (ClientDelete path) =
+    object ["type" .= ("delete" :: T.Text), "path" .= path]
+  toJSON (ClientReply path text) =
+    object ["type" .= ("reply" :: T.Text), "path" .= path, "text" .= text]
+
+  toEncoding (ClientHello extensions) =
+    pairs ("type" .= ("hello" :: T.Text) <> "extensions" .= extensions)
+  toEncoding (ClientAct path) =
+    pairs ("type" .= ("act" :: T.Text) <> "path" .= path)
+  toEncoding (ClientEdit path text) =
+    pairs ("type" .= ("edit" :: T.Text) <> "path" .= path <> "text" .= text)
+  toEncoding (ClientDelete path) =
+    pairs ("type" .= ("delete" :: T.Text) <> "path" .= path)
+  toEncoding (ClientReply path text) =
+    pairs ("type" .= ("reply" :: T.Text) <> "path" .= path <> "text" .= text)
+
+instance FromJSON ClientPacket where
+  parseJSON v =
+    parsePacket v "hello"  (\o -> ClientHello  <$> o .: "extensions")           <|>
+    parsePacket v "act"    (\o -> ClientAct    <$> o .: "path")                 <|>
+    parsePacket v "edit"   (\o -> ClientEdit   <$> o .: "path" <*> o .: "text") <|>
+    parsePacket v "delete" (\o -> ClientDelete <$> o .: "path")                 <|>
+    parsePacket v "reply"  (\o -> ClientReply  <$> o .: "path" <*> o .: "text")
+
+{- Server -}
+
+data ServerPacket
+  = ServerHello ![T.Text] !Node
+  | ServerUpdate !Path !Node
+  deriving (Show)
+
+instance ToJSON ServerPacket where
+  toJSON (ServerHello extensions node) =
+    object ["type" .= ("hello" :: T.Text), "extensions" .= extensions, "node" .= node]
+  toJSON (ServerUpdate path node) =
+    object ["type" .= ("update" :: T.Text), "path" .= path, "node" .= node]
+
+  toEncoding (ServerHello extensions node) =
+    pairs ("type" .= ("hello" :: T.Text) <> "extensions" .= extensions <> "node" .= node)
+  toEncoding (ServerUpdate path node) =
+    pairs ("type" .= ("update" :: T.Text) <> "path" .= path <> "node" .= node)
+
+instance FromJSON ServerPacket where
+  parseJSON v =
+    parsePacket v "hello" (\o -> ServerHello <$> o .: "extensions" <*> o .: "node") <|>
+    parsePacket v "update" (\o -> ServerUpdate <$> o .: "path" <*> o .: "node")

forest-common/src/Forest/Node.hs

@@ -0,0 +1,220 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+
+module Forest.Node
+  ( NodeId
+  , enumerateIds
+  , findUnusedId
+  , NodeFlags(..)
+  , readFlags
+  , Node(..)
+  , newNode
+  , txtNode
+  , hasChildren
+  , mapChildren
+  , applyId
+  , applyPath
+  , adjustAt
+  , replaceAt
+  , deleteAt
+  , appendAt
+  , diffNodes
+  , Path(..)
+  , referencedNodeExists
+  , splitHeadTail
+  , splitInitLast
+  , parent
+  , narrow
+  , narrowSet
+  ) where
+
+import           Control.Monad
+import           Data.Aeson
+import qualified Data.Map.Strict   as Map
+import           Data.Maybe
+import qualified Data.Set          as Set
+import qualified Data.Text         as T
+
+import qualified Forest.OrderedMap as OMap
+
+type NodeId = T.Text
+
+enumerateIds :: [NodeId]
+enumerateIds = map (T.pack . show) [(0::Integer)..]
+
+findUnusedId :: Set.Set NodeId -> NodeId
+findUnusedId usedIds =
+  head $ filter (\nid -> not $ nid `Set.member` usedIds) enumerateIds
+
+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
+  , nodeFlags    :: !NodeFlags
+  , nodeChildren :: !(OMap.OrderedMap NodeId Node)
+  } deriving (Show)
+
+instance ToJSON Node where
+  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 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 = Node
+  { nodeText = text
+  , nodeFlags = readFlags flags
+  , nodeChildren = OMap.fromList $ zip enumerateIds children
+  }
+
+txtNode :: String -> T.Text -> Node
+txtNode flags text = newNode flags text []
+
+hasChildren :: Node -> Bool
+hasChildren = not . OMap.null . nodeChildren
+
+mapChildren :: (NodeId -> Node -> a) -> Node -> [a]
+mapChildren f = map (uncurry f) . OMap.toList . nodeChildren
+
+applyId :: NodeId -> Node -> Maybe Node
+applyId nid node = nodeChildren node OMap.!? nid
+
+applyPath :: Path -> Node -> Maybe Node
+applyPath (Path ids) node = foldM (flip applyId) node ids
+
+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 node = adjustAt $ const node
+
+-- | Delete a subnode at a specified path. Does nothing if the path is 'mempty'.
+deleteAt :: Path -> Node -> Node
+deleteAt path node = case splitInitLast path of
+  Nothing -> node
+  Just (parentPath, nodeId) -> adjustAt
+    (\n -> n{nodeChildren = OMap.delete nodeId $ nodeChildren n})
+    parentPath
+    node
+
+-- | Append a new child node to the node at the specified path. Chooses an
+-- unused node id.
+appendAt :: Node -> Path -> Node -> Node
+appendAt node =
+  adjustAt (\n -> n {nodeChildren = appendAtNewId $ nodeChildren n})
+  where
+    appendAtNewId m =
+      let nid = findUnusedId $ OMap.keysSet m
+      in  OMap.append nid node m
+
+diffNodes :: Node -> Node -> Maybe (Path, Node)
+diffNodes a b
+  | nodesDiffer || childrenChanged = Just (Path [], b)
+  | otherwise = case differingChildren of
+      []                   -> Nothing
+      [(x, Path xs, node)] -> Just (Path (x:xs), node)
+      _                    -> Just (Path [], b)
+  where
+    nodesDiffer = nodeText a /= nodeText b || nodeFlags a /= nodeFlags b
+    aChildren = nodeChildren a
+    bChildren = nodeChildren b
+    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]
+
+newtype Path = Path
+  { pathElements :: [NodeId]
+  } deriving (Show, Eq, Ord, Semigroup, Monoid, ToJSON, FromJSON)
+
+referencedNodeExists :: Node -> Path -> Bool
+referencedNodeExists node path = isJust $ applyPath path node
+
+splitHeadTail :: Path -> Maybe (NodeId, Path)
+splitHeadTail (Path [])     = Nothing
+splitHeadTail (Path (x:xs)) = Just (x, Path xs)
+
+splitInitLast :: Path -> Maybe (Path, NodeId)
+splitInitLast (Path []) = Nothing
+splitInitLast (Path xs) = Just (Path (init xs), last xs)
+
+parent :: Path -> Maybe Path
+parent path = fst <$> splitInitLast path
+
+-- | 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 nid = Set.fromList . mapMaybe (narrow nid) . Set.toList

forest-common/src/Forest/OrderedMap.hs

@@ -0,0 +1,275 @@
+module Forest.OrderedMap
+  ( OrderedMap
+  -- * Construction
+  , empty
+  , singleton
+  , fromSet
+  -- ** From lists
+  , fromList
+  , fromListWith
+  , fromListWithKey
+  -- ** From maps
+  , fromMap
+  , fromMapWithOrder
+  -- * Insertion
+  , append
+  , appendWith
+  , appendWithKey
+  , appendLookupWithKey
+  , prepend
+  , prependWith
+  , prependWithKey
+  , prependLookupWithKey
+  -- * Deletion/Update
+  , delete
+  , adjust
+  , adjustWithKey
+  , update
+  , updateWithKey
+  -- * Query
+  -- ** Lookup
+  , Forest.OrderedMap.lookup
+  , (!?)
+  , (!)
+  , findWithDefault
+  , member
+  , notMember
+  , lookupLT
+  , lookupGT
+  , lookupLE
+  , lookupGE
+  -- ** Size
+  , Forest.OrderedMap.null
+  , size
+  -- * Traversal
+  -- ** Map
+  , Forest.OrderedMap.map
+  , mapWithKey
+  -- * Conversion
+  , elems
+  , keys
+  , assocs
+  , keysSet
+  -- ** Lists
+  , toList
+  -- ** Maps
+  , toMap
+  -- * Filter
+  , Forest.OrderedMap.filter
+  ) where
+
+import qualified Data.List       as L
+import qualified Data.Map.Strict as Map
+import qualified Data.Set        as Set
+
+data OrderedMap k a = OrderedMap
+  { omMap   :: Map.Map k a
+  , omOrder :: [k]
+  }
+
+instance (Ord k, Show k, Show a) => Show (OrderedMap k a) where
+  show m = "fromList " ++ show (toList m)
+
+-- Invariants of this data type:
+--
+-- 1. The 'omOrder' list contains each key from 'omMap' exactly once.
+-- 2. The 'omOrder' list contains no other values.
+--
+-- All functions operating on an 'OrderedMap' may assume these invariants. All
+-- modifications must preserve these invariants.
+
+-- | Like 'Map.empty'.
+empty :: OrderedMap k a
+empty = OrderedMap
+  { omMap   = Map.empty
+  , omOrder = []
+  }
+
+-- | Like 'Map.singleton'.
+singleton :: k -> a -> OrderedMap k a
+singleton k a = OrderedMap
+  { omMap   = Map.singleton k a
+  , omOrder = [k]
+  }
+
+-- | Like 'Map.fromSet'. Uses 'Set.toAscList' as the order.
+fromSet :: (k -> a) -> Set.Set k -> OrderedMap k a
+fromSet f kSet = OrderedMap
+  { omMap   = Map.fromSet f kSet
+  , omOrder = Set.toAscList kSet
+  }
+
+fromMap :: Map.Map k a -> OrderedMap k a
+fromMap m = OrderedMap
+  { omMap   = m
+  , omOrder = Map.keys m
+  }
+
+-- | Create a new 'OrderedMap' from a 'Map.Map' using a list of keys to specify
+-- the order. If the list of keys contains a key multiple times, only the last
+-- occurrence is counted. The keys missing from the list of keys are appended at
+-- the end in ascending order.
+fromMapWithOrder :: Ord k => Map.Map k a -> [k] -> OrderedMap k a
+fromMapWithOrder m l =
+  let kSet = Map.keysSet m
+      onlyExistingKeys = L.filter (`Set.member` kSet) l
+      deduplicatedKeys = fst $ keepLastInstances onlyExistingKeys
+      missingKeysSet = kSet Set.\\ Set.fromList deduplicatedKeys
+      order = if Set.null missingKeysSet
+        then deduplicatedKeys -- For the extra performance :P
+        else deduplicatedKeys ++ Set.toAscList missingKeysSet
+  in  OrderedMap {omMap = m, omOrder = order}
+
+keepLastInstances :: Ord a => [a] -> ([a], Set.Set a)
+keepLastInstances [] = ([], Set.empty)
+keepLastInstances (x:xs)
+  | x `Set.member` subset = (sublist, subset)
+  | otherwise = (x : sublist, Set.insert x subset)
+  where
+    (sublist, subset) = keepLastInstances xs
+
+-- | Like 'Map.fromList'. Uses the last occurrence of each key as the order.
+fromList :: Ord k => [(k, a)] -> OrderedMap k a
+-- This function could've been implemented as @fromListWith const@, but that
+-- might lead to a performance penalty. I don't know though ¯\_(ツ)_/¯
+fromList pairs = OrderedMap
+  { omMap   = Map.fromList pairs
+  , omOrder = fst $ keepLastInstances $ L.map fst pairs
+  }
+
+-- | Like 'Map.fromListWith'. Uses the last occurrence of each key as the order.
+fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> OrderedMap k a
+fromListWith f = fromListWithKey $ const f
+
+-- | Like 'Map.fromListWithKey'. Uses the last occurrence of each key as the
+-- order.
+fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k, a)] -> OrderedMap k a
+fromListWithKey f pairs = OrderedMap
+  { omMap   = Map.fromListWithKey f pairs
+  , omOrder = fst $ keepLastInstances $ L.map fst pairs
+  }
+
+append :: Ord k => k -> a -> OrderedMap k a -> OrderedMap k a
+append = appendWith const
+
+appendWith :: Ord k => (a -> a -> a) -> k -> a -> OrderedMap k a -> OrderedMap k a
+appendWith f = appendWithKey $ const f
+
+appendWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> OrderedMap k a -> OrderedMap k a
+appendWithKey f k a = snd . appendLookupWithKey f k a
+
+appendLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> OrderedMap k a -> (Maybe a, OrderedMap k a)
+appendLookupWithKey f k a m =
+  let (maybePrevA, newMap) = Map.insertLookupWithKey f k a $ omMap m
+      newOrder = case maybePrevA of
+        Nothing -> omOrder m ++ [k]
+        Just _  -> omOrder m
+  in  (maybePrevA, OrderedMap {omMap = newMap , omOrder = newOrder})
+
+prepend :: Ord k => k -> a -> OrderedMap k a -> OrderedMap k a
+prepend = prependWith const
+
+prependWith :: Ord k => (a -> a -> a) -> k -> a -> OrderedMap k a -> OrderedMap k a
+prependWith f = prependWithKey $ const f
+
+prependWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> OrderedMap k a -> OrderedMap k a
+prependWithKey f k a = snd . prependLookupWithKey f k a
+
+prependLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> OrderedMap k a -> (Maybe a, OrderedMap k a)
+prependLookupWithKey f k a m =
+  let (maybePrevA, newMap) = Map.insertLookupWithKey f k a $ omMap m
+      newOrder = case maybePrevA of
+        Nothing -> k : omOrder m
+        Just _  -> omOrder m
+  in  (maybePrevA, OrderedMap {omMap = newMap , omOrder = newOrder})
+
+delete :: Ord k => k -> OrderedMap k a -> OrderedMap k a
+delete k m = m
+  { omMap   = Map.delete k $ omMap m
+  , omOrder = L.delete k $ omOrder m
+  }
+
+adjust :: Ord k => (a -> a) -> k -> OrderedMap k a -> OrderedMap k a
+adjust f = adjustWithKey $ const f
+
+adjustWithKey :: Ord k => (k -> a -> a) -> k -> OrderedMap k a -> OrderedMap k a
+adjustWithKey f k m = m {omMap = Map.adjustWithKey f k $ omMap m}
+
+update :: Ord k => (a -> Maybe a) -> k -> OrderedMap k a -> OrderedMap k a
+update f = updateWithKey $ const f
+
+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> OrderedMap k a -> OrderedMap k a
+updateWithKey f k m =
+  let newMap = Map.updateWithKey f k $ omMap m
+      newOrder = case newMap Map.!? k of
+        Nothing -> L.delete k $ omOrder m
+        Just _  -> omOrder m
+  in  OrderedMap {omMap = newMap, omOrder = newOrder}
+
+lookup :: Ord k => k -> OrderedMap k a -> Maybe a
+lookup k = Map.lookup k . omMap
+
+infixl 9 !?
+(!?) :: Ord k => OrderedMap k a -> k -> Maybe a
+m !? k = omMap m Map.!? k
+
+infixl 9 !
+(!) :: Ord k => OrderedMap k a -> k -> a
+m ! k = omMap m Map.! k
+
+findWithDefault :: Ord k => a -> k -> OrderedMap k a -> a
+findWithDefault a k = Map.findWithDefault a k . omMap
+
+member :: Ord k => k -> OrderedMap k a -> Bool
+member k = Map.member k . omMap
+
+notMember :: Ord k => k -> OrderedMap k a -> Bool
+notMember k = Map.notMember k . omMap
+
+lookupLT :: Ord k => k -> OrderedMap k v -> Maybe (k, v)
+lookupLT k = Map.lookupLT k . omMap
+
+lookupGT :: Ord k => k -> OrderedMap k v -> Maybe (k, v)
+lookupGT k = Map.lookupGT k . omMap
+
+lookupLE :: Ord k => k -> OrderedMap k v -> Maybe (k, v)
+lookupLE k = Map.lookupLE k . omMap
+
+lookupGE :: Ord k => k -> OrderedMap k v -> Maybe (k, v)
+lookupGE k = Map.lookupGE k . omMap
+
+null :: OrderedMap k a -> Bool
+null = Map.null . omMap
+
+size :: OrderedMap k a -> Int
+size = Map.size . omMap
+
+map :: (a -> b) -> OrderedMap k a -> OrderedMap k b
+map f = mapWithKey $ const f
+
+mapWithKey :: (k -> a -> b) -> OrderedMap k a -> OrderedMap k b
+mapWithKey f m = m {omMap = Map.mapWithKey f $ omMap m}
+
+elems :: Ord k => OrderedMap k a -> [a]
+elems = L.map snd . assocs
+
+keys :: OrderedMap k a -> [k]
+keys = omOrder
+
+assocs :: Ord k => OrderedMap k a -> [(k, a)]
+assocs = toList
+
+keysSet :: OrderedMap k a -> Set.Set k
+keysSet = Map.keysSet . omMap
+
+toList :: Ord k => OrderedMap k a -> [(k, a)]
+toList m = L.map (\k -> (k, omMap m Map.! k)) $ omOrder m
+
+toMap :: OrderedMap k a -> Map.Map k a
+toMap = omMap
+
+filter :: Ord k => (a -> Bool) -> OrderedMap k a -> OrderedMap k a
+filter f m =
+  let newMap = Map.filter f $ omMap m
+      newOrder = L.filter (`Set.member` Map.keysSet newMap) $ omOrder m
+  in  OrderedMap {omMap = newMap, omOrder = newOrder}

forest-common/src/Forest/Util.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Forest.Util
+  (
+  -- * List operations
+    findPrev
+  , findNext
+  -- * Monadic looping constructs
+  , whileM
+  , whileNothingM
+  -- * Multithreading helpers
+  , withThread
+  -- * Websocket helper functions
+  , sendPacket
+  , closeWithErrorMessage
+  , receivePacket
+  ) where
+
+import           Control.Concurrent.Async
+import           Control.Monad
+import           Data.Aeson
+import           Data.List
+import qualified Data.Text                as T
+import qualified Network.WebSockets       as WS
+
+findPrev :: (a -> Bool) -> [a] -> Maybe a
+findPrev f as = fst <$> find (f . snd) (zip as $ tail as)
+
+findNext :: (a -> Bool) -> [a] -> Maybe a
+findNext f as = snd <$> find (f . fst) (zip as $ tail as)
+
+-- | Run a monadic action until it returns @False@ for the first time.
+whileM :: Monad m => m Bool -> m ()
+whileM f = do
+  continue <- f
+  if continue
+    then whileM f
+    else pure ()
+
+-- | Run a monadic action until it returns @Just a@ for the first time.
+whileNothingM :: Monad m => m (Maybe a) -> m a
+whileNothingM f = do
+  result <- f
+  case result of
+    Nothing -> whileNothingM f
+    Just a  -> pure a
+
+withThread :: IO () -> IO () -> IO ()
+withThread thread main = withAsync thread $ const main
+
+sendPacket :: ToJSON a => WS.Connection -> a -> IO ()
+sendPacket conn packet = WS.sendTextData conn $ encode packet
+
+waitForCloseException :: WS.Connection -> IO a
+waitForCloseException conn = forever $ void $ WS.receiveDataMessage conn
+
+closeWithErrorMessage :: WS.Connection -> T.Text -> IO a
+closeWithErrorMessage conn text =
+  WS.sendCloseCode conn 1003 text >> waitForCloseException conn
+
+receivePacket :: FromJSON a => WS.Connection -> IO a
+receivePacket conn = do
+  dataMessage <- WS.receiveDataMessage conn
+  closeOnErrorMessage $ case dataMessage of
+    WS.Binary _  -> Left "Invalid message format: Binary"
+    WS.Text bs _ -> case eitherDecode' bs of
+      Left errorMsg -> Left $ "Invalid packet: " <> T.pack errorMsg
+      Right packet  -> Right packet
+  where
+    closeOnErrorMessage :: Either T.Text a -> IO a
+    closeOnErrorMessage (Right a)       = pure a
+    closeOnErrorMessage (Left errorMsg) = closeWithErrorMessage conn errorMsg