Add a few node- and path-related functions
This commit is contained in:
parent
4a0c3e13d5
commit
580b3b3209
2 changed files with 38 additions and 2 deletions
|
|
@ -50,7 +50,7 @@ instance FromJSON Node where
|
||||||
|
|
||||||
newtype Path = Path
|
newtype Path = Path
|
||||||
{ pathElements :: [NodeId]
|
{ pathElements :: [NodeId]
|
||||||
} deriving (Show, Eq, ToJSON, FromJSON)
|
} deriving (Show, Eq, Ord, ToJSON, FromJSON)
|
||||||
|
|
||||||
parsePacket :: Value -> T.Text -> (Object -> Parser a) -> Parser a
|
parsePacket :: Value -> T.Text -> (Object -> Parser a) -> Parser a
|
||||||
parsePacket value packetType parser = parseJSON value >>= \o -> do
|
parsePacket value packetType parser = parseJSON value >>= \o -> do
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,24 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Forest.Tree
|
module Forest.Tree
|
||||||
( emptyNode
|
(
|
||||||
|
-- * Node-related functions
|
||||||
|
emptyNode
|
||||||
, initialNode
|
, initialNode
|
||||||
|
, applyId
|
||||||
|
, applyPath
|
||||||
|
-- * Path-related functions
|
||||||
|
, localPath
|
||||||
|
, isLocalPath
|
||||||
|
, isValidPath
|
||||||
|
, narrowPath
|
||||||
|
, narrowSet
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
|
import Data.Maybe
|
||||||
|
import qualified Data.Set as Set
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
|
||||||
import Forest.Api
|
import Forest.Api
|
||||||
|
|
@ -15,3 +28,26 @@ emptyNode text edit delete reply act = Node text edit delete reply act Map.empty
|
||||||
|
|
||||||
initialNode :: Node
|
initialNode :: Node
|
||||||
initialNode = emptyNode "Loading..." False False False False
|
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]
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue