Add T.P.XML.Light.Cursor.

1 files changed, 346 insertions, 0 deletions

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 <jgm@berkeley.edu>
+   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
+