module Text.XML.Expat.Cursor
( Tag(..), getTag, fromTag
, Cursor(..), Path
, fromTree
, fromForest
, toForest
, toTree
, parent
, root
, getChild
, firstChild
, lastChild
, left
, right
, nextDF
, findChild
, findLeft
, findRight
, findRec
, isRoot
, isFirst
, isLast
, isLeaf
, isChild
, hasChildren
, getNodeIndex
, setContent
, modifyContent
, modifyContentList
, modifyContentM
, insertLeft
, insertRight
, insertManyLeft
, insertManyRight
, insertFirstChild
, insertLastChild
, insertManyFirstChild
, insertManyLastChild
, insertGoLeft
, insertGoRight
, removeLeft
, removeRight
, removeGoLeft
, removeGoRight
, removeGoUp
) where
import Text.XML.Expat.Tree
import Data.Maybe(isNothing)
import Control.Monad(mplus)
data Tag tag text = Tag { tagName :: tag
, tagAttribs :: Attributes tag text
} deriving (Show)
fromTag :: Tag tag text -> [Node tag text] -> Node tag text
fromTag t cs = Element { eName = tagName t
, eAttrs = tagAttribs t
, eChildren = cs
}
type Path tag text = [([Node tag text],Tag tag text,[Node tag text])]
data Cursor tag text = Cur
{ current :: Node tag text
, lefts :: [Node tag text]
, rights :: [Node tag text]
, parents :: Path tag text
} deriving (Show)
parent :: Cursor tag text -> Maybe (Cursor tag text)
parent loc =
case parents loc of
(pls,v,prs) : ps -> Just
Cur { current = (fromTag v
(combChildren (lefts loc) (current loc) (rights loc)))
, lefts = pls, rights = prs, parents = ps
}
[] -> Nothing
root :: Cursor tag text -> Cursor tag text
root loc = maybe loc root (parent loc)
left :: Cursor tag text -> Maybe (Cursor tag text)
left loc =
case lefts loc of
t : ts -> Just loc { current = t, lefts = ts
, rights = current loc : rights loc }
[] -> Nothing
right :: Cursor tag text -> Maybe (Cursor tag text)
right loc =
case rights loc of
t : ts -> Just loc { current = t, lefts = current loc : lefts loc
, rights = ts }
[] -> Nothing
firstChild :: Cursor tag text -> Maybe (Cursor tag text)
firstChild loc =
do (t : ts, ps) <- downParents loc
return Cur { current = t, lefts = [], rights = ts , parents = ps }
lastChild :: Cursor tag text -> Maybe (Cursor tag text)
lastChild loc =
do (ts, ps) <- downParents loc
case reverse ts of
l : ls -> return Cur { current = l, lefts = ls, rights = []
, parents = ps }
[] -> Nothing
findLeft :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text)
findLeft p loc = do loc1 <- left loc
if p loc1 then return loc1 else findLeft p loc1
findRight :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text)
findRight p loc = do loc1 <- right loc
if p loc1 then return loc1 else findRight p loc1
findChild :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text)
findChild p loc =
do loc1 <- firstChild loc
if p loc1 then return loc1 else findRight p loc1
nextDF :: Cursor tag text -> Maybe (Cursor tag text)
nextDF c = firstChild c `mplus` up c
where up x = right x `mplus` (up =<< parent x)
findRec :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text)
findRec p c = if p c then Just c else findRec p =<< nextDF c
getChild :: Int -> Cursor tag text -> Maybe (Cursor tag text)
getChild n loc =
do (ts,ps) <- downParents loc
(ls,t,rs) <- splitChildren ts n
return Cur { current = t, lefts = ls, rights = rs, parents = ps }
downParents :: Cursor tag text -> Maybe ([Node tag text], Path tag text)
downParents loc =
case current loc of
Element n a c -> Just ( c
, (lefts loc, Tag n a, rights loc) : parents loc
)
_ -> Nothing
getTag :: Node tag text -> Tag tag text
getTag e = Tag { tagName = eName e
, tagAttribs = eAttrs e
}
fromTree :: Node tag text -> Cursor tag text
fromTree t = Cur { current = t, lefts = [], rights = [], parents = [] }
fromForest :: [Node tag text] -> Maybe (Cursor tag text)
fromForest (t:ts) = Just Cur { current = t, lefts = [], rights = ts
, parents = [] }
fromForest [] = Nothing
toTree :: Cursor tag text -> Node tag text
toTree loc = current (root loc)
toForest :: Cursor tag text -> [Node tag text]
toForest loc = let r = root loc in combChildren (lefts r) (current r) (rights r)
isRoot :: Cursor tag text -> Bool
isRoot loc = null (parents loc)
isFirst :: Cursor tag text -> Bool
isFirst loc = null (lefts loc)
isLast :: Cursor tag text -> Bool
isLast loc = null (rights loc)
isLeaf :: Cursor tag text -> Bool
isLeaf loc = isNothing (downParents loc)
isChild :: Cursor tag text -> Bool
isChild loc = not (isRoot loc)
getNodeIndex :: Cursor tag text -> Int
getNodeIndex loc = length (lefts loc)
hasChildren :: Cursor tag text -> Bool
hasChildren loc = not (isLeaf loc)
setContent :: Node tag text -> Cursor tag text -> Cursor tag text
setContent t loc = loc { current = t }
modifyContent :: (Node tag text -> Node tag text) -> Cursor tag text -> Cursor tag text
modifyContent f loc = setContent (f (current loc)) loc
modifyContentList :: (Node tag text -> [Node tag text]) -> Cursor tag text -> Maybe (Cursor tag text)
modifyContentList f loc = removeGoRight $ insertManyRight (f $ current loc) loc
modifyContentM :: Monad m => (Node tag text -> m (Node tag text)) -> Cursor tag text -> m (Cursor tag text)
modifyContentM f loc = do x <- f (current loc)
return (setContent x loc)
insertLeft :: Node tag text -> Cursor tag text -> Cursor tag text
insertLeft t loc = loc { lefts = t : lefts loc }
insertRight :: Node tag text -> Cursor tag text -> Cursor tag text
insertRight t loc = loc { rights = t : rights loc }
insertManyLeft :: [Node tag text] -> Cursor tag text -> Cursor tag text
insertManyLeft t loc = loc { lefts = reverse t ++ lefts loc }
insertManyRight :: [Node tag text] -> Cursor tag text -> Cursor tag text
insertManyRight t loc = loc { rights = t ++ rights loc }
mapChildren :: ([Node tag text] -> [Node tag text])
-> Cursor tag text
-> Maybe (Cursor tag text)
mapChildren f loc = let e = current loc in
case e of
Text _ -> Nothing
Element _ _ c -> Just $ loc { current = e { eChildren = f c } }
insertFirstChild :: Node tag text -> Cursor tag text -> Maybe (Cursor tag text)
insertFirstChild t = mapChildren (t:)
insertLastChild :: Node tag text -> Cursor tag text -> Maybe (Cursor tag text)
insertLastChild t = mapChildren (++[t])
insertManyFirstChild :: [Node tag text] -> Cursor tag text -> Maybe (Cursor tag text)
insertManyFirstChild t = mapChildren (t++)
insertManyLastChild :: [Node tag text] -> Cursor tag text -> Maybe (Cursor tag text)
insertManyLastChild t = mapChildren (++t)
removeLeft :: Cursor tag text -> Maybe (Node tag text,Cursor tag text)
removeLeft loc = case lefts loc of
l : ls -> return (l,loc { lefts = ls })
[] -> Nothing
removeRight :: Cursor tag text -> Maybe (Node tag text,Cursor tag text)
removeRight loc = case rights loc of
l : ls -> return (l,loc { rights = ls })
[] -> Nothing
insertGoLeft :: Node tag text -> Cursor tag text -> Cursor tag text
insertGoLeft t loc = loc { current = t, rights = current loc : rights loc }
insertGoRight :: Node tag text -> Cursor tag text -> Cursor tag text
insertGoRight t loc = loc { current = t, lefts = current loc : lefts loc }
removeGoLeft :: Cursor tag text -> Maybe (Cursor tag text)
removeGoLeft loc = case lefts loc of
l : ls -> Just loc { current = l, lefts = ls }
[] -> Nothing
removeGoRight :: Cursor tag text -> Maybe (Cursor tag text)
removeGoRight loc = case rights loc of
l : ls -> Just loc { current = l, rights = ls }
[] -> Nothing
removeGoUp :: Cursor tag text -> Maybe (Cursor tag text)
removeGoUp loc =
case parents loc of
(pls,v,prs) : ps -> Just
Cur { current = fromTag v (reverse (lefts loc) ++ rights loc)
, lefts = pls, rights = prs, parents = ps
}
[] -> Nothing
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 $! n1
loop _ _ _ = Nothing
combChildren :: [a] -> a -> [a] -> [a]
combChildren ls t rs = foldl (flip (:)) (t:rs) ls