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 @@ -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 diff --git a/Text/XML/Light/Lexer.hs b/Text/XML/Light/Lexer.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Light/Lexer.hs @@ -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 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 @@ -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) + + + diff --git a/xml.cabal b/xml.cabal --- a/xml.cabal +++ b/xml.cabal @@ -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