From d8fc4971868104274881570ce9bc3d9edf0d2506 Mon Sep 17 00:00:00 2001 From: John MacFarlane Date: Tue, 16 Feb 2021 18:51:41 -0800 Subject: Add T.P.XML.Light.Cursor. --- src/Text/Pandoc/XML/Light/Cursor.hs | 346 ++++++++++++++++++++++++++++++++++++ 1 file changed, 346 insertions(+) create mode 100644 src/Text/Pandoc/XML/Light/Cursor.hs (limited to 'src/Text/Pandoc') diff --git a/src/Text/Pandoc/XML/Light/Cursor.hs b/src/Text/Pandoc/XML/Light/Cursor.hs new file mode 100644 index 000000000..2e6da5346 --- /dev/null +++ b/src/Text/Pandoc/XML/Light/Cursor.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.XML.Light.Cursor + Copyright : Copyright (C) 2007 Galois, Inc., 2021 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + + This code is taken from xml-light, released under the BSD3 license. +-} +module Text.Pandoc.XML.Light.Cursor + ( -- * Replacement for xml-light's 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 Text.Pandoc.XML.Light.Types +import Data.Maybe(isNothing) +import Control.Monad(mplus) + +data Tag = Tag { tagName :: QName + , tagAttribs :: [Attr] + , tagLine :: Maybe Line + } deriving (Show) + +getTag :: Element -> Tag +getTag e = Tag { tagName = elName e + , tagAttribs = elAttribs e + , tagLine = elLine 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 + , elLine = tagLine 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) + +-- 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 `mplus` up c + where up x = right x `mplus` (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 + -- cgit v1.2.3