1 ------------------------------------------------------------------------------ 2 -- | A zipper for navigating and modifying XML trees. This is nearly the 3 -- same exposed interface as the @xml@ package in @Text.XML.Light.Cursor@, 4 -- with modifications as needed to adapt to different types. 5 module Text.XmlHtml.Cursor ( 6 -- * Cursor type 7 Cursor, 8 9 -- * Conversion to and from cursors 10 fromNode, 11 fromNodes, 12 topNode, 13 topNodes, 14 current, 15 siblings, 16 17 -- * Cursor navigation 18 parent, 19 root, 20 getChild, 21 firstChild, 22 lastChild, 23 left, 24 right, 25 nextDF, 26 27 -- * Search 28 findChild, 29 findLeft, 30 findRight, 31 findRec, 32 33 -- * Node classification 34 isRoot, 35 isFirst, 36 isLast, 37 isLeaf, 38 isChild, 39 hasChildren, 40 getNodeIndex, 41 42 -- * Updates 43 setNode, 44 modifyNode, 45 modifyNodeM, 46 47 -- * Insertions 48 insertLeft, 49 insertRight, 50 insertManyLeft, 51 insertManyRight, 52 insertFirstChild, 53 insertLastChild, 54 insertManyFirstChild, 55 insertManyLastChild, 56 insertGoLeft, 57 insertGoRight, 58 59 -- * Deletions 60 removeLeft, 61 removeRight, 62 removeGoLeft, 63 removeGoRight, 64 removeGoUp 65 ) where 66 67 import Control.Monad 68 import Data.Maybe 69 import Data.Text (Text) 70 import Text.XmlHtml 71 72 ------------------------------------------------------------------------------ 73 -- | Just the tag of an element 74 type Tag = (Text, [(Text, Text)]) 75 76 77 ------------------------------------------------------------------------------ 78 -- | Reconstructs an element from a tag and a list of its children. 79 fromTag :: Tag -> [Node] -> Node 80 fromTag (t,a) c = Element t a c 81 82 83 ------------------------------------------------------------------------------ 84 -- | A zipper for XML document forests. 85 data Cursor = Cursor { 86 current :: !Node, -- ^ Retrieves the current node of a 'Cursor' 87 lefts :: ![Node], -- right to left 88 rights :: ![Node], -- left to right 89 parents :: ![([Node], Tag, [Node])] -- parent's tag and siblings 90 } 91 deriving (Eq) 92 93 94 ------------------------------------------------------------------------------ 95 -- | Builds a 'Cursor' for navigating a tree. That is, a forest with a single 96 -- root 'Node'. 97 fromNode :: Node -> Cursor 98 fromNode n = Cursor n [] [] [] 99 100 101 ------------------------------------------------------------------------------ 102 -- | Builds a 'Cursor' for navigating a forest with the given list of roots. 103 -- The cursor is initially positioned at the left-most node. Gives 'Nothing' 104 -- if the list is empty. 105 fromNodes :: [Node] -> Maybe Cursor 106 fromNodes (n:ns) = Just (Cursor n [] ns []) 107 fromNodes [] = Nothing 108 109 110 ------------------------------------------------------------------------------ 111 -- | Retrieves the root node containing the current cursor position. 112 topNode :: Cursor -> Node 113 topNode cur = current (root cur) 114 115 116 ------------------------------------------------------------------------------ 117 -- | Retrieves the entire forest of 'Node's corresponding to a 'Cursor'. 118 topNodes :: Cursor -> [Node] 119 topNodes cur = siblings (root cur) 120 121 122 ------------------------------------------------------------------------------ 123 -- | Retrieves a list of the 'Node's at the same level as the current position 124 -- of a cursor, including the current node. 125 siblings :: Cursor -> [Node] 126 siblings (Cursor cur ls rs _) = foldl (flip (:)) (cur:rs) ls 127 128 129 ------------------------------------------------------------------------------ 130 -- | Navigates a 'Cursor' to its parent in the document. 131 parent :: Cursor -> Maybe Cursor 132 parent c@(Cursor _ _ _ ((ls,t,rs):ps)) 133 = Just (Cursor (fromTag t (siblings c)) ls rs ps) 134 parent _ = Nothing 135 136 137 ------------------------------------------------------------------------------ 138 -- | Navigates a 'Cursor' up through parents to reach the root level. 139 root :: Cursor -> Cursor 140 root = until isRoot (fromJust . parent) 141 142 143 ------------------------------------------------------------------------------ 144 -- | Navigates a 'Cursor' down to the indicated child index. 145 getChild :: Int -> Cursor -> Maybe Cursor 146 getChild i (Cursor n ls rs ps) = 147 case n of 148 Element t a cs -> let (lls, rest) = splitAt i cs in 149 if i >= length cs 150 then Nothing 151 else Just $ Cursor (head rest) 152 (reverse lls) 153 (tail rest) 154 ((ls, (t,a), rs):ps) 155 _ -> Nothing 156 157 158 ------------------------------------------------------------------------------ 159 -- | Navigates a 'Cursor' down to its first child. 160 firstChild :: Cursor -> Maybe Cursor 161 firstChild = getChild 0 162 163 164 ------------------------------------------------------------------------------ 165 -- | Navigates a 'Cursor' down to its last child. 166 lastChild :: Cursor -> Maybe Cursor 167 lastChild (Cursor (Element t a c) ls rs ps) | not (null c) 168 = let rc = reverse c 169 in Just $ Cursor (head rc) (tail rc) [] ((ls, (t,a), rs):ps) 170 lastChild _ 171 = Nothing 172 173 174 ------------------------------------------------------------------------------ 175 -- | Moves a 'Cursor' to its left sibling. 176 left :: Cursor -> Maybe Cursor 177 left (Cursor c (l:ls) rs ps) = Just (Cursor l ls (c:rs) ps) 178 left _ = Nothing 179 180 181 ------------------------------------------------------------------------------ 182 -- | Moves a 'Cursor' to its right sibling. 183 right :: Cursor -> Maybe Cursor 184 right (Cursor c ls (r:rs) ps) = Just (Cursor r (c:ls) rs ps) 185 right _ = Nothing 186 187 188 ------------------------------------------------------------------------------ 189 -- | Moves a 'Cursor' to the next node encountered in a depth-first search. 190 -- If it has children, this is equivalent to 'firstChild'. Otherwise, if it 191 -- has a right sibling, then this is equivalent to 'right'. Otherwise, the 192 -- cursor moves to the first right sibling of one of its parents. 193 nextDF :: Cursor -> Maybe Cursor 194 nextDF c = firstChild c `mplus` up c 195 where up x = right x `mplus` (up =<< parent x) 196 197 198 ------------------------------------------------------------------------------ 199 -- | Repeats the given move until a 'Cursor' is obtained that matches the 200 -- predicate. 201 search :: (Cursor -> Bool) -- ^ predicate 202 -> (Cursor -> Maybe Cursor) -- ^ move 203 -> Cursor -- ^ starting point 204 -> Maybe Cursor 205 search p move c | p c = return c 206 | otherwise = search p move =<< move c 207 208 209 ------------------------------------------------------------------------------ 210 -- | Navigates a 'Cursor' to the first child that matches the predicate. 211 findChild :: (Cursor -> Bool) -> Cursor -> Maybe Cursor 212 findChild p cur = search p right =<< firstChild cur 213 214 215 ------------------------------------------------------------------------------ 216 -- | Navigates a 'Cursor' to the nearest left sibling that matches a 217 -- predicate. 218 findLeft :: (Cursor -> Bool) -> Cursor -> Maybe Cursor 219 findLeft p cur = search p left =<< left cur 220 221 222 ------------------------------------------------------------------------------ 223 -- | Navigates a 'Cursor' to the nearest right sibling that matches a 224 -- predicate. 225 findRight :: (Cursor -> Bool) -> Cursor -> Maybe Cursor 226 findRight p cur = search p right =<< right cur 227 228 229 ------------------------------------------------------------------------------ 230 -- | Does a depth-first search for a descendant matching the predicate. This 231 -- can match the current cursor position. 232 findRec :: (Cursor -> Bool) -> Cursor -> Maybe Cursor 233 findRec p = search p nextDF 234 235 236 ------------------------------------------------------------------------------ 237 -- | Determines if the 'Cursor' is at a root node. 238 isRoot :: Cursor -> Bool 239 isRoot cur = null (parents cur) 240 241 242 ------------------------------------------------------------------------------ 243 -- | Determines if the 'Cursor' is at a first child. 244 isFirst :: Cursor -> Bool 245 isFirst cur = null (lefts cur) 246 247 248 ------------------------------------------------------------------------------ 249 -- | Determines if the 'Cursor' is at a last child. 250 isLast :: Cursor -> Bool 251 isLast cur = null (rights cur) 252 253 254 ------------------------------------------------------------------------------ 255 -- | Determines if the 'Cursor' is at a leaf node. 256 isLeaf :: Cursor -> Bool 257 isLeaf (Cursor (Element _ _ c) _ _ _) = null c 258 isLeaf _ = True 259 260 261 ------------------------------------------------------------------------------ 262 -- | Determines if the 'Cursor' is at a child node (i.e., if it has a parent). 263 isChild :: Cursor -> Bool 264 isChild = not . isRoot 265 266 267 ------------------------------------------------------------------------------ 268 -- | Determines if the 'Cursor' is at a non-leaf node (i.e., if it has 269 -- children). 270 hasChildren :: Cursor -> Bool 271 hasChildren = not . isLeaf 272 273 274 ------------------------------------------------------------------------------ 275 -- | Gets the index of the 'Cursor' among its siblings. 276 getNodeIndex :: Cursor -> Int 277 getNodeIndex cur = length (lefts cur) 278 279 280 ------------------------------------------------------------------------------ 281 -- | Replaces the current node. 282 setNode :: Node -> Cursor -> Cursor 283 setNode n cur = cur { current = n } 284 285 286 ------------------------------------------------------------------------------ 287 -- | Modifies the current node by applying a function. 288 modifyNode :: (Node -> Node) -> Cursor -> Cursor 289 modifyNode f cur = setNode (f (current cur)) cur 290 291 292 ------------------------------------------------------------------------------ 293 -- | Modifies the current node by applying an action in some functor. 294 modifyNodeM :: Functor m => (Node -> m Node) -> Cursor -> m Cursor 295 modifyNodeM f cur = flip setNode cur `fmap` f (current cur) 296 297 298 ------------------------------------------------------------------------------ 299 -- | Inserts a new 'Node' to the left of the current position. 300 insertLeft :: Node -> Cursor -> Cursor 301 insertLeft n (Cursor nn ls rs ps) = Cursor nn (n:ls) rs ps 302 303 304 ------------------------------------------------------------------------------ 305 -- | Inserts a new 'Node' to the right of the current position. 306 insertRight :: Node -> Cursor -> Cursor 307 insertRight n (Cursor nn ls rs ps) = Cursor nn ls (n:rs) ps 308 309 310 ------------------------------------------------------------------------------ 311 -- | Inserts a list of new 'Node's to the left of the current position. 312 insertManyLeft :: [Node] -> Cursor -> Cursor 313 insertManyLeft ns (Cursor nn ls rs ps) = Cursor nn (reverse ns ++ ls) rs ps 314 315 316 ------------------------------------------------------------------------------ 317 -- | Inserts a list of new 'Node's to the right of the current position. 318 insertManyRight :: [Node] -> Cursor -> Cursor 319 insertManyRight ns (Cursor nn ls rs ps) = Cursor nn ls (ns ++ rs) ps 320 321 322 ------------------------------------------------------------------------------ 323 -- | Inserts a 'Node' as the first child of the current element. 324 insertFirstChild :: Node -> Cursor -> Maybe Cursor 325 insertFirstChild n (Cursor (Element t a c) ls rs ps) 326 = Just (Cursor (Element t a (n:c)) ls rs ps) 327 insertFirstChild _ _ 328 = Nothing 329 330 331 ------------------------------------------------------------------------------ 332 -- | Inserts a 'Node' as the last child of the current element. 333 insertLastChild :: Node -> Cursor -> Maybe Cursor 334 insertLastChild n (Cursor (Element t a c) ls rs ps) 335 = Just (Cursor (Element t a (c ++ [n])) ls rs ps) 336 insertLastChild _ _ 337 = Nothing 338 339 340 ------------------------------------------------------------------------------ 341 -- | Inserts a list of 'Node's as the first children of the current element. 342 insertManyFirstChild :: [Node] -> Cursor -> Maybe Cursor 343 insertManyFirstChild ns (Cursor (Element t a c) ls rs ps) 344 = Just (Cursor (Element t a (ns ++ c)) ls rs ps) 345 insertManyFirstChild _ _ 346 = Nothing 347 348 349 ------------------------------------------------------------------------------ 350 -- | Inserts a list of 'Node's as the last children of the current element. 351 insertManyLastChild :: [Node] -> Cursor -> Maybe Cursor 352 insertManyLastChild ns (Cursor (Element t a c) ls rs ps) 353 = Just (Cursor (Element t a (c ++ ns)) ls rs ps) 354 insertManyLastChild _ _ 355 = Nothing 356 357 358 ------------------------------------------------------------------------------ 359 -- | Inserts a new 'Node' to the left of the current position, and moves 360 -- left to the new node. 361 insertGoLeft :: Node -> Cursor -> Cursor 362 insertGoLeft n (Cursor nn ls rs ps) = Cursor n ls (nn:rs) ps 363 364 365 ------------------------------------------------------------------------------ 366 -- | Inserts a new 'Node' to the right of the current position, and moves 367 -- right to the new node. 368 insertGoRight :: Node -> Cursor -> Cursor 369 insertGoRight n (Cursor nn ls rs ps) = Cursor n (nn:ls) rs ps 370 371 372 ------------------------------------------------------------------------------ 373 -- | Removes the 'Node' to the left of the current position, if any. 374 removeLeft :: Cursor -> Maybe (Node, Cursor) 375 removeLeft (Cursor n (l:ls) rs ps) = Just (l, Cursor n ls rs ps) 376 removeLeft _ = Nothing 377 378 379 ------------------------------------------------------------------------------ 380 -- | Removes the 'Node' to the right of the current position, if any. 381 removeRight :: Cursor -> Maybe (Node, Cursor) 382 removeRight (Cursor n ls (r:rs) ps) = Just (r, Cursor n ls rs ps) 383 removeRight _ = Nothing 384 385 386 ------------------------------------------------------------------------------ 387 -- | Removes the current 'Node', and moves the Cursor to its left sibling, 388 -- if any. 389 removeGoLeft :: Cursor -> Maybe Cursor 390 removeGoLeft (Cursor _ (l:ls) rs ps) = Just (Cursor l ls rs ps) 391 removeGoLeft _ = Nothing 392 393 394 ------------------------------------------------------------------------------ 395 -- | Removes the current 'Node', and moves the Cursor to its right sibling, 396 -- if any. 397 removeGoRight :: Cursor -> Maybe Cursor 398 removeGoRight (Cursor _ ls (r:rs) ps) = Just (Cursor r ls rs ps) 399 removeGoRight _ = Nothing 400 401 402 ------------------------------------------------------------------------------ 403 -- | Removes the current 'Node', and moves the Cursor to its parent, if any. 404 removeGoUp :: Cursor -> Maybe Cursor 405 removeGoUp (Cursor _ ls rs ((lls, (t,a), rrs):ps)) 406 = Just (Cursor (Element t a children) lls rrs ps) 407 where 408 children = foldl (flip (:)) (rs) ls 409 removeGoUp _ = Nothing 410