{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {- Copyright (c) 2019 Herbert Valerio Riedel This file is free software: you may copy, redistribute and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This file is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program (see `LICENSE.GPLv3`). If not, see . This file incorporates work covered by the following copyright and permission notice: (c) 2007 Galois Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -- | -- Module : Text.XML.Cursor -- Copyright : (c) Galois, Inc. 2008 -- (c) Herbert Valerio Riedel 2019 -- SPDX-License-Identifier: BSD-3-Clause AND GPL-3.0-or-later -- -- XML cursors for working XML content withing the context of -- an XML document. This implementation is based on the general -- tree zipper written by Krasimir Angelov and Iavor S. Diatchki. -- module Text.XML.Cursor ( Tag(..), getTag, setTag, fromTag , Cursor(..), Path -- * Conversions , fromContent , fromElement , fromForest , toForest , toTree -- * Moving around , parent , root , getChild , firstChild , lastChild , left , right , nextDF -- ** Searching , findChild , findLeft , findRight , findRec -- * Node classification , isRoot , isFirst , isLast , isLeaf , isChild , hasChildren , getNodeIndex -- * Updates , setContent , modifyContent , modifyContentM -- ** Inserting content , insertLeft , insertRight , insertGoLeft , insertGoRight -- ** Removing content , removeLeft , removeRight , removeGoLeft , removeGoRight , removeGoUp ) where import Common import Text.XML.Types data Tag = Tag { tagName :: QName , tagAttribs :: [Attr] } deriving (Show,Generic,Typeable,Data) instance NFData Tag getTag :: Element -> Tag getTag e = Tag { tagName = elName e , tagAttribs = elAttribs e } setTag :: Tag -> Element -> Element setTag t e = fromTag t (elContent e) fromTag :: Tag -> [Content] -> Element fromTag t cs = Element { elName = tagName t , elAttribs = tagAttribs t , elContent = cs } type Path = [([Content],Tag,[Content])] -- | The position of a piece of content in an XML document. data Cursor = Cur { current :: Content -- ^ The currently selected content. , lefts :: [Content] -- ^ Siblings on the left, closest first. , rights :: [Content] -- ^ Siblings on the right, closest first. , parents :: Path -- ^ The contexts of the parent elements of this location. } deriving (Show,Generic,Typeable,Data) instance NFData Cursor -- Moving around --------------------------------------------------------------- -- | The parent of the given location. parent :: Cursor -> Maybe Cursor parent loc = case parents loc of (pls,v,prs) : ps -> Just Cur { current = Elem (fromTag v (combChildren (lefts loc) (current loc) (rights loc))) , lefts = pls, rights = prs, parents = ps } [] -> Nothing -- | The top-most parent of the given location. root :: Cursor -> Cursor root loc = maybe loc root (parent loc) -- | The left sibling of the given location. left :: Cursor -> Maybe Cursor left loc = case lefts loc of t : ts -> Just loc { current = t, lefts = ts , rights = current loc : rights loc } [] -> Nothing -- | The right sibling of the given location. right :: Cursor -> Maybe Cursor right loc = case rights loc of t : ts -> Just loc { current = t, lefts = current loc : lefts loc , rights = ts } [] -> Nothing -- | The first child of the given location. firstChild :: Cursor -> Maybe Cursor firstChild loc = do (t : ts, ps) <- downParents loc return Cur { current = t, lefts = [], rights = ts , parents = ps } -- | The last child of the given location. lastChild :: Cursor -> Maybe Cursor lastChild loc = do (ts, ps) <- downParents loc case reverse ts of l : ls -> return Cur { current = l, lefts = ls, rights = [] , parents = ps } [] -> Nothing -- | Find the next left sibling that satisfies a predicate. findLeft :: (Cursor -> Bool) -> Cursor -> Maybe Cursor findLeft p loc = do loc1 <- left loc if p loc1 then return loc1 else findLeft p loc1 -- | Find the next right sibling that satisfies a predicate. findRight :: (Cursor -> Bool) -> Cursor -> Maybe Cursor findRight p loc = do loc1 <- right loc if p loc1 then return loc1 else findRight p loc1 -- | The first child that satisfies a predicate. findChild :: (Cursor -> Bool) -> Cursor -> Maybe Cursor findChild p loc = do loc1 <- firstChild loc if p loc1 then return loc1 else findRight p loc1 -- | The next position in a left-to-right depth-first traversal of a document: -- either the first child, right sibling, or the right sibling of a parent that -- has one. nextDF :: Cursor -> Maybe Cursor nextDF c = firstChild c <|> up c where up x = right x <|> (up =<< parent x) -- | Perform a depth first search for a descendant that satisfies the -- given predicate. findRec :: (Cursor -> Bool) -> Cursor -> Maybe Cursor findRec p c = if p c then Just c else findRec p =<< nextDF c -- | The child with the given index (starting from 0). getChild :: Int -> Cursor -> Maybe Cursor getChild n loc = do (ts,ps) <- downParents loc (ls,t,rs) <- splitChildren ts n return Cur { current = t, lefts = ls, rights = rs, parents = ps } -- | private: computes the parent for "down" operations. downParents :: Cursor -> Maybe ([Content], Path) downParents loc = case current loc of Elem e -> Just ( elContent e , (lefts loc, getTag e, rights loc) : parents loc ) _ -> Nothing -- Conversions ----------------------------------------------------------------- -- | A cursor for the given content. fromContent :: Content -> Cursor fromContent t = Cur { current = t, lefts = [], rights = [], parents = [] } -- | A cursor for the given element. fromElement :: Element -> Cursor fromElement e = fromContent (Elem e) -- | The location of the first tree in a forest. fromForest :: [Content] -> Maybe Cursor fromForest (t:ts) = Just Cur { current = t, lefts = [], rights = ts , parents = [] } fromForest [] = Nothing -- | Computes the tree containing this location. toTree :: Cursor -> Content toTree loc = current (root loc) -- | Computes the forest containing this location. toForest :: Cursor -> [Content] toForest loc = let r = root loc in combChildren (lefts r) (current r) (rights r) -- Queries --------------------------------------------------------------------- -- | Are we at the top of the document? isRoot :: Cursor -> Bool isRoot loc = null (parents loc) -- | Are we at the left end of the the document? isFirst :: Cursor -> Bool isFirst loc = null (lefts loc) -- | Are we at the right end of the document? isLast :: Cursor -> Bool isLast loc = null (rights loc) -- | Are we at the bottom of the document? isLeaf :: Cursor -> Bool isLeaf loc = isNothing (downParents loc) -- | Do we have a parent? isChild :: Cursor -> Bool isChild loc = not (isRoot loc) -- | Get the node index inside the sequence of children getNodeIndex :: Cursor -> Int getNodeIndex loc = length (lefts loc) -- | Do we have children? hasChildren :: Cursor -> Bool hasChildren loc = not (isLeaf loc) -- Updates --------------------------------------------------------------------- -- | Change the current content. setContent :: Content -> Cursor -> Cursor setContent t loc = loc { current = t } -- | Modify the current content. modifyContent :: (Content -> Content) -> Cursor -> Cursor modifyContent f loc = setContent (f (current loc)) loc -- | Modify the current content, allowing for an effect. modifyContentM :: Monad m => (Content -> m Content) -> Cursor -> m Cursor modifyContentM f loc = do x <- f (current loc) return (setContent x loc) -- | Insert content to the left of the current position. insertLeft :: Content -> Cursor -> Cursor insertLeft t loc = loc { lefts = t : lefts loc } -- | Insert content to the right of the current position. insertRight :: Content -> Cursor -> Cursor insertRight t loc = loc { rights = t : rights loc } -- | Remove the content on the left of the current position, if any. removeLeft :: Cursor -> Maybe (Content,Cursor) removeLeft loc = case lefts loc of l : ls -> return (l,loc { lefts = ls }) [] -> Nothing -- | Remove the content on the right of the current position, if any. removeRight :: Cursor -> Maybe (Content,Cursor) removeRight loc = case rights loc of l : ls -> return (l,loc { rights = ls }) [] -> Nothing -- | Insert content to the left of the current position. -- The new content becomes the current position. insertGoLeft :: Content -> Cursor -> Cursor insertGoLeft t loc = loc { current = t, rights = current loc : rights loc } -- | Insert content to the right of the current position. -- The new content becomes the current position. insertGoRight :: Content -> Cursor -> Cursor insertGoRight t loc = loc { current = t, lefts = current loc : lefts loc } -- | Remove the current element. -- The new position is the one on the left. removeGoLeft :: Cursor -> Maybe Cursor removeGoLeft loc = case lefts loc of l : ls -> Just loc { current = l, lefts = ls } [] -> Nothing -- | Remove the current element. -- The new position is the one on the right. removeGoRight :: Cursor -> Maybe Cursor removeGoRight loc = case rights loc of l : ls -> Just loc { current = l, rights = ls } [] -> Nothing -- | Remove the current element. -- The new position is the parent of the old position. removeGoUp :: Cursor -> Maybe Cursor removeGoUp loc = case parents loc of (pls,v,prs) : ps -> Just Cur { current = Elem (fromTag v (reverse (lefts loc) ++ rights loc)) , lefts = pls, rights = prs, parents = ps } [] -> Nothing -- | private: Gets the given element of a list. -- Also returns the preceding elements (reversed) and the following elements. splitChildren :: [a] -> Int -> Maybe ([a],a,[a]) splitChildren _ n | n < 0 = Nothing splitChildren cs pos = loop [] cs pos where loop acc (x:xs) 0 = Just (acc,x,xs) loop acc (x:xs) n = loop (x:acc) xs $! n-1 loop _ _ _ = Nothing -- | private: combChildren ls x ys = reverse ls ++ [x] ++ ys combChildren :: [a] -> a -> [a] -> [a] combChildren ls t rs = foldl (flip (:)) (t:rs) ls