@@ -0,0 +1,307 @@
1+--------------------------------------------------------------------
2+-- |
3+-- Module : Text.XML.Light.Input
4+-- Copyright : (c) Galois, Inc. 2007
5+-- License : BSD3
6+--
7+-- Maintainer: Iavor S. Diatchki <diatchki@galois.com>
8+-- Stability : provisional
9+-- Portability: portable
10+--
11+-- Lightweight XML parsing
12+--
13+
14+module Text.XML.Light.Input (parseXML,parseXMLDoc) where
15+
16+import Text.XML.Light.Types
17+import Text.XML.Light.Proc
18+import Text.XML.Light.Output(tagEnd)
19+
20+import Data.Char(isSpace)
21+import Data.List(isPrefixOf)
22+import Numeric(readHex)
23+
24+-- | parseXMLDoc, parse a XMLl document to maybe an element
25+parseXMLDoc :: String -> Maybe Element
26+parseXMLDoc xs = strip (parseXML xs)
27+ where strip cs = case onlyElems cs of
28+ e : es
29+ | "?xml" `isPrefixOf` qName (elName e)
30+ -> strip (map Elem es)
31+ | otherwise -> Just e
32+ _ -> Nothing
33+
34+-- | parseXML to a list of content chunks
35+parseXML :: String -> [Content]
36+parseXML xs = parse $ tokens $ preprocess xs
37+
38+------------------------------------------------------------------------
39+
40+parse :: [Token] -> [Content]
41+parse [] = []
42+parse ts = let (es,_,ts1) = nodes ([],Nothing) [] ts
43+ in es ++ parse ts1
44+
45+-- Information about namespaces.
46+-- The first component is a map that associates prefixes to URIs,
47+-- the second is the URI for the default namespace, if one was provided.
48+type NSInfo = ([(String,String)],Maybe String)
49+
50+nodes :: NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])
51+
52+nodes ns ps (TokCRef ref : ts) =
53+ let (es,qs,ts1) = nodes ns ps ts
54+ in (CRef ref : es, qs, ts1)
55+
56+nodes ns ps (TokText txt : ts) =
57+ let (es,qs,ts1) = nodes ns ps ts
58+ (more,es1) = case es of
59+ Text cd : es1'
60+ | cdVerbatim cd == cdVerbatim txt -> (cdData cd,es1')
61+ _ -> ([],es)
62+
63+ in (Text txt { cdData = cdData txt ++ more } : es1, qs, ts1)
64+
65+nodes cur_info ps (TokStart p t as empty : ts) = (node : siblings, open, toks)
66+ where
67+ new_name = annotName new_info t
68+ new_info = foldr addNS cur_info as
69+ node = Elem Element { elLine = Just p
70+ , elName = new_name
71+ , elAttribs = map (annotAttr new_info) as
72+ , elContent = children
73+ }
74+
75+ (children,(siblings,open,toks))
76+ | empty = ([], nodes cur_info ps ts)
77+ | otherwise = let (es1,qs1,ts1) = nodes new_info (new_name:ps) ts
78+ in (es1,
79+ case qs1 of
80+ [] -> nodes cur_info ps ts1
81+ _ : qs3 -> ([],qs3,ts1))
82+
83+nodes ns ps (TokEnd p t : ts) = let t1 = annotName ns t
84+ in case break (t1 ==) ps of
85+ (as,_:_) -> ([],as,ts)
86+ -- Unknown closing tag. Insert as text.
87+ (_,[]) ->
88+ let (es,qs,ts1) = nodes ns ps ts
89+ in (Text CData {
90+ cdLine = Just p,
91+ cdVerbatim = CDataText,
92+ cdData = tagEnd t ""
93+ } : es,qs, ts1)
94+
95+nodes _ ps [] = ([],ps,[])
96+
97+
98+annotName :: NSInfo -> QName -> QName
99+annotName (namespaces,def_ns) n =
100+ n { qURI = maybe def_ns (`lookup` namespaces) (qPrefix n) }
101+
102+annotAttr :: NSInfo -> Attr -> Attr
103+annotAttr ns a@(Attr { attrKey = k}) =
104+ case (qPrefix k, qName k) of
105+ (Nothing,"xmlns") -> a
106+ _ -> a { attrKey = annotName ns k }
107+
108+addNS :: Attr -> NSInfo -> NSInfo
109+addNS (Attr { attrKey = key, attrVal = val }) (ns,def) =
110+ case (qPrefix key, qName key) of
111+ (Nothing,"xmlns") -> (ns, if null val then Nothing else Just val)
112+ (Just "xmlns", k) -> ((k, val) : ns, def)
113+ _ -> (ns,def)
114+
115+
116+-- Lexer -----------------------------------------------------------------------
117+
118+type LChar = (Line,Char)
119+type LString = [LChar]
120+data Token = TokStart Line QName [Attr] Bool -- is empty?
121+ | TokEnd Line QName
122+ | TokCRef String
123+ | TokText CData
124+ deriving Show
125+
126+tokens :: String -> [Token]
127+tokens = tokens' . linenumber 1
128+
129+tokens' :: LString -> [Token]
130+tokens' ((_,'<') : c@(_,'!') : cs) = special c cs
131+
132+tokens' ((_,'<') : cs) = tag (dropSpace cs) -- we are being nice here
133+tokens' [] = []
134+tokens' cs@((l,_):_) = let (as,bs) = breakn ('<' ==) cs
135+ in map cvt (decode_text as) ++ tokens' bs
136+
137+ -- XXX: Note, some of the lines might be a bit inacuarate
138+ where cvt (TxtBit x) = TokText CData { cdLine = Just l
139+ , cdVerbatim = CDataText
140+ , cdData = x
141+ }
142+ cvt (CRefBit x) = case cref_to_char x of
143+ Just c -> TokText CData { cdLine = Just l
144+ , cdVerbatim = CDataText
145+ , cdData = [c]
146+ }
147+ Nothing -> TokCRef x
148+
149+
150+special :: LChar -> LString -> [Token]
151+special _ ((_,'-') : (_,'-') : cs) = skip cs
152+ where skip ((_,'-') : (_,'-') : (_,'>') : ds) = tokens' ds
153+ skip (_ : ds) = skip ds
154+ skip [] = [] -- unterminated comment
155+
156+special c ((_,'[') : (_,'C') : (_,'D') : (_,'A') : (_,'T') : (_,'A') : (_,'[')
157+ : cs) =
158+ let (xs,ts) = cdata cs
159+ in TokText CData { cdLine = Just (fst c), cdVerbatim = CDataVerbatim, cdData = xs }
160+ : tokens' ts
161+ where cdata ((_,']') : (_,']') : (_,'>') : ds) = ([],ds)
162+ cdata ((_,d) : ds) = let (xs,ys) = cdata ds in (d:xs,ys)
163+ cdata [] = ([],[])
164+
165+special c cs =
166+ let (xs,ts) = munch "" 0 cs
167+ in TokText CData { cdLine = Just (fst c), cdVerbatim = CDataRaw, cdData = '<':'!':(reverse xs) } : tokens' ts
168+ where munch acc nesting ((_,'>') : ds)
169+ | nesting == (0::Int) = ('>':acc,ds)
170+ | otherwise = munch ('>':acc) (nesting-1) ds
171+ munch acc nesting ((_,'<') : ds)
172+ = munch ('<':acc) (nesting+1) ds
173+ munch acc n ((_,x) : ds) = munch (x:acc) n ds
174+ munch acc _ [] = (acc,[]) -- unterminated DTD markup
175+
176+--special c cs = tag (c : cs) -- invalid specials are processed as tags
177+
178+
179+qualName :: LString -> (QName,LString)
180+qualName xs = let (as,bs) = breakn endName xs
181+ (q,n) = case break (':'==) as of
182+ (q1,_:n1) -> (Just q1, n1)
183+ _ -> (Nothing, as)
184+ in (QName { qURI = Nothing, qPrefix = q, qName = n }, bs)
185+ where endName x = isSpace x || x == '=' || x == '>' || x == '/'
186+
187+
188+
189+
190+
191+tag :: LString -> [Token]
192+tag ((p,'/') : cs) = let (n,ds) = qualName (dropSpace cs)
193+ in TokEnd p n : case ds of
194+ (_,'>') : es -> tokens' es
195+ -- tag was not properly closed...
196+ _ -> tokens' ds
197+tag [] = []
198+tag cs = let (n,ds) = qualName cs
199+ (as,b,ts) = attribs (dropSpace ds)
200+ in TokStart (fst (head cs)) n as b : ts
201+
202+attribs :: LString -> ([Attr], Bool, [Token])
203+attribs cs = case cs of
204+ (_,'>') : ds -> ([], False, tokens' ds)
205+
206+ (_,'/') : ds -> ([], True, case ds of
207+ (_,'>') : es -> tokens' es
208+ -- insert missing > ...
209+ _ -> tokens' ds)
210+
211+ (_,'?') : (_,'>') : ds -> ([], True, tokens' ds)
212+
213+ -- doc ended within a tag..
214+ [] -> ([],False,[])
215+
216+ _ -> let (a,cs1) = attrib cs
217+ (as,b,ts) = attribs cs1
218+ in (a:as,b,ts)
219+
220+attrib :: LString -> (Attr,LString)
221+attrib cs = let (ks,cs1) = qualName cs
222+ (vs,cs2) = attr_val (dropSpace cs1)
223+ in ((Attr ks (decode_attr vs)),dropSpace cs2)
224+
225+attr_val :: LString -> (String,LString)
226+attr_val ((_,'=') : cs) = string (dropSpace cs)
227+attr_val cs = ("",cs)
228+
229+
230+dropSpace :: LString -> LString
231+dropSpace = dropWhile (isSpace . snd)
232+
233+-- | Match the value for an attribute. For malformed XML we do
234+-- our best to guess the programmer's intention.
235+string :: LString -> (String,LString)
236+string ((_,'"') : cs) = break' ('"' ==) cs
237+
238+-- Allow attributes to be enclosed between ' '.
239+string ((_,'\'') : cs) = break' ('\'' ==) cs
240+
241+-- Allow attributes that are not enclosed by anything.
242+string cs = breakn eos cs
243+ where eos x = isSpace x || x == '>' || x == '/'
244+
245+
246+break' :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)])
247+break' p xs = let (as,bs) = breakn p xs
248+ in (as, case bs of
249+ [] -> []
250+ _ : cs -> cs)
251+
252+breakn :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)])
253+breakn p l = (map snd as,bs) where (as,bs) = break (p . snd) l
254+
255+
256+
257+decode_attr :: String -> String
258+decode_attr cs = concatMap cvt (decode_text cs)
259+ where cvt (TxtBit x) = x
260+ cvt (CRefBit x) = case cref_to_char x of
261+ Just c -> [c]
262+ Nothing -> '&' : x ++ ";"
263+
264+data Txt = TxtBit String | CRefBit String deriving Show
265+
266+decode_text :: [Char] -> [Txt]
267+decode_text xs@('&' : cs) = case break (';' ==) cs of
268+ (as,_:bs) -> CRefBit as : decode_text bs
269+ _ -> [TxtBit xs]
270+decode_text [] = []
271+decode_text cs = let (as,bs) = break ('&' ==) cs
272+ in TxtBit as : decode_text bs
273+
274+cref_to_char :: [Char] -> Maybe Char
275+cref_to_char cs = case cs of
276+ '#' : ds -> num_esc ds
277+ "lt" -> Just '<'
278+ "gt" -> Just '>'
279+ "amp" -> Just '&'
280+ "apos" -> Just '\''
281+ "quot" -> Just '"'
282+ _ -> Nothing
283+
284+num_esc :: String -> Maybe Char
285+num_esc cs = case cs of
286+ 'x' : ds -> check (readHex ds)
287+ _ -> check (reads cs)
288+
289+ where check [(n,"")] = cvt_char n
290+ check _ = Nothing
291+
292+cvt_char :: Int -> Maybe Char
293+cvt_char x
294+ | fromEnum (minBound :: Char) <= x && x <= fromEnum (maxBound::Char)
295+ = Just (toEnum x)
296+ | otherwise = Nothing
297+
298+preprocess :: String -> String
299+preprocess ('\r' : '\n' : cs) = '\n' : preprocess cs
300+preprocess ('\r' : cs) = '\n' : preprocess cs
301+preprocess (c : cs) = c : preprocess cs
302+preprocess [] = []
303+
304+linenumber :: Line -> String -> LString
305+linenumber _ [] = []
306+linenumber n ('\n':s) = n' `seq` ((n,'\n'):linenumber n' s) where n' = n + 1
307+linenumber n (c:s) = (n,c) : linenumber n s