From 68b1129a49b9857c688840822b2cc1b21d232dd9 Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 19 Mar 2020 19:07:53 +0000 Subject: [PATCH] [common] Clean up node module and add some useful functions --- forest-common/forest-common.cabal | 1 + forest-common/package.yaml | 1 + forest-common/src/Forest/Node.hs | 130 ++++++++++++++++++----- forest-tui/src/Forest/Client/NodeUtil.hs | 9 -- forest-tui/src/Forest/Client/UiState.hs | 15 +-- 5 files changed, 116 insertions(+), 40 deletions(-) diff --git a/forest-common/forest-common.cabal b/forest-common/forest-common.cabal index b888552..80b2f04 100644 --- a/forest-common/forest-common.cabal +++ b/forest-common/forest-common.cabal @@ -39,6 +39,7 @@ library , async , base >=4.7 && <5 , containers + , safe , text , websockets default-language: Haskell2010 diff --git a/forest-common/package.yaml b/forest-common/package.yaml index cc74cc9..b49c2d7 100644 --- a/forest-common/package.yaml +++ b/forest-common/package.yaml @@ -16,6 +16,7 @@ dependencies: - aeson - async - containers + - safe - text - websockets diff --git a/forest-common/src/Forest/Node.hs b/forest-common/src/Forest/Node.hs index b78a70a..d30ebb1 100644 --- a/forest-common/src/Forest/Node.hs +++ b/forest-common/src/Forest/Node.hs @@ -2,7 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} module Forest.Node - ( NodeId + ( + -- * Nodes + NodeId , enumerateIds , findUnusedId , NodeFlags(..) @@ -11,14 +13,27 @@ module Forest.Node , newNode , txtNode , hasChildren - , mapChildren + , diffNodes + , flatten + -- ** Traversing the tree , applyId , applyPath + , firstChild + , lastChild + , firstSibling + , prevSibling + , nextSibling + , lastSibling + , firstNode + , prevNode + , nextNode + , lastNode + -- ** Modifying at a path , adjustAt , replaceAt , deleteAt , appendAt - , diffNodes + -- * Paths , Path(..) , referencedNodeExists , splitHeadTail @@ -34,14 +49,21 @@ import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T +import Safe import qualified Forest.OrderedMap as OMap +import Forest.Util + +{- Nodes -} type NodeId = T.Text +-- | An infinite list of 'NodeId's. Does *not* contain every possible 'NodeId'. enumerateIds :: [NodeId] enumerateIds = map (T.pack . show) [(0::Integer)..] +-- | Find a 'NodeId' that is not contained in the given set of IDs. Returns the +-- first matching ID from 'enumerateIds'. findUnusedId :: Set.Set NodeId -> NodeId findUnusedId usedIds = head $ filter (\nid -> not $ nid `Set.member` usedIds) enumerateIds @@ -140,14 +162,87 @@ 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 +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] -applyId :: NodeId -> Node -> Maybe Node -applyId nid node = nodeChildren node OMap.!? nid +-- | Return the 'Path's to a node and its subnodes in the order they would be +-- displayed in. +flatten :: Node -> [Path] +flatten node = Path [] : flattenedChildren + where + flattenChild nid n = map (Path [nid] <>) (flatten n) + flattenedChildren = + concat $ OMap.elems $ OMap.mapWithKey flattenChild $ nodeChildren node -applyPath :: Path -> Node -> Maybe Node -applyPath (Path ids) node = foldM (flip applyId) node ids +{- Traversing the tree -} + +applyId :: Node -> NodeId -> Maybe Node +applyId node nid = nodeChildren node OMap.!? nid + +applyPath :: Node -> Path -> Maybe Node +applyPath node (Path ids) = foldM applyId node ids + +getChild :: ([NodeId] -> Maybe NodeId) -> Node -> Path -> Maybe Path +getChild f root path = do + node <- applyPath root path + let childIds = OMap.keys $ nodeChildren node + childId <- f childIds + pure $ path <> Path [childId] + +firstChild :: Node -> Path -> Maybe Path +firstChild = getChild headMay + +lastChild :: Node -> Path -> Maybe Path +lastChild = getChild lastMay + +getSibling :: (NodeId -> [NodeId] -> Maybe NodeId) -> Node -> Path -> Maybe Path +getSibling f root path = do + (parentPath, nodeId) <- splitInitLast path + parentNode <- applyPath root parentPath + let siblingIds = OMap.keys $ nodeChildren parentNode + siblingId <- f nodeId siblingIds + pure $ parentPath <> Path [siblingId] + +firstSibling :: Node -> Path -> Maybe Path +firstSibling = getSibling $ const headMay + +prevSibling :: Node -> Path -> Maybe Path +prevSibling = getSibling $ findPrev . (==) + +nextSibling :: Node -> Path -> Maybe Path +nextSibling = getSibling $ findNext . (==) + +lastSibling :: Node -> Path -> Maybe Path +lastSibling = getSibling $ const lastMay + +getNode :: (Path -> [Path] -> Maybe Path) -> Node -> Path -> Maybe Path +getNode f root path = f path $ flatten root + +firstNode :: Node -> Path -> Maybe Path +firstNode = getNode $ const headMay + +prevNode :: Node -> Path -> Maybe Path +prevNode = getNode $ findPrev . (==) + +nextNode :: Node -> Path -> Maybe Path +nextNode = getNode $ findNext . (==) + +lastNode :: Node -> Path -> Maybe Path +lastNode = getNode $ const lastMay + +{- Modifying at a path -} adjustAt :: (Node -> Node) -> Path -> Node -> Node adjustAt f (Path []) node = f node @@ -176,27 +271,14 @@ appendAt node = 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] +{- Paths -} newtype Path = Path { pathElements :: [NodeId] } deriving (Show, Eq, Ord, Semigroup, Monoid, ToJSON, FromJSON) referencedNodeExists :: Node -> Path -> Bool -referencedNodeExists node path = isJust $ applyPath path node +referencedNodeExists node path = isJust $ applyPath node path splitHeadTail :: Path -> Maybe (NodeId, Path) splitHeadTail (Path []) = Nothing diff --git a/forest-tui/src/Forest/Client/NodeUtil.hs b/forest-tui/src/Forest/Client/NodeUtil.hs index 1f0c031..3712e83 100644 --- a/forest-tui/src/Forest/Client/NodeUtil.hs +++ b/forest-tui/src/Forest/Client/NodeUtil.hs @@ -2,7 +2,6 @@ module Forest.Client.NodeUtil ( Unfolded , foldVisibleNodes , applyFolds - , flatten , findPrevNode , findNextNode ) where @@ -41,14 +40,6 @@ applyFolds unfolded node OMap.mapWithKey (\nid -> applyFolds $ narrowSet nid unfolded) $ nodeChildren node --- | Return the 'Path's to a node and its subnodes in the order they would be --- displayed in. -flatten :: Node -> [Path] -flatten node = - let flattenedChildren = - mapChildren (\nid n -> map (Path [nid] <>) $ flatten n) node - in Path [] : concat flattenedChildren - findPrevNode :: Node -> Path -> Path findPrevNode node path = fromMaybe path $ findPrev (==path) $ flatten node diff --git a/forest-tui/src/Forest/Client/UiState.hs b/forest-tui/src/Forest/Client/UiState.hs index 4531b45..28ae335 100644 --- a/forest-tui/src/Forest/Client/UiState.hs +++ b/forest-tui/src/Forest/Client/UiState.hs @@ -88,7 +88,7 @@ getFocusedPath :: UiState n -> Path getFocusedPath = uiFocused getFocusedNode :: UiState n -> Node -getFocusedNode s = fromMaybe rootNode $ applyPath (uiFocused s) rootNode +getFocusedNode s = fromMaybe rootNode $ applyPath rootNode $ uiFocused s where rootNode = uiRootNode s @@ -124,7 +124,7 @@ moveToTarget s = fromMaybe s $ do -- | Try to find the closest parent to a 'Path' that exists in the 'Node'. findValidParent :: Node -> Path -> Path findValidParent _ (Path []) = Path [] -findValidParent node (Path (x:xs)) = case applyId x node of +findValidParent node (Path (x:xs)) = case applyId node x of Nothing -> Path [] Just child -> Path [x] <> findValidParent child (Path xs) @@ -144,7 +144,7 @@ validateEditor :: UiState n -> UiState n validateEditor s = case uiEditor s of Nothing -> s Just e -> keepEditor $ fromMaybe False $ do - node <- applyPath (eiPath e) (uiRootNode s) + node <- applyPath (uiRootNode s) (eiPath e) let flags = nodeFlags node pure $ if eiReply e then flagReply flags else flagEdit flags where @@ -166,8 +166,8 @@ replaceRootNode node s = validate s findNextValidNode :: Node -> Node -> Path -> Path findNextValidNode _ _ (Path []) = Path [] findNextValidNode from to (Path (x:xs)) = fromMaybe (Path []) $ do - fromNode <- applyId x from - case applyId x to of + fromNode <- applyId from x + case applyId to x of Just toNode -> pure $ Path [x] <> findNextValidNode fromNode toNode (Path xs) Nothing -> do fromIdx <- elemIndex x $ OMap.keys $ nodeChildren from @@ -198,7 +198,7 @@ moveFocusToParent = moveFocus $ \_ focused -> fromMaybe focused $ parent focused moveFocusToChild :: ([NodeId] -> Maybe NodeId) -> UiState n -> UiState n moveFocusToChild f = moveFocus $ \node focused -> fromMaybe focused $ do - siblings <- nodeChildren <$> applyPath focused node + siblings <- nodeChildren <$> applyPath node focused firstSiblingName <- f $ OMap.keys siblings pure $ focused <> Path [firstSiblingName] @@ -283,9 +283,10 @@ data EditResult = EditResult , erReply :: Bool } deriving (Show) +-- TODO use new functions from the node module findTarget :: EditorInfo n -> UiState n -> FocusTarget findTarget e s = fromMaybe (FocusTarget (eiPath e) (eiReply e)) $ do - node <- applyPath (eiPath e) (uiRootNode s) + node <- applyPath (uiRootNode s) (eiPath e) lastChildId <- lastMay $ OMap.keys $ nodeChildren node let path = eiPath e <> Path [lastChildId] pure $ FocusTarget path False