xml-1.3.14/0000755000000000000000000000000012472717306010577 5ustar0000000000000000xml-1.3.14/xml.cabal0000644000000000000000000000157312472717306012371 0ustar0000000000000000Name: xml Version: 1.3.14 Homepage: http://code.galois.com Synopsis: A simple XML library. Description: A simple XML library. Category: Text, XML License: BSD3 License-File: LICENSE Author: Galois Inc. Maintainer: diatchki@galois.com Copyright: (c) 2007-2008 Galois Inc. Build-type: Simple Cabal-version: >= 1.6 library Build-depends: base >= 3 && < 5, bytestring, text Ghc-options: -Wall -O2 Exposed-modules: Text.XML.Light, Text.XML.Light.Types, Text.XML.Light.Output, Text.XML.Light.Input, Text.XML.Light.Lexer, Text.XML.Light.Proc Text.XML.Light.Cursor Extensions: FlexibleInstances source-repository head type: git location: git://code.galois.com/xml.git xml-1.3.14/LICENSE0000644000000000000000000000266612472717306011616 0ustar0000000000000000(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. ~ xml-1.3.14/Setup.hs0000644000000000000000000000012112472717306012225 0ustar0000000000000000module Main where import Distribution.Simple main :: IO () main = defaultMain xml-1.3.14/Text/0000755000000000000000000000000012472717306011523 5ustar0000000000000000xml-1.3.14/Text/XML/0000755000000000000000000000000012472717306012163 5ustar0000000000000000xml-1.3.14/Text/XML/Light.hs0000644000000000000000000000620612472717306013572 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} -------------------------------------------------------------------- -- | -- Module : Text.XML.Light -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 -- -- Maintainer: Iavor S. Diatchki -- Stability : provisional -- Portability: portability -- -- A lightweight XML parsing, filtering and generating library. -- -- This module reexports functions from: -- -- * "Text.XML.Light.Types" -- -- * "Text.XML.Light.Proc" -- -- * "Text.XML.Light.Input" -- -- * "Text.XML.Light.Output" -- module Text.XML.Light ( module Text.XML.Light, module Text.XML.Light.Types, module Text.XML.Light.Proc, module Text.XML.Light.Input, module Text.XML.Light.Output ) where import Text.XML.Light.Types import Text.XML.Light.Proc import Text.XML.Light.Input import Text.XML.Light.Output -- | Add an attribute to an element. add_attr :: Attr -> Element -> Element add_attr a e = add_attrs [a] e -- | Add some attributes to an element. add_attrs :: [Attr] -> Element -> Element add_attrs as e = e { elAttribs = as ++ elAttribs e } -- | Create an unqualified name. unqual :: String -> QName unqual x = blank_name { qName = x } -- | A smart element constructor which uses the type of its argument -- to determine what sort of element to make. class Node t where node :: QName -> t -> Element instance Node ([Attr],[Content]) where node n (attrs,cont) = blank_element { elName = n , elAttribs = attrs , elContent = cont } instance Node [Attr] where node n as = node n (as,[]::[Content]) instance Node Attr where node n a = node n [a] instance Node () where node n () = node n ([]::[Attr]) instance Node [Content] where node n cs = node n ([]::[Attr],cs) instance Node Content where node n c = node n [c] instance Node ([Attr],Content) where node n (as,c) = node n (as,[c]) instance Node (Attr,Content) where node n (a,c) = node n ([a],[c]) instance Node ([Attr],[Element]) where node n (as,cs) = node n (as,map Elem cs) instance Node ([Attr],Element) where node n (as,c) = node n (as,[c]) instance Node (Attr,Element) where node n (a,c) = node n ([a],c) instance Node ([Element]) where node n es = node n ([]::[Attr],es) instance Node (Element) where node n e = node n [e] instance Node ([Attr],[CData]) where node n (as,cs) = node n (as,map Text cs) instance Node ([Attr],CData) where node n (as,c) = node n (as,[c]) instance Node (Attr,CData) where node n (a,c) = node n ([a],c) instance Node [CData] where node n es = node n ([]::[Attr],es) instance Node CData where node n e = node n [e] instance Node ([Attr],String) where node n (as,t) = node n (as,blank_cdata { cdData = t }) instance Node (Attr,String) where node n (a,t) = node n ([a],t) instance Node [Char] where node n t = node n ([]::[Attr],t) -- | Create node with unqualified name unode :: Node t => String -> t -> Element unode = node . unqual xml-1.3.14/Text/XML/Light/0000755000000000000000000000000012472717306013232 5ustar0000000000000000xml-1.3.14/Text/XML/Light/Input.hs0000644000000000000000000001011312472717306014661 0ustar0000000000000000-------------------------------------------------------------------- -- | -- Module : Text.XML.Light.Input -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 -- -- Maintainer: Iavor S. Diatchki -- Stability : provisional -- Portability: portable -- -- Lightweight XML parsing -- module Text.XML.Light.Input (parseXML,parseXMLDoc) where import Text.XML.Light.Lexer import Text.XML.Light.Types import Text.XML.Light.Proc import Text.XML.Light.Output(tagEnd) import Data.List(isPrefixOf) -- | parseXMLDoc, parse a XMLl document to maybe an element parseXMLDoc :: XmlSource s => s -> Maybe Element parseXMLDoc xs = strip (parseXML xs) where strip cs = case onlyElems cs of e : es | "?xml" `isPrefixOf` qName (elName e) -> strip (map Elem es) | otherwise -> Just e _ -> Nothing -- | parseXML to a list of content chunks parseXML :: XmlSource s => s -> [Content] parseXML = parse . tokens ------------------------------------------------------------------------ parse :: [Token] -> [Content] parse [] = [] parse ts = let (es,_,ts1) = nodes ([],Nothing) [] ts in es ++ parse ts1 -- Information about namespaces. -- The first component is a map that associates prefixes to URIs, -- the second is the URI for the default namespace, if one was provided. type NSInfo = ([(String,String)],Maybe String) nodes :: NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token]) nodes ns ps (TokCRef ref : ts) = let (es,qs,ts1) = nodes ns ps ts in (CRef ref : es, qs, ts1) nodes ns ps (TokText txt : ts) = let (es,qs,ts1) = nodes ns ps ts (more,es1) = case es of Text cd : es1' | cdVerbatim cd == cdVerbatim txt -> (cdData cd,es1') _ -> ([],es) in (Text txt { cdData = cdData txt ++ more } : es1, qs, ts1) nodes cur_info ps (TokStart p t as empty : ts) = (node : siblings, open, toks) where new_name = annotName new_info t new_info = foldr addNS cur_info as node = Elem Element { elLine = Just p , elName = new_name , elAttribs = map (annotAttr new_info) as , elContent = children } (children,(siblings,open,toks)) | empty = ([], nodes cur_info ps ts) | otherwise = let (es1,qs1,ts1) = nodes new_info (new_name:ps) ts in (es1, case qs1 of [] -> nodes cur_info ps ts1 _ : qs3 -> ([],qs3,ts1)) nodes ns ps (TokEnd p t : ts) = let t1 = annotName ns t in case break (t1 ==) ps of (as,_:_) -> ([],as,ts) -- Unknown closing tag. Insert as text. (_,[]) -> let (es,qs,ts1) = nodes ns ps ts in (Text CData { cdLine = Just p, cdVerbatim = CDataText, cdData = tagEnd t "" } : es,qs, ts1) nodes _ ps [] = ([],ps,[]) annotName :: NSInfo -> QName -> QName annotName (namespaces,def_ns) n = n { qURI = maybe def_ns (`lookup` namespaces) (qPrefix n) } annotAttr :: NSInfo -> Attr -> Attr annotAttr ns a@(Attr { attrKey = k}) = case (qPrefix k, qName k) of -- Do not apply the default name-space to unqualified -- attributes. See Section 6.2 of . (Nothing, _) -> a _ -> a { attrKey = annotName ns k } addNS :: Attr -> NSInfo -> NSInfo addNS (Attr { attrKey = key, attrVal = val }) (ns,def) = case (qPrefix key, qName key) of (Nothing,"xmlns") -> (ns, if null val then Nothing else Just val) (Just "xmlns", k) -> ((k, val) : ns, def) _ -> (ns,def) xml-1.3.14/Text/XML/Light/Proc.hs0000644000000000000000000001051112472717306014467 0ustar0000000000000000-------------------------------------------------------------------- -- | -- Module : Text.XML.Light.Proc -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 -- -- Maintainer: Iavor S. Diatchki -- Stability : provisional -- Portability: -- -------------------------------------------------------------------- module Text.XML.Light.Proc where import Text.XML.Light.Types import Data.Maybe(listToMaybe) import Data.List(find) -- | Get the text value of an XML element. This function -- ignores non-text elements, and concatenates all text elements. strContent :: Element -> String strContent e = concatMap cdData $ onlyText $ elContent e -- | Select only the elements from a list of XML content. onlyElems :: [Content] -> [Element] onlyElems xs = [ x | Elem x <- xs ] -- | Select only the elements from a parent. elChildren :: Element -> [Element] elChildren e = [ x | Elem x <- elContent e ] -- | Select only the text from a list of XML content. onlyText :: [Content] -> [CData] onlyText xs = [ x | Text x <- xs ] -- | Find all immediate children with the given name. findChildren :: QName -> Element -> [Element] findChildren q e = filterChildren ((q ==) . elName) e -- | Filter all immediate children wrt a given predicate. filterChildren :: (Element -> Bool) -> Element -> [Element] filterChildren p e = filter p (onlyElems (elContent e)) -- | Filter all immediate children wrt a given predicate over their names. filterChildrenName :: (QName -> Bool) -> Element -> [Element] filterChildrenName p e = filter (p.elName) (onlyElems (elContent e)) -- | Find an immediate child with the given name. findChild :: QName -> Element -> Maybe Element findChild q e = listToMaybe (findChildren q e) -- | Find an immediate child with the given name. filterChild :: (Element -> Bool) -> Element -> Maybe Element filterChild p e = listToMaybe (filterChildren p e) -- | Find an immediate child with name matching a predicate. filterChildName :: (QName -> Bool) -> Element -> Maybe Element filterChildName p e = listToMaybe (filterChildrenName p e) -- | Find the left-most occurrence of an element matching given name. findElement :: QName -> Element -> Maybe Element findElement q e = listToMaybe (findElements q e) -- | Filter the left-most occurrence of an element wrt. given predicate. filterElement :: (Element -> Bool) -> Element -> Maybe Element filterElement p e = listToMaybe (filterElements p e) -- | Filter the left-most occurrence of an element wrt. given predicate. filterElementName :: (QName -> Bool) -> Element -> Maybe Element filterElementName p e = listToMaybe (filterElementsName p e) -- | Find all non-nested occurances of an element. -- (i.e., once we have found an element, we do not search -- for more occurances among the element's children). findElements :: QName -> Element -> [Element] findElements qn e = filterElementsName (qn==) e -- | Find all non-nested occurrences of an element wrt. given predicate. -- (i.e., once we have found an element, we do not search -- for more occurances among the element's children). filterElements :: (Element -> Bool) -> Element -> [Element] filterElements p e | p e = [e] | otherwise = concatMap (filterElements p) $ onlyElems $ elContent e -- | Find all non-nested occurences of an element wrt a predicate over element names. -- (i.e., once we have found an element, we do not search -- for more occurances among the element's children). filterElementsName :: (QName -> Bool) -> Element -> [Element] filterElementsName p e = filterElements (p.elName) e -- | Lookup the value of an attribute. findAttr :: QName -> Element -> Maybe String findAttr x e = lookupAttr x (elAttribs e) -- | Lookup attribute name from list. lookupAttr :: QName -> [Attr] -> Maybe String lookupAttr x = lookupAttrBy (x ==) -- | Lookup the first attribute whose name satisfies the given predicate. lookupAttrBy :: (QName -> Bool) -> [Attr] -> Maybe String lookupAttrBy p as = attrVal `fmap` find (p . attrKey) as -- | Lookup the value of the first attribute whose name -- satisfies the given predicate. findAttrBy :: (QName -> Bool) -> Element -> Maybe String findAttrBy p e = lookupAttrBy p (elAttribs e) xml-1.3.14/Text/XML/Light/Lexer.hs0000644000000000000000000002072012472717306014646 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} module Text.XML.Light.Lexer where import Text.XML.Light.Types import Data.Char (chr,isSpace) import Numeric (readHex) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Text as TS import qualified Data.Text.Lazy as TL class XmlSource s where uncons :: s -> Maybe (Char,s) instance XmlSource String where uncons (c:s) = Just (c,s) uncons "" = Nothing instance XmlSource S.ByteString where uncons bs = f `fmap` S.uncons bs where f (c,s) = (chr (fromEnum c), s) instance XmlSource L.ByteString where uncons bs = f `fmap` L.uncons bs where f (c,s) = (chr (fromEnum c), s) instance XmlSource TS.Text where uncons = TS.uncons instance XmlSource TL.Text where uncons = TL.uncons linenumber :: XmlSource s => Integer -> s -> LString linenumber n s = case uncons s of Nothing -> [] Just ('\r', s') -> case uncons s' of Just ('\n',s'') -> next s'' _ -> next s' Just ('\n', s') -> next s' Just (c , s') -> (n,c) : linenumber n s' where next s' = n' `seq` ((n,'\n'):linenumber n' s') where n' = n + 1 -- | This type may be used to provide a custom scanning function -- for extracting characters. data Scanner s = Scanner (Maybe (Char,s)) (s -> Maybe (Char,s)) -- | This type may be used to provide a custom scanning function -- for extracting characters. customScanner :: (s -> Maybe (Char,s)) -> s -> Scanner s customScanner next s = Scanner (next s) next instance XmlSource (Scanner s) where uncons (Scanner this next) = do (c,s1) <- this return (c, Scanner (next s1) next) -- Lexer ----------------------------------------------------------------------- type LChar = (Line,Char) type LString = [LChar] data Token = TokStart Line QName [Attr] Bool -- is empty? | TokEnd Line QName | TokCRef String | TokText CData deriving Show tokens :: XmlSource source => source -> [Token] tokens = tokens' . linenumber 1 tokens' :: LString -> [Token] tokens' ((_,'<') : c@(_,'!') : cs) = special c cs tokens' ((_,'<') : cs) = tag (dropSpace cs) -- we are being nice here tokens' [] = [] tokens' cs@((l,_):_) = let (as,bs) = breakn ('<' ==) cs in map cvt (decode_text as) ++ tokens' bs -- XXX: Note, some of the lines might be a bit inacuarate where cvt (TxtBit x) = TokText CData { cdLine = Just l , cdVerbatim = CDataText , cdData = x } cvt (CRefBit x) = case cref_to_char x of Just c -> TokText CData { cdLine = Just l , cdVerbatim = CDataText , cdData = [c] } Nothing -> TokCRef x special :: LChar -> LString -> [Token] special _ ((_,'-') : (_,'-') : cs) = skip cs where skip ((_,'-') : (_,'-') : (_,'>') : ds) = tokens' ds skip (_ : ds) = skip ds skip [] = [] -- unterminated comment special c ((_,'[') : (_,'C') : (_,'D') : (_,'A') : (_,'T') : (_,'A') : (_,'[') : cs) = let (xs,ts) = cdata cs 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 = 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 (q1,_:n1) -> (Just q1, n1) _ -> (Nothing, as) in (QName { qURI = Nothing, qPrefix = q, qName = n }, bs) where endName x = isSpace x || x == '=' || x == '>' || x == '/' tag :: LString -> [Token] tag ((p,'/') : cs) = let (n,ds) = qualName (dropSpace cs) in TokEnd p n : case (dropSpace ds) of (_,'>') : es -> tokens' es -- tag was not properly closed... _ -> tokens' ds tag [] = [] tag cs = let (n,ds) = qualName cs (as,b,ts) = attribs (dropSpace ds) in TokStart (fst (head cs)) n as b : ts attribs :: LString -> ([Attr], Bool, [Token]) attribs cs = case cs of (_,'>') : ds -> ([], False, tokens' ds) (_,'/') : ds -> ([], True, case ds of (_,'>') : es -> tokens' es -- insert missing > ... _ -> tokens' ds) (_,'?') : (_,'>') : ds -> ([], True, tokens' ds) -- doc ended within a tag.. [] -> ([],False,[]) _ -> let (a,cs1) = attrib cs (as,b,ts) = attribs cs1 in (a:as,b,ts) attrib :: LString -> (Attr,LString) attrib cs = let (ks,cs1) = qualName cs (vs,cs2) = attr_val (dropSpace cs1) in ((Attr ks (decode_attr vs)),dropSpace cs2) attr_val :: LString -> (String,LString) attr_val ((_,'=') : cs) = string (dropSpace cs) attr_val cs = ("",cs) dropSpace :: LString -> LString dropSpace = dropWhile (isSpace . snd) -- | Match the value for an attribute. For malformed XML we do -- our best to guess the programmer's intention. string :: LString -> (String,LString) string ((_,'"') : cs) = break' ('"' ==) cs -- Allow attributes to be enclosed between ' '. string ((_,'\'') : cs) = break' ('\'' ==) cs -- Allow attributes that are not enclosed by anything. string cs = breakn eos cs where eos x = isSpace x || x == '>' || x == '/' break' :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)]) break' p xs = let (as,bs) = breakn p xs in (as, case bs of [] -> [] _ : cs -> cs) breakn :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)]) breakn p l = (map snd as,bs) where (as,bs) = break (p . snd) l decode_attr :: String -> String decode_attr cs = concatMap cvt (decode_text cs) where cvt (TxtBit x) = x cvt (CRefBit x) = case cref_to_char x of Just c -> [c] Nothing -> '&' : x ++ ";" data Txt = TxtBit String | CRefBit String deriving Show decode_text :: [Char] -> [Txt] decode_text xs@('&' : cs) = case break (';' ==) cs of (as,_:bs) -> CRefBit as : decode_text bs _ -> [TxtBit xs] decode_text [] = [] decode_text cs = let (as,bs) = break ('&' ==) cs in TxtBit as : decode_text bs cref_to_char :: [Char] -> Maybe Char cref_to_char cs = case cs of '#' : ds -> num_esc ds "lt" -> Just '<' "gt" -> Just '>' "amp" -> Just '&' "apos" -> Just '\'' "quot" -> Just '"' _ -> Nothing num_esc :: String -> Maybe Char num_esc cs = case cs of 'x' : ds -> check (readHex ds) _ -> check (reads cs) where check [(n,"")] = cvt_char n check _ = Nothing cvt_char :: Int -> Maybe Char cvt_char x | fromEnum (minBound :: Char) <= x && x <= fromEnum (maxBound::Char) = Just (toEnum x) | otherwise = Nothing xml-1.3.14/Text/XML/Light/Types.hs0000644000000000000000000000523412472717306014676 0ustar0000000000000000-------------------------------------------------------------------- -- | -- Module : Text.XML.Light.Types -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 -- -- Maintainer: Iavor S. Diatchki -- Stability : provisional -- Portability: -- -- Basic XML types. -- {-# LANGUAGE DeriveDataTypeable #-} module Text.XML.Light.Types where import Data.Typeable(Typeable) import Data.Data(Data) -- | A line is an Integer type Line = Integer -- | XML content data Content = Elem Element | Text CData | CRef String deriving (Show, Typeable, Data) -- | XML elements data Element = Element { elName :: QName, elAttribs :: [Attr], elContent :: [Content], elLine :: Maybe Line } deriving (Show, Typeable, Data) -- | XML attributes data Attr = Attr { attrKey :: QName, attrVal :: String } deriving (Eq, Ord, Show, Typeable, Data) -- | XML CData data CData = CData { cdVerbatim :: CDataKind, cdData :: String, cdLine :: Maybe Line } deriving (Show, Typeable, Data) data CDataKind = CDataText -- ^ Ordinary character data; pretty printer escapes &, < etc. | CDataVerbatim -- ^ Unescaped character data; pretty printer embeds it in case (qURI q1, qURI q2) of (Nothing,Nothing) -> compare (qPrefix q1) (qPrefix q2) (u1,u2) -> compare u1 u2 x -> x -- blank elements -------------------------------------------------------------- -- | Blank names blank_name :: QName blank_name = QName { qName = "", qURI = Nothing, qPrefix = Nothing } -- | Blank cdata blank_cdata :: CData blank_cdata = CData { cdVerbatim = CDataText, cdData = "", cdLine = Nothing } -- | Blank elements blank_element :: Element blank_element = Element { elName = blank_name , elAttribs = [] , elContent = [] , elLine = Nothing } xml-1.3.14/Text/XML/Light/Cursor.hs0000644000000000000000000002451012472717306015045 0ustar0000000000000000-------------------------------------------------------------------- -- | -- Module : Text.XML.Light.Cursor -- Copyright : (c) Galois, Inc. 2008 -- License : BSD3 -- -- Maintainer: Iavor S. Diatchki -- Stability : provisional -- Portability: portable -- -- 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.Light.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 Text.XML.Light.Types import Data.Maybe(isNothing) import Control.Monad(mplus) 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 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 `mplus` up c where up x = right x `mplus` (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 xml-1.3.14/Text/XML/Light/Output.hs0000644000000000000000000001541212472717306015071 0ustar0000000000000000-------------------------------------------------------------------- -- | -- Module : Text.XML.Light.Output -- Copyright : (c) Galois, Inc. 2007 -- License : BSD3 -- -- Maintainer: Iavor S. Diatchki -- Stability : provisional -- Portability: -- -- Output handling for the lightweight XML lib. -- module Text.XML.Light.Output ( showTopElement, showContent, showElement, showCData, showQName, showAttr , ppTopElement, ppContent, ppElement , ppcTopElement, ppcContent, ppcElement , ConfigPP , defaultConfigPP, prettyConfigPP , useShortEmptyTags, useExtraWhiteSpace , tagEnd, xml_header ) where import Text.XML.Light.Types import Data.Char import Data.List ( isPrefixOf ) -- | The XML 1.0 header xml_header :: String xml_header = "" -------------------------------------------------------------------------------- data ConfigPP = ConfigPP { shortEmptyTag :: QName -> Bool , prettify :: Bool } -- | Default pretty orinting configuration. -- * Always use abbreviate empty tags. defaultConfigPP :: ConfigPP defaultConfigPP = ConfigPP { shortEmptyTag = const True , prettify = False } -- | The predicate specifies for which empty tags we should use XML's -- abbreviated notation . This is useful if we are working with -- some XML-ish standards (such as certain versions of HTML) where some -- empty tags should always be displayed in the form. useShortEmptyTags :: (QName -> Bool) -> ConfigPP -> ConfigPP useShortEmptyTags p c = c { shortEmptyTag = p } -- | Specify if we should use extra white-space to make document more readable. -- WARNING: This adds additional white-space to text elements, -- and so it may change the meaning of the document. useExtraWhiteSpace :: Bool -> ConfigPP -> ConfigPP useExtraWhiteSpace p c = c { prettify = p } -- | A configuration that tries to make things pretty -- (possibly at the cost of changing the semantics a bit -- through adding white space.) prettyConfigPP :: ConfigPP prettyConfigPP = useExtraWhiteSpace True defaultConfigPP -------------------------------------------------------------------------------- -- | Pretty printing renders XML documents faithfully, -- with the exception that whitespace may be added\/removed -- in non-verbatim character data. ppTopElement :: Element -> String ppTopElement = ppcTopElement prettyConfigPP -- | Pretty printing elements ppElement :: Element -> String ppElement = ppcElement prettyConfigPP -- | Pretty printing content ppContent :: Content -> String ppContent = ppcContent prettyConfigPP -- | Pretty printing renders XML documents faithfully, -- with the exception that whitespace may be added\/removed -- in non-verbatim character data. ppcTopElement :: ConfigPP -> Element -> String ppcTopElement c e = unlines [xml_header,ppcElement c e] -- | Pretty printing elements ppcElement :: ConfigPP -> Element -> String ppcElement c e = ppElementS c "" e "" -- | Pretty printing content ppcContent :: ConfigPP -> Content -> String ppcContent c x = ppContentS c "" x "" -- | Pretty printing content using ShowS ppContentS :: ConfigPP -> String -> Content -> ShowS ppContentS c i x xs = case x of Elem e -> ppElementS c i e xs Text t -> ppCDataS c i t xs CRef r -> showCRefS r xs ppElementS :: ConfigPP -> String -> Element -> ShowS ppElementS c i e xs = i ++ (tagStart (elName e) (elAttribs e) $ case elContent e of [] | "?" `isPrefixOf` qName name -> " ?>" ++ xs | shortEmptyTag c name -> " />" ++ xs [Text t] -> ">" ++ ppCDataS c "" t (tagEnd name xs) cs -> '>' : nl ++ foldr ppSub (i ++ tagEnd name xs) cs where ppSub e1 = ppContentS c (sp ++ i) e1 . showString nl (nl,sp) = if prettify c then ("\n"," ") else ("","") ) where name = elName e ppCDataS :: ConfigPP -> String -> CData -> ShowS ppCDataS c i t xs = i ++ if cdVerbatim t /= CDataText || not (prettify c) then showCDataS t xs else foldr cons xs (showCData t) where cons :: Char -> String -> String cons '\n' ys = "\n" ++ i ++ ys cons y ys = y : ys -------------------------------------------------------------------------------- -- | Adds the header. showTopElement :: Element -> String showTopElement c = xml_header ++ showElement c showContent :: Content -> String showContent c = ppContentS defaultConfigPP "" c "" showElement :: Element -> String showElement c = ppElementS defaultConfigPP "" c "" showCData :: CData -> String showCData c = ppCDataS defaultConfigPP "" c "" -- Note: crefs should not contain '&', ';', etc. showCRefS :: String -> ShowS showCRefS r xs = '&' : r ++ ';' : xs -- | Convert a text element to characters. showCDataS :: CData -> ShowS showCDataS cd = case cdVerbatim cd of CDataText -> escStr (cdData cd) CDataVerbatim -> showString "" CDataRaw -> \ xs -> cdData cd ++ xs -------------------------------------------------------------------------------- escCData :: String -> ShowS escCData (']' : ']' : '>' : cs) = showString "]]]]>" . escCData cs escCData (c : cs) = showChar c . escCData cs escCData [] = id escChar :: Char -> ShowS escChar c = case c of '<' -> showString "<" '>' -> showString ">" '&' -> showString "&" '"' -> showString """ -- we use ' instead of ' because IE apparently has difficulties -- rendering ' in xhtml. -- Reported by Rohan Drape . '\'' -> showString "'" -- NOTE: We escape '\r' explicitly because otherwise they get lost -- when parsed back in because of then end-of-line normalization rules. _ | isPrint c || c == '\n' -> showChar c | otherwise -> showString "&#" . shows oc . showChar ';' where oc = ord c escStr :: String -> ShowS escStr cs rs = foldr escChar rs cs tagEnd :: QName -> ShowS tagEnd qn rs = '<':'/':showQName qn ++ '>':rs tagStart :: QName -> [Attr] -> ShowS tagStart qn as rs = '<':showQName qn ++ as_str ++ rs where as_str = if null as then "" else ' ' : unwords (map showAttr as) showAttr :: Attr -> String showAttr (Attr qn v) = showQName qn ++ '=' : '"' : escStr v "\"" showQName :: QName -> String showQName q = pre ++ qName q where pre = case qPrefix q of Nothing -> "" Just p -> p ++ ":"