Cursor.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric      #-}

{-

Copyright (c) 2019  Herbert Valerio Riedel <hvr@gnu.org>

 This file is free software: you may copy, redistribute and/or modify it
 under the terms of the GNU General Public License as published by the
 Free Software Foundation, either version 3 of the License, or (at your
 option) any later version.

 This file is distributed in the hope that it will be useful, but
 WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 General Public License for more details.

 You should have received a copy of the GNU General Public License
 along with this program (see `LICENSE.GPLv3`).  If not, see
 <https://www.gnu.org/licenses/gpl-3.0.html>.

This file incorporates work covered by the following copyright and
permission notice:

    (c) 2007 Galois Inc.

    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    1. Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.

    2. Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in the
    documentation and/or other materials provided with the distribution.

    3. Neither the name of the author nor the names of his contributors
    may be used to endorse or promote products derived from this software
    without specific prior written permission.

    THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
    OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
    DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
    ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
    DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
    OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
    HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
    STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    POSSIBILITY OF SUCH DAMAGE.

-}

-- |
-- Module    : Text.XML.Cursor
-- Copyright : (c) Galois, Inc. 2008
--             (c) Herbert Valerio Riedel 2019
-- SPDX-License-Identifier: BSD-3-Clause AND GPL-3.0-or-later
--
-- XML cursors for working XML content withing the context of
-- an XML document.  This implementation is based on the general
-- tree zipper written by Krasimir Angelov and Iavor S. Diatchki.
--
module 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           Common
import           Text.XML.Types

data Tag = Tag
  { tagName    :: QName
  , tagAttribs :: [Attr]
  } deriving (Show,Generic,Typeable,Data)

instance NFData Tag

getTag :: Element -> Tag
getTag e = Tag { tagName = elName e
               , tagAttribs = elAttribs 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
                       , 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,Generic,Typeable,Data)

instance NFData Cursor

-- 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 <|> up c
  where up x = right x <|> (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