xml 1.2.6 → 1.3.1
raw patch · 7 files changed
+371/−23 lines, 7 filesnew-uploader
Files
- Text/XML/Light.hs +1/−1
- Text/XML/Light/Cursor.hs +327/−0
- Text/XML/Light/Input.hs +20/−9
- Text/XML/Light/Output.hs +11/−8
- Text/XML/Light/Proc.hs +1/−1
- Text/XML/Light/Types.hs +9/−3
- xml.cabal +2/−1
Text/XML/Light.hs view
@@ -5,7 +5,7 @@ -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 ----- Maintainer: Don Stewart <dons@galois.com>+-- Maintainer: Iavor S. Diatchki <diatchki@galois.com> -- Stability : provisional -- Portability: portability --
+ Text/XML/Light/Cursor.hs view
@@ -0,0 +1,327 @@+--------------------------------------------------------------------+-- |+-- Module : Text.XML.Light.Cursor+-- Copyright : (c) Galois, Inc. 2008+-- License : BSD3+--+-- Maintainer: Iavor S. Diatchki <diatchki@galois.com>+-- 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
Text/XML/Light/Input.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 ----- Maintainer: Don Stewart <dons@galois.com>+-- Maintainer: Iavor S. Diatchki <diatchki@galois.com> -- 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,[])
Text/XML/Light/Output.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 ----- Maintainer: Don Stewart <dons@galois.com>+-- Maintainer: Iavor S. Diatchki <diatchki@galois.com> -- 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 "<![CDATA[" . escCData (cdData cd)- . showString "]]>"- | otherwise = escStr (cdData cd)-+showCDataS cd = + case cdVerbatim cd of+ CDataText -> escStr (cdData cd)+ CDataVerbatim -> showString "<![CDATA[" . escCData (cdData cd) . showString "]]>"+ CDataRaw -> \ xs -> cdData cd ++ xs -------------------------------------------------------------------------------- escCData :: String -> ShowS
Text/XML/Light/Proc.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 ----- Maintainer: Don Stewart <dons@galois.com>+-- Maintainer: Iavor S. Diatchki <diatchki@galois.com> -- Stability : provisional -- Portability: --
Text/XML/Light/Types.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 ----- Maintainer: Don Stewart <dons@galois.com>+-- Maintainer: Iavor S. Diatchki <diatchki@galois.com> -- 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 <![CDATA[..+ | CDataRaw -- ^ As-is character data; pretty printer passes it along without any escaping or CDATA wrap-up.+ deriving ( Eq, Show )+ -- | XML qualified names data QName = QName { qName :: String,@@ -71,7 +77,7 @@ -- | Blank cdata blank_cdata :: CData-blank_cdata = CData { cdVerbatim = False, cdData = "", cdLine = Nothing }+blank_cdata = CData { cdVerbatim = CDataText, cdData = "", cdLine = Nothing } -- | Blank elements blank_element :: Element
xml.cabal view
@@ -1,5 +1,5 @@ Name: xml-Version: 1.2.6+Version: 1.3.1 Homepage: http://galois.com Synopsis: A simple XML library. Description: A simple XML library.@@ -16,5 +16,6 @@ Text.XML.Light.Output, Text.XML.Light.Input, Text.XML.Light.Proc+ Text.XML.Light.Cursor Extensions: FlexibleInstances Build-type: Simple