diff --git a/Text/XML/Light.hs b/Text/XML/Light.hs --- a/Text/XML/Light.hs +++ b/Text/XML/Light.hs @@ -5,7 +5,7 @@ -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 -- --- Maintainer: Don Stewart +-- Maintainer: Iavor S. Diatchki -- Stability : provisional -- Portability: portability -- diff --git a/Text/XML/Light/Cursor.hs b/Text/XML/Light/Cursor.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Light/Cursor.hs @@ -0,0 +1,327 @@ +-------------------------------------------------------------------- +-- | +-- Module : Text.XML.Light.Cursor +-- Copyright : (c) Galois, Inc. 2008 +-- License : BSD3 +-- +-- Maintainer: Iavor S. Diatchki +-- Stability : provisional +-- Portability: +-- +-- XML cursors for working XML content withing the context of +-- an XML document. This implemntation is based on the general +-- tree zipper written by Krasimir Angelov and Iavor S. Diatchki. +-- + +module Text.XML.Light.Cursor + ( Tag(..), getTag, setTag, fromTag + , Cursor(..), Path + + -- * Conversions + , fromContent + , fromElement + , fromForest + , toForest + , toTree + + -- * Moving around + , parent + , root + , getChild + , firstChild + , lastChild + , left + , right + + -- ** Searching + , findChild + , findLeft + , findRight + + -- * 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 Text.XML.Light.Types +import Data.Maybe(isNothing) + +data Tag = Tag { tagName :: QName + , tagAttribs :: [Attr] + , tagLine :: Maybe Line + } deriving (Show) + +getTag :: Element -> Tag +getTag e = Tag { tagName = elName e + , tagAttribs = elAttribs e + , tagLine = elLine 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 + , elLine = tagLine 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) + +-- 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 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 guven content. +fromContent :: Content -> Cursor +fromContent t = Cur { current = t, lefts = [], rights = [], parents = [] } + +-- | A cursor for the guven 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 conent 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 conent 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 preceeding elements (reversed) and the folloing 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 diff --git a/Text/XML/Light/Input.hs b/Text/XML/Light/Input.hs --- a/Text/XML/Light/Input.hs +++ b/Text/XML/Light/Input.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 -- --- Maintainer: Don Stewart +-- Maintainer: Iavor S. Diatchki -- Stability : provisional -- Portability: portable -- @@ -25,9 +25,9 @@ parseXMLDoc :: String -> Maybe Element parseXMLDoc xs = strip (parseXML xs) where strip cs = case onlyElems cs of - e : _ + e : es | "?xml" `isPrefixOf` qName (elName e) - -> strip (elContent e) + -> strip (map Elem es) | otherwise -> Just e _ -> Nothing @@ -88,7 +88,7 @@ let (es,qs,ts1) = nodes ns ps ts in (Text CData { cdLine = Just p, - cdVerbatim = False, + cdVerbatim = CDataText, cdData = tagEnd t "" } : es,qs, ts1) @@ -136,12 +136,12 @@ -- XXX: Note, some of the lines might be a bit inacuarate where cvt (TxtBit x) = TokText CData { cdLine = Just l - , cdVerbatim = False + , cdVerbatim = CDataText , cdData = x } cvt (CRefBit x) = case cref_to_char x of Just c -> TokText CData { cdLine = Just l - , cdVerbatim = False + , cdVerbatim = CDataText , cdData = [c] } Nothing -> TokCRef x @@ -156,15 +156,26 @@ special c ((_,'[') : (_,'C') : (_,'D') : (_,'A') : (_,'T') : (_,'A') : (_,'[') : cs) = let (xs,ts) = cdata cs - in TokText CData { cdLine = Just (fst c), cdVerbatim = True, cdData = xs } + in TokText CData { cdLine = Just (fst c), cdVerbatim = CDataVerbatim, cdData = xs } : tokens' ts where cdata ((_,']') : (_,']') : (_,'>') : ds) = ([],ds) cdata ((_,d) : ds) = let (xs,ys) = cdata ds in (d:xs,ys) cdata [] = ([],[]) -special c cs = tag (c : cs) -- invalid specials are processed as tags +special c cs = + let (xs,ts) = munch "" 0 cs + in TokText CData { cdLine = Just (fst c), cdVerbatim = CDataRaw, cdData = '<':'!':(reverse xs) } : tokens' ts + where munch acc nesting ((_,'>') : ds) + | nesting == (0::Int) = ('>':acc,ds) + | otherwise = munch ('>':acc) (nesting-1) ds + munch acc nesting ((_,'<') : ds) + = munch ('<':acc) (nesting+1) ds + munch acc n ((_,x) : ds) = munch (x:acc) n ds + munch acc _ [] = (acc,[]) -- unterminated DTD markup +--special c cs = tag (c : cs) -- invalid specials are processed as tags + qualName :: LString -> (QName,LString) qualName xs = let (as,bs) = breakn endName xs (q,n) = case break (':'==) as of @@ -197,7 +208,7 @@ -- insert missing > ... _ -> tokens' ds) - (_,'?') : (_,'>') : ds -> ([], False, tokens' ds) + (_,'?') : (_,'>') : ds -> ([], True, tokens' ds) -- doc ended within a tag.. [] -> ([],False,[]) diff --git a/Text/XML/Light/Output.hs b/Text/XML/Light/Output.hs --- a/Text/XML/Light/Output.hs +++ b/Text/XML/Light/Output.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 -- --- Maintainer: Don Stewart +-- Maintainer: Iavor S. Diatchki -- Stability : provisional -- Portability: -- @@ -19,6 +19,7 @@ import Text.XML.Light.Types import Data.Char +import Data.List ( isPrefixOf ) -- | The XML 1.0 header xml_header :: String @@ -48,14 +49,16 @@ ppElementS :: String -> Element -> ShowS ppElementS i e xs = i ++ (tagStart (elName e) (elAttribs e) $ case elContent e of - [] -> " />" ++ xs + [] + | not ("?xml" `isPrefixOf` (qName $ elName e)) -> " />" ++ xs + | otherwise -> " ?>" ++ xs [Text t] -> ">" ++ ppCData "" t (tagEnd (elName e) xs) cs -> ">\n" ++ foldr ppSub (i ++ tagEnd (elName e) xs) cs where ppSub e1 = ppContentS (" " ++ i) e1 . showChar '\n' ) ppCData :: String -> CData -> ShowS -ppCData i c xs = i ++ if cdVerbatim c +ppCData i c xs = i ++ if (cdVerbatim c /= CDataText ) then showCDataS c xs else foldr cons xs (showCData c) @@ -99,11 +102,11 @@ -- | Convert a text element to characters. showCDataS :: CData -> ShowS -showCDataS cd - | cdVerbatim cd = showString "" - | otherwise = escStr (cdData cd) - +showCDataS cd = + case cdVerbatim cd of + CDataText -> escStr (cdData cd) + CDataVerbatim -> showString "" + CDataRaw -> \ xs -> cdData cd ++ xs -------------------------------------------------------------------------------- escCData :: String -> ShowS diff --git a/Text/XML/Light/Proc.hs b/Text/XML/Light/Proc.hs --- a/Text/XML/Light/Proc.hs +++ b/Text/XML/Light/Proc.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 -- --- Maintainer: Don Stewart +-- Maintainer: Iavor S. Diatchki -- Stability : provisional -- Portability: -- diff --git a/Text/XML/Light/Types.hs b/Text/XML/Light/Types.hs --- a/Text/XML/Light/Types.hs +++ b/Text/XML/Light/Types.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 -- --- Maintainer: Don Stewart +-- Maintainer: Iavor S. Diatchki -- Stability : provisional -- Portability: -- @@ -38,11 +38,17 @@ -- | XML CData data CData = CData { - cdVerbatim :: Bool, + cdVerbatim :: CDataKind, cdData :: String, cdLine :: Maybe Line } deriving Show +data CDataKind + = CDataText -- ^ Ordinary character data; pretty printer escapes &, < etc. + | CDataVerbatim -- ^ Unescaped character data; pretty printer embeds it in