module Text.XML.Light.Cursor
( Tag(..), getTag, setTag, fromTag
, Cursor(..), Path
, fromContent
, fromElement
, fromForest
, toForest
, toTree
, parent
, root
, getChild
, firstChild
, lastChild
, left
, right
, nextDF
, findChild
, findLeft
, findRight
, findRec
, isRoot
, isFirst
, isLast
, isLeaf
, isChild
, hasChildren
, getNodeIndex
, setContent
, modifyContent
, modifyContentM
, insertLeft
, insertRight
, insertGoLeft
, insertGoRight
, removeLeft
, removeRight
, removeGoLeft
, removeGoRight
, removeGoUp
) where
import Text.XML.Light.Types
import Data.Maybe(isNothing)
import Control.Monad(mplus)
data Tag = Tag { Tag -> QName
tagName :: QName
, Tag -> [Attr]
tagAttribs :: [Attr]
, Tag -> Maybe Line
tagLine :: Maybe Line
} deriving (Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> String
(Int -> Tag -> ShowS)
-> (Tag -> String) -> ([Tag] -> ShowS) -> Show Tag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tag -> ShowS
showsPrec :: Int -> Tag -> ShowS
$cshow :: Tag -> String
show :: Tag -> String
$cshowList :: [Tag] -> ShowS
showList :: [Tag] -> ShowS
Show)
getTag :: Element -> Tag
getTag :: Element -> Tag
getTag Element
e = Tag { tagName :: QName
tagName = Element -> QName
elName Element
e
, tagAttribs :: [Attr]
tagAttribs = Element -> [Attr]
elAttribs Element
e
, tagLine :: Maybe Line
tagLine = Element -> Maybe Line
elLine Element
e
}
setTag :: Tag -> Element -> Element
setTag :: Tag -> Element -> Element
setTag Tag
t Element
e = Tag -> [Content] -> Element
fromTag Tag
t (Element -> [Content]
elContent Element
e)
fromTag :: Tag -> [Content] -> Element
fromTag :: Tag -> [Content] -> Element
fromTag Tag
t [Content]
cs = Element { elName :: QName
elName = Tag -> QName
tagName Tag
t
, elAttribs :: [Attr]
elAttribs = Tag -> [Attr]
tagAttribs Tag
t
, elLine :: Maybe Line
elLine = Tag -> Maybe Line
tagLine Tag
t
, elContent :: [Content]
elContent = [Content]
cs
}
type Path = [([Content],Tag,[Content])]
data Cursor = Cur
{ Cursor -> Content
current :: Content
, Cursor -> [Content]
lefts :: [Content]
, Cursor -> [Content]
rights :: [Content]
, Cursor -> Path
parents :: Path
} deriving (Int -> Cursor -> ShowS
[Cursor] -> ShowS
Cursor -> String
(Int -> Cursor -> ShowS)
-> (Cursor -> String) -> ([Cursor] -> ShowS) -> Show Cursor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cursor -> ShowS
showsPrec :: Int -> Cursor -> ShowS
$cshow :: Cursor -> String
show :: Cursor -> String
$cshowList :: [Cursor] -> ShowS
showList :: [Cursor] -> ShowS
Show)
parent :: Cursor -> Maybe Cursor
parent :: Cursor -> Maybe Cursor
parent Cursor
loc =
case Cursor -> Path
parents Cursor
loc of
([Content]
pls,Tag
v,[Content]
prs) : Path
ps -> Cursor -> Maybe Cursor
forall a. a -> Maybe a
Just
Cur { current :: Content
current = Element -> Content
Elem
(Tag -> [Content] -> Element
fromTag Tag
v
([Content] -> Content -> [Content] -> [Content]
forall a. [a] -> a -> [a] -> [a]
combChildren (Cursor -> [Content]
lefts Cursor
loc) (Cursor -> Content
current Cursor
loc) (Cursor -> [Content]
rights Cursor
loc)))
, lefts :: [Content]
lefts = [Content]
pls, rights :: [Content]
rights = [Content]
prs, parents :: Path
parents = Path
ps
}
[] -> Maybe Cursor
forall a. Maybe a
Nothing
root :: Cursor -> Cursor
root :: Cursor -> Cursor
root Cursor
loc = Cursor -> (Cursor -> Cursor) -> Maybe Cursor -> Cursor
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Cursor
loc Cursor -> Cursor
root (Cursor -> Maybe Cursor
parent Cursor
loc)
left :: Cursor -> Maybe Cursor
left :: Cursor -> Maybe Cursor
left Cursor
loc =
case Cursor -> [Content]
lefts Cursor
loc of
Content
t : [Content]
ts -> Cursor -> Maybe Cursor
forall a. a -> Maybe a
Just Cursor
loc { current = t, lefts = ts
, rights = current loc : rights loc }
[] -> Maybe Cursor
forall a. Maybe a
Nothing
right :: Cursor -> Maybe Cursor
right :: Cursor -> Maybe Cursor
right Cursor
loc =
case Cursor -> [Content]
rights Cursor
loc of
Content
t : [Content]
ts -> Cursor -> Maybe Cursor
forall a. a -> Maybe a
Just Cursor
loc { current = t, lefts = current loc : lefts loc
, rights = ts }
[] -> Maybe Cursor
forall a. Maybe a
Nothing
firstChild :: Cursor -> Maybe Cursor
firstChild :: Cursor -> Maybe Cursor
firstChild Cursor
loc =
do (Content
t : [Content]
ts, Path
ps) <- Cursor -> Maybe ([Content], Path)
downParents Cursor
loc
Cursor -> Maybe Cursor
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Cur { current :: Content
current = Content
t, lefts :: [Content]
lefts = [], rights :: [Content]
rights = [Content]
ts , parents :: Path
parents = Path
ps }
lastChild :: Cursor -> Maybe Cursor
lastChild :: Cursor -> Maybe Cursor
lastChild Cursor
loc =
do ([Content]
ts, Path
ps) <- Cursor -> Maybe ([Content], Path)
downParents Cursor
loc
case [Content] -> [Content]
forall a. [a] -> [a]
reverse [Content]
ts of
Content
l : [Content]
ls -> Cursor -> Maybe Cursor
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Cur { current :: Content
current = Content
l, lefts :: [Content]
lefts = [Content]
ls, rights :: [Content]
rights = []
, parents :: Path
parents = Path
ps }
[] -> Maybe Cursor
forall a. Maybe a
Nothing
findLeft :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
findLeft :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
findLeft Cursor -> Bool
p Cursor
loc = do Cursor
loc1 <- Cursor -> Maybe Cursor
left Cursor
loc
if Cursor -> Bool
p Cursor
loc1 then Cursor -> Maybe Cursor
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Cursor
loc1 else (Cursor -> Bool) -> Cursor -> Maybe Cursor
findLeft Cursor -> Bool
p Cursor
loc1
findRight :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
findRight :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
findRight Cursor -> Bool
p Cursor
loc = do Cursor
loc1 <- Cursor -> Maybe Cursor
right Cursor
loc
if Cursor -> Bool
p Cursor
loc1 then Cursor -> Maybe Cursor
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Cursor
loc1 else (Cursor -> Bool) -> Cursor -> Maybe Cursor
findRight Cursor -> Bool
p Cursor
loc1
findChild :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
findChild :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
findChild Cursor -> Bool
p Cursor
loc =
do Cursor
loc1 <- Cursor -> Maybe Cursor
firstChild Cursor
loc
if Cursor -> Bool
p Cursor
loc1 then Cursor -> Maybe Cursor
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Cursor
loc1 else (Cursor -> Bool) -> Cursor -> Maybe Cursor
findRight Cursor -> Bool
p Cursor
loc1
nextDF :: Cursor -> Maybe Cursor
nextDF :: Cursor -> Maybe Cursor
nextDF Cursor
c = Cursor -> Maybe Cursor
firstChild Cursor
c Maybe Cursor -> Maybe Cursor -> Maybe Cursor
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Cursor -> Maybe Cursor
up Cursor
c
where up :: Cursor -> Maybe Cursor
up Cursor
x = Cursor -> Maybe Cursor
right Cursor
x Maybe Cursor -> Maybe Cursor -> Maybe Cursor
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Cursor -> Maybe Cursor
up (Cursor -> Maybe Cursor) -> Maybe Cursor -> Maybe Cursor
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cursor -> Maybe Cursor
parent Cursor
x)
findRec :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
findRec :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
findRec Cursor -> Bool
p Cursor
c = if Cursor -> Bool
p Cursor
c then Cursor -> Maybe Cursor
forall a. a -> Maybe a
Just Cursor
c else (Cursor -> Bool) -> Cursor -> Maybe Cursor
findRec Cursor -> Bool
p (Cursor -> Maybe Cursor) -> Maybe Cursor -> Maybe Cursor
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cursor -> Maybe Cursor
nextDF Cursor
c
getChild :: Int -> Cursor -> Maybe Cursor
getChild :: Int -> Cursor -> Maybe Cursor
getChild Int
n Cursor
loc =
do ([Content]
ts,Path
ps) <- Cursor -> Maybe ([Content], Path)
downParents Cursor
loc
([Content]
ls,Content
t,[Content]
rs) <- [Content] -> Int -> Maybe ([Content], Content, [Content])
forall a. [a] -> Int -> Maybe ([a], a, [a])
splitChildren [Content]
ts Int
n
Cursor -> Maybe Cursor
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Cur { current :: Content
current = Content
t, lefts :: [Content]
lefts = [Content]
ls, rights :: [Content]
rights = [Content]
rs, parents :: Path
parents = Path
ps }
downParents :: Cursor -> Maybe ([Content], Path)
downParents :: Cursor -> Maybe ([Content], Path)
downParents Cursor
loc =
case Cursor -> Content
current Cursor
loc of
Elem Element
e -> ([Content], Path) -> Maybe ([Content], Path)
forall a. a -> Maybe a
Just ( Element -> [Content]
elContent Element
e
, (Cursor -> [Content]
lefts Cursor
loc, Element -> Tag
getTag Element
e, Cursor -> [Content]
rights Cursor
loc) ([Content], Tag, [Content]) -> Path -> Path
forall a. a -> [a] -> [a]
: Cursor -> Path
parents Cursor
loc
)
Content
_ -> Maybe ([Content], Path)
forall a. Maybe a
Nothing
fromContent :: Content -> Cursor
fromContent :: Content -> Cursor
fromContent Content
t = Cur { current :: Content
current = Content
t, lefts :: [Content]
lefts = [], rights :: [Content]
rights = [], parents :: Path
parents = [] }
fromElement :: Element -> Cursor
fromElement :: Element -> Cursor
fromElement Element
e = Content -> Cursor
fromContent (Element -> Content
Elem Element
e)
fromForest :: [Content] -> Maybe Cursor
fromForest :: [Content] -> Maybe Cursor
fromForest (Content
t:[Content]
ts) = Cursor -> Maybe Cursor
forall a. a -> Maybe a
Just Cur { current :: Content
current = Content
t, lefts :: [Content]
lefts = [], rights :: [Content]
rights = [Content]
ts
, parents :: Path
parents = [] }
fromForest [] = Maybe Cursor
forall a. Maybe a
Nothing
toTree :: Cursor -> Content
toTree :: Cursor -> Content
toTree Cursor
loc = Cursor -> Content
current (Cursor -> Cursor
root Cursor
loc)
toForest :: Cursor -> [Content]
toForest :: Cursor -> [Content]
toForest Cursor
loc = let r :: Cursor
r = Cursor -> Cursor
root Cursor
loc in [Content] -> Content -> [Content] -> [Content]
forall a. [a] -> a -> [a] -> [a]
combChildren (Cursor -> [Content]
lefts Cursor
r) (Cursor -> Content
current Cursor
r) (Cursor -> [Content]
rights Cursor
r)
isRoot :: Cursor -> Bool
isRoot :: Cursor -> Bool
isRoot Cursor
loc = Path -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Cursor -> Path
parents Cursor
loc)
isFirst :: Cursor -> Bool
isFirst :: Cursor -> Bool
isFirst Cursor
loc = [Content] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Cursor -> [Content]
lefts Cursor
loc)
isLast :: Cursor -> Bool
isLast :: Cursor -> Bool
isLast Cursor
loc = [Content] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Cursor -> [Content]
rights Cursor
loc)
isLeaf :: Cursor -> Bool
isLeaf :: Cursor -> Bool
isLeaf Cursor
loc = Maybe ([Content], Path) -> Bool
forall a. Maybe a -> Bool
isNothing (Cursor -> Maybe ([Content], Path)
downParents Cursor
loc)
isChild :: Cursor -> Bool
isChild :: Cursor -> Bool
isChild Cursor
loc = Bool -> Bool
not (Cursor -> Bool
isRoot Cursor
loc)
getNodeIndex :: Cursor -> Int
getNodeIndex :: Cursor -> Int
getNodeIndex Cursor
loc = [Content] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Cursor -> [Content]
lefts Cursor
loc)
hasChildren :: Cursor -> Bool
hasChildren :: Cursor -> Bool
hasChildren Cursor
loc = Bool -> Bool
not (Cursor -> Bool
isLeaf Cursor
loc)
setContent :: Content -> Cursor -> Cursor
setContent :: Content -> Cursor -> Cursor
setContent Content
t Cursor
loc = Cursor
loc { current = t }
modifyContent :: (Content -> Content) -> Cursor -> Cursor
modifyContent :: (Content -> Content) -> Cursor -> Cursor
modifyContent Content -> Content
f Cursor
loc = Content -> Cursor -> Cursor
setContent (Content -> Content
f (Cursor -> Content
current Cursor
loc)) Cursor
loc
modifyContentM :: Monad m => (Content -> m Content) -> Cursor -> m Cursor
modifyContentM :: forall (m :: * -> *).
Monad m =>
(Content -> m Content) -> Cursor -> m Cursor
modifyContentM Content -> m Content
f Cursor
loc = do Content
x <- Content -> m Content
f (Cursor -> Content
current Cursor
loc)
Cursor -> m Cursor
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Content -> Cursor -> Cursor
setContent Content
x Cursor
loc)
insertLeft :: Content -> Cursor -> Cursor
insertLeft :: Content -> Cursor -> Cursor
insertLeft Content
t Cursor
loc = Cursor
loc { lefts = t : lefts loc }
insertRight :: Content -> Cursor -> Cursor
insertRight :: Content -> Cursor -> Cursor
insertRight Content
t Cursor
loc = Cursor
loc { rights = t : rights loc }
removeLeft :: Cursor -> Maybe (Content,Cursor)
removeLeft :: Cursor -> Maybe (Content, Cursor)
removeLeft Cursor
loc = case Cursor -> [Content]
lefts Cursor
loc of
Content
l : [Content]
ls -> (Content, Cursor) -> Maybe (Content, Cursor)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Content
l,Cursor
loc { lefts = ls })
[] -> Maybe (Content, Cursor)
forall a. Maybe a
Nothing
removeRight :: Cursor -> Maybe (Content,Cursor)
removeRight :: Cursor -> Maybe (Content, Cursor)
removeRight Cursor
loc = case Cursor -> [Content]
rights Cursor
loc of
Content
l : [Content]
ls -> (Content, Cursor) -> Maybe (Content, Cursor)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Content
l,Cursor
loc { rights = ls })
[] -> Maybe (Content, Cursor)
forall a. Maybe a
Nothing
insertGoLeft :: Content -> Cursor -> Cursor
insertGoLeft :: Content -> Cursor -> Cursor
insertGoLeft Content
t Cursor
loc = Cursor
loc { current = t, rights = current loc : rights loc }
insertGoRight :: Content -> Cursor -> Cursor
insertGoRight :: Content -> Cursor -> Cursor
insertGoRight Content
t Cursor
loc = Cursor
loc { current = t, lefts = current loc : lefts loc }
removeGoLeft :: Cursor -> Maybe Cursor
removeGoLeft :: Cursor -> Maybe Cursor
removeGoLeft Cursor
loc = case Cursor -> [Content]
lefts Cursor
loc of
Content
l : [Content]
ls -> Cursor -> Maybe Cursor
forall a. a -> Maybe a
Just Cursor
loc { current = l, lefts = ls }
[] -> Maybe Cursor
forall a. Maybe a
Nothing
removeGoRight :: Cursor -> Maybe Cursor
removeGoRight :: Cursor -> Maybe Cursor
removeGoRight Cursor
loc = case Cursor -> [Content]
rights Cursor
loc of
Content
l : [Content]
ls -> Cursor -> Maybe Cursor
forall a. a -> Maybe a
Just Cursor
loc { current = l, rights = ls }
[] -> Maybe Cursor
forall a. Maybe a
Nothing
removeGoUp :: Cursor -> Maybe Cursor
removeGoUp :: Cursor -> Maybe Cursor
removeGoUp Cursor
loc =
case Cursor -> Path
parents Cursor
loc of
([Content]
pls,Tag
v,[Content]
prs) : Path
ps -> Cursor -> Maybe Cursor
forall a. a -> Maybe a
Just
Cur { current :: Content
current = Element -> Content
Elem (Tag -> [Content] -> Element
fromTag Tag
v ([Content] -> [Content]
forall a. [a] -> [a]
reverse (Cursor -> [Content]
lefts Cursor
loc) [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ Cursor -> [Content]
rights Cursor
loc))
, lefts :: [Content]
lefts = [Content]
pls, rights :: [Content]
rights = [Content]
prs, parents :: Path
parents = Path
ps
}
[] -> Maybe Cursor
forall a. Maybe a
Nothing
splitChildren :: [a] -> Int -> Maybe ([a],a,[a])
splitChildren :: forall a. [a] -> Int -> Maybe ([a], a, [a])
splitChildren [a]
_ Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Maybe ([a], a, [a])
forall a. Maybe a
Nothing
splitChildren [a]
cs Int
pos = [a] -> [a] -> Int -> Maybe ([a], a, [a])
forall {a} {a}.
(Eq a, Num a) =>
[a] -> [a] -> a -> Maybe ([a], a, [a])
loop [] [a]
cs Int
pos
where loop :: [a] -> [a] -> a -> Maybe ([a], a, [a])
loop [a]
acc (a
x:[a]
xs) a
0 = ([a], a, [a]) -> Maybe ([a], a, [a])
forall a. a -> Maybe a
Just ([a]
acc,a
x,[a]
xs)
loop [a]
acc (a
x:[a]
xs) a
n = [a] -> [a] -> a -> Maybe ([a], a, [a])
loop (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc) [a]
xs (a -> Maybe ([a], a, [a])) -> a -> Maybe ([a], a, [a])
forall a b. (a -> b) -> a -> b
$! a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1
loop [a]
_ [a]
_ a
_ = Maybe ([a], a, [a])
forall a. Maybe a
Nothing
combChildren :: [a] -> a -> [a] -> [a]
combChildren :: forall a. [a] -> a -> [a] -> [a]
combChildren [a]
ls a
t [a]
rs = ([a] -> a -> [a]) -> [a] -> [a] -> [a]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((a -> [a] -> [a]) -> [a] -> a -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) (a
ta -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rs) [a]
ls