git.iko.soy/typeable/pandoc
on master help sign in
Added code for xml library (Text.XML.Light) to source tree,
0c6dd10fiddlosopher
Text/XML/Light.hsnew file+96
compare with master
unifiedsplit
@@ -0,0 +1,96 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+--------------------------------------------------------------------
3+-- |
4+-- Module : Text.XML.Light
5+-- Copyright : (c) Galois, Inc. 2007
6+-- License : BSD3
7+--
8+-- Maintainer: Iavor S. Diatchki <diatchki@galois.com>
9+-- Stability : provisional
10+-- Portability: portability
11+--
12+-- A lightweight XML parsing, filtering and generating library.
13+--
14+-- This module reexports functions from:
15+--
16+-- * "Text.XML.Light.Types"
17+--
18+-- * "Text.XML.Light.Proc"
19+--
20+-- * "Text.XML.Light.Input"
21+--
22+-- * "Text.XML.Light.Output"
23+--
24+
25+module Text.XML.Light (
26+
27+ module Text.XML.Light,
28+ module Text.XML.Light.Types,
29+ module Text.XML.Light.Proc,
30+ module Text.XML.Light.Input,
31+ module Text.XML.Light.Output
32+
33+ ) where
34+
35+import Text.XML.Light.Types
36+import Text.XML.Light.Proc
37+import Text.XML.Light.Input
38+import Text.XML.Light.Output
39+
40+-- | Add an attribute to an element.
41+add_attr :: Attr -> Element -> Element
42+add_attr a e = add_attrs [a] e
43+
44+-- | Add some attributes to an element.
45+add_attrs :: [Attr] -> Element -> Element
46+add_attrs as e = e { elAttribs = as ++ elAttribs e }
47+
48+-- | Create an unqualified name.
49+unqual :: String -> QName
50+unqual x = blank_name { qName = x }
51+
52+-- | A smart element constructor which uses the type of its argument
53+-- to determine what sort of element to make.
54+class Node t where
55+ node :: QName -> t -> Element
56+
57+instance Node ([Attr],[Content]) where
58+ node n (attrs,cont) = blank_element { elName = n
59+ , elAttribs = attrs
60+ , elContent = cont
61+ }
62+
63+instance Node [Attr] where node n as = node n (as,[]::[Content])
64+instance Node Attr where node n a = node n [a]
65+instance Node () where node n () = node n ([]::[Attr])
66+
67+instance Node [Content] where node n cs = node n ([]::[Attr],cs)
68+instance Node Content where node n c = node n [c]
69+instance Node ([Attr],Content) where node n (as,c) = node n (as,[c])
70+instance Node (Attr,Content) where node n (a,c) = node n ([a],[c])
71+
72+instance Node ([Attr],[Element]) where
73+ node n (as,cs) = node n (as,map Elem cs)
74+
75+instance Node ([Attr],Element) where node n (as,c) = node n (as,[c])
76+instance Node (Attr,Element) where node n (a,c) = node n ([a],c)
77+instance Node ([Element]) where node n es = node n ([]::[Attr],es)
78+instance Node (Element) where node n e = node n [e]
79+
80+instance Node ([Attr],[CData]) where
81+ node n (as,cs) = node n (as,map Text cs)
82+
83+instance Node ([Attr],CData) where node n (as,c) = node n (as,[c])
84+instance Node (Attr,CData) where node n (a,c) = node n ([a],c)
85+instance Node [CData] where node n es = node n ([]::[Attr],es)
86+instance Node CData where node n e = node n [e]
87+
88+instance Node ([Attr],String) where
89+ node n (as,t) = node n (as,blank_cdata { cdData = t })
90+
91+instance Node (Attr,String) where node n (a,t) = node n ([a],t)
92+instance Node [Char] where node n t = node n ([]::[Attr],t)
93+
94+-- | Create node with unqualified name
95+unode :: Node t => String -> t -> Element
96+unode = node . unqual
Text/XML/Light/Cursor.hsnew file+327
@@ -0,0 +1,327 @@
1+--------------------------------------------------------------------
2+-- |
3+-- Module : Text.XML.Light.Cursor
4+-- Copyright : (c) Galois, Inc. 2008
5+-- License : BSD3
6+--
7+-- Maintainer: Iavor S. Diatchki <diatchki@galois.com>
8+-- Stability : provisional
9+-- Portability:
10+--
11+-- XML cursors for working XML content withing the context of
12+-- an XML document. This implemntation is based on the general
13+-- tree zipper written by Krasimir Angelov and Iavor S. Diatchki.
14+--
15+
16+module Text.XML.Light.Cursor
17+ ( Tag(..), getTag, setTag, fromTag
18+ , Cursor(..), Path
19+
20+ -- * Conversions
21+ , fromContent
22+ , fromElement
23+ , fromForest
24+ , toForest
25+ , toTree
26+
27+ -- * Moving around
28+ , parent
29+ , root
30+ , getChild
31+ , firstChild
32+ , lastChild
33+ , left
34+ , right
35+
36+ -- ** Searching
37+ , findChild
38+ , findLeft
39+ , findRight
40+
41+ -- * Node classification
42+ , isRoot
43+ , isFirst
44+ , isLast
45+ , isLeaf
46+ , isChild
47+ , hasChildren
48+ , getNodeIndex
49+
50+ -- * Updates
51+ , setContent
52+ , modifyContent
53+ , modifyContentM
54+
55+ -- ** Inserting content
56+ , insertLeft
57+ , insertRight
58+ , insertGoLeft
59+ , insertGoRight
60+
61+ -- ** Removing content
62+ , removeLeft
63+ , removeRight
64+ , removeGoLeft
65+ , removeGoRight
66+ , removeGoUp
67+
68+ ) where
69+
70+import Text.XML.Light.Types
71+import Data.Maybe(isNothing)
72+
73+data Tag = Tag { tagName :: QName
74+ , tagAttribs :: [Attr]
75+ , tagLine :: Maybe Line
76+ } deriving (Show)
77+
78+getTag :: Element -> Tag
79+getTag e = Tag { tagName = elName e
80+ , tagAttribs = elAttribs e
81+ , tagLine = elLine e
82+ }
83+
84+setTag :: Tag -> Element -> Element
85+setTag t e = fromTag t (elContent e)
86+
87+fromTag :: Tag -> [Content] -> Element
88+fromTag t cs = Element { elName = tagName t
89+ , elAttribs = tagAttribs t
90+ , elLine = tagLine t
91+ , elContent = cs
92+ }
93+
94+type Path = [([Content],Tag,[Content])]
95+
96+-- | The position of a piece of content in an XML document.
97+data Cursor = Cur
98+ { current :: Content -- ^ The currently selected content.
99+ , lefts :: [Content] -- ^ Siblings on the left, closest first.
100+ , rights :: [Content] -- ^ Siblings on the right, closest first.
101+ , parents :: Path -- ^ The contexts of the parent elements of this location.
102+ } deriving (Show)
103+
104+-- Moving around ---------------------------------------------------------------
105+
106+-- | The parent of the given location.
107+parent :: Cursor -> Maybe Cursor
108+parent loc =
109+ case parents loc of
110+ (pls,v,prs) : ps -> Just
111+ Cur { current = Elem
112+ (fromTag v
113+ (combChildren (lefts loc) (current loc) (rights loc)))
114+ , lefts = pls, rights = prs, parents = ps
115+ }
116+ [] -> Nothing
117+
118+
119+-- | The top-most parent of the given location.
120+root :: Cursor -> Cursor
121+root loc = maybe loc root (parent loc)
122+
123+-- | The left sibling of the given location.
124+left :: Cursor -> Maybe Cursor
125+left loc =
126+ case lefts loc of
127+ t : ts -> Just loc { current = t, lefts = ts
128+ , rights = current loc : rights loc }
129+ [] -> Nothing
130+
131+-- | The right sibling of the given location.
132+right :: Cursor -> Maybe Cursor
133+right loc =
134+ case rights loc of
135+ t : ts -> Just loc { current = t, lefts = current loc : lefts loc
136+ , rights = ts }
137+ [] -> Nothing
138+
139+-- | The first child of the given location.
140+firstChild :: Cursor -> Maybe Cursor
141+firstChild loc =
142+ do (t : ts, ps) <- downParents loc
143+ return Cur { current = t, lefts = [], rights = ts , parents = ps }
144+
145+-- | The last child of the given location.
146+lastChild :: Cursor -> Maybe Cursor
147+lastChild loc =
148+ do (ts, ps) <- downParents loc
149+ case reverse ts of
150+ l : ls -> return Cur { current = l, lefts = ls, rights = []
151+ , parents = ps }
152+ [] -> Nothing
153+
154+-- | Find the next left sibling that satisfies a predicate.
155+findLeft :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
156+findLeft p loc = do loc1 <- left loc
157+ if p loc1 then return loc1 else findLeft p loc1
158+
159+-- | Find the next right sibling that satisfies a predicate.
160+findRight :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
161+findRight p loc = do loc1 <- right loc
162+ if p loc1 then return loc1 else findRight p loc1
163+
164+-- | The first child that satisfies a predicate.
165+findChild :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
166+findChild p loc =
167+ do loc1 <- firstChild loc
168+ if p loc1 then return loc1 else findRight p loc1
169+
170+-- | The child with the given index (starting from 0).
171+getChild :: Int -> Cursor -> Maybe Cursor
172+getChild n loc =
173+ do (ts,ps) <- downParents loc
174+ (ls,t,rs) <- splitChildren ts n
175+ return Cur { current = t, lefts = ls, rights = rs, parents = ps }
176+
177+
178+-- | private: computes the parent for "down" operations.
179+downParents :: Cursor -> Maybe ([Content], Path)
180+downParents loc =
181+ case current loc of
182+ Elem e -> Just ( elContent e
183+ , (lefts loc, getTag e, rights loc) : parents loc
184+ )
185+ _ -> Nothing
186+
187+-- Conversions -----------------------------------------------------------------
188+
189+-- | A cursor for the guven content.
190+fromContent :: Content -> Cursor
191+fromContent t = Cur { current = t, lefts = [], rights = [], parents = [] }
192+
193+-- | A cursor for the guven element.
194+fromElement :: Element -> Cursor
195+fromElement e = fromContent (Elem e)
196+
197+-- | The location of the first tree in a forest.
198+fromForest :: [Content] -> Maybe Cursor
199+fromForest (t:ts) = Just Cur { current = t, lefts = [], rights = ts
200+ , parents = [] }
201+fromForest [] = Nothing
202+
203+-- | Computes the tree containing this location.
204+toTree :: Cursor -> Content
205+toTree loc = current (root loc)
206+
207+-- | Computes the forest containing this location.
208+toForest :: Cursor -> [Content]
209+toForest loc = let r = root loc in combChildren (lefts r) (current r) (rights r)
210+
211+
212+-- Queries ---------------------------------------------------------------------
213+
214+-- | Are we at the top of the document?
215+isRoot :: Cursor -> Bool
216+isRoot loc = null (parents loc)
217+
218+-- | Are we at the left end of the the document?
219+isFirst :: Cursor -> Bool
220+isFirst loc = null (lefts loc)
221+
222+-- | Are we at the right end of the document?
223+isLast :: Cursor -> Bool
224+isLast loc = null (rights loc)
225+
226+-- | Are we at the bottom of the document?
227+isLeaf :: Cursor -> Bool
228+isLeaf loc = isNothing (downParents loc)
229+
230+-- | Do we have a parent?
231+isChild :: Cursor -> Bool
232+isChild loc = not (isRoot loc)
233+
234+-- | Get the node index inside the sequence of children
235+getNodeIndex :: Cursor -> Int
236+getNodeIndex loc = length (lefts loc)
237+
238+-- | Do we have children?
239+hasChildren :: Cursor -> Bool
240+hasChildren loc = not (isLeaf loc)
241+
242+
243+
244+-- Updates ---------------------------------------------------------------------
245+
246+-- | Change the current content.
247+setContent :: Content -> Cursor -> Cursor
248+setContent t loc = loc { current = t }
249+
250+-- | Modify the current content.
251+modifyContent :: (Content -> Content) -> Cursor -> Cursor
252+modifyContent f loc = setContent (f (current loc)) loc
253+
254+-- | Modify the current content, allowing for an effect.
255+modifyContentM :: Monad m => (Content -> m Content) -> Cursor -> m Cursor
256+modifyContentM f loc = do x <- f (current loc)
257+ return (setContent x loc)
258+
259+-- | Insert content to the left of the current position.
260+insertLeft :: Content -> Cursor -> Cursor
261+insertLeft t loc = loc { lefts = t : lefts loc }
262+
263+-- | Insert content to the right of the current position.
264+insertRight :: Content -> Cursor -> Cursor
265+insertRight t loc = loc { rights = t : rights loc }
266+
267+-- | Remove the conent on the left of the current position, if any.
268+removeLeft :: Cursor -> Maybe (Content,Cursor)
269+removeLeft loc = case lefts loc of
270+ l : ls -> return (l,loc { lefts = ls })
271+ [] -> Nothing
272+
273+-- | Remove the conent on the right of the current position, if any.
274+removeRight :: Cursor -> Maybe (Content,Cursor)
275+removeRight loc = case rights loc of
276+ l : ls -> return (l,loc { rights = ls })
277+ [] -> Nothing
278+
279+
280+-- | Insert content to the left of the current position.
281+-- The new content becomes the current position.
282+insertGoLeft :: Content -> Cursor -> Cursor
283+insertGoLeft t loc = loc { current = t, rights = current loc : rights loc }
284+
285+-- | Insert content to the right of the current position.
286+-- The new content becomes the current position.
287+insertGoRight :: Content -> Cursor -> Cursor
288+insertGoRight t loc = loc { current = t, lefts = current loc : lefts loc }
289+
290+-- | Remove the current element.
291+-- The new position is the one on the left.
292+removeGoLeft :: Cursor -> Maybe Cursor
293+removeGoLeft loc = case lefts loc of
294+ l : ls -> Just loc { current = l, lefts = ls }
295+ [] -> Nothing
296+
297+-- | Remove the current element.
298+-- The new position is the one on the right.
299+removeGoRight :: Cursor -> Maybe Cursor
300+removeGoRight loc = case rights loc of
301+ l : ls -> Just loc { current = l, rights = ls }
302+ [] -> Nothing
303+
304+-- | Remove the current element.
305+-- The new position is the parent of the old position.
306+removeGoUp :: Cursor -> Maybe Cursor
307+removeGoUp loc =
308+ case parents loc of
309+ (pls,v,prs) : ps -> Just
310+ Cur { current = Elem (fromTag v (reverse (lefts loc) ++ rights loc))
311+ , lefts = pls, rights = prs, parents = ps
312+ }
313+ [] -> Nothing
314+
315+
316+-- | private: Gets the given element of a list.
317+-- Also returns the preceeding elements (reversed) and the folloing elements.
318+splitChildren :: [a] -> Int -> Maybe ([a],a,[a])
319+splitChildren _ n | n < 0 = Nothing
320+splitChildren cs pos = loop [] cs pos
321+ where loop acc (x:xs) 0 = Just (acc,x,xs)
322+ loop acc (x:xs) n = loop (x:acc) xs $! n-1
323+ loop _ _ _ = Nothing
324+
325+-- | private: combChildren ls x ys = reverse ls ++ [x] ++ ys
326+combChildren :: [a] -> a -> [a] -> [a]
327+combChildren ls t rs = foldl (flip (:)) (t:rs) ls
Text/XML/Light/Input.hsnew file+307
@@ -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
Text/XML/Light/Output.hsnew file+150
@@ -0,0 +1,150 @@
1+--------------------------------------------------------------------
2+-- |
3+-- Module : Text.XML.Light.Output
4+-- Copyright : (c) Galois, Inc. 2007
5+-- License : BSD3
6+--
7+-- Maintainer: Iavor S. Diatchki <diatchki@galois.com>
8+-- Stability : provisional
9+-- Portability:
10+--
11+-- Output handling for the lightweight XML lib.
12+--
13+
14+module Text.XML.Light.Output
15+ ( showTopElement, showContent, showElement, showCData, showQName, showAttr
16+ , ppTopElement, ppContent, ppElement
17+ , tagEnd, xml_header
18+ ) where
19+
20+import Text.XML.Light.Types
21+import Data.Char
22+import Data.List ( isPrefixOf )
23+
24+-- | The XML 1.0 header
25+xml_header :: String
26+xml_header = "<?xml version='1.0' ?>"
27+
28+-- | Pretty printing renders XML documents faithfully,
29+-- with the exception that whitespace may be added\/removed
30+-- in non-verbatim character data.
31+ppTopElement :: Element -> String
32+ppTopElement e = unlines [xml_header,ppElement e]
33+
34+-- | Pretty printing elements
35+ppElement :: Element -> String
36+ppElement e = ppElementS "" e ""
37+
38+-- | Pretty printing content
39+ppContent :: Content -> String
40+ppContent x = ppContentS "" x ""
41+
42+-- | Pretty printing content using ShowS
43+ppContentS :: String -> Content -> ShowS
44+ppContentS i x xs = case x of
45+ Elem e -> ppElementS i e xs
46+ Text c -> ppCData i c xs
47+ CRef r -> showCRefS r xs
48+
49+ppElementS :: String -> Element -> ShowS
50+ppElementS i e xs = i ++ (tagStart (elName e) (elAttribs e) $
51+ case elContent e of
52+ []
53+ | not ("?xml" `isPrefixOf` (qName $ elName e)) -> " />" ++ xs
54+ | otherwise -> " ?>" ++ xs
55+ [Text t] -> ">" ++ ppCData "" t (tagEnd (elName e) xs)
56+ cs -> ">\n" ++ foldr ppSub (i ++ tagEnd (elName e) xs) cs
57+ where ppSub e1 = ppContentS (" " ++ i) e1 . showChar '\n'
58+ )
59+
60+ppCData :: String -> CData -> ShowS
61+ppCData i c xs = i ++ if (cdVerbatim c /= CDataText )
62+ then showCDataS c xs
63+ else foldr cons xs (showCData c)
64+
65+ where cons :: Char -> String -> String
66+ cons '\n' ys = "\n" ++ i ++ ys
67+ cons y ys = y : ys
68+
69+
70+
71+--------------------------------------------------------------------------------
72+-- | Adds the <?xml?> header.
73+showTopElement :: Element -> String
74+showTopElement c = xml_header ++ showElement c
75+
76+showContent :: Content -> String
77+showContent c = showContentS c ""
78+
79+showElement :: Element -> String
80+showElement c = showElementS c ""
81+
82+showCData :: CData -> String
83+showCData c = showCDataS c ""
84+
85+-- Note: crefs should not contain '&', ';', etc.
86+showCRefS :: String -> ShowS
87+showCRefS r xs = '&' : r ++ ';' : xs
88+
89+-- | Good for transmition (no extra white space etc.) but less readable.
90+showContentS :: Content -> ShowS
91+showContentS (Elem e) = showElementS e
92+showContentS (Text cs) = showCDataS cs
93+showContentS (CRef cs) = showCRefS cs
94+
95+-- | Good for transmition (no extra white space etc.) but less readable.
96+showElementS :: Element -> ShowS
97+showElementS e xs =
98+ tagStart (elName e) (elAttribs e)
99+ $ case elContent e of
100+ [] -> " />" ++ xs
101+ ch -> '>' : foldr showContentS (tagEnd (elName e) xs) ch
102+
103+-- | Convert a text element to characters.
104+showCDataS :: CData -> ShowS
105+showCDataS cd =
106+ case cdVerbatim cd of
107+ CDataText -> escStr (cdData cd)
108+ CDataVerbatim -> showString "<![CDATA[" . escCData (cdData cd) . showString "]]>"
109+ CDataRaw -> \ xs -> cdData cd ++ xs
110+
111+--------------------------------------------------------------------------------
112+escCData :: String -> ShowS
113+escCData (']' : ']' : '>' : cs) = showString "]]]]><![CDATA[>" . escCData cs
114+escCData (c : cs) = showChar c . escCData cs
115+escCData [] = id
116+
117+escChar :: Char -> ShowS
118+escChar c = case c of
119+ '<' -> showString "&lt;"
120+ '>' -> showString "&gt;"
121+ '&' -> showString "&amp;"
122+ '"' -> showString "&quot;"
123+ '\'' -> showString "&apos;"
124+ -- XXX: Is this really wortherd?
125+ -- We could deal with these issues when we convert characters to bytes.
126+ _ | (oc <= 0x7f && isPrint c) || c == '\n' || c == '\r' -> showChar c
127+ | otherwise -> showString "&#" . shows oc . showChar ';'
128+ where oc = ord c
129+
130+escStr :: String -> ShowS
131+escStr cs rs = foldr escChar rs cs
132+
133+tagEnd :: QName -> ShowS
134+tagEnd qn rs = '<':'/':showQName qn ++ '>':rs
135+
136+tagStart :: QName -> [Attr] -> ShowS
137+tagStart qn as rs = '<':showQName qn ++ as_str ++ rs
138+ where as_str = if null as then "" else ' ' : unwords (map showAttr as)
139+
140+showAttr :: Attr -> String
141+showAttr (Attr qn v) = showQName qn ++ '=' : '"' : escStr v "\""
142+
143+showQName :: QName -> String
144+showQName q = pre ++ qName q
145+ where pre = case qPrefix q of
146+ Nothing -> ""
147+ Just p -> p ++ ":"
148+
149+
150+
Text/XML/Light/Proc.hsnew file+103
@@ -0,0 +1,103 @@
1+--------------------------------------------------------------------
2+-- |
3+-- Module : Text.XML.Light.Proc
4+-- Copyright : (c) Galois, Inc. 2007
5+-- License : BSD3
6+--
7+-- Maintainer: Iavor S. Diatchki <diatchki@galois.com>
8+-- Stability : provisional
9+-- Portability:
10+--
11+--------------------------------------------------------------------
12+
13+
14+module Text.XML.Light.Proc where
15+
16+import Text.XML.Light.Types
17+
18+import Data.Maybe(listToMaybe)
19+import Data.List(find)
20+
21+-- | Get the text value of an XML element. This function
22+-- ignores non-text elements, and concatenates all text elements.
23+strContent :: Element -> String
24+strContent e = concatMap cdData $ onlyText $ elContent e
25+
26+-- | Select only the elements from a list of XML content.
27+onlyElems :: [Content] -> [Element]
28+onlyElems xs = [ x | Elem x <- xs ]
29+
30+-- | Select only the elements from a parent.
31+elChildren :: Element -> [Element]
32+elChildren e = [ x | Elem x <- elContent e ]
33+
34+-- | Select only the text from a list of XML content.
35+onlyText :: [Content] -> [CData]
36+onlyText xs = [ x | Text x <- xs ]
37+
38+-- | Find all immediate children with the given name.
39+findChildren :: QName -> Element -> [Element]
40+findChildren q e = filterChildren ((q ==) . elName) e
41+
42+-- | Filter all immediate children wrt a given predicate.
43+filterChildren :: (Element -> Bool) -> Element -> [Element]
44+filterChildren p e = filter p (onlyElems (elContent e))
45+
46+
47+-- | Filter all immediate children wrt a given predicate over their names.
48+filterChildrenName :: (QName -> Bool) -> Element -> [Element]
49+filterChildrenName p e = filter (p.elName) (onlyElems (elContent e))
50+
51+
52+-- | Find an immediate child with the given name.
53+findChild :: QName -> Element -> Maybe Element
54+findChild q e = listToMaybe (findChildren q e)
55+
56+-- | Find an immediate child with the given name.
57+filterChild :: (Element -> Bool) -> Element -> Maybe Element
58+filterChild p e = listToMaybe (filterChildren p e)
59+
60+-- | Find an immediate child with name matching a predicate.
61+filterChildName :: (QName -> Bool) -> Element -> Maybe Element
62+filterChildName p e = listToMaybe (filterChildrenName p e)
63+
64+-- | Find the left-most occurrence of an element matching given name.
65+findElement :: QName -> Element -> Maybe Element
66+findElement q e = listToMaybe (findElements q e)
67+
68+-- | Filter the left-most occurrence of an element wrt. given predicate.
69+filterElement :: (Element -> Bool) -> Element -> Maybe Element
70+filterElement p e = listToMaybe (filterElements p e)
71+
72+-- | Filter the left-most occurrence of an element wrt. given predicate.
73+filterElementName :: (QName -> Bool) -> Element -> Maybe Element
74+filterElementName p e = listToMaybe (filterElementsName p e)
75+
76+-- | Find all non-nested occurances of an element.
77+-- (i.e., once we have found an element, we do not search
78+-- for more occurances among the element's children).
79+findElements :: QName -> Element -> [Element]
80+findElements qn e = filterElementsName (qn==) e
81+
82+-- | Find all non-nested occurrences of an element wrt. given predicate.
83+-- (i.e., once we have found an element, we do not search
84+-- for more occurances among the element's children).
85+filterElements :: (Element -> Bool) -> Element -> [Element]
86+filterElements p e
87+ | p e = [e]
88+ | otherwise = concatMap (filterElements p) $ onlyElems $ elContent e
89+
90+-- | Find all non-nested occurences of an element wrt a predicate over element names.
91+-- (i.e., once we have found an element, we do not search
92+-- for more occurances among the element's children).
93+filterElementsName :: (QName -> Bool) -> Element -> [Element]
94+filterElementsName p e = filterElements (p.elName) e
95+
96+-- | Lookup the value of an attribute.
97+findAttr :: QName -> Element -> Maybe String
98+findAttr x e = attrVal `fmap` find ((x ==) . attrKey) (elAttribs e)
99+
100+-- | Lookup attribute name from list.
101+lookupAttr :: QName -> [Attr] -> Maybe String
102+lookupAttr x as = attrVal `fmap` find ((x ==) . attrKey) as
103+
Text/XML/Light/Types.hsnew file+91
@@ -0,0 +1,91 @@
1+--------------------------------------------------------------------
2+-- |
3+-- Module : Text.XML.Light.Types
4+-- Copyright : (c) Galois, Inc. 2007
5+-- License : BSD3
6+--
7+-- Maintainer: Iavor S. Diatchki <diatchki@galois.com>
8+-- Stability : provisional
9+-- Portability:
10+--
11+-- Basic XML types.
12+--
13+
14+module Text.XML.Light.Types where
15+
16+-- | A line is an Integer
17+type Line = Integer
18+
19+-- | XML content
20+data Content = Elem Element
21+ | Text CData
22+ | CRef String
23+ deriving Show
24+
25+-- | XML elements
26+data Element = Element {
27+ elName :: QName,
28+ elAttribs :: [Attr],
29+ elContent :: [Content],
30+ elLine :: Maybe Line
31+ } deriving Show
32+
33+-- | XML attributes
34+data Attr = Attr {
35+ attrKey :: QName,
36+ attrVal :: String
37+ } deriving (Eq,Ord,Show)
38+
39+-- | XML CData
40+data CData = CData {
41+ cdVerbatim :: CDataKind,
42+ cdData :: String,
43+ cdLine :: Maybe Line
44+ } deriving Show
45+
46+data CDataKind
47+ = CDataText -- ^ Ordinary character data; pretty printer escapes &, < etc.
48+ | CDataVerbatim -- ^ Unescaped character data; pretty printer embeds it in <![CDATA[..
49+ | CDataRaw -- ^ As-is character data; pretty printer passes it along without any escaping or CDATA wrap-up.
50+ deriving ( Eq, Show )
51+
52+-- | XML qualified names
53+data QName = QName {
54+ qName :: String,
55+ qURI :: Maybe String,
56+ qPrefix :: Maybe String
57+ } deriving Show
58+
59+
60+instance Eq QName where
61+ q1 == q2 = compare q1 q2 == EQ
62+
63+instance Ord QName where
64+ compare q1 q2 =
65+ case compare (qName q1) (qName q2) of
66+ EQ -> case (qURI q1, qURI q2) of
67+ (Nothing,Nothing) -> compare (qPrefix q1) (qPrefix q2)
68+ (u1,u2) -> compare u1 u2
69+ x -> x
70+
71+
72+-- blank elements --------------------------------------------------------------
73+
74+-- | Blank names
75+blank_name :: QName
76+blank_name = QName { qName = "", qURI = Nothing, qPrefix = Nothing }
77+
78+-- | Blank cdata
79+blank_cdata :: CData
80+blank_cdata = CData { cdVerbatim = CDataText, cdData = "", cdLine = Nothing }
81+
82+-- | Blank elements
83+blank_element :: Element
84+blank_element = Element
85+ { elName = blank_name
86+ , elAttribs = []
87+ , elContent = []
88+ , elLine = Nothing
89+ }
90+
91+
debian/copyright+33
@@ -50,3 +50,36 @@ by Eric A. Meyer
50<http://meyerweb.com/eric/tools/s5
50<http://meyerweb.com/eric/tools/s5
51
51
52Released under an explicit Public Domain License
52Released under an explicit Public Domain License
53+
54+----------------------------------------------------------------------
55+Text/XML/Light/*
56+(c) 2007 Galois Inc.
57+
58+All rights reserved.
59+
60+Redistribution and use in source and binary forms, with or without
61+modification, are permitted provided that the following conditions
62+are met:
63+
64+1. Redistributions of source code must retain the above copyright
65+notice, this list of conditions and the following disclaimer.
66+
67+2. Redistributions in binary form must reproduce the above copyright
68+notice, this list of conditions and the following disclaimer in the
69+documentation and/or other materials provided with the distribution.
70+
71+3. Neither the name of the author nor the names of his contributors
72+may be used to endorse or promote products derived from this software
73+without specific prior written permission.
74+
75+THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
76+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
77+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
78+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
79+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
80+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
81+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
82+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
83+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
84+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
85+POSSIBILITY OF SUCH DAMAGE.
pandoc.cabal+9−4
@@ -79,8 +79,7 @@ Library
79 if flag(highlighting)
79 if flag(highlighting)
80 Build-depends: highlighting-kate
80 Build-depends: highlighting-kate
81 cpp-options: -DHIGHLIGHTING
81 cpp-options: -DHIGHLIGHTING
82− Build-Depends: parsec < 3, xhtml, mtl, network, filepath, process, directory, xml,
82+ Build-Depends: parsec < 3, xhtml, mtl, network, filepath, process, directory, utf8-string
83− utf8-string
84 Hs-Source-Dirs: .
83 Hs-Source-Dirs: .
85 Exposed-Modules: Text.Pandoc,
84 Exposed-Modules: Text.Pandoc,
86 Text.Pandoc.Blocks,
85 Text.Pandoc.Blocks,
@@ -108,10 +107,16 @@ Library
108 Text.Pandoc.Writers.MediaWiki,
107 Text.Pandoc.Writers.MediaWiki,
109 Text.Pandoc.Writers.RTF,
108 Text.Pandoc.Writers.RTF,
110 Text.Pandoc.Writers.S5
109 Text.Pandoc.Writers.S5
111− Other-Modules: Text.Pandoc.XML
110+ Other-Modules: Text.Pandoc.XML,
111+ Text.XML.Light,
112+ Text.XML.Light.Types,
113+ Text.XML.Light.Output,
114+ Text.XML.Light.Input,
115+ Text.XML.Light.Cursor
112 Ghc-Options: -O2 -Wall -threaded
116 Ghc-Options: -O2 -Wall -threaded
113 Ghc-Prof-Options: -auto-all
117 Ghc-Prof-Options: -auto-all
114− Extensions: CPP
118+ Extensions: CPP, FlexibleInstances
119+ -- FlexibleInstances needed for Text.XML.Light
115
120
116 if flag(library)
121 if flag(library)
117 Buildable: True
122 Buildable: True