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