xml 1.3.5 → 1.3.7
raw patch · 4 files changed
+246/−208 lines, 4 filesdep +bytestring
Dependencies added: bytestring
Files
- Text/XML/Light/Input.hs +4/−202
- Text/XML/Light/Lexer.hs +223/−0
- Text/XML/Light/Proc.hs +16/−4
- xml.cabal +3/−2
Text/XML/Light/Input.hs view
@@ -13,16 +13,15 @@ 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.Char(isSpace) import Data.List(isPrefixOf)-import Numeric(readHex) -- | parseXMLDoc, parse a XMLl document to maybe an element-parseXMLDoc :: String -> Maybe Element+parseXMLDoc :: XmlSource s => s -> Maybe Element parseXMLDoc xs = strip (parseXML xs) where strip cs = case onlyElems cs of e : es@@ -32,8 +31,8 @@ _ -> Nothing -- | parseXML to a list of content chunks-parseXML :: String -> [Content]-parseXML xs = parse $ tokens $ preprocess xs+parseXML :: XmlSource s => s -> [Content]+parseXML = parse . tokens ------------------------------------------------------------------------ @@ -113,200 +112,3 @@ (Nothing,"xmlns") -> (ns, if null val then Nothing else Just val) (Just "xmlns", k) -> ((k, val) : ns, def) _ -> (ns,def)----- 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 :: String -> [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 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--preprocess :: String -> String-preprocess ('\r' : '\n' : cs) = '\n' : preprocess cs-preprocess ('\r' : cs) = '\n' : preprocess cs-preprocess (c : cs) = c : preprocess cs-preprocess [] = []--linenumber :: Line -> String -> LString-linenumber _ [] = []-linenumber n ('\n':s) = n' `seq` ((n,'\n'):linenumber n' s) where n' = n + 1-linenumber n (c:s) = (n,c) : linenumber n s
+ Text/XML/Light/Lexer.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE TypeSynonymInstances #-}++module Text.XML.Light.Lexer where++import Text.XML.Light.Types++import Data.Char (chr,isSpace,ord)+import Numeric (readHex)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+++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)++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+++-- 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 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
Text/XML/Light/Proc.hs view
@@ -94,10 +94,22 @@ filterElementsName p e = filterElements (p.elName) e -- | Lookup the value of an attribute.-findAttr :: QName -> Element -> Maybe String-findAttr x e = attrVal `fmap` find ((x ==) . attrKey) (elAttribs e)+findAttr :: QName -> Element -> Maybe String+findAttr x e = lookupAttr x (elAttribs e) -- | Lookup attribute name from list.-lookupAttr :: QName -> [Attr] -> Maybe String-lookupAttr x as = attrVal `fmap` find ((x ==) . attrKey) as+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.cabal view
@@ -1,5 +1,5 @@ Name: xml-Version: 1.3.5+Version: 1.3.7 Homepage: http://code.galois.com Synopsis: A simple XML library. Description: A simple XML library.@@ -9,12 +9,13 @@ Author: Galois Inc. Maintainer: diatchki@galois.com Copyright: (c) 2007-2008 Galois Inc.-Build-depends: base >= 3 && < 5+Build-depends: base >= 3 && < 5, bytestring 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