Add a few node- and path-related functions

This commit is contained in:
Joscha 2020-02-08 23:09:49 +00:00
parent 4a0c3e13d5
commit 580b3b3209
2 changed files with 38 additions and 2 deletions

View file

@ -50,7 +50,7 @@ instance FromJSON Node where
newtype Path = Path
{ pathElements :: [NodeId]
} deriving (Show, Eq, ToJSON, FromJSON)
} deriving (Show, Eq, Ord, ToJSON, FromJSON)
parsePacket :: Value -> T.Text -> (Object -> Parser a) -> Parser a
parsePacket value packetType parser = parseJSON value >>= \o -> do

View file

@ -1,11 +1,24 @@
{-# LANGUAGE OverloadedStrings #-}
module Forest.Tree
( emptyNode
(
-- * Node-related functions
emptyNode
, initialNode
, applyId
, applyPath
-- * Path-related functions
, localPath
, isLocalPath
, isValidPath
, narrowPath
, narrowSet
) where
import Control.Monad
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Text as T
import Forest.Api
@ -15,3 +28,26 @@ emptyNode text edit delete reply act = Node text edit delete reply act Map.empty
initialNode :: Node
initialNode = emptyNode "Loading..." False False False False
applyId :: NodeId -> Node -> Maybe Node
applyId nodeId node = nodeChildren node Map.!? nodeId
applyPath :: Path -> Node -> Maybe Node
applyPath (Path ids) node = foldM (flip applyId) node ids
localPath :: Path
localPath = Path []
isLocalPath :: Path -> Bool
isLocalPath = (== localPath)
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
narrowSet :: NodeId -> Set.Set Path -> Set.Set Path
narrowSet x s = Set.fromList [Path ys | Path (y:ys) <- Set.toList s, x == y]