@@ -0,0 +1,346 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE OverloadedStrings #-}
4+ Module : Text.Pandoc.XML.Light.Cursor
5+ Copyright : Copyright (C) 2007 Galois, Inc., 2021 John MacFarlane
6+ License : GNU GPL, version 2 or above
8+ Maintainer : John MacFarlane <jgm@berkeley.edu>
10+ Portability : portable
12+ This code is taken from xml-light, released under the BSD3 license.
14+module Text.Pandoc.XML.Light.Cursor
15+ ( -- * Replacement for xml-light's Text.XML.Cursor
46+ -- * Node classification
60+ -- ** Inserting content
66+ -- ** Removing content
75+import Text.Pandoc.XML.Light.Types
76+import Data.Maybe(isNothing)
77+import Control.Monad(mplus)
79+data Tag = Tag { tagName :: QName
80+ , tagAttribs :: [Attr]
81+ , tagLine :: Maybe Line
84+getTag :: Element -> Tag
85+getTag e = Tag { tagName = elName e
86+ , tagAttribs = elAttribs e
90+setTag :: Tag -> Element -> Element
91+setTag t e = fromTag t (elContent e)
93+fromTag :: Tag -> [Content] -> Element
94+fromTag t cs = Element { elName = tagName t
95+ , elAttribs = tagAttribs t
100+type Path = [([Content],Tag,[Content])]
102+-- | The position of a piece of content in an XML document.
104+ { current :: Content -- ^ The currently selected content.
105+ , lefts :: [Content] -- ^ Siblings on the left, closest first.
106+ , rights :: [Content] -- ^ Siblings on the right, closest first.
107+ , parents :: Path -- ^ The contexts of the parent elements of this location.
110+-- Moving around ---------------------------------------------------------------
112+-- | The parent of the given location.
113+parent :: Cursor -> Maybe Cursor
116+ (pls,v,prs) : ps -> Just
117+ Cur { current = Elem
119+ (combChildren (lefts loc) (current loc) (rights loc)))
120+ , lefts = pls, rights = prs, parents = ps
125+-- | The top-most parent of the given location.
126+root :: Cursor -> Cursor
127+root loc = maybe loc root (parent loc)
129+-- | The left sibling of the given location.
130+left :: Cursor -> Maybe Cursor
133+ t : ts -> Just loc { current = t, lefts = ts
134+ , rights = current loc : rights loc }
137+-- | The right sibling of the given location.
138+right :: Cursor -> Maybe Cursor
141+ t : ts -> Just loc { current = t, lefts = current loc : lefts loc
145+-- | The first child of the given location.
146+firstChild :: Cursor -> Maybe Cursor
148+ do (t : ts, ps) <- downParents loc
149+ return Cur { current = t, lefts = [], rights = ts , parents = ps }
151+-- | The last child of the given location.
152+lastChild :: Cursor -> Maybe Cursor
154+ do (ts, ps) <- downParents loc
156+ l : ls -> return Cur { current = l, lefts = ls, rights = []
160+-- | Find the next left sibling that satisfies a predicate.
161+findLeft :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
162+findLeft p loc = do loc1 <- left loc
163+ if p loc1 then return loc1 else findLeft p loc1
165+-- | Find the next right sibling that satisfies a predicate.
166+findRight :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
167+findRight p loc = do loc1 <- right loc
168+ if p loc1 then return loc1 else findRight p loc1
170+-- | The first child that satisfies a predicate.
171+findChild :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
173+ do loc1 <- firstChild loc
174+ if p loc1 then return loc1 else findRight p loc1
176+-- | The next position in a left-to-right depth-first traversal of a document:
177+-- either the first child, right sibling, or the right sibling of a parent that
179+nextDF :: Cursor -> Maybe Cursor
180+nextDF c = firstChild c `mplus` up c
181+ where up x = right x `mplus` (up =<< parent x)
183+-- | Perform a depth first search for a descendant that satisfies the
185+findRec :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
186+findRec p c = if p c then Just c else findRec p =<< nextDF c
188+-- | The child with the given index (starting from 0).
189+getChild :: Int -> Cursor -> Maybe Cursor
191+ do (ts,ps) <- downParents loc
192+ (ls,t,rs) <- splitChildren ts n
193+ return Cur { current = t, lefts = ls, rights = rs, parents = ps }
196+-- | private: computes the parent for "down" operations.
197+downParents :: Cursor -> Maybe ([Content], Path)
200+ Elem e -> Just ( elContent e
201+ , (lefts loc, getTag e, rights loc) : parents loc
205+-- Conversions -----------------------------------------------------------------
207+-- | A cursor for the given content.
208+fromContent :: Content -> Cursor
209+fromContent t = Cur { current = t, lefts = [], rights = [], parents = [] }
211+-- | A cursor for the given element.
212+fromElement :: Element -> Cursor
213+fromElement e = fromContent (Elem e)
215+-- | The location of the first tree in a forest.
216+fromForest :: [Content] -> Maybe Cursor
217+fromForest (t:ts) = Just Cur { current = t, lefts = [], rights = ts
219+fromForest [] = Nothing
221+-- | Computes the tree containing this location.
222+toTree :: Cursor -> Content
223+toTree loc = current (root loc)
225+-- | Computes the forest containing this location.
226+toForest :: Cursor -> [Content]
227+toForest loc = let r = root loc in combChildren (lefts r) (current r) (rights r)
230+-- Queries ---------------------------------------------------------------------
232+-- | Are we at the top of the document?
233+isRoot :: Cursor -> Bool
234+isRoot loc = null (parents loc)
236+-- | Are we at the left end of the the document?
237+isFirst :: Cursor -> Bool
238+isFirst loc = null (lefts loc)
240+-- | Are we at the right end of the document?
241+isLast :: Cursor -> Bool
242+isLast loc = null (rights loc)
244+-- | Are we at the bottom of the document?
245+isLeaf :: Cursor -> Bool
246+isLeaf loc = isNothing (downParents loc)
248+-- | Do we have a parent?
249+isChild :: Cursor -> Bool
250+isChild loc = not (isRoot loc)
252+-- | Get the node index inside the sequence of children
253+getNodeIndex :: Cursor -> Int
254+getNodeIndex loc = length (lefts loc)
256+-- | Do we have children?
257+hasChildren :: Cursor -> Bool
258+hasChildren loc = not (isLeaf loc)
262+-- Updates ---------------------------------------------------------------------
264+-- | Change the current content.
265+setContent :: Content -> Cursor -> Cursor
266+setContent t loc = loc { current = t }
268+-- | Modify the current content.
269+modifyContent :: (Content -> Content) -> Cursor -> Cursor
270+modifyContent f loc = setContent (f (current loc)) loc
272+-- | Modify the current content, allowing for an effect.
273+modifyContentM :: Monad m => (Content -> m Content) -> Cursor -> m Cursor
274+modifyContentM f loc = do x <- f (current loc)
275+ return (setContent x loc)
277+-- | Insert content to the left of the current position.
278+insertLeft :: Content -> Cursor -> Cursor
279+insertLeft t loc = loc { lefts = t : lefts loc }
281+-- | Insert content to the right of the current position.
282+insertRight :: Content -> Cursor -> Cursor
283+insertRight t loc = loc { rights = t : rights loc }
285+-- | Remove the content on the left of the current position, if any.
286+removeLeft :: Cursor -> Maybe (Content,Cursor)
287+removeLeft loc = case lefts loc of
288+ l : ls -> return (l,loc { lefts = ls })
291+-- | Remove the content on the right of the current position, if any.
292+removeRight :: Cursor -> Maybe (Content,Cursor)
293+removeRight loc = case rights loc of
294+ l : ls -> return (l,loc { rights = ls })
298+-- | Insert content to the left of the current position.
299+-- The new content becomes the current position.
300+insertGoLeft :: Content -> Cursor -> Cursor
301+insertGoLeft t loc = loc { current = t, rights = current loc : rights loc }
303+-- | Insert content to the right of the current position.
304+-- The new content becomes the current position.
305+insertGoRight :: Content -> Cursor -> Cursor
306+insertGoRight t loc = loc { current = t, lefts = current loc : lefts loc }
308+-- | Remove the current element.
309+-- The new position is the one on the left.
310+removeGoLeft :: Cursor -> Maybe Cursor
311+removeGoLeft loc = case lefts loc of
312+ l : ls -> Just loc { current = l, lefts = ls }
315+-- | Remove the current element.
316+-- The new position is the one on the right.
317+removeGoRight :: Cursor -> Maybe Cursor
318+removeGoRight loc = case rights loc of
319+ l : ls -> Just loc { current = l, rights = ls }
322+-- | Remove the current element.
323+-- The new position is the parent of the old position.
324+removeGoUp :: Cursor -> Maybe Cursor
327+ (pls,v,prs) : ps -> Just
328+ Cur { current = Elem (fromTag v (reverse (lefts loc) ++ rights loc))
329+ , lefts = pls, rights = prs, parents = ps
334+-- | private: Gets the given element of a list.
335+-- Also returns the preceding elements (reversed) and the following elements.
336+splitChildren :: [a] -> Int -> Maybe ([a],a,[a])
337+splitChildren _ n | n < 0 = Nothing
338+splitChildren cs pos = loop [] cs pos
339+ where loop acc (x:xs) 0 = Just (acc,x,xs)
340+ loop acc (x:xs) n = loop (x:acc) xs $! n-1
341+ loop _ _ _ = Nothing
343+-- | private: combChildren ls x ys = reverse ls ++ [x] ++ ys
344+combChildren :: [a] -> a -> [a] -> [a]
345+combChildren ls t rs = foldl (flip (:)) (t:rs) ls