diff --git a/HaXml.cabal b/HaXml.cabal --- a/HaXml.cabal +++ b/HaXml.cabal @@ -1,5 +1,5 @@ name: HaXml -version: 1.19.4 +version: 1.19.5 license: LGPL license-file: COPYRIGHT author: Malcolm Wallace @@ -50,7 +50,7 @@ Text.XML.HaXml.Xtract.Lex, Text.XML.HaXml.Xtract.Parse hs-source-dirs: src - build-depends: base, haskell98, polyparse + build-depends: base, haskell98, polyparse, filepath if flag(splitBase) build-depends: base >= 3, pretty, random, containers else diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ SOFTWARE = HaXml -VERSION = 1.19.4 +VERSION = 1.19.5 #CPP = cpp -traditional CPP = cpphs --text --noline # useful e.g. on MacOS X diff --git a/configure b/configure --- a/configure +++ b/configure @@ -2,7 +2,7 @@ # configure -- prepare to compile/install the HaXml package # author: Malcolm.Wallace@cs.york.ac.uk, August 2002 -VERSION="1.19.4" +VERSION="1.19.5" if [ -f obj/prefix ] then INSTALLDIR=`cat obj/prefix` diff --git a/docs/HaXml/Text-XML-HaXml-TypeMapping.html b/docs/HaXml/Text-XML-HaXml-TypeMapping.html --- a/docs/HaXml/Text-XML-HaXml-TypeMapping.html +++ b/docs/HaXml/Text-XML-HaXml-TypeMapping.html @@ -483,6 +483,258 @@ >(HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e, HTypeable f, HTypeable g) => HTypeable (a, b, c, d, e, f, g)(HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e, HTypeable f, HTypeable g, HTypeable h) => HTypeable (a, b, c, d, e, f, g, h)(HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e, HTypeable f, HTypeable g, HTypeable h, HTypeable i) => HTypeable (a, b, c, d, e, f, g, h, i)(HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e, HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j) => HTypeable (a, b, c, d, e, f, g, h, i, j)(HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e, HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j, HTypeable k) => HTypeable (a, b, c, d, e, f, g, h, i, j, k)(HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e, HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j, HTypeable k, HTypeable l) => HTypeable (a, b, c, d, e, f, g, h, i, j, k, l)(HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e, HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j, HTypeable k, HTypeable l, HTypeable m) => HTypeable (a, b, c, d, e, f, g, h, i, j, k, l, m)(HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e, HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j, HTypeable k, HTypeable l, HTypeable m, HTypeable n) => HTypeable (a, b, c, d, e, f, g, h, i, j, k, l, m, n)(HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e, HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j, HTypeable k, HTypeable l, HTypeable m, HTypeable n, HTypeable o) => HTypeable (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)HTypeable a => Posn -> IO ()onContent :: CFilter i -> Document i -> Document i
onContent :: CFilter i -> Document i -> Document iSource
The wrapper onContent simply applies a given content filter to a + document. Ambiguous or empty results raise an error exception. +(XmlContent a, XmlContent b, XmlContent c, XmlContent d, XmlContent e, XmlContent f, XmlContent g) => XmlContent (a, b, c, d, e, f, g)(XmlContent a, XmlContent b, XmlContent c, XmlContent d, XmlContent e, XmlContent f, XmlContent g, XmlContent h) => XmlContent (a, b, c, d, e, f, g, h)(XmlContent a, XmlContent b, XmlContent c, XmlContent d, XmlContent e, XmlContent f, XmlContent g, XmlContent h, XmlContent i) => XmlContent (a, b, c, d, e, f, g, h, i)(XmlContent a, XmlContent b, XmlContent c, XmlContent d, XmlContent e, XmlContent f, XmlContent g, XmlContent h, XmlContent i, XmlContent j) => XmlContent (a, b, c, d, e, f, g, h, i, j)(XmlContent a, XmlContent b, XmlContent c, XmlContent d, XmlContent e, XmlContent f, XmlContent g, XmlContent h, XmlContent i, XmlContent j, XmlContent k) => XmlContent (a, b, c, d, e, f, g, h, i, j, k)(XmlContent a, XmlContent b, XmlContent c, XmlContent d, XmlContent e, XmlContent f, XmlContent g, XmlContent h, XmlContent i, XmlContent j, XmlContent k, XmlContent l) => XmlContent (a, b, c, d, e, f, g, h, i, j, k, l)(XmlContent a, XmlContent b, XmlContent c, XmlContent d, XmlContent e, XmlContent f, XmlContent g, XmlContent h, XmlContent i, XmlContent j, XmlContent k, XmlContent l, XmlContent m) => XmlContent (a, b, c, d, e, f, g, h, i, j, k, l, m)(XmlContent a, XmlContent b, XmlContent c, XmlContent d, XmlContent e, XmlContent f, XmlContent g, XmlContent h, XmlContent i, XmlContent j, XmlContent k, XmlContent l, XmlContent m, XmlContent n) => XmlContent (a, b, c, d, e, f, g, h, i, j, k, l, m, n)(XmlContent a, XmlContent b, XmlContent c, XmlContent d, XmlContent e, XmlContent f, XmlContent g, XmlContent h, XmlContent i, XmlContent j, XmlContent k, XmlContent l, XmlContent m, XmlContent n, XmlContent o) => XmlContent (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)XmlContent a => onContentText.XML.HaXml.Wrappersoo -
#define dummy	-- just to ensure cpp gets called on this file
--- | This is just a convenient way of bunching the XML combinators
---   together with some other things you are likely to want at the
---   same time.
-module Text.XML.HaXml
-  ( module Text.XML.HaXml.Types
-  , module Text.XML.HaXml.Combinators
-  , module Text.XML.HaXml.Parse
-  , module Text.XML.HaXml.Pretty
-  , module Text.XML.HaXml.Html.Generate
-  , module Text.XML.HaXml.Html.Parse
-  , module Text.XML.HaXml.Validate
-  , module Text.XML.HaXml.Wrappers
-  , module Text.XML.HaXml.Verbatim
-  , module Text.XML.HaXml.Escape
-  , render
-  , version
-  ) where
-
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.Combinators
-import Text.XML.HaXml.Parse       (xmlParse,dtdParse)
-import Text.XML.HaXml.Pretty      (element)
-import Text.XML.HaXml.Html.Generate
-import Text.XML.HaXml.Html.Parse  (htmlParse)
-import Text.XML.HaXml.Validate    (validate)
-import Text.XML.HaXml.Wrappers    (fix2Args,processXmlWith)
-import Text.XML.HaXml.Verbatim
-import Text.XML.HaXml.Escape
-
-import Text.PrettyPrint.HughesPJ  (render)
-
--- | The version of the library.
-version :: String
-version  = "VERSION"
-		-- expect cpp to fill in value
+
+
+src/Text/XML/HaXml.hs
+
+
+
#define dummy	-- just to ensure cpp gets called on this file
+-- | This is just a convenient way of bunching the XML combinators
+--   together with some other things you are likely to want at the
+--   same time.
+module Text.XML.HaXml
+  ( module Text.XML.HaXml.Types
+  , module Text.XML.HaXml.Combinators
+  , module Text.XML.HaXml.Parse
+  , module Text.XML.HaXml.Pretty
+  , module Text.XML.HaXml.Html.Generate
+  , module Text.XML.HaXml.Html.Parse
+  , module Text.XML.HaXml.Validate
+  , module Text.XML.HaXml.Wrappers
+  , module Text.XML.HaXml.Verbatim
+  , module Text.XML.HaXml.Escape
+  , render
+  , version
+  ) where
+
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.Combinators
+import Text.XML.HaXml.Parse       (xmlParse,dtdParse)
+import Text.XML.HaXml.Pretty      (element)
+import Text.XML.HaXml.Html.Generate
+import Text.XML.HaXml.Html.Parse  (htmlParse)
+import Text.XML.HaXml.Validate    (validate)
+import Text.XML.HaXml.Wrappers    (fix2Args,processXmlWith)
+import Text.XML.HaXml.Verbatim
+import Text.XML.HaXml.Escape
+
+import Text.PrettyPrint.HughesPJ  (render)
+
+-- | The version of the library.
+version :: String
+version  = "VERSION"
+		-- expect cpp to fill in value
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/ByteStringPP.html b/docs/HaXml/src/Text/XML/HaXml/ByteStringPP.html
--- a/docs/HaXml/src/Text/XML/HaXml/ByteStringPP.html
+++ b/docs/HaXml/src/Text/XML/HaXml/ByteStringPP.html
@@ -1,344 +1,350 @@
 
 
-
-- | This is a fast non-pretty-printer for turning the internal representation
---   of generic structured XML documents into Lazy ByteStrings.
---   Like in Text.Xml.HaXml.Pretty, there is one pp function for each type in
---   Text.Xml.HaXml.Types, so you can pretty-print as much or as little
---   of the document as you wish.
-
-module Text.XML.HaXml.ByteStringPP
-  (
-  -- * Pretty-print a whole document
-    document
-  -- ** Just one content
-  ,   content
-  -- ** Just one tagged element
-  ,   element
-  -- * Pretty-print just a DTD
-  , doctypedecl
-  -- ** The prolog
-  ,   prolog
-  -- ** A content particle description
-  ,   cp
-  ) where
-
-import Prelude hiding (maybe,either,elem,concat)
-import Maybe hiding (maybe)
-import Data.List (intersperse)
---import Data.ByteString.Lazy hiding (pack,map,head,any,singleton,intersperse,join)
-import Data.ByteString.Lazy.Char8 (ByteString(), concat, pack, singleton, intercalate
-                                  , append, elem, empty)
-import Text.XML.HaXml.Types
-
-either :: (t -> t1) -> (t2 -> t1) -> Either t t2 -> t1
-either f _ (Left x)  = f x
-either _ g (Right x) = g x
-
-maybe :: (t -> ByteString) -> Maybe t -> ByteString
-maybe _ Nothing  = empty
-maybe f (Just x) = f x
-
-
--- A simple implementation of the pretty-printing combinator interface,
--- but for plain ByteStrings:
-infixl 6 <>
-infixl 6 <+>
-infixl 5 $$
-(<>)   :: ByteString   -> ByteString -> ByteString -- Beside
-hcat   :: [ByteString] -> ByteString                 -- List version of <>
-(<+>)  :: ByteString   -> ByteString -> ByteString -- Beside, separated by space
-hsep   :: [ByteString] -> ByteString                 -- List version of <+>
-($$)   :: ByteString   -> ByteString -> ByteString -- Above; if there is no
-                                                   -- overlap, it "dovetails"
-vcat   :: [ByteString] -> ByteString       -- List version of $$
--- cat    :: [ByteString] -> ByteString       -- Either hcat or vcat
-sep    :: [ByteString] -> ByteString       -- Either hsep or vcat
--- fcat   :: [ByteString] -> ByteString       -- ``Paragraph fill'' version of cat
-fsep   :: [ByteString] -> ByteString       -- ``Paragraph fill'' version of sep
-nest   :: Int -> ByteString -> ByteString  -- Nested
-
-(<>)  b1 b2  = b1 `append` b2
-(<+>) b1 b2  = b1 <> pack " " <> b2
-($$)  b1 b2  = b1 <> pack "\n" <> b2
--- ($+$)        = ($$)
-
-hcat = Data.ByteString.Lazy.Char8.concat
-hsep = Data.ByteString.Lazy.Char8.intercalate (singleton ' ')
-vcat = Data.ByteString.Lazy.Char8.intercalate (singleton '\n')
-_  = hcat
-sep  = hsep
-text :: [Char] -> ByteString
-text = pack
--- _ = cat
-fsep = sep
-nest _ b = pack " " <> b
-parens :: ByteString -> ByteString
-parens p = pack "(" <> p <> pack ")"
-
-
-----
--- Now for the XML pretty-printing interface.
--- (Basically copied direct from Text.XML.HaXml.Pretty).
-
-document :: Document i -> ByteString
-prolog   :: Prolog     -> ByteString
-xmldecl  :: XMLDecl    -> ByteString
-misc     :: Misc       -> ByteString
-sddecl   :: Bool       -> ByteString
-
-doctypedecl   :: DocTypeDecl   -> ByteString
-markupdecl    :: MarkupDecl    -> ByteString
--- extsubset     :: ExtSubset     -> ByteString
--- extsubsetdecl :: ExtSubsetDecl -> ByteString
-cp            :: CP            -> ByteString
-
-element   :: Element i -> ByteString
-attribute :: Attribute -> ByteString
-content   :: Content i -> ByteString
-
-----
-
-document (Document p _ e m)= prolog p $$ element e $$ vcat (Prelude.map misc m)
-prolog (Prolog x m1 dtd m2)= maybe xmldecl x $$
-                             vcat (Prelude.map misc m1) $$
-                             maybe doctypedecl dtd $$
-                             vcat (Prelude.map misc m2)
-xmldecl (XMLDecl v e sd)   = text "<?xml version='" <> text v <> text "'" <+>
-                             maybe encodingdecl e <+>
-                             maybe sddecl sd <+>
-                             text "?>"
-misc (Comment s)           = text "<!--" <+> text s <+> text "-->"
-misc (PI (n,s))            = text "<?" <> text n <+> text s <+> text "?>"
-sddecl sd   | sd           = text "standalone='yes'"
-            | otherwise    = text "standalone='no'"
-doctypedecl (DTD n eid ds) = if Prelude.null ds then
-                                  hd <> text ">"
-                             else hd <+> text " [" $$
-                                  vcat (Prelude.map markupdecl ds) $$ text "]>"
-                           where hd = text "<!DOCTYPE" <+> text n <+>
-                                      maybe externalid eid
-markupdecl (Element e)     = elementdecl e
-markupdecl (AttList a)     = attlistdecl a
-markupdecl (Entity e)      = entitydecl e
-markupdecl (Notation n)    = notationdecl n
-markupdecl (MarkupMisc m)  = misc m
---markupdecl (MarkupPE p m)  = peref p
--- _ (ExtSubset t ds) = maybe textdecl t $$
---                             vcat (Prelude.map extsubsetdecl ds)
--- _ (ExtMarkupDecl m)      = markupdecl m
--- extsubsetdecl (ExtConditionalSect c) = conditionalsect c
---extsubsetdecl (ExtPEReference p e)   = peref p
-
-element (Elem n as []) = text "<" <> text n <+>
-                         fsep (Prelude.map attribute as) <> text "/>"
-element e@(Elem n as cs)
---  | any isText cs    = text "<" <> text n <+> fsep (map attribute as) <>
---                       text ">" <> hcat (map content cs) <>
---                       text "</" <> text n <> text ">"
-    | isText (head cs) = text "<" <> text n <+> fsep (Prelude.map attribute as) <>
-                         text ">" <> hcat (Prelude.map content cs) <>
-                         text "</" <> text n <> text ">"
-    | otherwise        = let (d,c) = carryelem e empty
-                         in d <> c
-
-isText :: Content t -> Bool
-isText (CString _ _ _) = True
-isText (CRef _ _)      = True
-isText _               = False
-
-carryelem :: Element t -> ByteString -> (ByteString, ByteString)
-carryelem (Elem n as []) c
-                       = ( c <>
-                           text "<" <> text n <+> fsep (Prelude.map attribute as)
-                         , text "/>")
-carryelem (Elem n as cs) c
---  | any isText cs    =  ( c <> element e, empty)
-    | otherwise        =  let (cs0,d0) = carryscan carrycontent cs (text ">")
-                          in
-                          ( c <>
-                            text "<" <> text n <+> fsep (Prelude.map attribute as) $$
-                            nest 2 (vcat cs0) <> --- $$
-                            d0 <> text "</" <> text n
-                          , text ">")
-carrycontent :: Content t -> ByteString -> (ByteString, ByteString)
-carrycontent (CElem e _) c   = carryelem e c
-carrycontent (CString False s _) c = (c <> chardata s, empty)
-carrycontent (CString True  s _) c = (c <> cdsect s, empty)
-carrycontent (CRef r _) c    = (c <> reference r, empty)
-carrycontent (CMisc m _) c   = (c <> misc m, empty)
-
-carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c)
-carryscan _ []     c = ([],c)
-carryscan f (a:as) c = let (b, c0) = f a c
-                           (bs,c1) = carryscan f as c0
-                       in (b:bs, c1)
-
---carryelem e@(Elem n as cs) c
---  | isText (head cs) =
---        ( start <>
---          text ">" <> hcat (map content cs) <> text "</" <> text n
---        , text ">")
---  | otherwise =
---        let (d,c0) = foldl carrycontent (start, text ">") cs in
---        ( d <> c0 <> text "</" <> text n
---        , text ">")
---  where start = c <> text "<" <> text n <+> fsep (map attribute as)
---
---carrycontent (d,c) (CElem e)   = let (d',c') = carryelem e c in
---                                 (d $$ nest 2 d',       c')
---carrycontent (d,c) (CString _ s) = (d <> c <> chardata s, empty)
---carrycontent (d,c) (CRef r)    = (d <> c <> reference r,empty)
---carrycontent (d,c) (CMisc m)   = (d $$ c <> misc m,     empty)
-
-
-attribute (n,v)             = text n <> text "=" <> attvalue v
-content (CElem e _)         = element e
-content (CString False s _) = chardata s
-content (CString True s _)  = cdsect s
-content (CRef r _)          = reference r
-content (CMisc m _)         = misc m
-
-elementdecl :: ElementDecl -> ByteString
-elementdecl (ElementDecl n cs) = text "<!ELEMENT" <+> text n <+>
-                                 contentspec cs <> text ">"
-contentspec :: ContentSpec -> ByteString
-contentspec EMPTY              = text "EMPTY"
-contentspec ANY                = text "ANY"
-contentspec (Mixed m)          = mixed m
-contentspec (ContentSpec c)    = cp c
---contentspec (ContentPE p cs)   = peref p
-cp (TagName n m)       = text n <> modifier m
-cp (Choice cs m)       = parens (hcat (intersperse (text "|") (Prelude.map cp cs))) <>
-                           modifier m
-cp (Seq cs m)          = parens (hcat (intersperse (text ",") (Prelude.map cp cs))) <>
-                           modifier m
---cp (CPPE p c)          = peref p
-modifier :: Modifier -> ByteString
-modifier None          = empty
-modifier Query         = text "?"
-modifier Star          = text "*"
-modifier Plus          = text "+"
-mixed :: Mixed -> ByteString
-mixed  PCDATA          = text "(#PCDATA)"
-mixed (PCDATAplus ns)  = text "(#PCDATA |" <+>
-                         hcat (intersperse (text "|") (Prelude.map text ns)) <>
-                         text ")*"
-
-attlistdecl :: AttListDecl -> ByteString
-attlistdecl (AttListDecl n ds) = text "<!ATTLIST" <+> text n <+>
-                                 fsep (Prelude.map attdef ds) <> text ">"
-attdef :: AttDef -> ByteString
-attdef (AttDef n t d)          = text n <+> atttype t <+> defaultdecl d
-atttype :: AttType -> ByteString
-atttype  StringType            = text "CDATA"
-atttype (TokenizedType t)      = tokenizedtype t
-atttype (EnumeratedType t)     = enumeratedtype t
-tokenizedtype :: TokenizedType -> ByteString
-tokenizedtype ID               = text "ID"
-tokenizedtype IDREF            = text "IDREF"
-tokenizedtype IDREFS           = text "IDREFS"
-tokenizedtype ENTITY           = text "ENTITY"
-tokenizedtype ENTITIES         = text "ENTITIES"
-tokenizedtype NMTOKEN          = text "NMTOKEN"
-tokenizedtype NMTOKENS         = text "NMTOKENS"
-enumeratedtype :: EnumeratedType -> ByteString
-enumeratedtype (NotationType n)= notationtype n
-enumeratedtype (Enumeration e) = enumeration e
-notationtype :: [[Char]] -> ByteString
-notationtype ns                = text "NOTATION" <+>
-                                 parens (hcat (intersperse (text "|") (Prelude.map text ns)))
-enumeration :: [[Char]] -> ByteString
-enumeration ns                 = parens (hcat (intersperse (text "|") (Prelude.map nmtoken ns)))
-defaultdecl :: DefaultDecl -> ByteString
-defaultdecl  REQUIRED          = text "#REQUIRED"
-defaultdecl  IMPLIED           = text "#IMPLIED"
-defaultdecl (DefaultTo a f)    = maybe (const (text "#FIXED")) f <+> attvalue a
---_ (IncludeSect i)= text "<![INCLUDE [" <+>
---                                 vcat (Prelude.map extsubsetdecl i) <+> text "]]>"
--- conditionalsect (IgnoreSect i) = text "<![IGNORE [" <+>
---                                  fsep (Prelude.map ignoresectcontents i) <+> text "]]>"
--- -- _ (Ignore)                = empty
--- ignoresectcontents :: IgnoreSectContents -> ByteString
--- _ (IgnoreSectContents i is)
---                                = ignore i <+> vcat (Prelude.map internal is)
---                           where internal (ics,i) = text "<![[" <+>
---                                                    ignoresectcontents ics <+>
---                                                    text "]]>" <+> ignore i
-reference :: Reference -> ByteString
-reference (RefEntity er)       = entityref er
-reference (RefChar cr)         = charref cr
-entityref :: [Char] -> ByteString
-entityref n                    = text "&" <> text n <> text ";"
-charref :: (Show a) => a -> ByteString
-charref c                      = text "&#" <> text (show c) <> text ";"
-entitydecl :: EntityDecl -> ByteString
-entitydecl (EntityGEDecl d)    = gedecl d
-entitydecl (EntityPEDecl d)    = pedecl d
-gedecl :: GEDecl -> ByteString
-gedecl (GEDecl n ed)           = text "<!ENTITY" <+> text n <+> entitydef ed <>
-                                 text ">"
-pedecl :: PEDecl -> ByteString
-pedecl (PEDecl n pd)           = text "<!ENTITY %" <> text n <+> pedef pd <>
-                                 text ">"
-entitydef :: EntityDef -> ByteString
-entitydef (DefEntityValue ew)  = entityvalue ew
-entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd
-pedef :: PEDef -> ByteString
-pedef (PEDefEntityValue ew)    = entityvalue ew
-pedef (PEDefExternalID eid)    = externalid eid
-externalid :: ExternalID -> ByteString
-externalid (SYSTEM sl)         = text "SYSTEM" <+> systemliteral sl
-externalid (PUBLIC i sl)       = text "PUBLIC" <+> pubidliteral i <+>
-                                 systemliteral sl
-ndatadecl :: NDataDecl -> ByteString
-ndatadecl (NDATA n)            = text "NDATA" <+> text n
--- _ (TextDecl vi ed)      = text "<?xml" <+> maybe text vi <+>
---                                  encodingdecl ed <> text "?>"
--- extparsedent :: ExtParsedEnt t -> ByteString
--- _ (ExtParsedEnt t c)= maybe textdecl t <+> content c
--- _ (ExtPE t esd)            = maybe textdecl t <+>
---                                  vcat (Prelude.map extsubsetdecl esd)
-notationdecl :: NotationDecl -> ByteString
-notationdecl (NOTATION n e)    = text "<!NOTATION" <+> text n <+>
-                                 either externalid publicid e <>
-                                 text ">"
-publicid :: PublicID -> ByteString
-publicid (PUBLICID p)          = text "PUBLICID" <+> pubidliteral p
-encodingdecl :: EncodingDecl -> ByteString
-encodingdecl (EncodingDecl s)  = text "encoding='" <> text s <> text "'"
-nmtoken :: [Char] -> ByteString
-nmtoken s                      = text s
-attvalue :: AttValue -> ByteString
-attvalue (AttValue esr)        = text "\"" <>
-                                 hcat (Prelude.map (either text reference) esr) <>
-                                 text "\""
-entityvalue :: EntityValue -> ByteString
-entityvalue (EntityValue evs)
-  | containsDoubleQuote evs    = text "'"  <> hcat (Prelude.map ev evs) <> text "'"
-  | otherwise                  = text "\"" <> hcat (Prelude.map ev evs) <> text "\""
-ev :: EV -> ByteString
-ev (EVString s)                = text s
---ev (EVPERef p e)               = peref p
-ev (EVRef r)                   = reference r
-pubidliteral :: PubidLiteral -> ByteString
-pubidliteral (PubidLiteral s)
-    | toWord8 '"' `elem` (pack s) = text "'" <> text s <> text "'"
-    | otherwise                = text "\"" <> text s <> text "\""
-systemliteral :: SystemLiteral -> ByteString
-systemliteral (SystemLiteral s)
-    | toWord8 '"' `elem` (pack s) = text "'" <> text s <> text "'"
-    | otherwise                = text "\"" <> text s <> text "\""
-chardata, cdsect :: [Char] -> ByteString
-chardata s                     = {-if all isSpace s then empty else-} text s
-cdsect c                       = text "<![CDATA[" <> chardata c <> text "]]>"
-
--- toWord8 :: Char -> Word8
-toWord8 :: (Enum a, Enum a1) => a1 -> a
-toWord8 = toEnum . fromEnum
-
-containsDoubleQuote :: [EV] -> Bool
-containsDoubleQuote evs = any csq evs
-    where csq (EVString s) = toWord8 '"' `elem` (pack s)
-          csq _            = False
+
+
+src/Text/XML/HaXml/ByteStringPP.hs
+
+
+
-- | This is a fast non-pretty-printer for turning the internal representation
+--   of generic structured XML documents into Lazy ByteStrings.
+--   Like in Text.Xml.HaXml.Pretty, there is one pp function for each type in
+--   Text.Xml.HaXml.Types, so you can pretty-print as much or as little
+--   of the document as you wish.
+
+module Text.XML.HaXml.ByteStringPP
+  (
+  -- * Pretty-print a whole document
+    document
+  -- ** Just one content
+  ,   content
+  -- ** Just one tagged element
+  ,   element
+  -- * Pretty-print just a DTD
+  , doctypedecl
+  -- ** The prolog
+  ,   prolog
+  -- ** A content particle description
+  ,   cp
+  ) where
+
+import Prelude hiding (maybe,either,elem,concat)
+import Maybe hiding (maybe)
+import Data.List (intersperse)
+--import Data.ByteString.Lazy hiding (pack,map,head,any,singleton,intersperse,join)
+import Data.ByteString.Lazy.Char8 (ByteString(), concat, pack, singleton, intercalate
+                                  , append, elem, empty)
+import Text.XML.HaXml.Types
+
+either :: (t -> t1) -> (t2 -> t1) -> Either t t2 -> t1
+either f _ (Left x)  = f x
+either _ g (Right x) = g x
+
+maybe :: (t -> ByteString) -> Maybe t -> ByteString
+maybe _ Nothing  = empty
+maybe f (Just x) = f x
+
+
+-- A simple implementation of the pretty-printing combinator interface,
+-- but for plain ByteStrings:
+infixl 6 <>
+infixl 6 <+>
+infixl 5 $$
+(<>)   :: ByteString   -> ByteString -> ByteString -- Beside
+hcat   :: [ByteString] -> ByteString                 -- List version of <>
+(<+>)  :: ByteString   -> ByteString -> ByteString -- Beside, separated by space
+hsep   :: [ByteString] -> ByteString                 -- List version of <+>
+($$)   :: ByteString   -> ByteString -> ByteString -- Above; if there is no
+                                                   -- overlap, it "dovetails"
+vcat   :: [ByteString] -> ByteString       -- List version of $$
+-- cat    :: [ByteString] -> ByteString       -- Either hcat or vcat
+sep    :: [ByteString] -> ByteString       -- Either hsep or vcat
+-- fcat   :: [ByteString] -> ByteString       -- ``Paragraph fill'' version of cat
+fsep   :: [ByteString] -> ByteString       -- ``Paragraph fill'' version of sep
+nest   :: Int -> ByteString -> ByteString  -- Nested
+
+(<>)  b1 b2  = b1 `append` b2
+(<+>) b1 b2  = b1 <> pack " " <> b2
+($$)  b1 b2  = b1 <> pack "\n" <> b2
+-- ($+$)        = ($$)
+
+hcat = Data.ByteString.Lazy.Char8.concat
+hsep = Data.ByteString.Lazy.Char8.intercalate (singleton ' ')
+vcat = Data.ByteString.Lazy.Char8.intercalate (singleton '\n')
+_  = hcat
+sep  = hsep
+text :: [Char] -> ByteString
+text = pack
+-- _ = cat
+fsep = sep
+nest _ b = pack " " <> b
+parens :: ByteString -> ByteString
+parens p = pack "(" <> p <> pack ")"
+
+
+----
+-- Now for the XML pretty-printing interface.
+-- (Basically copied direct from Text.XML.HaXml.Pretty).
+
+document :: Document i -> ByteString
+prolog   :: Prolog     -> ByteString
+xmldecl  :: XMLDecl    -> ByteString
+misc     :: Misc       -> ByteString
+sddecl   :: Bool       -> ByteString
+
+doctypedecl   :: DocTypeDecl   -> ByteString
+markupdecl    :: MarkupDecl    -> ByteString
+-- extsubset     :: ExtSubset     -> ByteString
+-- extsubsetdecl :: ExtSubsetDecl -> ByteString
+cp            :: CP            -> ByteString
+
+element   :: Element i -> ByteString
+attribute :: Attribute -> ByteString
+content   :: Content i -> ByteString
+
+----
+
+document (Document p _ e m)= prolog p $$ element e $$ vcat (Prelude.map misc m)
+prolog (Prolog x m1 dtd m2)= maybe xmldecl x $$
+                             vcat (Prelude.map misc m1) $$
+                             maybe doctypedecl dtd $$
+                             vcat (Prelude.map misc m2)
+xmldecl (XMLDecl v e sd)   = text "<?xml version='" <> text v <> text "'" <+>
+                             maybe encodingdecl e <+>
+                             maybe sddecl sd <+>
+                             text "?>"
+misc (Comment s)           = text "<!--" <+> text s <+> text "-->"
+misc (PI (n,s))            = text "<?" <> text n <+> text s <+> text "?>"
+sddecl sd   | sd           = text "standalone='yes'"
+            | otherwise    = text "standalone='no'"
+doctypedecl (DTD n eid ds) = if Prelude.null ds then
+                                  hd <> text ">"
+                             else hd <+> text " [" $$
+                                  vcat (Prelude.map markupdecl ds) $$ text "]>"
+                           where hd = text "<!DOCTYPE" <+> text n <+>
+                                      maybe externalid eid
+markupdecl (Element e)     = elementdecl e
+markupdecl (AttList a)     = attlistdecl a
+markupdecl (Entity e)      = entitydecl e
+markupdecl (Notation n)    = notationdecl n
+markupdecl (MarkupMisc m)  = misc m
+--markupdecl (MarkupPE p m)  = peref p
+-- _ (ExtSubset t ds) = maybe textdecl t $$
+--                             vcat (Prelude.map extsubsetdecl ds)
+-- _ (ExtMarkupDecl m)      = markupdecl m
+-- extsubsetdecl (ExtConditionalSect c) = conditionalsect c
+--extsubsetdecl (ExtPEReference p e)   = peref p
+
+element (Elem n as []) = text "<" <> text n <+>
+                         fsep (Prelude.map attribute as) <> text "/>"
+element e@(Elem n as cs)
+--  | any isText cs    = text "<" <> text n <+> fsep (map attribute as) <>
+--                       text ">" <> hcat (map content cs) <>
+--                       text "</" <> text n <> text ">"
+    | isText (head cs) = text "<" <> text n <+> fsep (Prelude.map attribute as) <>
+                         text ">" <> hcat (Prelude.map content cs) <>
+                         text "</" <> text n <> text ">"
+    | otherwise        = let (d,c) = carryelem e empty
+                         in d <> c
+
+isText :: Content t -> Bool
+isText (CString _ _ _) = True
+isText (CRef _ _)      = True
+isText _               = False
+
+carryelem :: Element t -> ByteString -> (ByteString, ByteString)
+carryelem (Elem n as []) c
+                       = ( c <>
+                           text "<" <> text n <+> fsep (Prelude.map attribute as)
+                         , text "/>")
+carryelem (Elem n as cs) c
+--  | any isText cs    =  ( c <> element e, empty)
+    | otherwise        =  let (cs0,d0) = carryscan carrycontent cs (text ">")
+                          in
+                          ( c <>
+                            text "<" <> text n <+> fsep (Prelude.map attribute as) $$
+                            nest 2 (vcat cs0) <> --- $$
+                            d0 <> text "</" <> text n
+                          , text ">")
+carrycontent :: Content t -> ByteString -> (ByteString, ByteString)
+carrycontent (CElem e _) c   = carryelem e c
+carrycontent (CString False s _) c = (c <> chardata s, empty)
+carrycontent (CString True  s _) c = (c <> cdsect s, empty)
+carrycontent (CRef r _) c    = (c <> reference r, empty)
+carrycontent (CMisc m _) c   = (c <> misc m, empty)
+
+carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c)
+carryscan _ []     c = ([],c)
+carryscan f (a:as) c = let (b, c0) = f a c
+                           (bs,c1) = carryscan f as c0
+                       in (b:bs, c1)
+
+--carryelem e@(Elem n as cs) c
+--  | isText (head cs) =
+--        ( start <>
+--          text ">" <> hcat (map content cs) <> text "</" <> text n
+--        , text ">")
+--  | otherwise =
+--        let (d,c0) = foldl carrycontent (start, text ">") cs in
+--        ( d <> c0 <> text "</" <> text n
+--        , text ">")
+--  where start = c <> text "<" <> text n <+> fsep (map attribute as)
+--
+--carrycontent (d,c) (CElem e)   = let (d',c') = carryelem e c in
+--                                 (d $$ nest 2 d',       c')
+--carrycontent (d,c) (CString _ s) = (d <> c <> chardata s, empty)
+--carrycontent (d,c) (CRef r)    = (d <> c <> reference r,empty)
+--carrycontent (d,c) (CMisc m)   = (d $$ c <> misc m,     empty)
+
+
+attribute (n,v)             = text n <> text "=" <> attvalue v
+content (CElem e _)         = element e
+content (CString False s _) = chardata s
+content (CString True s _)  = cdsect s
+content (CRef r _)          = reference r
+content (CMisc m _)         = misc m
+
+elementdecl :: ElementDecl -> ByteString
+elementdecl (ElementDecl n cs) = text "<!ELEMENT" <+> text n <+>
+                                 contentspec cs <> text ">"
+contentspec :: ContentSpec -> ByteString
+contentspec EMPTY              = text "EMPTY"
+contentspec ANY                = text "ANY"
+contentspec (Mixed m)          = mixed m
+contentspec (ContentSpec c)    = cp c
+--contentspec (ContentPE p cs)   = peref p
+cp (TagName n m)       = text n <> modifier m
+cp (Choice cs m)       = parens (hcat (intersperse (text "|") (Prelude.map cp cs))) <>
+                           modifier m
+cp (Seq cs m)          = parens (hcat (intersperse (text ",") (Prelude.map cp cs))) <>
+                           modifier m
+--cp (CPPE p c)          = peref p
+modifier :: Modifier -> ByteString
+modifier None          = empty
+modifier Query         = text "?"
+modifier Star          = text "*"
+modifier Plus          = text "+"
+mixed :: Mixed -> ByteString
+mixed  PCDATA          = text "(#PCDATA)"
+mixed (PCDATAplus ns)  = text "(#PCDATA |" <+>
+                         hcat (intersperse (text "|") (Prelude.map text ns)) <>
+                         text ")*"
+
+attlistdecl :: AttListDecl -> ByteString
+attlistdecl (AttListDecl n ds) = text "<!ATTLIST" <+> text n <+>
+                                 fsep (Prelude.map attdef ds) <> text ">"
+attdef :: AttDef -> ByteString
+attdef (AttDef n t d)          = text n <+> atttype t <+> defaultdecl d
+atttype :: AttType -> ByteString
+atttype  StringType            = text "CDATA"
+atttype (TokenizedType t)      = tokenizedtype t
+atttype (EnumeratedType t)     = enumeratedtype t
+tokenizedtype :: TokenizedType -> ByteString
+tokenizedtype ID               = text "ID"
+tokenizedtype IDREF            = text "IDREF"
+tokenizedtype IDREFS           = text "IDREFS"
+tokenizedtype ENTITY           = text "ENTITY"
+tokenizedtype ENTITIES         = text "ENTITIES"
+tokenizedtype NMTOKEN          = text "NMTOKEN"
+tokenizedtype NMTOKENS         = text "NMTOKENS"
+enumeratedtype :: EnumeratedType -> ByteString
+enumeratedtype (NotationType n)= notationtype n
+enumeratedtype (Enumeration e) = enumeration e
+notationtype :: [[Char]] -> ByteString
+notationtype ns                = text "NOTATION" <+>
+                                 parens (hcat (intersperse (text "|") (Prelude.map text ns)))
+enumeration :: [[Char]] -> ByteString
+enumeration ns                 = parens (hcat (intersperse (text "|") (Prelude.map nmtoken ns)))
+defaultdecl :: DefaultDecl -> ByteString
+defaultdecl  REQUIRED          = text "#REQUIRED"
+defaultdecl  IMPLIED           = text "#IMPLIED"
+defaultdecl (DefaultTo a f)    = maybe (const (text "#FIXED")) f <+> attvalue a
+--_ (IncludeSect i)= text "<![INCLUDE [" <+>
+--                                 vcat (Prelude.map extsubsetdecl i) <+> text "]]>"
+-- conditionalsect (IgnoreSect i) = text "<![IGNORE [" <+>
+--                                  fsep (Prelude.map ignoresectcontents i) <+> text "]]>"
+-- -- _ (Ignore)                = empty
+-- ignoresectcontents :: IgnoreSectContents -> ByteString
+-- _ (IgnoreSectContents i is)
+--                                = ignore i <+> vcat (Prelude.map internal is)
+--                           where internal (ics,i) = text "<![[" <+>
+--                                                    ignoresectcontents ics <+>
+--                                                    text "]]>" <+> ignore i
+reference :: Reference -> ByteString
+reference (RefEntity er)       = entityref er
+reference (RefChar cr)         = charref cr
+entityref :: [Char] -> ByteString
+entityref n                    = text "&" <> text n <> text ";"
+charref :: (Show a) => a -> ByteString
+charref c                      = text "&#" <> text (show c) <> text ";"
+entitydecl :: EntityDecl -> ByteString
+entitydecl (EntityGEDecl d)    = gedecl d
+entitydecl (EntityPEDecl d)    = pedecl d
+gedecl :: GEDecl -> ByteString
+gedecl (GEDecl n ed)           = text "<!ENTITY" <+> text n <+> entitydef ed <>
+                                 text ">"
+pedecl :: PEDecl -> ByteString
+pedecl (PEDecl n pd)           = text "<!ENTITY %" <> text n <+> pedef pd <>
+                                 text ">"
+entitydef :: EntityDef -> ByteString
+entitydef (DefEntityValue ew)  = entityvalue ew
+entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd
+pedef :: PEDef -> ByteString
+pedef (PEDefEntityValue ew)    = entityvalue ew
+pedef (PEDefExternalID eid)    = externalid eid
+externalid :: ExternalID -> ByteString
+externalid (SYSTEM sl)         = text "SYSTEM" <+> systemliteral sl
+externalid (PUBLIC i sl)       = text "PUBLIC" <+> pubidliteral i <+>
+                                 systemliteral sl
+ndatadecl :: NDataDecl -> ByteString
+ndatadecl (NDATA n)            = text "NDATA" <+> text n
+-- _ (TextDecl vi ed)      = text "<?xml" <+> maybe text vi <+>
+--                                  encodingdecl ed <> text "?>"
+-- extparsedent :: ExtParsedEnt t -> ByteString
+-- _ (ExtParsedEnt t c)= maybe textdecl t <+> content c
+-- _ (ExtPE t esd)            = maybe textdecl t <+>
+--                                  vcat (Prelude.map extsubsetdecl esd)
+notationdecl :: NotationDecl -> ByteString
+notationdecl (NOTATION n e)    = text "<!NOTATION" <+> text n <+>
+                                 either externalid publicid e <>
+                                 text ">"
+publicid :: PublicID -> ByteString
+publicid (PUBLICID p)          = text "PUBLICID" <+> pubidliteral p
+encodingdecl :: EncodingDecl -> ByteString
+encodingdecl (EncodingDecl s)  = text "encoding='" <> text s <> text "'"
+nmtoken :: [Char] -> ByteString
+nmtoken s                      = text s
+attvalue :: AttValue -> ByteString
+attvalue (AttValue esr)        = text "\"" <>
+                                 hcat (Prelude.map (either text reference) esr) <>
+                                 text "\""
+entityvalue :: EntityValue -> ByteString
+entityvalue (EntityValue evs)
+  | containsDoubleQuote evs    = text "'"  <> hcat (Prelude.map ev evs) <> text "'"
+  | otherwise                  = text "\"" <> hcat (Prelude.map ev evs) <> text "\""
+ev :: EV -> ByteString
+ev (EVString s)                = text s
+--ev (EVPERef p e)               = peref p
+ev (EVRef r)                   = reference r
+pubidliteral :: PubidLiteral -> ByteString
+pubidliteral (PubidLiteral s)
+    | toWord8 '"' `elem` (pack s) = text "'" <> text s <> text "'"
+    | otherwise                = text "\"" <> text s <> text "\""
+systemliteral :: SystemLiteral -> ByteString
+systemliteral (SystemLiteral s)
+    | toWord8 '"' `elem` (pack s) = text "'" <> text s <> text "'"
+    | otherwise                = text "\"" <> text s <> text "\""
+chardata, cdsect :: [Char] -> ByteString
+chardata s                     = {-if all isSpace s then empty else-} text s
+cdsect c                       = text "<![CDATA[" <> chardata c <> text "]]>"
+
+-- toWord8 :: Char -> Word8
+toWord8 :: (Enum a, Enum a1) => a1 -> a
+toWord8 = toEnum . fromEnum
+
+containsDoubleQuote :: [EV] -> Bool
+containsDoubleQuote evs = any csq evs
+    where csq (EVString s) = toWord8 '"' `elem` (pack s)
+          csq _            = False
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Combinators.html b/docs/HaXml/src/Text/XML/HaXml/Combinators.html
--- a/docs/HaXml/src/Text/XML/HaXml/Combinators.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Combinators.html
@@ -1,428 +1,434 @@
 
 
-
--------------------------------------------
--- | This module defines the notion of filters and filter combinators
---   for processing XML documents.
---
---   These XML transformation combinators are described in the paper
---   ``Haskell and XML: Generic Combinators or Type-Based Translation?''
---   Malcolm Wallace and Colin Runciman, Proceedings ICFP'99.
---------------------------------------------
-module Text.XML.HaXml.Combinators
-  (-- * The content filter type.
-    CFilter
-
-   -- * Simple filters.
-   -- ** Selection filters.
-   -- $selection
-  , keep, none, children, position
-
-   -- ** Predicate filters.
-   -- $pred
-  , elm, txt, tag, attr, attrval, tagWith
-
-   -- ** Search filters.
-  , find, iffind, ifTxt
-
-   -- * Filter combinators
-   -- ** Basic combinators.
-  , o, union, cat, andThen
-  , (|>|), with, without
-  , (/>), (</), et
-  , path
-   -- ** Recursive search.
-   -- $recursive
-  , deep, deepest, multi
-   -- ** Interior editing.
-  , when, guards, chip, inplace, foldXml
-   -- ** Constructive filters.
-  , mkElem, mkElemAttr, literal, cdata, replaceTag, replaceAttrs
-
-   -- * C-like conditionals.
-   -- $cond
-  , ThenElse(..), (?>)
-
-   -- * Filters with labelled results.
-  , LabelFilter
-   -- ** Using and combining labelled filters.
-  , oo, x
-   -- ** Some label-generating filters.
-  , numbered, interspersed, tagged, attributed, textlabelled, extracted
-
-  ) where
-
-
-import Text.XML.HaXml.Types
-import Maybe (fromMaybe)
-
-infixl 6 `with`, `without`
-infixr 5 `o`, `oo`, `union`, `andThen`		-- , `orelse`
-infixl 5 />, </, |>|
-infixr 4 `when`, `guards`
-infixr 3 ?>, :>
-
-
-
--- THE CONTENT FILTER TYPE
-
--- | All document transformations are /content filters/.
---   A filter takes a single XML 'Content' value and returns a sequence
---   of 'Content' values, possibly empty.
-type CFilter i  = Content i -> [Content i]
-
-
-
--- BASIC SELECTION FILTERS
--- $selection
--- In the algebra of combinators, @none@ is the zero, and @keep@ the identity.
--- (They have a more general type than just CFilter.)
-keep :: a->[a]
-keep = \x->[x]
-none :: a->[b]
-none = \x->[]
-
--- | Throw away current node, keep just the (unprocessed) children.
-children :: CFilter i
-children (CElem (Elem _ _ cs) _) = cs
-children _ = []
-
--- | Select the @n@'th positional result of a filter.
-position :: Int -> CFilter i -> CFilter i
-position n f = (\cs-> [cs!!n]) . f
-
-
-
--- BASIC PREDICATE FILTERS
--- $pred
--- These filters either keep or throw away some content based on
--- a simple test.  For instance, @elm@ keeps only a tagged element,
--- @txt@ keeps only non-element text, @tag@ keeps only an element
--- with the named tag, @attr@ keeps only an element with the named
--- attribute, @attrval@ keeps only an element with the given
--- attribute value, @tagWith@ keeps only an element whose tag name
--- satisfies the given predicate.
-
-elm, txt   :: CFilter i
-tag        :: String -> CFilter i
-attr       :: Name -> CFilter i
-attrval    :: Attribute -> CFilter i
-tagWith    :: (String->Bool) -> CFilter i
-
-elm x@(CElem _ _) = [x]
-elm _             = []
-
-txt x@(CString _ _ _) = [x]
-txt x@(CRef _ _)      = [x]
-txt _                 = []
-
-tag t x@(CElem (Elem n _ _) _) | t==n  = [x]
-tag t _  = []
-
-tagWith p x@(CElem (Elem n _ _) _) | p n  = [x]
-tagWith p _  = []
-
-attr n x@(CElem (Elem _ as _) _) | n `elem` (map fst as)  = [x]
-attr n _  = []
-
-attrval av x@(CElem (Elem _ as _) _) | av `elem` as  = [x]
-attrval av _  = []
-
-
-
--- SEARCH FILTERS
-
--- | For a mandatory attribute field, @find key cont@ looks up the value of
---   the attribute name @key@, and applies the continuation @cont@ to
---   the value.
-find :: String -> (String->CFilter i) -> CFilter i
-find key cont c@(CElem (Elem _ as _) _) = cont (show (lookfor key as)) c
-  where lookfor x = fromMaybe (error ("missing attribute: "++show x)) . lookup x
--- 'lookfor' has the more general type :: (Eq a,Show a) => a -> [(a,b)] -> b
-
--- | When an attribute field may be absent, use @iffind key yes no@ to lookup
---   its value.  If the attribute is absent, it acts as the @no@ filter,
---   otherwise it applies the @yes@ filter.
-iffind :: String -> (String->CFilter i) -> CFilter i -> CFilter i
-iffind key yes no c@(CElem (Elem _ as _) _) =
-  case (lookup key as) of
-    Nothing  -> no c
-    (Just v@(AttValue _)) -> yes (show v) c
-iffind key yes no other = no other
-
--- | @ifTxt yes no@ processes any textual content with the @yes@ filter,
---   but otherwise is the same as the @no@ filter.
-ifTxt :: (String->CFilter i) -> CFilter i -> CFilter i
-ifTxt yes no c@(CString _ s _) = yes s c
-ifTxt yes no c                 = no c
-
-
-
--- C-LIKE CONDITIONALS
---
--- $cond
--- These definitions provide C-like conditionals, lifted to the filter level.
---
--- The @(cond ? yes : no)@ style in C becomes @(cond ?> yes :> no)@ in Haskell.
-
--- | Conjoin the two branches of a conditional.
-data ThenElse a = a :> a
-
--- | Select between the two branches of a joined conditional.
-(?>) :: (a->[b]) -> ThenElse (a->[b]) -> (a->[b])
-p ?> (f :> g) = \c-> if (not.null.p) c then f c else g c
-
-
-
--- FILTER COMBINATORS
-
-
--- | Sequential (/Irish/,/backwards/) composition
-o :: CFilter i -> CFilter i -> CFilter i
-f `o` g = concatMap f . g
-
--- | Binary parallel composition.  Each filter uses a copy of the input,
--- rather than one filter using the result of the other.
---   (Has a more general type than just CFilter.)
-union :: (a->[b]) -> (a->[b]) -> (a->[b])
-union = lift (++)		-- in Haskell 98:   union = lift List.union
-  where
-    lift :: (a->b->d) -> (c->a) -> (c->b) -> c -> d
-    lift f g h = \x-> f (g x) (h x)
-
--- | Glue a list of filters together.  (A list version of union;
---   also has a more general type than just CFilter.)
-cat :: [a->[b]] -> (a->[b])
---   Specification: cat fs = \e-> concat [ f e | f <- fs ]
---   more efficient implementation below:
-cat [] = const []
-cat fs = foldr1 union fs
-
--- | A special form of filter composition where the second filter
---   works over the same data as the first, but also uses the
---   first's result.
-andThen :: (a->c) -> (c->a->b) -> (a->b)
-andThen f g = \x-> g (f x) x			-- lift g f id
-
--- | Process children using specified filters.  /not exported/
-childrenBy :: CFilter i -> CFilter i 
-childrenBy f = f `o` children
-
--- | Directional choice:
---   in @f |>| g@ give g-productions only if no f-productions
-(|>|) :: (a->[b]) -> (a->[b]) -> (a->[b])
-f |>| g = \x-> let fx = f x in if null fx then g x else fx
---      f |>| g  =  f ?> f :> g
-
--- | Pruning: in @f `with` g@,
---   keep only those f-productions which have at least one g-production
-with :: CFilter i -> CFilter i -> CFilter i
-f `with` g = filter (not.null.g) . f
-
--- | Pruning: in @f `without` g@,
---   keep only those f-productions which have no g-productions
-without :: CFilter i -> CFilter i -> CFilter i
-f `without` g = filter (null.g) . f
-
--- | Pronounced /slash/, @f \/> g@ means g inside f
-(/>) :: CFilter i -> CFilter i -> CFilter i
-f /> g = g `o` children `o` f
-
--- | Pronounced /outside/, @f \<\/ g@ means f containing g
-(</) :: CFilter i -> CFilter i -> CFilter i
-f </ g = f `with` (g `o` children)
-
--- | Join an element-matching filter with a text-only filter
-et :: (String->CFilter i) -> CFilter i -> CFilter i
-et f g = (f `oo` tagged elm)
-            |>|
-         (g `o` txt)
-
--- | Express a list of filters like an XPath query, e.g.
---   @path [children, tag \"name1\", attr \"attr1\", children, tag \"name2\"]@
---   is like the XPath query @\/name1[\@attr1]\/name2@.
-path :: [CFilter i] -> CFilter i
-path fs = foldr (flip (o)) keep fs
-
-
--- RECURSIVE SEARCH
--- $recursive
--- Recursive search has three variants: @deep@ does a breadth-first
--- search of the tree, @deepest@ does a depth-first search, @multi@ returns
--- content at all tree-levels, even those strictly contained within results
--- that have already been returned.
-deep, deepest, multi :: CFilter i -> CFilter i
-deep f     = f |>| (deep f `o` children)
-deepest f  = (deepest f `o` children) |>| f
-multi f    = f `union` (multi f `o` children)
-
--- | Interior editing:
---   @f `when` g@ applies @f@ only when the predicate @g@ succeeds,
---   otherwise the content is unchanged.
-when   :: CFilter i -> CFilter i -> CFilter i
--- | Interior editing:
---   @g `guards` f@ applies @f@ only when the predicate @g@ succeeds,
---   otherwise the content is discarded.
-guards :: CFilter i -> CFilter i -> CFilter i
-f `when` g       = g ?> f :> keep
-g `guards` f     = g ?> f :> none	-- = f `o` (keep `with` g)
-
--- | Process CHildren In Place.  The filter is applied to any children
---   of an element content, and the element rebuilt around the results.
-chip :: CFilter i -> CFilter i
-chip f (CElem (Elem n as cs) i) = [ CElem (Elem n as (concatMap f cs)) i ]
-chip f c = [c]
--- chip f = inplace (f `o` children)
-
--- | Process an element In Place.  The filter is applied to the element
---   itself, and then the original element rebuilt around the results.
-inplace :: CFilter i -> CFilter i
-inplace f c@(CElem (Elem name as _) i) = [ CElem (Elem name as (f c)) i ]
-inplace f c = [c]
-
-
--- | Recursive application of filters: a fold-like operator.  Defined
---   as @f `o` chip (foldXml f)@.
-foldXml :: CFilter i -> CFilter i
-foldXml f = f `o` chip (foldXml f)
-
-
-
-
--- CONSTRUCTIVE CONTENT FILTERS
-
--- | Build an element with the given tag name - its content is the results
---   of the given list of filters.
-mkElem :: String -> [CFilter i] -> CFilter i
-mkElem h cfs = \t-> [ CElem (Elem h [] (cat cfs t)) undefined ]
-
--- | Build an element with the given name, attributes, and content.
-mkElemAttr :: String -> [(String,CFilter i)] -> [CFilter i] -> CFilter i
-mkElemAttr h as cfs = \t-> [ CElem (Elem h (map (attr t) as) (cat cfs t)) undefined ]
-  where attr t (n,vf) =
-            let v = concat [ s | (CString _ s _) <- (deep txt `o` vf) t ]
-            in  (n, AttValue [Left v])
-
--- | Build some textual content.
-literal :: String -> CFilter i
-literal s = const [CString False s undefined]
-
--- | Build some CDATA content.
-cdata :: String -> CFilter i
-cdata s = const [CString True s undefined]
-
--- | Rename an element tag (leaving attributes in place).
-replaceTag :: String -> CFilter i
-replaceTag n (CElem (Elem _ as cs) i) = [CElem (Elem n as cs) i]
-replaceTag n _ = []
-
--- | Replace the attributes of an element (leaving tag the same).
-replaceAttrs :: [(String,String)] -> CFilter i
-replaceAttrs as (CElem (Elem n _ cs) i) = [CElem (Elem n as' cs) i]
-    where as' = map (\(n,v)-> (n, AttValue [Left v])) as
-replaceAttrs as _ = []
-
-
-
--- LABELLING
-
--- | A LabelFilter is like a CFilter except that it pairs up a polymorphic
---   value (label) with each of its results.
-type LabelFilter i a = Content i -> [(a,Content i)]
-
--- | Compose a label-processing filter with a label-generating filter.
-oo :: (a->CFilter i) -> LabelFilter i a -> CFilter i
-f `oo` g = concatMap (uncurry f) . g
-
-{-
--- | Process the information labels (very nearly monadic bind).
-oo :: (b -> CFilter b c) -> CFilter a b -> CFilter a c
-f `oo` g = concatMap info . g
-    where info c@(CElem _ i)     = f i c
-          info c@(CString _ _ i) = f i c
-          info c@(CRef _ i)      = f i c
-          info c                 = [c]
--}
-
--- | Combine labels.  Think of this as a pair-wise zip on labels.
---   e.g. @(numbered `x` tagged)@
-x :: (CFilter i->LabelFilter i a) -> (CFilter i->LabelFilter i b) ->
-       (CFilter i->LabelFilter i (a,b))
-f `x` g = \cf c-> let gs = map fst (g cf c)
-                      fs = map fst (f cf c)
-                  in zip (zip fs gs) (cf c)
-
-
--- Some basic label-generating filters.
-
--- | Number the results from 1 upwards.
-numbered :: CFilter i -> LabelFilter i Int
-numbered f = zip [1..] . f
-
--- | In @interspersed a f b@, label each result of @f@ with the string @a@,
---   except for the last one which is labelled with the string @b@.
-interspersed :: String -> CFilter i -> String -> LabelFilter i String
-interspersed a f b =
-  (\xs-> zip (replicate (len xs) a ++ [b]) xs) . f
-  where
-  len [] = 0
-  len xs = length xs - 1
-
--- | Label each element in the result with its tag name.  Non-element
---   results get an empty string label.
-tagged :: CFilter i -> LabelFilter i String
-tagged f = extracted name f
-  where name (CElem (Elem n _ _) _) = n
-        name _                      = ""
-
--- | Label each element in the result with the value of the named attribute.
---   Elements without the attribute, and non-element results, get an
---   empty string label.
-attributed :: String -> CFilter i -> LabelFilter i String
-attributed key f = extracted att f
-  where att (CElem (Elem _ as _) _) =
-            case (lookup key as) of
-              Nothing  -> ""
-              (Just v@(AttValue _)) -> show v
-        att _ = ""
-
--- | Label each textual part of the result with its text.  Element
---   results get an empty string label.
-textlabelled :: CFilter i -> LabelFilter i (Maybe String)
-textlabelled f = extracted text f
-  where text (CString _ s _) = Just s
-        text _               = Nothing
-
--- | Label each content with some information extracted from itself.
-extracted :: (Content i->a) -> CFilter i -> LabelFilter i a
-extracted proj f = concatMap (\c->[(proj c, c)]) . f
-                                                                                
-
-
-{-
--- MISC
-
--- | I haven't yet remembered \/ worked out what this does.
-combine :: (Read a,Show a) => ([a]->a) -> LabelFilter String -> CFilter
-combine f lf = \c-> [ CString False (show (f [ read l | (l,_) <- lf c ])) ]
--}
-
-
-{- OLD STUFF - OBSOLETE
--- Keep an element by its numbered position (starting at 1).
-position :: Int -> [Content] -> [Content]
-position n | n>0  = (:[]) . (!!(n-1))
-           | otherwise = const []
-
--- Chop and remove the root portions of trees to depth n.
-layer :: Int -> [Content] -> [Content]
-layer n = apply n (concatMap lay)
-  where lay (CElem (Elem _ _ cs)) = cs
-        lay _ = []
-        apply 0 f xs = xs
-        apply n f xs = apply (n-1) f (f xs)
-
-combine :: (Read a, Show a) => ([a]->a) -> [Content] -> [Content]
-combine f = \cs-> [ CString False (show (f [ read s | CString _ s <- cs ])) ]
--}
+
+
+src/Text/XML/HaXml/Combinators.hs
+
+
+
--------------------------------------------
+-- | This module defines the notion of filters and filter combinators
+--   for processing XML documents.
+--
+--   These XML transformation combinators are described in the paper
+--   ``Haskell and XML: Generic Combinators or Type-Based Translation?''
+--   Malcolm Wallace and Colin Runciman, Proceedings ICFP'99.
+--------------------------------------------
+module Text.XML.HaXml.Combinators
+  (-- * The content filter type.
+    CFilter
+
+   -- * Simple filters.
+   -- ** Selection filters.
+   -- $selection
+  , keep, none, children, position
+
+   -- ** Predicate filters.
+   -- $pred
+  , elm, txt, tag, attr, attrval, tagWith
+
+   -- ** Search filters.
+  , find, iffind, ifTxt
+
+   -- * Filter combinators
+   -- ** Basic combinators.
+  , o, union, cat, andThen
+  , (|>|), with, without
+  , (/>), (</), et
+  , path
+   -- ** Recursive search.
+   -- $recursive
+  , deep, deepest, multi
+   -- ** Interior editing.
+  , when, guards, chip, inplace, foldXml
+   -- ** Constructive filters.
+  , mkElem, mkElemAttr, literal, cdata, replaceTag, replaceAttrs
+
+   -- * C-like conditionals.
+   -- $cond
+  , ThenElse(..), (?>)
+
+   -- * Filters with labelled results.
+  , LabelFilter
+   -- ** Using and combining labelled filters.
+  , oo, x
+   -- ** Some label-generating filters.
+  , numbered, interspersed, tagged, attributed, textlabelled, extracted
+
+  ) where
+
+
+import Text.XML.HaXml.Types
+import Maybe (fromMaybe)
+
+infixl 6 `with`, `without`
+infixr 5 `o`, `oo`, `union`, `andThen`		-- , `orelse`
+infixl 5 />, </, |>|
+infixr 4 `when`, `guards`
+infixr 3 ?>, :>
+
+
+
+-- THE CONTENT FILTER TYPE
+
+-- | All document transformations are /content filters/.
+--   A filter takes a single XML 'Content' value and returns a sequence
+--   of 'Content' values, possibly empty.
+type CFilter i  = Content i -> [Content i]
+
+
+
+-- BASIC SELECTION FILTERS
+-- $selection
+-- In the algebra of combinators, @none@ is the zero, and @keep@ the identity.
+-- (They have a more general type than just CFilter.)
+keep :: a->[a]
+keep = \x->[x]
+none :: a->[b]
+none = \x->[]
+
+-- | Throw away current node, keep just the (unprocessed) children.
+children :: CFilter i
+children (CElem (Elem _ _ cs) _) = cs
+children _ = []
+
+-- | Select the @n@'th positional result of a filter.
+position :: Int -> CFilter i -> CFilter i
+position n f = (\cs-> [cs!!n]) . f
+
+
+
+-- BASIC PREDICATE FILTERS
+-- $pred
+-- These filters either keep or throw away some content based on
+-- a simple test.  For instance, @elm@ keeps only a tagged element,
+-- @txt@ keeps only non-element text, @tag@ keeps only an element
+-- with the named tag, @attr@ keeps only an element with the named
+-- attribute, @attrval@ keeps only an element with the given
+-- attribute value, @tagWith@ keeps only an element whose tag name
+-- satisfies the given predicate.
+
+elm, txt   :: CFilter i
+tag        :: String -> CFilter i
+attr       :: Name -> CFilter i
+attrval    :: Attribute -> CFilter i
+tagWith    :: (String->Bool) -> CFilter i
+
+elm x@(CElem _ _) = [x]
+elm _             = []
+
+txt x@(CString _ _ _) = [x]
+txt x@(CRef _ _)      = [x]
+txt _                 = []
+
+tag t x@(CElem (Elem n _ _) _) | t==n  = [x]
+tag t _  = []
+
+tagWith p x@(CElem (Elem n _ _) _) | p n  = [x]
+tagWith p _  = []
+
+attr n x@(CElem (Elem _ as _) _) | n `elem` (map fst as)  = [x]
+attr n _  = []
+
+attrval av x@(CElem (Elem _ as _) _) | av `elem` as  = [x]
+attrval av _  = []
+
+
+
+-- SEARCH FILTERS
+
+-- | For a mandatory attribute field, @find key cont@ looks up the value of
+--   the attribute name @key@, and applies the continuation @cont@ to
+--   the value.
+find :: String -> (String->CFilter i) -> CFilter i
+find key cont c@(CElem (Elem _ as _) _) = cont (show (lookfor key as)) c
+  where lookfor x = fromMaybe (error ("missing attribute: "++show x)) . lookup x
+-- 'lookfor' has the more general type :: (Eq a,Show a) => a -> [(a,b)] -> b
+
+-- | When an attribute field may be absent, use @iffind key yes no@ to lookup
+--   its value.  If the attribute is absent, it acts as the @no@ filter,
+--   otherwise it applies the @yes@ filter.
+iffind :: String -> (String->CFilter i) -> CFilter i -> CFilter i
+iffind key yes no c@(CElem (Elem _ as _) _) =
+  case (lookup key as) of
+    Nothing  -> no c
+    (Just v@(AttValue _)) -> yes (show v) c
+iffind key yes no other = no other
+
+-- | @ifTxt yes no@ processes any textual content with the @yes@ filter,
+--   but otherwise is the same as the @no@ filter.
+ifTxt :: (String->CFilter i) -> CFilter i -> CFilter i
+ifTxt yes no c@(CString _ s _) = yes s c
+ifTxt yes no c                 = no c
+
+
+
+-- C-LIKE CONDITIONALS
+--
+-- $cond
+-- These definitions provide C-like conditionals, lifted to the filter level.
+--
+-- The @(cond ? yes : no)@ style in C becomes @(cond ?> yes :> no)@ in Haskell.
+
+-- | Conjoin the two branches of a conditional.
+data ThenElse a = a :> a
+
+-- | Select between the two branches of a joined conditional.
+(?>) :: (a->[b]) -> ThenElse (a->[b]) -> (a->[b])
+p ?> (f :> g) = \c-> if (not.null.p) c then f c else g c
+
+
+
+-- FILTER COMBINATORS
+
+
+-- | Sequential (/Irish/,/backwards/) composition
+o :: CFilter i -> CFilter i -> CFilter i
+f `o` g = concatMap f . g
+
+-- | Binary parallel composition.  Each filter uses a copy of the input,
+-- rather than one filter using the result of the other.
+--   (Has a more general type than just CFilter.)
+union :: (a->[b]) -> (a->[b]) -> (a->[b])
+union = lift (++)		-- in Haskell 98:   union = lift List.union
+  where
+    lift :: (a->b->d) -> (c->a) -> (c->b) -> c -> d
+    lift f g h = \x-> f (g x) (h x)
+
+-- | Glue a list of filters together.  (A list version of union;
+--   also has a more general type than just CFilter.)
+cat :: [a->[b]] -> (a->[b])
+--   Specification: cat fs = \e-> concat [ f e | f <- fs ]
+--   more efficient implementation below:
+cat [] = const []
+cat fs = foldr1 union fs
+
+-- | A special form of filter composition where the second filter
+--   works over the same data as the first, but also uses the
+--   first's result.
+andThen :: (a->c) -> (c->a->b) -> (a->b)
+andThen f g = \x-> g (f x) x			-- lift g f id
+
+-- | Process children using specified filters.  /not exported/
+childrenBy :: CFilter i -> CFilter i 
+childrenBy f = f `o` children
+
+-- | Directional choice:
+--   in @f |>| g@ give g-productions only if no f-productions
+(|>|) :: (a->[b]) -> (a->[b]) -> (a->[b])
+f |>| g = \x-> let fx = f x in if null fx then g x else fx
+--      f |>| g  =  f ?> f :> g
+
+-- | Pruning: in @f `with` g@,
+--   keep only those f-productions which have at least one g-production
+with :: CFilter i -> CFilter i -> CFilter i
+f `with` g = filter (not.null.g) . f
+
+-- | Pruning: in @f `without` g@,
+--   keep only those f-productions which have no g-productions
+without :: CFilter i -> CFilter i -> CFilter i
+f `without` g = filter (null.g) . f
+
+-- | Pronounced /slash/, @f \/> g@ means g inside f
+(/>) :: CFilter i -> CFilter i -> CFilter i
+f /> g = g `o` children `o` f
+
+-- | Pronounced /outside/, @f \<\/ g@ means f containing g
+(</) :: CFilter i -> CFilter i -> CFilter i
+f </ g = f `with` (g `o` children)
+
+-- | Join an element-matching filter with a text-only filter
+et :: (String->CFilter i) -> CFilter i -> CFilter i
+et f g = (f `oo` tagged elm)
+            |>|
+         (g `o` txt)
+
+-- | Express a list of filters like an XPath query, e.g.
+--   @path [children, tag \"name1\", attr \"attr1\", children, tag \"name2\"]@
+--   is like the XPath query @\/name1[\@attr1]\/name2@.
+path :: [CFilter i] -> CFilter i
+path fs = foldr (flip (o)) keep fs
+
+
+-- RECURSIVE SEARCH
+-- $recursive
+-- Recursive search has three variants: @deep@ does a breadth-first
+-- search of the tree, @deepest@ does a depth-first search, @multi@ returns
+-- content at all tree-levels, even those strictly contained within results
+-- that have already been returned.
+deep, deepest, multi :: CFilter i -> CFilter i
+deep f     = f |>| (deep f `o` children)
+deepest f  = (deepest f `o` children) |>| f
+multi f    = f `union` (multi f `o` children)
+
+-- | Interior editing:
+--   @f `when` g@ applies @f@ only when the predicate @g@ succeeds,
+--   otherwise the content is unchanged.
+when   :: CFilter i -> CFilter i -> CFilter i
+-- | Interior editing:
+--   @g `guards` f@ applies @f@ only when the predicate @g@ succeeds,
+--   otherwise the content is discarded.
+guards :: CFilter i -> CFilter i -> CFilter i
+f `when` g       = g ?> f :> keep
+g `guards` f     = g ?> f :> none	-- = f `o` (keep `with` g)
+
+-- | Process CHildren In Place.  The filter is applied to any children
+--   of an element content, and the element rebuilt around the results.
+chip :: CFilter i -> CFilter i
+chip f (CElem (Elem n as cs) i) = [ CElem (Elem n as (concatMap f cs)) i ]
+chip f c = [c]
+-- chip f = inplace (f `o` children)
+
+-- | Process an element In Place.  The filter is applied to the element
+--   itself, and then the original element rebuilt around the results.
+inplace :: CFilter i -> CFilter i
+inplace f c@(CElem (Elem name as _) i) = [ CElem (Elem name as (f c)) i ]
+inplace f c = [c]
+
+
+-- | Recursive application of filters: a fold-like operator.  Defined
+--   as @f `o` chip (foldXml f)@.
+foldXml :: CFilter i -> CFilter i
+foldXml f = f `o` chip (foldXml f)
+
+
+
+
+-- CONSTRUCTIVE CONTENT FILTERS
+
+-- | Build an element with the given tag name - its content is the results
+--   of the given list of filters.
+mkElem :: String -> [CFilter i] -> CFilter i
+mkElem h cfs = \t-> [ CElem (Elem h [] (cat cfs t)) undefined ]
+
+-- | Build an element with the given name, attributes, and content.
+mkElemAttr :: String -> [(String,CFilter i)] -> [CFilter i] -> CFilter i
+mkElemAttr h as cfs = \t-> [ CElem (Elem h (map (attr t) as) (cat cfs t)) undefined ]
+  where attr t (n,vf) =
+            let v = concat [ s | (CString _ s _) <- (deep txt `o` vf) t ]
+            in  (n, AttValue [Left v])
+
+-- | Build some textual content.
+literal :: String -> CFilter i
+literal s = const [CString False s undefined]
+
+-- | Build some CDATA content.
+cdata :: String -> CFilter i
+cdata s = const [CString True s undefined]
+
+-- | Rename an element tag (leaving attributes in place).
+replaceTag :: String -> CFilter i
+replaceTag n (CElem (Elem _ as cs) i) = [CElem (Elem n as cs) i]
+replaceTag n _ = []
+
+-- | Replace the attributes of an element (leaving tag the same).
+replaceAttrs :: [(String,String)] -> CFilter i
+replaceAttrs as (CElem (Elem n _ cs) i) = [CElem (Elem n as' cs) i]
+    where as' = map (\(n,v)-> (n, AttValue [Left v])) as
+replaceAttrs as _ = []
+
+
+
+-- LABELLING
+
+-- | A LabelFilter is like a CFilter except that it pairs up a polymorphic
+--   value (label) with each of its results.
+type LabelFilter i a = Content i -> [(a,Content i)]
+
+-- | Compose a label-processing filter with a label-generating filter.
+oo :: (a->CFilter i) -> LabelFilter i a -> CFilter i
+f `oo` g = concatMap (uncurry f) . g
+
+{-
+-- | Process the information labels (very nearly monadic bind).
+oo :: (b -> CFilter b c) -> CFilter a b -> CFilter a c
+f `oo` g = concatMap info . g
+    where info c@(CElem _ i)     = f i c
+          info c@(CString _ _ i) = f i c
+          info c@(CRef _ i)      = f i c
+          info c                 = [c]
+-}
+
+-- | Combine labels.  Think of this as a pair-wise zip on labels.
+--   e.g. @(numbered `x` tagged)@
+x :: (CFilter i->LabelFilter i a) -> (CFilter i->LabelFilter i b) ->
+       (CFilter i->LabelFilter i (a,b))
+f `x` g = \cf c-> let gs = map fst (g cf c)
+                      fs = map fst (f cf c)
+                  in zip (zip fs gs) (cf c)
+
+
+-- Some basic label-generating filters.
+
+-- | Number the results from 1 upwards.
+numbered :: CFilter i -> LabelFilter i Int
+numbered f = zip [1..] . f
+
+-- | In @interspersed a f b@, label each result of @f@ with the string @a@,
+--   except for the last one which is labelled with the string @b@.
+interspersed :: String -> CFilter i -> String -> LabelFilter i String
+interspersed a f b =
+  (\xs-> zip (replicate (len xs) a ++ [b]) xs) . f
+  where
+  len [] = 0
+  len xs = length xs - 1
+
+-- | Label each element in the result with its tag name.  Non-element
+--   results get an empty string label.
+tagged :: CFilter i -> LabelFilter i String
+tagged f = extracted name f
+  where name (CElem (Elem n _ _) _) = n
+        name _                      = ""
+
+-- | Label each element in the result with the value of the named attribute.
+--   Elements without the attribute, and non-element results, get an
+--   empty string label.
+attributed :: String -> CFilter i -> LabelFilter i String
+attributed key f = extracted att f
+  where att (CElem (Elem _ as _) _) =
+            case (lookup key as) of
+              Nothing  -> ""
+              (Just v@(AttValue _)) -> show v
+        att _ = ""
+
+-- | Label each textual part of the result with its text.  Element
+--   results get an empty string label.
+textlabelled :: CFilter i -> LabelFilter i (Maybe String)
+textlabelled f = extracted text f
+  where text (CString _ s _) = Just s
+        text _               = Nothing
+
+-- | Label each content with some information extracted from itself.
+extracted :: (Content i->a) -> CFilter i -> LabelFilter i a
+extracted proj f = concatMap (\c->[(proj c, c)]) . f
+                                                                                
+
+
+{-
+-- MISC
+
+-- | I haven't yet remembered \/ worked out what this does.
+combine :: (Read a,Show a) => ([a]->a) -> LabelFilter String -> CFilter
+combine f lf = \c-> [ CString False (show (f [ read l | (l,_) <- lf c ])) ]
+-}
+
+
+{- OLD STUFF - OBSOLETE
+-- Keep an element by its numbered position (starting at 1).
+position :: Int -> [Content] -> [Content]
+position n | n>0  = (:[]) . (!!(n-1))
+           | otherwise = const []
+
+-- Chop and remove the root portions of trees to depth n.
+layer :: Int -> [Content] -> [Content]
+layer n = apply n (concatMap lay)
+  where lay (CElem (Elem _ _ cs)) = cs
+        lay _ = []
+        apply 0 f xs = xs
+        apply n f xs = apply (n-1) f (f xs)
+
+combine :: (Read a, Show a) => ([a]->a) -> [Content] -> [Content]
+combine f = \cs-> [ CString False (show (f [ read s | CString _ s <- cs ])) ]
+-}
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/DtdToHaskell/Convert.html b/docs/HaXml/src/Text/XML/HaXml/DtdToHaskell/Convert.html
--- a/docs/HaXml/src/Text/XML/HaXml/DtdToHaskell/Convert.html
+++ b/docs/HaXml/src/Text/XML/HaXml/DtdToHaskell/Convert.html
@@ -1,131 +1,137 @@
 
 
-
-- | This module performs the translation of a parsed XML DTD into the
---   internal representation of corresponding Haskell data\/newtypes.
-
-module Text.XML.HaXml.DtdToHaskell.Convert
-  ( dtd2TypeDef
-  ) where
-
-import List (intersperse)
-
-import Text.XML.HaXml.Types hiding (Name)
-import Text.XML.HaXml.DtdToHaskell.TypeDef
-
-
----- Internal representation for database of DTD decls ----
-data Record = R [AttDef] ContentSpec
--- type Db = [(String,Record)]
-
-
----- Build a database of DTD decls then convert them to typedefs ----
----- (Done in two steps because we need to merge ELEMENT and ATTLIST decls.)
----- Apparently multiple ATTLIST decls for the same element are permitted,
----- although only one ELEMENT decl for it is allowed.
-dtd2TypeDef :: [MarkupDecl] -> [TypeDef]
-dtd2TypeDef mds =
-  (concatMap convert . reverse . database []) mds
-  where
-  database db [] = db
-  database db (m:ms) =
-      case m of
-        (Element (ElementDecl n cs)) ->
-          case lookup n db of
-            Nothing -> database ((n, R [] cs):db) ms
-            (Just (R as _)) -> database (replace n (R as cs) db) ms
-        (AttList (AttListDecl n as)) ->
-          case lookup n db of
-            Nothing -> database ((n, R as EMPTY):db) ms
-            (Just (R a cs)) -> database (replace n (R (a++as) cs) db) ms
-    --  (MarkupPE _ m') -> database db (m':ms)
-        _ -> database db ms
-
-  replace _ _ [] = error "dtd2TypeDef.replace: no element to replace"
-  replace n v (x@(n0,_):db)
-      | n==n0     = (n,v): db
-      | otherwise = x: replace n v db
-
-
-
----- Convert DTD record to typedef ----
-convert :: (String, Record) -> [TypeDef]
-convert (n, R as cs) =
-    case cs of
-      EMPTY                   -> modifier None []
-      ANY                     -> modifier None [[Any]]
-                                 --error "NYI: contentspec of ANY"
-      (Mixed PCDATA)          -> modifier None [[String]]
-      (Mixed (PCDATAplus ns)) -> modifier Star ([String]: map ((:[]) . Defined . name) ns)
-      (ContentSpec cp)        ->
-          case cp of
-            (TagName n' m) -> modifier m [[Defined (name n')]]
-            (Choice cps m) -> modifier m (map ((:[]).inner) cps)
-            (Seq cps m)    -> modifier m [map inner cps]
-    ++ concatMap (mkAttrDef n) as
-  where
-    attrs    :: AttrFields
-    attrs     = map (mkAttrField n) as
-
-    modifier None sts   = mkData sts            attrs False (name n)
-    modifier m   [[st]] = mkData [[modf m st]]  attrs False (name n)
-    modifier m    sts   = mkData [[modf m (Defined (name_ n))]]
-                                                attrs False (name n) ++
-                          mkData sts            []    True  (name_ n)
-
-    inner :: CP -> StructType
-    inner (TagName n' m) = modf m (Defined (name n'))
-    inner (Choice cps m) = modf m (OneOf (map inner cps))
-    inner (Seq cps None) = Tuple (map inner cps)
-    inner (Seq cps m)    = modf m (Tuple (map inner cps))
-
-    modf None x  = x
-    modf Query x = Maybe x
-    modf Star x  = List x
-    modf Plus x  = List1 x
-
-mkData :: [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
-mkData []   fs aux n  = [DataDef aux n fs []]
-mkData [ts] fs aux n  = [DataDef aux n fs [(n, ts)]]
-mkData tss  fs aux n  = [DataDef aux n fs (map (mkConstr n) tss)]
-  where
-    mkConstr m ts = (mkConsName m ts, ts)
-    mkConsName (Name x m) sts = Name x (m++concat (intersperse "_" (map flatten sts)))
-    flatten (Maybe st)   = {-"Maybe_" ++ -} flatten st
-    flatten (List st)    = {-"List_" ++ -} flatten st
-    flatten (List1 st)   = {-"List1_" ++ -} flatten st
-    flatten (Tuple sts)  = {-"Tuple" ++ show (length sts) ++ "_" ++ -}
-                            concat (intersperse "_" (map flatten sts))
-    flatten String       = "Str"
-    flatten (OneOf sts)  = {-"OneOf" ++ show (length sts) ++ "_" ++ -}
-                            concat (intersperse "_" (map flatten sts))
-    flatten Any          = "Any"
-    flatten (Defined (Name _ m))  = m
-
-mkAttrDef :: String -> AttDef -> [TypeDef]
-mkAttrDef _ (AttDef _ StringType _) =
-    []
-mkAttrDef _ (AttDef _ (TokenizedType _) _) =
-    [] -- mkData [[String]] [] False (name n)
-mkAttrDef e (AttDef n (EnumeratedType (NotationType nt)) _) =
-    [EnumDef (name_a e n) (map (name_ac e n) nt)]
-mkAttrDef e (AttDef n (EnumeratedType (Enumeration es)) _) =
-    [EnumDef (name_a e n) (map (name_ac e n) es)]
-        -- Default attribute values not handled here
-
-mkAttrField :: String -> AttDef -> (Name,StructType)
-mkAttrField e (AttDef n typ req) = (name_f e n, mkType typ req)
-  where
-    mkType StringType REQUIRED = String
-    mkType StringType IMPLIED  = Maybe String
-    mkType StringType (DefaultTo v@(AttValue _) _) = Defaultable String (show v)
-    mkType (TokenizedType _) REQUIRED  = String
-    mkType (TokenizedType _) IMPLIED   = Maybe String
-    mkType (TokenizedType _) (DefaultTo v@(AttValue _) _) =
-                                                        Defaultable String (show v)
-    mkType (EnumeratedType _) REQUIRED = Defined (name_a e n)
-    mkType (EnumeratedType _) IMPLIED  = Maybe (Defined (name_a e n))
-    mkType (EnumeratedType _) (DefaultTo v@(AttValue _) _) =
-                Defaultable (Defined (name_a e n)) (hName (name_ac e n (show v)))
-
+
+
+src/Text/XML/HaXml/DtdToHaskell/Convert.hs
+
+
+
-- | This module performs the translation of a parsed XML DTD into the
+--   internal representation of corresponding Haskell data\/newtypes.
+
+module Text.XML.HaXml.DtdToHaskell.Convert
+  ( dtd2TypeDef
+  ) where
+
+import List (intersperse,nub)
+
+import Text.XML.HaXml.Types hiding (Name)
+import Text.XML.HaXml.DtdToHaskell.TypeDef
+
+
+---- Internal representation for database of DTD decls ----
+data Record = R [AttDef] ContentSpec
+-- type Db = [(String,Record)]
+
+
+---- Build a database of DTD decls then convert them to typedefs ----
+---- (Done in two steps because we need to merge ELEMENT and ATTLIST decls.)
+---- Apparently multiple ATTLIST decls for the same element are permitted,
+---- although only one ELEMENT decl for it is allowed.
+dtd2TypeDef :: [MarkupDecl] -> [TypeDef]
+dtd2TypeDef mds =
+  (concatMap convert . reverse . database []) mds
+  where
+  database db [] = db
+  database db (m:ms) =
+      case m of
+        (Element (ElementDecl n cs)) ->
+          case lookup n db of
+            Nothing -> database ((n, R [] cs):db) ms
+            (Just (R as _)) -> database (replace n (R as cs) db) ms
+        (AttList (AttListDecl n as)) ->
+          case lookup n db of
+            Nothing -> database ((n, R as EMPTY):db) ms
+            (Just (R a cs)) -> database (replace n (R (nub (a++as)) cs) db) ms
+    --  (MarkupPE _ m') -> database db (m':ms)
+        _ -> database db ms
+
+  replace _ _ [] = error "dtd2TypeDef.replace: no element to replace"
+  replace n v (x@(n0,_):db)
+      | n==n0     = (n,v): db
+      | otherwise = x: replace n v db
+
+
+
+---- Convert DTD record to typedef ----
+convert :: (String, Record) -> [TypeDef]
+convert (n, R as cs) =
+    case cs of
+      EMPTY                   -> modifier None []
+      ANY                     -> modifier None [[Any]]
+                                 --error "NYI: contentspec of ANY"
+      (Mixed PCDATA)          -> modifier None [[String]]
+      (Mixed (PCDATAplus ns)) -> modifier Star ([String]: map ((:[]) . Defined . name) ns)
+      (ContentSpec cp)        ->
+          case cp of
+            (TagName n' m) -> modifier m [[Defined (name n')]]
+            (Choice cps m) -> modifier m (map ((:[]).inner) cps)
+            (Seq cps m)    -> modifier m [map inner cps]
+    ++ concatMap (mkAttrDef n) as
+  where
+    attrs    :: AttrFields
+    attrs     = map (mkAttrField n) as
+
+    modifier None sts   = mkData sts            attrs False (name n)
+    modifier m   [[st]] = mkData [[modf m st]]  attrs False (name n)
+    modifier m    sts   = mkData [[modf m (Defined (name_ n))]]
+                                                attrs False (name n) ++
+                          mkData sts            []    True  (name_ n)
+
+    inner :: CP -> StructType
+    inner (TagName n' m) = modf m (Defined (name n'))
+    inner (Choice cps m) = modf m (OneOf (map inner cps))
+    inner (Seq cps None) = Tuple (map inner cps)
+    inner (Seq cps m)    = modf m (Tuple (map inner cps))
+
+    modf None x  = x
+    modf Query x = Maybe x
+    modf Star x  = List x
+    modf Plus x  = List1 x
+
+mkData :: [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
+mkData []   fs aux n  = [DataDef aux n fs []]
+mkData [ts] fs aux n  = [DataDef aux n fs [(n, ts)]]
+mkData tss  fs aux n  = [DataDef aux n fs (map (mkConstr n) tss)]
+  where
+    mkConstr m ts = (mkConsName m ts, ts)
+    mkConsName (Name x m) sts = Name x (m++concat (intersperse "_" (map flatten sts)))
+    flatten (Maybe st)   = {-"Maybe_" ++ -} flatten st
+    flatten (List st)    = {-"List_" ++ -} flatten st
+    flatten (List1 st)   = {-"List1_" ++ -} flatten st
+    flatten (Tuple sts)  = {-"Tuple" ++ show (length sts) ++ "_" ++ -}
+                            concat (intersperse "_" (map flatten sts))
+    flatten String       = "Str"
+    flatten (OneOf sts)  = {-"OneOf" ++ show (length sts) ++ "_" ++ -}
+                            concat (intersperse "_" (map flatten sts))
+    flatten Any          = "Any"
+    flatten (Defined (Name _ m))  = m
+
+mkAttrDef :: String -> AttDef -> [TypeDef]
+mkAttrDef _ (AttDef _ StringType _) =
+    []
+mkAttrDef _ (AttDef _ (TokenizedType _) _) =
+    [] -- mkData [[String]] [] False (name n)
+mkAttrDef e (AttDef n (EnumeratedType (NotationType nt)) _) =
+    [EnumDef (name_a e n) (map (name_ac e n) nt)]
+mkAttrDef e (AttDef n (EnumeratedType (Enumeration es)) _) =
+    [EnumDef (name_a e n) (map (name_ac e n) es)]
+        -- Default attribute values not handled here
+
+mkAttrField :: String -> AttDef -> (Name,StructType)
+mkAttrField e (AttDef n typ req) = (name_f e n, mkType typ req)
+  where
+    mkType StringType REQUIRED = String
+    mkType StringType IMPLIED  = Maybe String
+    mkType StringType (DefaultTo v@(AttValue _) _) = Defaultable String (show v)
+    mkType (TokenizedType _) REQUIRED  = String
+    mkType (TokenizedType _) IMPLIED   = Maybe String
+    mkType (TokenizedType _) (DefaultTo v@(AttValue _) _) =
+                                                        Defaultable String (show v)
+    mkType (EnumeratedType _) REQUIRED = Defined (name_a e n)
+    mkType (EnumeratedType _) IMPLIED  = Maybe (Defined (name_a e n))
+    mkType (EnumeratedType _) (DefaultTo v@(AttValue _) _) =
+                Defaultable (Defined (name_a e n)) (hName (name_ac e n (show v)))
+
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/DtdToHaskell/Instance.html b/docs/HaXml/src/Text/XML/HaXml/DtdToHaskell/Instance.html
--- a/docs/HaXml/src/Text/XML/HaXml/DtdToHaskell/Instance.html
+++ b/docs/HaXml/src/Text/XML/HaXml/DtdToHaskell/Instance.html
@@ -1,397 +1,405 @@
 
 
-
module Text.XML.HaXml.DtdToHaskell.Instance
-  ( mkInstance
-  ) where
-
-import List (intersperse)
-
-import Text.XML.HaXml.DtdToHaskell.TypeDef
-import Text.PrettyPrint.HughesPJ
-
--- | Convert typedef to appropriate instance declaration, either @XmlContent@,
---   @XmlAttributes@, or @XmlAttrType@.
-mkInstance :: TypeDef -> Doc
-
--- no constructors - represents an element with empty content but attributes.
-mkInstance (DataDef _ n fs []) =
-    let (_, frattr, topat, toattr) = attrpats fs
-        frretval = if null fs then ppHName n else frattr
-        topatval = if null fs then ppHName n else topat
-    in
-    text "instance HTypeable" <+> ppHName n <+> text "where" $$
-    nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" )
-    $$
-    text "instance XmlContent" <+> ppHName n <+> text "where" $$
-    nest 4 (
-             text "toContents" <+> topatval <+> text "=" $$
-             nest 4 (text "[CElem (Elem \"" <> ppXName n <> text "\""
-                          <+> toattr <+> text "[]) ()]")
-           $$
-             text "parseContents = do" $$
-             nest 4 (text "{ (Elem _ as []) <- element [\""
-                             <> ppXName n <> text "\"]" $$
-                     text "; return" <+> frretval $$
-                     text "} `adjustErr` (\"in <" <> ppXName n
-                                                  <> text ">, \"++)"
-                    )
-           )
-    $$
-    mkInstanceAttrs Same n fs
-
--- single constructor, "real" (non-auxiliary) type
-mkInstance (DataDef False n fs [(n0,sts)]) =
-    let vs = nameSupply sts
-        (frpat, frattr, topat, toattr) = attrpats fs
-    in
-    text "instance HTypeable" <+> ppHName n <+> text "where" $$
-    nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" )
-    $$
-    text "instance XmlContent" <+> ppHName n <+> text "where" $$
-    nest 4 (
-             text "toContents" <+> parens (mkCpat n0 topat vs) <+> text "=" $$
-             nest 4 (text "[CElem (Elem \"" <> ppXName n <> text "\""
-                          <+> toattr <+> parens (mkToElem sts vs)
-                          <> text ") ()]")
-           $$
-             text "parseContents = do" $$
-             nest 4 (text "{ e@(Elem _"<+> frpat <+> text "_) <- element [\""
-                             <> ppXName n <> text "\"]"
-                     $$ text "; interior e $"
-                           <+> (mkParseConstr frattr (n0,sts))
-                     $$ text "} `adjustErr` (\"in <" <> ppXName n
-                                                     <> text ">, \"++)")
-           )
-    $$
-    mkInstanceAttrs Extended n fs
-
--- single constructor, auxiliary type (i.e. no corresponding element tag)
---   cannot be attributes here?
-mkInstance (DataDef True n [] [(n0,sts)]) =
-    let vs = nameSupply sts
-    in
-    text "instance HTypeable" <+> ppHName n <+> text "where" $$
-    nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" )
-    $$
-    text "instance XmlContent" <+> ppHName n <+> text "where" $$
-    nest 4 ( text "toContents" <+> parens (mkCpat n0 empty vs)
-                               <+> text "="
-                               $$  nest 4 (parens (mkToElem sts vs))
-           $$
-             text "parseContents =" <+> mkParseConstr empty (n0,sts)
-           )
-
--- multiple constructors (real)
-mkInstance (DataDef False n fs cs) =
-    let _ = nameSupply cs
-        (frpat, frattr, topat, toattr) = attrpats fs
-        _ = if null fs then False else True
-    in
-    text "instance HTypeable" <+> ppHName n <+> text "where" $$
-    nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" )
-    $$
-    text "instance XmlContent" <+> ppHName n <+> text "where" $$
-    nest 4 ( vcat (map (mkToMult n topat toattr) cs)
-           $$ text "parseContents = do "
-           $$ nest 4 (text "{ e@(Elem _"<+> frpat <+> text "_) <- element [\""
-                                                  <> ppXName n <> text "\"]"
-                     $$ text "; interior e $ oneOf"
-                     $$ nest 4 ( text "[" <+> mkParseConstr frattr (head cs)
-                               $$ vcat (map (\c-> text "," <+> mkParseConstr frattr c)
-                                            (tail cs))
-                               $$ text "] `adjustErr` (\"in <" <> ppXName n
-                                                             <> text ">, \"++)"
-                               )
-                     $$ text "}"
-                     )
-           )
-    $$
-    mkInstanceAttrs Extended n fs
-
--- multiple constructors (auxiliary)
-mkInstance (DataDef True n fs cs) =
-    let _ = nameSupply cs
-        (_, frattr, _, _) = attrpats fs
-        mixattrs = if null fs then False else True
-    in
-    text "instance HTypeable" <+> ppHName n <+> text "where" $$
-    nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" )
-    $$
-    text "instance XmlContent" <+> ppHName n <+> text "where" $$
-    nest 4 ( vcat (map (mkToAux mixattrs) cs)
-           $$ text "parseContents = oneOf"
-           $$ nest 4 ( text "[" <+> mkParseConstr frattr (head cs)
-                     $$ vcat (map (\c-> text "," <+> mkParseConstr frattr c)
-                                  (tail cs))
-                     $$ text "] `adjustErr` (\"in <" <> ppXName n
-                                                     <> text ">, \"++)"
-                     )
-           )
-    $$
-    mkInstanceAttrs Extended n fs
-
--- enumeration of attribute values
-mkInstance (EnumDef n es) =
-    text "instance XmlAttrType" <+> ppHName n <+> text "where" $$
-    nest 4 ( text "fromAttrToTyp n (n',v)" $$
-             nest 4 (text "| n==n'     = translate (attr2str v)" $$
-                     text "| otherwise = Nothing") $$
-             nest 2 (text "where" <+> mkTranslate es)
-           $$
-             vcat (map mkToAttr es)
-           )
-
-
-data SameName = Same | Extended
-
-mkInstanceAttrs        :: SameName -> Name -> AttrFields -> Doc
-mkInstanceAttrs _ _ []  = empty
-mkInstanceAttrs s n fs  =
-    let ppName = case s of { Same-> ppHName;  Extended-> ppAName; }
-    in
-    text "instance XmlAttributes" <+> ppName n <+> text "where" $$
-    nest 4 ( text "fromAttrs as =" $$
-             nest 4 ( ppName n $$
-                      nest 2 (vcat ((text "{" <+> mkFrFld n (head fs)):
-                                     map (\x-> comma <+> mkFrFld n x) (tail fs)) $$
-                              text "}"))
-           $$
-             text "toAttrs v = catMaybes " $$
-             nest 4 (vcat ((text "[" <+> mkToFld (head fs)):
-                           map (\x-> comma <+> mkToFld x) (tail fs)) $$
-                     text "]")
-           )
-
-
---                  respectively (frpat,frattr,topat,toattr)
-attrpats :: AttrFields -> (Doc,Doc,Doc,Doc)
-attrpats fs =
-  if null fs then (text "[]", empty, empty, text "[]")
-  else (text "as", parens (text "fromAttrs as"), text "as", parens (text "toAttrs as"))
-
-
-
-
--- mkFrElem :: Name -> [StructType] -> [Doc] -> Doc -> Doc
--- mkFrElem n sts vs inner =
---     foldr (frElem n) inner (zip3 sts vs cvs)
---   where
---     cvs = let ns = nameSupply2 vs
---           in zip ns (text "c0": init ns)
---     frElem _ (st,v,(cvi,cvo)) inner =
---         parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$
---                 nest 2 inner) $$
---         parens (
---           case st of
---             (Maybe String)  -> text "fromText" <+> cvo
---             (Maybe _)       -> text "fromElem" <+> cvo
---             (List String)   -> text "many fromText" <+> cvo
---             (List _)        -> text "many fromElem" <+> cvo
---             (List1 s)       -> text "definite fromElem"
---                                <+> text "\"" <> text (show s)<> text "+\""
---                                <+> text "\"" <> ppXName n <> text "\""
---                                <+> cvo
---             (Tuple ss)  -> text "definite fromElem"
---                            <+> text "\"(" <> hcat (intersperse (text ",")
---                                                            (map (text.show) ss))
---                                           <> text ")\""
---                            <+> text "\"" <> ppXName n <> text "\""
---                            <+> cvo
---             (OneOf _)  -> text "definite fromElem"
---                            <+> text "\"OneOf\""
---                            <+> text "\"" <> ppXName n <> text "\""
---                            <+> cvo
---             (String)    -> text "definite fromText" <+> text "\"text\" \"" <>
---                                                  ppXName n <> text "\"" <+> cvo
---             (Any)       -> text "definite fromElem" <+> text "\"ANY\" \"" <>
---                                                  ppXName n <> text "\"" <+> cvo
---             (Defined m) -> text "definite fromElem" <+>
---                                  text "\"<" <> ppXName m <> text ">\" \"" <>
---                                                  ppXName m <> text "\"" <+> cvo
---             (Defaultable _ _)  -> text "nyi_fromElem_Defaultable" <+> cvo
---           )
-
---
-{-
-mkParseContents :: Name -> [StructType] -> [Doc] -> Doc -> Doc
-mkParseContents n sts vs inner =
-    foldr (frElem n) inner (zip3 sts vs cvs)
-  where
-    cvs = let ns = nameSupply2 vs
-          in zip ns (text "c0": init ns)
-    frElem n (st,v,(cvi,cvo)) inner =
-        parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$
-                nest 2 inner) $$
-        parens (
-          )
--}
-mkParseConstr :: Doc -> (Name, [StructType]) -> Doc
-mkParseConstr frattr (c,sts) =
-        fsep (text "return" <+> parens (ppHName c <+> frattr)
-             : map mkParseContents sts)
-
-mkParseContents :: StructType -> Doc
-mkParseContents st =
-  let ap = text "`apply`" in
-          case st of
-            (Maybe String)  -> ap <+> text "optional text"
-            (Maybe _)       -> ap <+> text "optional parseContents"
-            (List String)   -> ap <+> text "many text"
-            (List _)        -> ap <+> text "many parseContents"
-            (List1 _)       -> ap <+> text "parseContents"
-            (Tuple _)      -> ap <+> text "parseContents"
-            (OneOf _)      -> ap <+> text "parseContents"
-            (String)        -> ap <+> text "(text `onFail` return \"\")"
-            (Any)           -> ap <+> text "parseContents"
-            (Defined _)     -> ap <+> text "parseContents"
-            (Defaultable _ _)  -> ap <+> text "nyi_fromElem_Defaultable"
-
---
-mkToElem :: [StructType] -> [Doc] -> Doc
-mkToElem []  [] = text "[]"
-mkToElem sts vs =
-    fsep (intersperse (text "++") (zipWith toElem sts vs))
-  where
-    toElem st v =
-      case st of
-        (Maybe String)  -> text "maybe [] toText" <+> v
-        (Maybe _)       -> text "maybe [] toContents" <+> v
-        (List String)   -> text "concatMap toText" <+> v
-        (List _)        -> text "concatMap toContents" <+> v
-        (List1 _)       -> text "toContents" <+> v
-        (Tuple _)      -> text "toContents" <+> v
-        (OneOf _)      -> text "toContents" <+> v
-        (String)        -> text "toText" <+> v
-        (Any)           -> text "toContents" <+> v
-        (Defined _)     -> text "toContents" <+> v
-        (Defaultable _ _)  -> text "nyi_toElem_Defaultable" <+> v
-
--- mkRpat :: [Doc] -> Doc
--- mkRpat [v] = v
--- mkRpat vs  = (parens . hcat . intersperse comma) vs
-
-mkCpat :: Name -> Doc -> [Doc] -> Doc
-mkCpat n i vs = ppHName n <+> i <+> fsep vs
-
-nameSupply :: [b] -> [Doc]
-nameSupply  ss = take (length ss) (map char ['a'..])
--- nameSupply2 ss = take (length ss) [ text ('c':v:[]) | v <- ['a'..]]
-
-mkTranslate :: [Name] -> Doc
-mkTranslate es =
-    vcat (map trans es) $$
-    text "translate _ = Nothing"
-  where
-    trans n = text "translate \"" <> ppXName n <> text "\" =" <+>
-              text "Just" <+> ppHName n
-
-mkToAttr :: Name -> Doc
-mkToAttr n = text "toAttrFrTyp n" <+> ppHName n <+> text "=" <+>
-             text "Just (n, str2attr" <+> doubleQuotes (ppXName n) <> text ")"
-
-mkFrFld :: Name -> (Name,StructType) -> Doc
-mkFrFld tag (n,st) =
-    ppHName n <+> text "=" <+>
-    ( case st of
-        (Defaultable String s) -> text "defaultA fromAttrToStr" <+>
-                                                 doubleQuotes (text s)
-        (Defaultable _ s)      -> text "defaultA fromAttrToTyp" <+> text s
-        (Maybe String)         -> text "possibleA fromAttrToStr"
-        (Maybe _)              -> text "possibleA fromAttrToTyp"
-        String                 -> text "definiteA fromAttrToStr" <+>
-                                                 doubleQuotes (ppXName tag)
-        _                      -> text "definiteA fromAttrToTyp" <+>
-                                                 doubleQuotes (ppXName tag)
-    ) <+> doubleQuotes (ppXName n) <+> text "as"
-
-mkToFld :: (Name,StructType) -> Doc
-mkToFld (n,st) =
-    ( case st of
-        (Defaultable String _) -> text "defaultToAttr toAttrFrStr"
-        (Defaultable _ _)      -> text "defaultToAttr toAttrFrTyp"
-        (Maybe String)         -> text "maybeToAttr toAttrFrStr"
-        (Maybe _)              -> text "maybeToAttr toAttrFrTyp"
-        String                 -> text "toAttrFrStr"
-        _                      -> text "toAttrFrTyp"
-    ) <+> doubleQuotes (ppXName n) <+> parens (ppHName n <+> text "v")
-
--- mkFrAux :: Bool -> Doc -> [(Name,[StructType])] -> Doc
--- mkFrAux keeprest attrs cs = foldr frAux inner cs
---   where
---     inner = text "(Nothing, c0)"
---     rest  = if keeprest then text "rest" else text "_"
---     frAux (n,sts) innr =
---         let vs  = nameSupply sts in
---         nest 4 (text "case" <+> blah sts vs <+> text "of" $$
---                 succpat sts vs <+> text "-> (Just" <+>
---                                    parens (mkCpat n attrs vs) <> text ", rest)"
---                 $$
---                 failpat sts <+> text "->" $$ nest 4 innr
---                )
---     blah [st] [_] =
---         blahblahblah st (text "c0")
---     blah sts vs =
---         let ns = nameSupply2 vs
---             cvs = zip ns (text "c0": init ns)
---             blahblah (st,v,(cvi,cvo)) innr =
---                 parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$
---                         nest 2 innr) $$
---                 blahblahblah st cvo
---         in
---         foldr blahblah (mkRpat (vs++[last ns])) (zip3 sts vs cvs)
---     blahblahblah st cvo = parens (
---         case st of
---           (Maybe String) -> text "fromText" <+> cvo
---           (Maybe _)      -> text "fromElem" <+> cvo
---           (List String)  -> text "many fromText" <+> cvo
---           (List _)       -> text "many fromElem" <+> cvo
---           (List1 _)      -> text "fromElem" <+> cvo
---           (Tuple _)     -> text "fromElem" <+> cvo      -- ??
---           (OneOf _)     -> text "fromElem" <+> cvo
---           (String)       -> text "fromText" <+> cvo
---           (Any)          -> text "fromElem" <+> cvo
---           (Defined _)    -> text "fromElem" <+> cvo
---         )
---     failpat sts =
---         let fp st =
---                 case st of
---                   (Maybe _)   -> text "Nothing"
---                   (List _)    -> text "[]"
---                   (List1 _)   -> text "_"
---                   (Tuple _)  -> text "_"
---                   (OneOf _)  -> text "_"
---                   (String)    -> text "_"
---                   (Any)       -> text "_"
---                   (Defined _) -> text "_"
---         in parens (hcat (intersperse comma (map fp sts++[text "_"])))
---     succpat sts vs =
---         let sp st v =
---                 case st of
---                   (Maybe _)   -> v
---                   (List _)    -> v
---                   (List1 _)   -> text "Just" <+> v
---                   (Tuple _)  -> text "Just" <+> v
---                   (OneOf _)  -> text "Just" <+> v
---                   (String)    -> text "Just" <+> v
---                   (Any)       -> text "Just" <+> v
---                   (Defined _) -> text "Just" <+> v
---         in parens (hcat (intersperse comma (zipWith sp sts vs++[rest])))
-
-mkToAux :: Bool -> (Name,[StructType]) -> Doc
-mkToAux mixattrs (n,sts) =
-    let vs = nameSupply sts
-        attrs = if mixattrs then text "as" else empty
-    in
-    text "toContents" <+> parens (mkCpat n attrs vs) <+> text "=" <+>
-    mkToElem sts vs
-
-mkToMult :: Name -> Doc -> Doc -> (Name,[StructType]) -> Doc
-mkToMult tag attrpat attrexp (n,sts) =
-    let vs = nameSupply sts
-    in
-    text "toContents" <+> parens (mkCpat n attrpat vs) <+> text "="
-    $$ nest 4 (text "[CElem (Elem \"" <> ppXName tag <> text "\""<+> attrexp
-              <+> parens (mkToElem sts vs) <+> text ") ()]")
-
+
+
+src/Text/XML/HaXml/DtdToHaskell/Instance.hs
+
+
+
module Text.XML.HaXml.DtdToHaskell.Instance
+  ( mkInstance
+  ) where
+
+import List (intersperse)
+
+import Text.XML.HaXml.DtdToHaskell.TypeDef
+import Text.PrettyPrint.HughesPJ
+
+-- | Convert typedef to appropriate instance declaration, either @XmlContent@,
+--   @XmlAttributes@, or @XmlAttrType@.
+mkInstance :: TypeDef -> Doc
+
+-- no constructors - represents an element with empty content but attributes.
+mkInstance (DataDef _ n fs []) =
+    let (_, frattr, topat, toattr) = attrpats fs
+        frretval = if null fs then ppHName n else frattr
+        topatval = if null fs then ppHName n else topat
+    in
+    text "instance HTypeable" <+> ppHName n <+> text "where" $$
+    nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" )
+    $$
+    text "instance XmlContent" <+> ppHName n <+> text "where" $$
+    nest 4 (
+             text "toContents" <+> topatval <+> text "=" $$
+             nest 4 (text "[CElem (Elem \"" <> ppXName n <> text "\""
+                          <+> toattr <+> text "[]) ()]")
+           $$
+             text "parseContents = do" $$
+             nest 4 (text "{ (Elem _ as []) <- element [\""
+                             <> ppXName n <> text "\"]" $$
+                     text "; return" <+> frretval $$
+                     text "} `adjustErr` (\"in <" <> ppXName n
+                                                  <> text ">, \"++)"
+                    )
+           )
+    $$
+    mkInstanceAttrs Same n fs
+
+-- single constructor, "real" (non-auxiliary) type
+mkInstance (DataDef False n fs [(n0,sts)]) =
+    let vs = nameSupply sts
+        (frpat, frattr, topat, toattr) = attrpats fs
+    in
+    text "instance HTypeable" <+> ppHName n <+> text "where" $$
+    nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" )
+    $$
+    text "instance XmlContent" <+> ppHName n <+> text "where" $$
+    nest 4 (
+             text "toContents" <+> parens (mkCpat n0 topat vs) <+> text "=" $$
+             nest 4 (text "[CElem (Elem \"" <> ppXName n <> text "\""
+                          <+> toattr <+> parens (mkToElem sts vs)
+                          <> text ") ()]")
+           $$
+             text "parseContents = do" $$
+             nest 4 (text "{ e@(Elem _"<+> frpat <+> text "_) <- element [\""
+                             <> ppXName n <> text "\"]"
+                     $$ text "; interior e $"
+                           <+> (mkParseConstr frattr (n0,sts))
+                     $$ text "} `adjustErr` (\"in <" <> ppXName n
+                                                     <> text ">, \"++)")
+           )
+    $$
+    mkInstanceAttrs Extended n fs
+
+-- single constructor, auxiliary type (i.e. no corresponding element tag)
+--   cannot be attributes here?
+mkInstance (DataDef True n [] [(n0,sts)]) =
+    let vs = nameSupply sts
+    in
+    text "instance HTypeable" <+> ppHName n <+> text "where" $$
+    nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" )
+    $$
+    text "instance XmlContent" <+> ppHName n <+> text "where" $$
+    nest 4 ( text "toContents" <+> parens (mkCpat n0 empty vs)
+                               <+> text "="
+                               $$  nest 4 (parens (mkToElem sts vs))
+           $$
+             text "parseContents =" <+> mkParseConstr empty (n0,sts)
+           )
+
+-- multiple constructors (real)
+mkInstance (DataDef False n fs cs) =
+    let _ = nameSupply cs
+        (frpat, frattr, topat, toattr) = attrpats fs
+        _ = if null fs then False else True
+    in
+    text "instance HTypeable" <+> ppHName n <+> text "where" $$
+    nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" )
+    $$
+    text "instance XmlContent" <+> ppHName n <+> text "where" $$
+    nest 4 ( vcat (map (mkToMult n topat toattr) cs)
+           $$ text "parseContents = do "
+           $$ nest 4 (text "{ e@(Elem _"<+> frpat <+> text "_) <- element [\""
+                                                  <> ppXName n <> text "\"]"
+                     $$ text "; interior e $ oneOf"
+                     $$ nest 4 ( text "[" <+> mkParseConstr frattr (head cs)
+                               $$ vcat (map (\c-> text "," <+> mkParseConstr frattr c)
+                                            (tail cs))
+                               $$ text "] `adjustErr` (\"in <" <> ppXName n
+                                                             <> text ">, \"++)"
+                               )
+                     $$ text "}"
+                     )
+           )
+    $$
+    mkInstanceAttrs Extended n fs
+
+-- multiple constructors (auxiliary)
+mkInstance (DataDef True n fs cs) =
+    let _ = nameSupply cs
+        (_, frattr, _, _) = attrpats fs
+        mixattrs = if null fs then False else True
+    in
+    text "instance HTypeable" <+> ppHName n <+> text "where" $$
+    nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" )
+    $$
+    text "instance XmlContent" <+> ppHName n <+> text "where" $$
+    nest 4 ( vcat (map (mkToAux mixattrs) cs)
+           $$ text "parseContents = oneOf"
+           $$ nest 4 ( text "[" <+> mkParseConstr frattr (head cs)
+                     $$ vcat (map (\c-> text "," <+> mkParseConstr frattr c)
+                                  (tail cs))
+                     $$ text "] `adjustErr` (\"in <" <> ppXName n
+                                                     <> text ">, \"++)"
+                     )
+           )
+    $$
+    mkInstanceAttrs Extended n fs
+
+-- enumeration of attribute values
+mkInstance (EnumDef n es) =
+    text "instance XmlAttrType" <+> ppHName n <+> text "where" $$
+    nest 4 ( text "fromAttrToTyp n (n',v)" $$
+             nest 4 (text "| n==n'     = translate (attr2str v)" $$
+                     text "| otherwise = Nothing") $$
+             nest 2 (text "where" <+> mkTranslate es)
+           $$
+             vcat (map mkToAttr es)
+           )
+
+
+data SameName = Same | Extended
+
+mkInstanceAttrs        :: SameName -> Name -> AttrFields -> Doc
+mkInstanceAttrs _ _ []  = empty
+mkInstanceAttrs s n fs  =
+    let ppName = case s of { Same-> ppHName;  Extended-> ppAName; }
+    in
+    text "instance XmlAttributes" <+> ppName n <+> text "where" $$
+    nest 4 ( text "fromAttrs as =" $$
+             nest 4 ( ppName n $$
+                      nest 2 (vcat ((text "{" <+> mkFrFld n (head fs)):
+                                     map (\x-> comma <+> mkFrFld n x) (tail fs)) $$
+                              text "}"))
+           $$
+             text "toAttrs v = catMaybes " $$
+             nest 4 (vcat ((text "[" <+> mkToFld (head fs)):
+                           map (\x-> comma <+> mkToFld x) (tail fs)) $$
+                     text "]")
+           )
+
+
+--                  respectively (frpat,frattr,topat,toattr)
+attrpats :: AttrFields -> (Doc,Doc,Doc,Doc)
+attrpats fs =
+  if null fs then (text "[]", empty, empty, text "[]")
+  else (text "as", parens (text "fromAttrs as"), text "as", parens (text "toAttrs as"))
+
+
+
+
+-- mkFrElem :: Name -> [StructType] -> [Doc] -> Doc -> Doc
+-- mkFrElem n sts vs inner =
+--     foldr (frElem n) inner (zip3 sts vs cvs)
+--   where
+--     cvs = let ns = nameSupply2 vs
+--           in zip ns (text "c0": init ns)
+--     frElem _ (st,v,(cvi,cvo)) inner =
+--         parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$
+--                 nest 2 inner) $$
+--         parens (
+--           case st of
+--             (Maybe String)  -> text "fromText" <+> cvo
+--             (Maybe _)       -> text "fromElem" <+> cvo
+--             (List String)   -> text "many fromText" <+> cvo
+--             (List _)        -> text "many fromElem" <+> cvo
+--             (List1 s)       -> text "definite fromElem"
+--                                <+> text "\"" <> text (show s)<> text "+\""
+--                                <+> text "\"" <> ppXName n <> text "\""
+--                                <+> cvo
+--             (Tuple ss)  -> text "definite fromElem"
+--                            <+> text "\"(" <> hcat (intersperse (text ",")
+--                                                            (map (text.show) ss))
+--                                           <> text ")\""
+--                            <+> text "\"" <> ppXName n <> text "\""
+--                            <+> cvo
+--             (OneOf _)  -> text "definite fromElem"
+--                            <+> text "\"OneOf\""
+--                            <+> text "\"" <> ppXName n <> text "\""
+--                            <+> cvo
+--             (String)    -> text "definite fromText" <+> text "\"text\" \"" <>
+--                                                  ppXName n <> text "\"" <+> cvo
+--             (Any)       -> text "definite fromElem" <+> text "\"ANY\" \"" <>
+--                                                  ppXName n <> text "\"" <+> cvo
+--             (Defined m) -> text "definite fromElem" <+>
+--                                  text "\"<" <> ppXName m <> text ">\" \"" <>
+--                                                  ppXName m <> text "\"" <+> cvo
+--             (Defaultable _ _)  -> text "nyi_fromElem_Defaultable" <+> cvo
+--           )
+
+--
+{-
+mkParseContents :: Name -> [StructType] -> [Doc] -> Doc -> Doc
+mkParseContents n sts vs inner =
+    foldr (frElem n) inner (zip3 sts vs cvs)
+  where
+    cvs = let ns = nameSupply2 vs
+          in zip ns (text "c0": init ns)
+    frElem n (st,v,(cvi,cvo)) inner =
+        parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$
+                nest 2 inner) $$
+        parens (
+          )
+-}
+mkParseConstr :: Doc -> (Name, [StructType]) -> Doc
+mkParseConstr frattr (c,sts) =
+        fsep (text "return" <+> parens (ppHName c <+> frattr)
+             : map mkParseContents sts)
+
+mkParseContents :: StructType -> Doc
+mkParseContents st =
+  let ap = text "`apply`" in
+          case st of
+            (Maybe String)  -> ap <+> text "optional text"
+            (Maybe _)       -> ap <+> text "optional parseContents"
+            (List String)   -> ap <+> text "many text"
+            (List _)        -> ap <+> text "many parseContents"
+            (List1 _)       -> ap <+> text "parseContents"
+            (Tuple _)      -> ap <+> text "parseContents"
+            (OneOf _)      -> ap <+> text "parseContents"
+            (String)        -> ap <+> text "(text `onFail` return \"\")"
+            (Any)           -> ap <+> text "parseContents"
+            (Defined _)     -> ap <+> text "parseContents"
+            (Defaultable _ _)  -> ap <+> text "nyi_fromElem_Defaultable"
+
+--
+mkToElem :: [StructType] -> [Doc] -> Doc
+mkToElem []  [] = text "[]"
+mkToElem sts vs =
+    fsep (intersperse (text "++") (zipWith toElem sts vs))
+  where
+    toElem st v =
+      case st of
+        (Maybe String)  -> text "maybe [] toText" <+> v
+        (Maybe _)       -> text "maybe [] toContents" <+> v
+        (List String)   -> text "concatMap toText" <+> v
+        (List _)        -> text "concatMap toContents" <+> v
+        (List1 _)       -> text "toContents" <+> v
+        (Tuple _)      -> text "toContents" <+> v
+        (OneOf _)      -> text "toContents" <+> v
+        (String)        -> text "toText" <+> v
+        (Any)           -> text "toContents" <+> v
+        (Defined _)     -> text "toContents" <+> v
+        (Defaultable _ _)  -> text "nyi_toElem_Defaultable" <+> v
+
+-- mkRpat :: [Doc] -> Doc
+-- mkRpat [v] = v
+-- mkRpat vs  = (parens . hcat . intersperse comma) vs
+
+mkCpat :: Name -> Doc -> [Doc] -> Doc
+mkCpat n i vs = ppHName n <+> i <+> fsep vs
+
+nameSupply :: [b] -> [Doc]
+nameSupply  ss = take (length ss) (map char ['a'..'z']
+                                  ++ map text [ a:n:[] | n <- ['0'..'9']
+                                                       , a <- ['a'..'z'] ])
+-- nameSupply2 ss = take (length ss) [ text ('c':v:[]) | v <- ['a'..]]
+
+mkTranslate :: [Name] -> Doc
+mkTranslate es =
+    vcat (map trans es) $$
+    text "translate _ = Nothing"
+  where
+    trans n = text "translate \"" <> ppXName n <> text "\" =" <+>
+              text "Just" <+> ppHName n
+
+mkToAttr :: Name -> Doc
+mkToAttr n = text "toAttrFrTyp n" <+> ppHName n <+> text "=" <+>
+             text "Just (n, str2attr" <+> doubleQuotes (ppXName n) <> text ")"
+
+mkFrFld :: Name -> (Name,StructType) -> Doc
+mkFrFld tag (n,st) =
+    ppHName n <+> text "=" <+>
+    ( case st of
+        (Defaultable String s) -> text "defaultA fromAttrToStr" <+>
+                                                 doubleQuotes (text s)
+        (Defaultable _ s)      -> text "defaultA fromAttrToTyp" <+> text s
+        (Maybe String)         -> text "possibleA fromAttrToStr"
+        (Maybe _)              -> text "possibleA fromAttrToTyp"
+        String                 -> text "definiteA fromAttrToStr" <+>
+                                                 doubleQuotes (ppXName tag)
+        _                      -> text "definiteA fromAttrToTyp" <+>
+                                                 doubleQuotes (ppXName tag)
+    ) <+> doubleQuotes (ppXName n) <+> text "as"
+
+mkToFld :: (Name,StructType) -> Doc
+mkToFld (n,st) =
+    ( case st of
+        (Defaultable String _) -> text "defaultToAttr toAttrFrStr"
+        (Defaultable _ _)      -> text "defaultToAttr toAttrFrTyp"
+        (Maybe String)         -> text "maybeToAttr toAttrFrStr"
+        (Maybe _)              -> text "maybeToAttr toAttrFrTyp"
+        String                 -> text "toAttrFrStr"
+        _                      -> text "toAttrFrTyp"
+    ) <+> doubleQuotes (ppXName n) <+> parens (ppHName n <+> text "v")
+
+-- mkFrAux :: Bool -> Doc -> [(Name,[StructType])] -> Doc
+-- mkFrAux keeprest attrs cs = foldr frAux inner cs
+--   where
+--     inner = text "(Nothing, c0)"
+--     rest  = if keeprest then text "rest" else text "_"
+--     frAux (n,sts) innr =
+--         let vs  = nameSupply sts in
+--         nest 4 (text "case" <+> blah sts vs <+> text "of" $$
+--                 succpat sts vs <+> text "-> (Just" <+>
+--                                    parens (mkCpat n attrs vs) <> text ", rest)"
+--                 $$
+--                 failpat sts <+> text "->" $$ nest 4 innr
+--                )
+--     blah [st] [_] =
+--         blahblahblah st (text "c0")
+--     blah sts vs =
+--         let ns = nameSupply2 vs
+--             cvs = zip ns (text "c0": init ns)
+--             blahblah (st,v,(cvi,cvo)) innr =
+--                 parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$
+--                         nest 2 innr) $$
+--                 blahblahblah st cvo
+--         in
+--         foldr blahblah (mkRpat (vs++[last ns])) (zip3 sts vs cvs)
+--     blahblahblah st cvo = parens (
+--         case st of
+--           (Maybe String) -> text "fromText" <+> cvo
+--           (Maybe _)      -> text "fromElem" <+> cvo
+--           (List String)  -> text "many fromText" <+> cvo
+--           (List _)       -> text "many fromElem" <+> cvo
+--           (List1 _)      -> text "fromElem" <+> cvo
+--           (Tuple _)     -> text "fromElem" <+> cvo      -- ??
+--           (OneOf _)     -> text "fromElem" <+> cvo
+--           (String)       -> text "fromText" <+> cvo
+--           (Any)          -> text "fromElem" <+> cvo
+--           (Defined _)    -> text "fromElem" <+> cvo
+--         )
+--     failpat sts =
+--         let fp st =
+--                 case st of
+--                   (Maybe _)   -> text "Nothing"
+--                   (List _)    -> text "[]"
+--                   (List1 _)   -> text "_"
+--                   (Tuple _)  -> text "_"
+--                   (OneOf _)  -> text "_"
+--                   (String)    -> text "_"
+--                   (Any)       -> text "_"
+--                   (Defined _) -> text "_"
+--         in parens (hcat (intersperse comma (map fp sts++[text "_"])))
+--     succpat sts vs =
+--         let sp st v =
+--                 case st of
+--                   (Maybe _)   -> v
+--                   (List _)    -> v
+--                   (List1 _)   -> text "Just" <+> v
+--                   (Tuple _)  -> text "Just" <+> v
+--                   (OneOf _)  -> text "Just" <+> v
+--                   (String)    -> text "Just" <+> v
+--                   (Any)       -> text "Just" <+> v
+--                   (Defined _) -> text "Just" <+> v
+--         in parens (hcat (intersperse comma (zipWith sp sts vs++[rest])))
+
+mkToAux :: Bool -> (Name,[StructType]) -> Doc
+mkToAux mixattrs (n,sts) =
+    let vs = nameSupply sts
+        attrs = if mixattrs then text "as" else empty
+    in
+    text "toContents" <+> parens (mkCpat n attrs vs) <+> text "=" <+>
+    mkToElem sts vs
+
+mkToMult :: Name -> Doc -> Doc -> (Name,[StructType]) -> Doc
+mkToMult tag attrpat attrexp (n,sts) =
+    let vs = nameSupply sts
+    in
+    text "toContents" <+> parens (mkCpat n attrpat vs) <+> text "="
+    $$ nest 4 (text "[CElem (Elem \"" <> ppXName tag <> text "\""<+> attrexp
+              <+> parens (mkToElem sts vs) <+> text ") ()]")
+
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/DtdToHaskell/TypeDef.html b/docs/HaXml/src/Text/XML/HaXml/DtdToHaskell/TypeDef.html
--- a/docs/HaXml/src/Text/XML/HaXml/DtdToHaskell/TypeDef.html
+++ b/docs/HaXml/src/Text/XML/HaXml/DtdToHaskell/TypeDef.html
@@ -1,252 +1,258 @@
 
 
-
-- | Defines an internal representation of Haskell data\/newtype definitions
---   that correspond to the XML DTD types, and provides pretty-printers to
---   convert these types into the 'Doc' type of "Text.PrettyPrint.HughesPJ".
-
-module Text.XML.HaXml.DtdToHaskell.TypeDef
-  ( -- * Internal representation of types
-    TypeDef(..)
-  , Constructors
-  , AttrFields
-  , StructType(..)
-  -- * Pretty-print a TypeDef
-  , ppTypeDef
-  , ppHName
-  , ppXName
-  , ppAName
-  -- * Name mangling
-  , Name(..)
-  , name, name_, name_a, name_ac, name_f, mangle, manglef
-  ) where
-
-import Char (isLower, isUpper, toLower, toUpper, isDigit)
-import List (intersperse)
-import Text.PrettyPrint.HughesPJ
-
-
----- Internal representation for typedefs ----
-
--- | Need to keep both the XML and Haskell versions of a name.
-data Name = Name { xName :: String       -- ^ original XML name
-                 , hName :: String       -- ^ mangled Haskell name
-                 }
-          deriving Eq
-
-data TypeDef =
-      DataDef Bool Name AttrFields Constructors -- ^ Bool for main\/aux.
-    | EnumDef Name [Name]
-    deriving Eq
-type Constructors = [(Name,[StructType])]
-type AttrFields   = [(Name, StructType)]
-data StructType =
-      Maybe StructType
-    | Defaultable StructType String     -- ^ String holds default value.
-    | List StructType
-    | List1 StructType                  -- ^ Non-empty lists.
-    | Tuple [StructType]
-    | OneOf [StructType]
-    | Any                               -- ^ XML's contentspec allows ANY
-    | String
-    | Defined Name
-    deriving Eq
-
--- used for converting StructType (roughly) back to an XML content model
-instance Show StructType where
-    showsPrec p (Maybe s)         = showsPrec (p+1) s . showChar '?'
-    showsPrec _ (Defaultable s _) = shows s
-    showsPrec p (List s)          = showsPrec (p+1) s . showChar '*'
-    showsPrec p (List1 s)         = showsPrec (p+1) s . showChar '+'
-    showsPrec _ (Tuple ss)        = showChar '('
-                                    . foldr1 (.) (intersperse (showChar ',')
-                                                              (map shows ss))
-                                    . showChar ')'
-    showsPrec _ (OneOf ss)        = showChar '('
-                                    . foldr1 (.) (intersperse (showChar '|')
-                                                              (map shows ss))
-                                    . showChar ')'
-    showsPrec _ (Any)             = showString "ANY"
-    showsPrec _ (String)          = showString "#PCDATA"
-    showsPrec _ (Defined (Name n _)) = showString n
-
-
----- Pretty-printing typedefs ----
-ppTypeDef :: TypeDef -> Doc
-
---      no attrs, no constructors
-ppTypeDef (DataDef _ n [] []) =
-    let nme = ppHName n in
-    text "data" <+> nme <+> text "=" <+> nme <+> text "\t\t" <> derives
-
---      no attrs, single constructor
-ppTypeDef (DataDef _ n [] [c@(_,[_])]) =
-    text "newtype" <+> ppHName n <+> text "=" <+> ppC c <+> text "\t\t" <> derives
-
---      no attrs, multiple constrs
-ppTypeDef (DataDef _ n [] cs) =
-    text "data" <+> ppHName n <+>
-           ( text "=" <+> ppC (head cs) $$
-             vcat (map (\c-> text "|" <+> ppC c) (tail cs)) $$
-             derives )
-
---      nonzero attrs, no constructors
-ppTypeDef (DataDef _ n fs []) =
-    let nme = ppHName n in
-    text "data" <+> nme <+> text "=" <+> nme $$
-    nest 4 ( text "{" <+> ppF (head fs) $$
-             vcat (map (\f-> text "," <+> ppF f) (tail fs)) $$
-             text "}" <+> derives )
-
---      nonzero attrs, one or more constrs
-ppTypeDef (DataDef _ n fs cs) =
-    let attr = ppAName n in
-    text "data" <+> ppHName n <+>
-           ( text "=" <+> ppAC attr (head cs) $$
-             vcat (map (\c-> text "|" <+> ppAC attr c) (tail cs)) $$
-             derives )  $$
-    text "data" <+> attr <+> text "=" <+> attr $$
-    nest 4 ( text "{" <+> ppF (head fs) $$
-             vcat (map (\f-> text "," <+> ppF f) (tail fs)) $$
-             text "}" <+> derives )
-
---      enumerations (of attribute values)
-ppTypeDef (EnumDef n es) =
-    text "data" <+> ppHName n <+>
-    ( text "=" <+>
-      fsep (intersperse (text " | ") (map ppHName es))
-    $$ derives )
-
-
-ppST :: StructType -> Doc
-ppST (Defaultable st _)  = parens (text "Defaultable" <+> ppST st)
-ppST (Maybe st)  = parens (text "Maybe" <+> ppST st)
-ppST (List st)   = text "[" <> ppST st <> text "]"
-ppST (List1 st)  = parens (text "List1" <+> ppST st)
-ppST (Tuple sts) = parens (commaList (map ppST sts))
-ppST (OneOf sts) = parens (text "OneOf" <> text (show (length sts)) <+>
-                           hsep (map ppST sts))
-ppST  String     = text "String"
-ppST  Any        = text "ANYContent"
-ppST (Defined n) = ppHName n
-
--- constructor and components
-ppC :: (Name,[StructType]) -> Doc
-ppC (n,sts) = ppHName n <+> fsep (map ppST sts)
-
--- attribute (fieldname and type)
-ppF :: (Name,StructType) -> Doc
-ppF (n,st) = ppHName n <+> text "::" <+> ppST st
-
--- constructor and components with initial attr-type
-ppAC :: Doc -> (Name,[StructType]) -> Doc
-ppAC atype (n,sts) = ppHName n <+> fsep (atype: map ppST sts)
-
--- | Pretty print Haskell name.
-ppHName :: Name -> Doc
-ppHName (Name _ s) = text s
--- | Pretty print XML name.
-ppXName :: Name -> Doc
-ppXName (Name s _) = text s
--- | Pretty print Haskell attributes name.
-ppAName :: Name -> Doc
-ppAName (Name _ s) = text s <> text "_Attrs"
-
-derives :: Doc
-derives = text "deriving" <+> parens (commaList (map text ["Eq","Show"]))
-
-
----- Some operations on Names ----
-
--- | Make a type name valid in both XML and Haskell.
-name :: String -> Name
-name n     = Name { xName = n
-                  , hName = mangle n }
-
--- | Append an underscore to the Haskell version of the name.
-name_ :: String -> Name
-name_ n    = Name { xName = n
-                  , hName = mangle n ++ "_" }
-
--- | Prefix an attribute enumeration type name with its containing element
---   name.
-name_a :: String -> String -> Name
-name_a e n = Name { xName = n
-                  , hName = mangle e ++ "_" ++ map decolonify n }
-
--- | Prefix an attribute enumeration constructor with its element-tag name,
---   and its enumeration type name.
-name_ac :: String -> String -> String -> Name
-name_ac e t n = Name { xName = n
-                     , hName = mangle e ++ "_" ++ map decolonify t
-                                        ++ "_" ++ map decolonify n }
-
--- | Prefix a field name with its enclosing element name.
-name_f :: String -> String -> Name
-name_f e n = Name { xName = n
-                  , hName = manglef e ++ mangle n }
-
----- obsolete
--- elementname_at :: String -> Name
--- elementname_at n  = Name n (mangle n ++ "_Attrs")
-
--- | Convert an XML name to a Haskell conid.
-mangle :: String -> String
-mangle (n:ns)
-    | isLower n   = notPrelude (toUpper n: map decolonify ns)
-    | isDigit n   = 'I': n: map decolonify ns
-    | otherwise   = notPrelude (n: map decolonify ns)
-
--- | Ensure a generated name does not conflict with a standard haskell one.
-notPrelude :: String -> String
-notPrelude "Bool"    = "ABool"
-notPrelude "Bounded" = "ABounded"
-notPrelude "Char"    = "AChar"
-notPrelude "Double"  = "ADouble"
-notPrelude "Either"  = "AEither"
-notPrelude "Enum"    = "AEnum"
-notPrelude "Eq"      = "AEq"
-notPrelude "FilePath"= "AFilePath"
-notPrelude "Float"   = "AFloat"
-notPrelude "Floating"= "AFloating"
-notPrelude "Fractional"= "AFractional"
-notPrelude "Functor" = "AFunctor"
-notPrelude "IO"      = "AIO"
-notPrelude "IOError" = "AIOError"
-notPrelude "Int"     = "AInt"
-notPrelude "Integer" = "AInteger"
-notPrelude "Integral"= "AIntegral"
-notPrelude "List1"   = "AList1" -- part of HaXml
-notPrelude "Maybe"   = "AMaybe"
-notPrelude "Monad"   = "AMonad"
-notPrelude "Num"     = "ANum"
-notPrelude "Ord"     = "AOrd"
-notPrelude "Ordering"= "AOrdering"
-notPrelude "Rational"= "ARational"
-notPrelude "Read"    = "ARead"
-notPrelude "ReadS"   = "AReadS"
-notPrelude "Real"    = "AReal"
-notPrelude "RealFloat" = "ARealFloat"
-notPrelude "RealFrac"= "ARealFrac"
-notPrelude "Show"    = "AShow"
-notPrelude "ShowS"   = "AShowS"
-notPrelude "String"  = "AString"
-notPrelude n         = n
-
--- | Convert an XML name to a Haskell varid.
-manglef :: String -> String
-manglef (n:ns)
-    | isUpper n   = toLower n: map decolonify ns
-    | isDigit n   = '_': n: map decolonify ns
-    | otherwise   = n: map decolonify ns
-
--- | Convert colon to prime, hyphen to underscore.
-decolonify :: Char -> Char
-decolonify ':' = '\''   -- TODO: turn namespaces into qualified identifiers
-decolonify '-' = '_'
-decolonify '.' = '_'
-decolonify  c  = c
-
-commaList :: [Doc] -> Doc
-commaList = hcat . intersperse comma
+
+
+src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs
+
+
+
-- | Defines an internal representation of Haskell data\/newtype definitions
+--   that correspond to the XML DTD types, and provides pretty-printers to
+--   convert these types into the 'Doc' type of "Text.PrettyPrint.HughesPJ".
+
+module Text.XML.HaXml.DtdToHaskell.TypeDef
+  ( -- * Internal representation of types
+    TypeDef(..)
+  , Constructors
+  , AttrFields
+  , StructType(..)
+  -- * Pretty-print a TypeDef
+  , ppTypeDef
+  , ppHName
+  , ppXName
+  , ppAName
+  -- * Name mangling
+  , Name(..)
+  , name, name_, name_a, name_ac, name_f, mangle, manglef
+  ) where
+
+import Char (isLower, isUpper, toLower, toUpper, isDigit)
+import List (intersperse)
+import Text.PrettyPrint.HughesPJ
+
+
+---- Internal representation for typedefs ----
+
+-- | Need to keep both the XML and Haskell versions of a name.
+data Name = Name { xName :: String       -- ^ original XML name
+                 , hName :: String       -- ^ mangled Haskell name
+                 }
+          deriving Eq
+
+data TypeDef =
+      DataDef Bool Name AttrFields Constructors -- ^ Bool for main\/aux.
+    | EnumDef Name [Name]
+    deriving Eq
+type Constructors = [(Name,[StructType])]
+type AttrFields   = [(Name, StructType)]
+data StructType =
+      Maybe StructType
+    | Defaultable StructType String     -- ^ String holds default value.
+    | List StructType
+    | List1 StructType                  -- ^ Non-empty lists.
+    | Tuple [StructType]
+    | OneOf [StructType]
+    | Any                               -- ^ XML's contentspec allows ANY
+    | String
+    | Defined Name
+    deriving Eq
+
+-- used for converting StructType (roughly) back to an XML content model
+instance Show StructType where
+    showsPrec p (Maybe s)         = showsPrec (p+1) s . showChar '?'
+    showsPrec _ (Defaultable s _) = shows s
+    showsPrec p (List s)          = showsPrec (p+1) s . showChar '*'
+    showsPrec p (List1 s)         = showsPrec (p+1) s . showChar '+'
+    showsPrec _ (Tuple ss)        = showChar '('
+                                    . foldr1 (.) (intersperse (showChar ',')
+                                                              (map shows ss))
+                                    . showChar ')'
+    showsPrec _ (OneOf ss)        = showChar '('
+                                    . foldr1 (.) (intersperse (showChar '|')
+                                                              (map shows ss))
+                                    . showChar ')'
+    showsPrec _ (Any)             = showString "ANY"
+    showsPrec _ (String)          = showString "#PCDATA"
+    showsPrec _ (Defined (Name n _)) = showString n
+
+
+---- Pretty-printing typedefs ----
+ppTypeDef :: TypeDef -> Doc
+
+--      no attrs, no constructors
+ppTypeDef (DataDef _ n [] []) =
+    let nme = ppHName n in
+    text "data" <+> nme <+> text "=" <+> nme <+> text "\t\t" <> derives
+
+--      no attrs, single constructor
+ppTypeDef (DataDef _ n [] [c@(_,[_])]) =
+    text "newtype" <+> ppHName n <+> text "=" <+> ppC c <+> text "\t\t" <> derives
+
+--      no attrs, multiple constrs
+ppTypeDef (DataDef _ n [] cs) =
+    text "data" <+> ppHName n <+>
+           ( text "=" <+> ppC (head cs) $$
+             vcat (map (\c-> text "|" <+> ppC c) (tail cs)) $$
+             derives )
+
+--      nonzero attrs, no constructors
+ppTypeDef (DataDef _ n fs []) =
+    let nme = ppHName n in
+    text "data" <+> nme <+> text "=" <+> nme $$
+    nest 4 ( text "{" <+> ppF (head fs) $$
+             vcat (map (\f-> text "," <+> ppF f) (tail fs)) $$
+             text "}" <+> derives )
+
+--      nonzero attrs, one or more constrs
+ppTypeDef (DataDef _ n fs cs) =
+    let attr = ppAName n in
+    text "data" <+> ppHName n <+>
+           ( text "=" <+> ppAC attr (head cs) $$
+             vcat (map (\c-> text "|" <+> ppAC attr c) (tail cs)) $$
+             derives )  $$
+    text "data" <+> attr <+> text "=" <+> attr $$
+    nest 4 ( text "{" <+> ppF (head fs) $$
+             vcat (map (\f-> text "," <+> ppF f) (tail fs)) $$
+             text "}" <+> derives )
+
+--      enumerations (of attribute values)
+ppTypeDef (EnumDef n es) =
+    text "data" <+> ppHName n <+>
+    ( text "=" <+>
+      fsep (intersperse (text " | ") (map ppHName es))
+    $$ derives )
+
+
+ppST :: StructType -> Doc
+ppST (Defaultable st _)  = parens (text "Defaultable" <+> ppST st)
+ppST (Maybe st)  = parens (text "Maybe" <+> ppST st)
+ppST (List st)   = text "[" <> ppST st <> text "]"
+ppST (List1 st)  = parens (text "List1" <+> ppST st)
+ppST (Tuple sts) = parens (commaList (map ppST sts))
+ppST (OneOf sts) = parens (text "OneOf" <> text (show (length sts)) <+>
+                           hsep (map ppST sts))
+ppST  String     = text "String"
+ppST  Any        = text "ANYContent"
+ppST (Defined n) = ppHName n
+
+-- constructor and components
+ppC :: (Name,[StructType]) -> Doc
+ppC (n,sts) = ppHName n <+> fsep (map ppST sts)
+
+-- attribute (fieldname and type)
+ppF :: (Name,StructType) -> Doc
+ppF (n,st) = ppHName n <+> text "::" <+> ppST st
+
+-- constructor and components with initial attr-type
+ppAC :: Doc -> (Name,[StructType]) -> Doc
+ppAC atype (n,sts) = ppHName n <+> fsep (atype: map ppST sts)
+
+-- | Pretty print Haskell name.
+ppHName :: Name -> Doc
+ppHName (Name _ s) = text s
+-- | Pretty print XML name.
+ppXName :: Name -> Doc
+ppXName (Name s _) = text s
+-- | Pretty print Haskell attributes name.
+ppAName :: Name -> Doc
+ppAName (Name _ s) = text s <> text "_Attrs"
+
+derives :: Doc
+derives = text "deriving" <+> parens (commaList (map text ["Eq","Show"]))
+
+
+---- Some operations on Names ----
+
+-- | Make a type name valid in both XML and Haskell.
+name :: String -> Name
+name n     = Name { xName = n
+                  , hName = mangle n }
+
+-- | Append an underscore to the Haskell version of the name.
+name_ :: String -> Name
+name_ n    = Name { xName = n
+                  , hName = mangle n ++ "_" }
+
+-- | Prefix an attribute enumeration type name with its containing element
+--   name.
+name_a :: String -> String -> Name
+name_a e n = Name { xName = n
+                  , hName = mangle e ++ "_" ++ map decolonify n }
+
+-- | Prefix an attribute enumeration constructor with its element-tag name,
+--   and its enumeration type name.
+name_ac :: String -> String -> String -> Name
+name_ac e t n = Name { xName = n
+                     , hName = mangle e ++ "_" ++ map decolonify t
+                                        ++ "_" ++ map decolonify n }
+
+-- | Prefix a field name with its enclosing element name.
+name_f :: String -> String -> Name
+name_f e n = Name { xName = n
+                  , hName = manglef e ++ mangle n }
+
+---- obsolete
+-- elementname_at :: String -> Name
+-- elementname_at n  = Name n (mangle n ++ "_Attrs")
+
+-- | Convert an XML name to a Haskell conid.
+mangle :: String -> String
+mangle (n:ns)
+    | isLower n   = notPrelude (toUpper n: map decolonify ns)
+    | isDigit n   = 'I': n: map decolonify ns
+    | otherwise   = notPrelude (n: map decolonify ns)
+
+-- | Ensure a generated name does not conflict with a standard haskell one.
+notPrelude :: String -> String
+notPrelude "Bool"    = "ABool"
+notPrelude "Bounded" = "ABounded"
+notPrelude "Char"    = "AChar"
+notPrelude "Double"  = "ADouble"
+notPrelude "Either"  = "AEither"
+notPrelude "Enum"    = "AEnum"
+notPrelude "Eq"      = "AEq"
+notPrelude "FilePath"= "AFilePath"
+notPrelude "Float"   = "AFloat"
+notPrelude "Floating"= "AFloating"
+notPrelude "Fractional"= "AFractional"
+notPrelude "Functor" = "AFunctor"
+notPrelude "IO"      = "AIO"
+notPrelude "IOError" = "AIOError"
+notPrelude "Int"     = "AInt"
+notPrelude "Integer" = "AInteger"
+notPrelude "Integral"= "AIntegral"
+notPrelude "List1"   = "AList1" -- part of HaXml
+notPrelude "Maybe"   = "AMaybe"
+notPrelude "Monad"   = "AMonad"
+notPrelude "Num"     = "ANum"
+notPrelude "Ord"     = "AOrd"
+notPrelude "Ordering"= "AOrdering"
+notPrelude "Rational"= "ARational"
+notPrelude "Read"    = "ARead"
+notPrelude "ReadS"   = "AReadS"
+notPrelude "Real"    = "AReal"
+notPrelude "RealFloat" = "ARealFloat"
+notPrelude "RealFrac"= "ARealFrac"
+notPrelude "Show"    = "AShow"
+notPrelude "ShowS"   = "AShowS"
+notPrelude "String"  = "AString"
+notPrelude n         = n
+
+-- | Convert an XML name to a Haskell varid.
+manglef :: String -> String
+manglef (n:ns)
+    | isUpper n   = toLower n: map decolonify ns
+    | isDigit n   = '_': n: map decolonify ns
+    | otherwise   = n: map decolonify ns
+
+-- | Convert colon to prime, hyphen to underscore.
+decolonify :: Char -> Char
+decolonify ':' = '\''   -- TODO: turn namespaces into qualified identifiers
+decolonify '-' = '_'
+decolonify '.' = '_'
+decolonify  c  = c
+
+commaList :: [Doc] -> Doc
+commaList = hcat . intersperse comma
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Escape.html b/docs/HaXml/src/Text/XML/HaXml/Escape.html
--- a/docs/HaXml/src/Text/XML/HaXml/Escape.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Escape.html
@@ -1,295 +1,301 @@
 
 
-
{- This module contains code for escaping/unescaping text in attributes
-   and elements in the HaXml Element type, replacing characters by character
-   references or vice-versa.  Two uses are envisaged for this:
-
-   (1) stopping HaXml generating incorrect XML when a character is included
-       which is also the appropriate XML terminating character, for example
-       when an attribute includes a double quote.
-   (2) representing XML which contains non-ASCII characters as ASCII.
-   -}
-module Text.XML.HaXml.Escape(
-   xmlEscape,
-      -- :: XmlEscaper -> Element i -> Element i
-   xmlUnEscape,
-      -- :: XmlEscaper -> Element i -> Element i
-   xmlEscapeContent,
-      -- :: XmlEscaper -> [Content i] -> [Content i]
-   xmlUnEscapeContent,
-      -- :: XmlEscaper -> [Content i] -> [Content i]
-
-   XmlEscaper,
-      -- Something describing a particular set of escapes.
-
-   stdXmlEscaper,
-      -- Standard boilerplate escaper, escaping everything that is
-      -- nonprintable, non-ASCII, or might conceivably cause problems by
-      -- parsing XML, for example quotes, < signs, and ampersands.
-
-   mkXmlEscaper,
-      -- :: [(Char,String)] -> (Char -> Bool) -> XmlEscaper
-      -- The first argument contains a list of characters, with their
-      --    corresponding character reference names.
-      --    For example [('\60',"lt"),('\62',"gt"),('\38',"amp"),
-      --       ('\39',"apos"),('\34',"quot")] will give you the "standard"
-      --       XML escapes listed in section 4.6 of the XML standard, so that
-      --       "&quot;" will automatically get translated into a double
-      --       quotation mark.
-      --
-      --       It's the caller's responsibility to see that the reference
-      --       names ("lt","gt","amp","apos" and "quot" in the above example)
-      --       are valid XML reference names.  A sequence of letters, digits,
-      --       "." or ":" characters should be fine so long as the first one
-      --       isn't a digit.
-      --
-      -- The second argument is a function applied to each text character.
-      --    If it returns True, that means we should escape this character.
-
-      -- Policy: on escaping, we expand all characters for which the
-      -- (Char -> Bool) function returns True, either giving the corresponding
-      -- character reference name if one was supplied, or else using a
-      -- hexadecimal CharRef.
-      --
-      -- on unescaping, we translate all the references we understand
-      --   (hexadecimal,decimal, and the ones in the [(Char,String)] list,
-      --   and leave the others alone.
-
-   ) where
-
-import Char
--- import Numeric
-import Text.XML.HaXml.Types
-
-#if __GLASGOW_HASKELL__ >= 604 || __NHC__ >= 118 || defined(__HUGS__)
--- emulate older finite map interface using Data.Map, if it is available
-import qualified Data.Map as Map
-type FiniteMap a b = Map.Map a b
-listToFM :: Ord a => [(a,b)] -> FiniteMap a b
-listToFM = Map.fromList
-lookupFM :: Ord a => FiniteMap a b -> a -> Maybe b
-lookupFM = flip Map.lookup
-#elif __GLASGOW_HASKELL__ >= 504 || __NHC__ > 114
--- real finite map, if it is available
-import Data.FiniteMap
-#else
--- otherwise, a very simple and inefficient implementation of a finite map
-type FiniteMap a b = [(a,b)]
-listToFM :: Eq a => [(a,b)] -> FiniteMap a b
-listToFM = id
-lookupFM :: Eq a => FiniteMap a b -> a -> Maybe b
-lookupFM fm k = lookup k fm
-#endif
-
-
--- ------------------------------------------------------------------------
--- Data types
--- ------------------------------------------------------------------------
-
-data XmlEscaper = XmlEscaper {
-   toEscape :: FiniteMap Char String,
-   fromEscape :: FiniteMap String Char,
-   isEscape :: Char -> Bool
-   }
-
-
--- ------------------------------------------------------------------------
--- Escaping
--- ------------------------------------------------------------------------
-
-
-
-xmlEscape :: XmlEscaper -> Element i -> Element i
-xmlEscape xmlEscaper element =
-   compressElement (escapeElement xmlEscaper element)
-
-xmlEscapeContent :: XmlEscaper -> [Content i] -> [Content i]
-xmlEscapeContent xmlEscaper cs =
-   compressContent (escapeContent xmlEscaper cs)
-
-escapeElement :: XmlEscaper -> Element i -> Element i
-escapeElement xmlEscaper (Elem name attributes content) =
-   Elem name (escapeAttributes xmlEscaper attributes)
-      (escapeContent xmlEscaper content)
-
-escapeAttributes :: XmlEscaper -> [Attribute] -> [Attribute]
-escapeAttributes xmlEscaper atts =
-   map
-      (\ (name,av) -> (name,escapeAttValue xmlEscaper av))
-      atts
-
-escapeAttValue :: XmlEscaper -> AttValue -> AttValue
-escapeAttValue xmlEscaper (AttValue attValList) =
-   AttValue (
-      concat (
-         map
-            (\ av -> case av of
-               Right _ -> [av]
-               Left s ->
-                  map
-                     (\ c -> if isEscape xmlEscaper c
-                        then
-                           Right (mkEscape xmlEscaper c)
-                        else
-                           Left [c]
-                        )
-                     s
-               )
-            attValList
-         )
-      )
-
-escapeContent :: XmlEscaper -> [Content i] -> [Content i]
-escapeContent xmlEscaper contents =
-   concat
-      (map
-          (\ content -> case content of
-             (CString b str i) ->
-                map
-                   (\ c -> if isEscape xmlEscaper c
-                      then
-                         CRef (mkEscape xmlEscaper c) i
-                      else
-                         CString b [c] i
-                      )
-                   str
-             (CElem element i) -> [CElem (escapeElement xmlEscaper element) i]
-             _ -> [content]
-             )
-          contents
-          )
-
-mkEscape :: XmlEscaper -> Char -> Reference
-mkEscape (XmlEscaper {toEscape = toescape}) ch =
-   case lookupFM toescape ch of
-      Nothing  -> RefChar (ord ch)
-      Just str -> RefEntity str
---    where
---       _ = showIntAtBase 16 intToDigit
---       -- It should be, but in GHC it isn't.
-
--- ------------------------------------------------------------------------
--- Unescaping
--- ------------------------------------------------------------------------
-
-xmlUnEscape :: XmlEscaper -> Element i -> Element i
-xmlUnEscape xmlEscaper element =
-   compressElement (unEscapeElement xmlEscaper element)
-
-xmlUnEscapeContent :: XmlEscaper -> [Content i] -> [Content i]
-xmlUnEscapeContent xmlEscaper cs =
-   compressContent (unEscapeContent xmlEscaper cs)
-
-unEscapeElement :: XmlEscaper -> Element i -> Element i
-unEscapeElement xmlEscaper (Elem name attributes content) =
-   Elem name (unEscapeAttributes xmlEscaper attributes)
-      (unEscapeContent xmlEscaper content)
-
-unEscapeAttributes :: XmlEscaper -> [Attribute] -> [Attribute]
-unEscapeAttributes xmlEscaper atts =
-   map
-      (\ (name,av) -> (name,unEscapeAttValue xmlEscaper av))
-      atts
-
-unEscapeAttValue :: XmlEscaper -> AttValue -> AttValue
-unEscapeAttValue xmlEscaper (AttValue attValList) =
-   AttValue (
-      map
-         (\ av -> case av of
-            Left _ -> av
-            Right ref -> case unEscapeChar xmlEscaper ref of
-               Just c -> Left [c]
-               Nothing -> av
-            )
-         attValList
-      )
-
-unEscapeContent :: XmlEscaper -> [Content i] -> [Content i]
-unEscapeContent xmlEscaper content =
-   map
-      (\ cntnt -> case cntnt of
-         CRef ref i -> case unEscapeChar xmlEscaper ref of
-            Just c -> CString False [c] i
-            Nothing -> cntnt
-         CElem element i -> CElem (unEscapeElement xmlEscaper element) i
-         _ -> cntnt
-         )
-      content
-
-unEscapeChar :: XmlEscaper -> Reference -> Maybe Char
-unEscapeChar xmlEscaper ref =
-   case ref of
-      RefChar i      -> Just (chr i)
-      RefEntity name -> lookupFM (fromEscape xmlEscaper) name
-
--- ------------------------------------------------------------------------
--- After escaping and unescaping we rebuild the lists, compressing
--- adjacent identical character data.
--- ------------------------------------------------------------------------
-
-compressElement :: Element i -> Element i
-compressElement (Elem name attributes content) =
-   Elem name (compressAttributes attributes) (compressContent content)
-
-compressAttributes :: [(Name,AttValue)] -> [(Name,AttValue)]
-compressAttributes atts =
-   map
-      (\ (name,av) -> (name,compressAttValue av))
-      atts
-
-compressAttValue :: AttValue -> AttValue
-compressAttValue (AttValue l) = AttValue (compress l)
-   where
-      compress :: [Either String Reference] -> [Either String Reference]
-      compress [] = []
-      compress (Right ref : es) = Right ref : (compress es)
-      compress ( (ls @ (Left s1)) : es) =
-         case compress es of
-            (Left s2 : es2) -> Left (s1 ++ s2) : es2
-            es2 -> ls : es2
-
-compressContent :: [Content i] -> [Content i]
-compressContent [] = []
-compressContent ((csb @ (CString b1 s1 i1)) : cs) =
-   case compressContent cs of
-      (CString b2 s2 _) : cs2
-          | b1 == b2
-          -> CString b1 (s1 ++ s2) i1: cs2
-      cs2 -> csb : cs2
-compressContent (CElem element i : cs) =
-   CElem (compressElement element) i : compressContent cs
-compressContent (c : cs) = c : compressContent cs
-
-
--- ------------------------------------------------------------------------
--- Making XmlEscaper values.
--- ------------------------------------------------------------------------
-
-stdXmlEscaper :: XmlEscaper
-stdXmlEscaper = mkXmlEscaper
-   [('\60',"lt"),('\62',"gt"),('\38',"amp"),('\39',"apos"),('\34',"quot")]
-   (\ ch ->
-      let
-         i = ord ch
-      in
-         i < 10 || (10<i && i<32) || i >= 127 ||
-            case ch of
-               '\'' -> True
-               '\"' -> True
-               '&' -> True
-               '<' -> True
-               '>' -> True
-               _ -> False
-      )
-
-
-mkXmlEscaper :: [(Char,String)] -> (Char -> Bool) -> XmlEscaper
-mkXmlEscaper escapes isescape =
-   XmlEscaper {
-      toEscape = listToFM escapes,
-      fromEscape = listToFM (map (\ (c,str) -> (str,c)) escapes),
-      isEscape = isescape
-      }
-
+
+
+src/Text/XML/HaXml/Escape.hs
+
+
+
{- This module contains code for escaping/unescaping text in attributes
+   and elements in the HaXml Element type, replacing characters by character
+   references or vice-versa.  Two uses are envisaged for this:
+
+   (1) stopping HaXml generating incorrect XML when a character is included
+       which is also the appropriate XML terminating character, for example
+       when an attribute includes a double quote.
+   (2) representing XML which contains non-ASCII characters as ASCII.
+   -}
+module Text.XML.HaXml.Escape(
+   xmlEscape,
+      -- :: XmlEscaper -> Element i -> Element i
+   xmlUnEscape,
+      -- :: XmlEscaper -> Element i -> Element i
+   xmlEscapeContent,
+      -- :: XmlEscaper -> [Content i] -> [Content i]
+   xmlUnEscapeContent,
+      -- :: XmlEscaper -> [Content i] -> [Content i]
+
+   XmlEscaper,
+      -- Something describing a particular set of escapes.
+
+   stdXmlEscaper,
+      -- Standard boilerplate escaper, escaping everything that is
+      -- nonprintable, non-ASCII, or might conceivably cause problems by
+      -- parsing XML, for example quotes, < signs, and ampersands.
+
+   mkXmlEscaper,
+      -- :: [(Char,String)] -> (Char -> Bool) -> XmlEscaper
+      -- The first argument contains a list of characters, with their
+      --    corresponding character reference names.
+      --    For example [('\60',"lt"),('\62',"gt"),('\38',"amp"),
+      --       ('\39',"apos"),('\34',"quot")] will give you the "standard"
+      --       XML escapes listed in section 4.6 of the XML standard, so that
+      --       "&quot;" will automatically get translated into a double
+      --       quotation mark.
+      --
+      --       It's the caller's responsibility to see that the reference
+      --       names ("lt","gt","amp","apos" and "quot" in the above example)
+      --       are valid XML reference names.  A sequence of letters, digits,
+      --       "." or ":" characters should be fine so long as the first one
+      --       isn't a digit.
+      --
+      -- The second argument is a function applied to each text character.
+      --    If it returns True, that means we should escape this character.
+
+      -- Policy: on escaping, we expand all characters for which the
+      -- (Char -> Bool) function returns True, either giving the corresponding
+      -- character reference name if one was supplied, or else using a
+      -- hexadecimal CharRef.
+      --
+      -- on unescaping, we translate all the references we understand
+      --   (hexadecimal,decimal, and the ones in the [(Char,String)] list,
+      --   and leave the others alone.
+
+   ) where
+
+import Char
+-- import Numeric
+import Text.XML.HaXml.Types
+
+#if __GLASGOW_HASKELL__ >= 604 || __NHC__ >= 118 || defined(__HUGS__)
+-- emulate older finite map interface using Data.Map, if it is available
+import qualified Data.Map as Map
+type FiniteMap a b = Map.Map a b
+listToFM :: Ord a => [(a,b)] -> FiniteMap a b
+listToFM = Map.fromList
+lookupFM :: Ord a => FiniteMap a b -> a -> Maybe b
+lookupFM = flip Map.lookup
+#elif __GLASGOW_HASKELL__ >= 504 || __NHC__ > 114
+-- real finite map, if it is available
+import Data.FiniteMap
+#else
+-- otherwise, a very simple and inefficient implementation of a finite map
+type FiniteMap a b = [(a,b)]
+listToFM :: Eq a => [(a,b)] -> FiniteMap a b
+listToFM = id
+lookupFM :: Eq a => FiniteMap a b -> a -> Maybe b
+lookupFM fm k = lookup k fm
+#endif
+
+
+-- ------------------------------------------------------------------------
+-- Data types
+-- ------------------------------------------------------------------------
+
+data XmlEscaper = XmlEscaper {
+   toEscape :: FiniteMap Char String,
+   fromEscape :: FiniteMap String Char,
+   isEscape :: Char -> Bool
+   }
+
+
+-- ------------------------------------------------------------------------
+-- Escaping
+-- ------------------------------------------------------------------------
+
+
+
+xmlEscape :: XmlEscaper -> Element i -> Element i
+xmlEscape xmlEscaper element =
+   compressElement (escapeElement xmlEscaper element)
+
+xmlEscapeContent :: XmlEscaper -> [Content i] -> [Content i]
+xmlEscapeContent xmlEscaper cs =
+   compressContent (escapeContent xmlEscaper cs)
+
+escapeElement :: XmlEscaper -> Element i -> Element i
+escapeElement xmlEscaper (Elem name attributes content) =
+   Elem name (escapeAttributes xmlEscaper attributes)
+      (escapeContent xmlEscaper content)
+
+escapeAttributes :: XmlEscaper -> [Attribute] -> [Attribute]
+escapeAttributes xmlEscaper atts =
+   map
+      (\ (name,av) -> (name,escapeAttValue xmlEscaper av))
+      atts
+
+escapeAttValue :: XmlEscaper -> AttValue -> AttValue
+escapeAttValue xmlEscaper (AttValue attValList) =
+   AttValue (
+      concat (
+         map
+            (\ av -> case av of
+               Right _ -> [av]
+               Left s ->
+                  map
+                     (\ c -> if isEscape xmlEscaper c
+                        then
+                           Right (mkEscape xmlEscaper c)
+                        else
+                           Left [c]
+                        )
+                     s
+               )
+            attValList
+         )
+      )
+
+escapeContent :: XmlEscaper -> [Content i] -> [Content i]
+escapeContent xmlEscaper contents =
+   concat
+      (map
+          (\ content -> case content of
+             (CString b str i) ->
+                map
+                   (\ c -> if isEscape xmlEscaper c
+                      then
+                         CRef (mkEscape xmlEscaper c) i
+                      else
+                         CString b [c] i
+                      )
+                   str
+             (CElem element i) -> [CElem (escapeElement xmlEscaper element) i]
+             _ -> [content]
+             )
+          contents
+          )
+
+mkEscape :: XmlEscaper -> Char -> Reference
+mkEscape (XmlEscaper {toEscape = toescape}) ch =
+   case lookupFM toescape ch of
+      Nothing  -> RefChar (ord ch)
+      Just str -> RefEntity str
+--    where
+--       _ = showIntAtBase 16 intToDigit
+--       -- It should be, but in GHC it isn't.
+
+-- ------------------------------------------------------------------------
+-- Unescaping
+-- ------------------------------------------------------------------------
+
+xmlUnEscape :: XmlEscaper -> Element i -> Element i
+xmlUnEscape xmlEscaper element =
+   compressElement (unEscapeElement xmlEscaper element)
+
+xmlUnEscapeContent :: XmlEscaper -> [Content i] -> [Content i]
+xmlUnEscapeContent xmlEscaper cs =
+   compressContent (unEscapeContent xmlEscaper cs)
+
+unEscapeElement :: XmlEscaper -> Element i -> Element i
+unEscapeElement xmlEscaper (Elem name attributes content) =
+   Elem name (unEscapeAttributes xmlEscaper attributes)
+      (unEscapeContent xmlEscaper content)
+
+unEscapeAttributes :: XmlEscaper -> [Attribute] -> [Attribute]
+unEscapeAttributes xmlEscaper atts =
+   map
+      (\ (name,av) -> (name,unEscapeAttValue xmlEscaper av))
+      atts
+
+unEscapeAttValue :: XmlEscaper -> AttValue -> AttValue
+unEscapeAttValue xmlEscaper (AttValue attValList) =
+   AttValue (
+      map
+         (\ av -> case av of
+            Left _ -> av
+            Right ref -> case unEscapeChar xmlEscaper ref of
+               Just c -> Left [c]
+               Nothing -> av
+            )
+         attValList
+      )
+
+unEscapeContent :: XmlEscaper -> [Content i] -> [Content i]
+unEscapeContent xmlEscaper content =
+   map
+      (\ cntnt -> case cntnt of
+         CRef ref i -> case unEscapeChar xmlEscaper ref of
+            Just c -> CString False [c] i
+            Nothing -> cntnt
+         CElem element i -> CElem (unEscapeElement xmlEscaper element) i
+         _ -> cntnt
+         )
+      content
+
+unEscapeChar :: XmlEscaper -> Reference -> Maybe Char
+unEscapeChar xmlEscaper ref =
+   case ref of
+      RefChar i      -> Just (chr i)
+      RefEntity name -> lookupFM (fromEscape xmlEscaper) name
+
+-- ------------------------------------------------------------------------
+-- After escaping and unescaping we rebuild the lists, compressing
+-- adjacent identical character data.
+-- ------------------------------------------------------------------------
+
+compressElement :: Element i -> Element i
+compressElement (Elem name attributes content) =
+   Elem name (compressAttributes attributes) (compressContent content)
+
+compressAttributes :: [(Name,AttValue)] -> [(Name,AttValue)]
+compressAttributes atts =
+   map
+      (\ (name,av) -> (name,compressAttValue av))
+      atts
+
+compressAttValue :: AttValue -> AttValue
+compressAttValue (AttValue l) = AttValue (compress l)
+   where
+      compress :: [Either String Reference] -> [Either String Reference]
+      compress [] = []
+      compress (Right ref : es) = Right ref : (compress es)
+      compress ( (ls @ (Left s1)) : es) =
+         case compress es of
+            (Left s2 : es2) -> Left (s1 ++ s2) : es2
+            es2 -> ls : es2
+
+compressContent :: [Content i] -> [Content i]
+compressContent [] = []
+compressContent ((csb @ (CString b1 s1 i1)) : cs) =
+   case compressContent cs of
+      (CString b2 s2 _) : cs2
+          | b1 == b2
+          -> CString b1 (s1 ++ s2) i1: cs2
+      cs2 -> csb : cs2
+compressContent (CElem element i : cs) =
+   CElem (compressElement element) i : compressContent cs
+compressContent (c : cs) = c : compressContent cs
+
+
+-- ------------------------------------------------------------------------
+-- Making XmlEscaper values.
+-- ------------------------------------------------------------------------
+
+stdXmlEscaper :: XmlEscaper
+stdXmlEscaper = mkXmlEscaper
+   [('\60',"lt"),('\62',"gt"),('\38',"amp"),('\39',"apos"),('\34',"quot")]
+   (\ ch ->
+      let
+         i = ord ch
+      in
+         i < 10 || (10<i && i<32) || i >= 127 ||
+            case ch of
+               '\'' -> True
+               '\"' -> True
+               '&' -> True
+               '<' -> True
+               '>' -> True
+               _ -> False
+      )
+
+
+mkXmlEscaper :: [(Char,String)] -> (Char -> Bool) -> XmlEscaper
+mkXmlEscaper escapes isescape =
+   XmlEscaper {
+      toEscape = listToFM escapes,
+      fromEscape = listToFM (map (\ (c,str) -> (str,c)) escapes),
+      isEscape = isescape
+      }
+
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Html/Generate.html b/docs/HaXml/src/Text/XML/HaXml/Html/Generate.html
--- a/docs/HaXml/src/Text/XML/HaXml/Html/Generate.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Html/Generate.html
@@ -1,179 +1,185 @@
 
 
-
-- | These are just some common abbreviations for generating HTML
---   content within the XML transformation framework defined
---   by "Text.Xml.HaXml.Combinators".
-module Text.XML.HaXml.Html.Generate
-  ( -- * HTML construction filters
-  -- ** Containers
-    html
-  , hhead
-  , htitle
-  , hbody
-  , h1, h2, h3, h4
-  , hpara
-  , hdiv, hspan, margin
-  -- ** Anchors
-  , anchor, makehref, anchorname
-  -- ** Text style
-  , hpre
-  , hcentre
-  , hem, htt, hbold
-  , parens, bullet
-  -- ** Tables
-  , htable, hrow, hcol
-  -- ** Breaks, lines
-  , hbr, hhr
-  -- ** Attributes
-  , showattr, (!), (?)
-  -- * A simple HTML pretty-printer
-  , htmlprint
-  ) where
-
-import Char (isSpace)
-
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.Combinators
-import qualified Text.PrettyPrint.HughesPJ as Pretty
-
----- Constructor functions
-
-html, hhead, htitle, hbody, h1, h2, h3, h4, hpara, hpre, hcentre,
-    hem, htt, hbold, htable, hrow, hcol, hdiv, hspan, margin
-       :: [CFilter i] -> CFilter i
-html    = mkElem "html"
-hhead   = mkElem "head"
-htitle  = mkElem "title"
-hbody   = mkElem "body"
-h1      = mkElem "h1"
-h2      = mkElem "h2"
-h3      = mkElem "h3"
-h4      = mkElem "h4"
-hpara   = mkElem "p"
-hpre    = mkElem "pre"
-hcentre = mkElem "center"
-hem     = mkElem "em"
-htt     = mkElem "tt"
-hbold   = mkElem "b"
-
-htable = mkElem "table"
-hrow   = mkElem "tr"
-hcol   = mkElem "td"
-
-hdiv   = mkElem "div"
-hspan  = mkElem "span"
-margin = mkElemAttr "div" [("margin-left",("2em"!)),
-                           ("margin-top", ("1em"!))]
-
-anchor      :: [(String, CFilter i)] -> [CFilter i] -> CFilter  i
-anchor       = mkElemAttr "a"
-
-makehref, anchorname :: CFilter i -> [CFilter i] -> CFilter i
-makehref r   = anchor [ ("href",r) ]
-anchorname n = anchor [ ("name",n) ]
-
-
-hbr, hhr :: CFilter i
-hbr       = mkElem "br" []
-hhr       = mkElem "hr" []
-
-
-showattr, (!), (?) :: String -> CFilter i
-showattr n = find n literal
-(!) = literal
-(?) = showattr
-
-parens :: CFilter i -> CFilter i
-parens f = cat [ literal "(", f, literal ")" ]
-
-bullet :: [CFilter i] -> CFilter i
-bullet = cat . (literal "M-^U":)
-
-
----- Printing function
-
--- htmlprint :: [Content] -> String
--- htmlprint = concatMap cprint
---   where
---   cprint (CElem e _) = elem e
---   cprint (CString _ s) = s
---   cprint (CMisc m) = ""
---
---   elem (Elem n as []) = "\n<"++n++attrs as++" />"
---   elem (Elem n as cs) = "\n<"++n++attrs as++">"++htmlprint cs++"\n</"++n++">"
---
---   attrs = concatMap attr
---   attr (n,v) = " "++n++"='"++v++"'"
-
-
-htmlprint :: [Content i] -> Pretty.Doc
-htmlprint = Pretty.cat . map cprint . foldrefs
-  where
-  foldrefs [] = []
-  foldrefs (CString ws s1 i:CRef r _:CString _ s2 _:cs) =
-              CString ws (s1++"&"++ref r++";"++s2) i: foldrefs cs
-  foldrefs (c:cs) = c : foldrefs cs
-
---ref (RefEntity (EntityRef n)) = n     -- Actually, should look-up symtable.
---ref (RefChar (CharRef s)) = s
-  ref (RefEntity n) = n -- Actually, should look-up symtable.
-  ref (RefChar s) = show s
-
-  cprint (CElem e _)      = element e
-  cprint (CString ws s _) = Pretty.cat (map Pretty.text (fmt 60
-                                             ((if ws then id else deSpace) s)))
-  cprint (CRef r _)       = Pretty.text ("&"++ref r++";")
-  cprint (CMisc _ _)      = Pretty.empty
-
-  element (Elem n as []) = Pretty.text "<"   Pretty.<>
-                        Pretty.text n     Pretty.<>
-                        attrs as          Pretty.<>
-                        Pretty.text " />"
-  element (Elem n as cs) =
-                    --  ( Pretty.text "<"   Pretty.<>
-                    --    Pretty.text n     Pretty.<>
-                    --    attrs as          Pretty.<>
-                    --    Pretty.text ">")  Pretty.$$
-                    --  Pretty.nest 6 (htmlprint cs)  Pretty.$$
-                    --  ( Pretty.text "</"  Pretty.<>
-                    --    Pretty.text n     Pretty.<>
-                    --    Pretty.text ">" )
-                        Pretty.fcat [ ( Pretty.text "<"   Pretty.<>
-                                        Pretty.text n     Pretty.<>
-                                        attrs as          Pretty.<>
-                                        Pretty.text ">")
-                                    , Pretty.nest 4 (htmlprint cs)
-                                    , ( Pretty.text "</"  Pretty.<>
-                                        Pretty.text n     Pretty.<>
-                                        Pretty.text ">" )
-                                    ]
-
-  attrs = Pretty.cat . map attribute
-  attribute (n,v@(AttValue _)) =
-               Pretty.text " "  Pretty.<>
-               Pretty.text n    Pretty.<>
-               Pretty.text "='" Pretty.<>
-               Pretty.text (show v) Pretty.<>
-               Pretty.text "'"
-
-  fmt _ [] = []
-  fmt n s  = let (top,bot) = splitAt n s
-                 (word,left) = keepUntil isSpace (reverse top)
-             in if length top < n then [s]
-                else if not (null left) then
-                     reverse left: fmt n (word++bot)
-                else let (big,rest) = keepUntil isSpace s
-                     in reverse big: fmt n rest
-
-  deSpace []     = []
-  deSpace (c:cs) | c=='\n'   = deSpace (' ':cs)
-                 | isSpace c = c : deSpace (dropWhile isSpace cs)
-                 | otherwise = c : deSpace cs
-
-  keepUntil p xs = select p ([],xs)
-      where select _ (ls,[])     = (ls,[])
-            select q (ls,(y:ys)) | q y       = (ls,y:ys)
-                                 | otherwise = select q (y:ls,ys)
-
+
+
+src/Text/XML/HaXml/Html/Generate.hs
+
+
+
-- | These are just some common abbreviations for generating HTML
+--   content within the XML transformation framework defined
+--   by "Text.Xml.HaXml.Combinators".
+module Text.XML.HaXml.Html.Generate
+  ( -- * HTML construction filters
+  -- ** Containers
+    html
+  , hhead
+  , htitle
+  , hbody
+  , h1, h2, h3, h4
+  , hpara
+  , hdiv, hspan, margin
+  -- ** Anchors
+  , anchor, makehref, anchorname
+  -- ** Text style
+  , hpre
+  , hcentre
+  , hem, htt, hbold
+  , parens, bullet
+  -- ** Tables
+  , htable, hrow, hcol
+  -- ** Breaks, lines
+  , hbr, hhr
+  -- ** Attributes
+  , showattr, (!), (?)
+  -- * A simple HTML pretty-printer
+  , htmlprint
+  ) where
+
+import Char (isSpace)
+
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.Combinators
+import qualified Text.PrettyPrint.HughesPJ as Pretty
+
+---- Constructor functions
+
+html, hhead, htitle, hbody, h1, h2, h3, h4, hpara, hpre, hcentre,
+    hem, htt, hbold, htable, hrow, hcol, hdiv, hspan, margin
+       :: [CFilter i] -> CFilter i
+html    = mkElem "html"
+hhead   = mkElem "head"
+htitle  = mkElem "title"
+hbody   = mkElem "body"
+h1      = mkElem "h1"
+h2      = mkElem "h2"
+h3      = mkElem "h3"
+h4      = mkElem "h4"
+hpara   = mkElem "p"
+hpre    = mkElem "pre"
+hcentre = mkElem "center"
+hem     = mkElem "em"
+htt     = mkElem "tt"
+hbold   = mkElem "b"
+
+htable = mkElem "table"
+hrow   = mkElem "tr"
+hcol   = mkElem "td"
+
+hdiv   = mkElem "div"
+hspan  = mkElem "span"
+margin = mkElemAttr "div" [("margin-left",("2em"!)),
+                           ("margin-top", ("1em"!))]
+
+anchor      :: [(String, CFilter i)] -> [CFilter i] -> CFilter  i
+anchor       = mkElemAttr "a"
+
+makehref, anchorname :: CFilter i -> [CFilter i] -> CFilter i
+makehref r   = anchor [ ("href",r) ]
+anchorname n = anchor [ ("name",n) ]
+
+
+hbr, hhr :: CFilter i
+hbr       = mkElem "br" []
+hhr       = mkElem "hr" []
+
+
+showattr, (!), (?) :: String -> CFilter i
+showattr n = find n literal
+(!) = literal
+(?) = showattr
+
+parens :: CFilter i -> CFilter i
+parens f = cat [ literal "(", f, literal ")" ]
+
+bullet :: [CFilter i] -> CFilter i
+bullet = cat . (literal "M-^U":)
+
+
+---- Printing function
+
+-- htmlprint :: [Content] -> String
+-- htmlprint = concatMap cprint
+--   where
+--   cprint (CElem e _) = elem e
+--   cprint (CString _ s) = s
+--   cprint (CMisc m) = ""
+--
+--   elem (Elem n as []) = "\n<"++n++attrs as++" />"
+--   elem (Elem n as cs) = "\n<"++n++attrs as++">"++htmlprint cs++"\n</"++n++">"
+--
+--   attrs = concatMap attr
+--   attr (n,v) = " "++n++"='"++v++"'"
+
+
+htmlprint :: [Content i] -> Pretty.Doc
+htmlprint = Pretty.cat . map cprint . foldrefs
+  where
+  foldrefs [] = []
+  foldrefs (CString ws s1 i:CRef r _:CString _ s2 _:cs) =
+              CString ws (s1++"&"++ref r++";"++s2) i: foldrefs cs
+  foldrefs (c:cs) = c : foldrefs cs
+
+--ref (RefEntity (EntityRef n)) = n     -- Actually, should look-up symtable.
+--ref (RefChar (CharRef s)) = s
+  ref (RefEntity n) = n -- Actually, should look-up symtable.
+  ref (RefChar s) = show s
+
+  cprint (CElem e _)      = element e
+  cprint (CString ws s _) = Pretty.cat (map Pretty.text (fmt 60
+                                             ((if ws then id else deSpace) s)))
+  cprint (CRef r _)       = Pretty.text ("&"++ref r++";")
+  cprint (CMisc _ _)      = Pretty.empty
+
+  element (Elem n as []) = Pretty.text "<"   Pretty.<>
+                        Pretty.text n     Pretty.<>
+                        attrs as          Pretty.<>
+                        Pretty.text " />"
+  element (Elem n as cs) =
+                    --  ( Pretty.text "<"   Pretty.<>
+                    --    Pretty.text n     Pretty.<>
+                    --    attrs as          Pretty.<>
+                    --    Pretty.text ">")  Pretty.$$
+                    --  Pretty.nest 6 (htmlprint cs)  Pretty.$$
+                    --  ( Pretty.text "</"  Pretty.<>
+                    --    Pretty.text n     Pretty.<>
+                    --    Pretty.text ">" )
+                        Pretty.fcat [ ( Pretty.text "<"   Pretty.<>
+                                        Pretty.text n     Pretty.<>
+                                        attrs as          Pretty.<>
+                                        Pretty.text ">")
+                                    , Pretty.nest 4 (htmlprint cs)
+                                    , ( Pretty.text "</"  Pretty.<>
+                                        Pretty.text n     Pretty.<>
+                                        Pretty.text ">" )
+                                    ]
+
+  attrs = Pretty.cat . map attribute
+  attribute (n,v@(AttValue _)) =
+               Pretty.text " "  Pretty.<>
+               Pretty.text n    Pretty.<>
+               Pretty.text "='" Pretty.<>
+               Pretty.text (show v) Pretty.<>
+               Pretty.text "'"
+
+  fmt _ [] = []
+  fmt n s  = let (top,bot) = splitAt n s
+                 (word,left) = keepUntil isSpace (reverse top)
+             in if length top < n then [s]
+                else if not (null left) then
+                     reverse left: fmt n (word++bot)
+                else let (big,rest) = keepUntil isSpace s
+                     in reverse big: fmt n rest
+
+  deSpace []     = []
+  deSpace (c:cs) | c=='\n'   = deSpace (' ':cs)
+                 | isSpace c = c : deSpace (dropWhile isSpace cs)
+                 | otherwise = c : deSpace cs
+
+  keepUntil p xs = select p ([],xs)
+      where select _ (ls,[])     = (ls,[])
+            select q (ls,(y:ys)) | q y       = (ls,y:ys)
+                                 | otherwise = select q (y:ls,ys)
+
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Html/Parse.html b/docs/HaXml/src/Text/XML/HaXml/Html/Parse.html
--- a/docs/HaXml/src/Text/XML/HaXml/Html/Parse.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Html/Parse.html
@@ -1,728 +1,734 @@
 
 
-
-- | This is a parser for HTML documents.  Unlike for XML documents, it
---   must include a certain amount of error-correction to account for
---   HTML features like self-terminating tags, unterminated tags, and
---   incorrect nesting.  The input is tokenised by the
---   XML lexer (a separate lexer is not required for HTML).
-
--- It uses a slightly extended version of the Hutton/Meijer parser
--- combinators.
-
-module Text.XML.HaXml.Html.Parse
-  ( htmlParse
-  ) where
-
-import Prelude hiding (either,maybe,sequence)
-import qualified Prelude (either)
-import Maybe hiding (maybe)
-import Char (toLower, isSpace, isDigit, isHexDigit)
-import Numeric (readDec,readHex)
-import Monad
-
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.Lex
-import Text.XML.HaXml.Posn
-import Text.ParserCombinators.Poly.NoLeak.Plain
-
---  #define DEBUG
- 
-#if defined(DEBUG)
-#  if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
-      ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
-import Debug.Trace(trace)
-#  elif defined(__GLASGOW_HASKELL__)
-import IOExts(trace)
-#  elif defined(__NHC__) || defined(__HBC__)
-import NonStdTrace
-#  endif
-debug :: Monad m => String -> m ()
-debug s = trace s (return ())
-#else
-debug :: Monad m => String -> m ()
-debug s = return ()
-#endif
-
-
--- | The first argument is the name of the file, the second is the string
---   contents of the file.  The result is the generic representation of
---   an XML document.  Any errors cause program failure with message to stderr.
-htmlParse :: String -> String -> Document Posn
-htmlParse name = Prelude.either error id . htmlParse' name
-
--- | The first argument is the name of the file, the second is the string
---   contents of the file.  The result is the generic representation of
---   an XML document.  Any parsing errors are returned in the @Either@ type.
-htmlParse' :: String -> String -> Either String (Document Posn)
-htmlParse' name = Prelude.either Left (Right . simplify) . fst
-                  . runParser document . xmlLex name
-
----- Document simplification ----
-
-simplify :: Document i -> Document i
-simplify (Document p st (Elem n avs cs) ms) =
-    Document p st (Elem n avs (deepfilter simp cs)) ms
-  where
-    simp (CElem (Elem "null" [] []) _) = False
-    simp (CElem (Elem  n     _  []) _) | n `elem` ["font","p","i","b","em"
-                                                  ,"tt","big","small"] = False
- -- simp (CString False s _) | all isSpace s = False
-    simp _ = True
-    deepfilter p =
-        filter p . map (\c-> case c of
-                          CElem (Elem n avs cs) i
-                                  -> CElem (Elem n avs (deepfilter p cs)) i
-                          _       -> c)
-
--- opening any of these, they close again immediately
-selfclosingtags = ["img","hr","br","meta","col","link","base"
-                  ,"param","area","frame","input"]
-
---closing this, implicitly closes any of those which are contained in it
-closeInnerTags =
-  [ ("ul",      ["li"])
-  , ("ol",      ["li"])
-  , ("dl",      ["dt","dd"])
-  , ("tr",      ["th","td"])
-  , ("div",     ["p"])
-  , ("thead",   ["th","tr","td"])
-  , ("tfoot",   ["th","tr","td"])
-  , ("tbody",   ["th","tr","td"])
-  , ("table",   ["th","tr","td","thead","tfoot","tbody"])
-  , ("caption", ["p"])
-  , ("th",      ["p"])
-  , ("td",      ["p"])
-  , ("li",      ["p"])
-  , ("dt",      ["p"])
-  , ("dd",      ["p"])
-  , ("object",  ["p"])
-  , ("map",     ["p"])
-  , ("body",    ["p"])
-  ]
-
---opening this, implicitly closes that
-closes :: Name -> Name -> Bool
-"a"  `closes` "a"   =  True
-"li" `closes` "li"  =  True
-"th" `closes`  t    | t `elem` ["th","td"]      =  True
-"td" `closes`  t    | t `elem` ["th","td"]      =  True
-"tr" `closes`  t    | t `elem` ["th","td","tr"] =  True
-"dt" `closes`  t    | t `elem` ["dt","dd"]      =  True
-"dd" `closes`  t    | t `elem` ["dt","dd"]      =  True
-"form"  `closes` "form"      = True
-"label" `closes` "label"     = True
-_       `closes` "option"    = True
-"thead" `closes` t  | t `elem` ["colgroup"]          = True
-"tfoot" `closes` t  | t `elem` ["thead","colgroup"]  = True
-"tbody" `closes` t  | t `elem` ["tbody","tfoot","thead","colgroup"] = True
-"colgroup" `closes` "colgroup"  = True
-t `closes` "p"
-    | t `elem` ["p","h1","h2","h3","h4","h5","h6"
-               ,"hr","div","ul","dl","ol","table"]  =  True
-_ `closes` _ = False
-
-
-
----- Misc ----
-
-fst3 (a,_,_) = a
-snd3 (_,a,_) = a
-thd3 (_,_,a) = a
-
-
-
----- Auxiliary Parsing Functions ----
-
-type HParser a = Parser (Posn,TokenT) a
-
-tok :: TokenT -> HParser TokenT
-tok t = do (p,t') <- next
-           case t' of TokError s    -> report failBad (show t) p t'
-                      _ | t'==t     -> return t
-                        | otherwise -> report fail (show t) p t'
-
-name :: HParser Name
---name = do {(p,TokName s) <- next; return s}
-name = do (p,tok) <- next
-          case tok of 
-            TokName s  -> return s 
-            TokError s -> report failBad "a name" p tok
-            _          -> report fail "a name" p tok
-
-string, freetext :: HParser String
-string   = do (p,t) <- next
-              case t of TokName s -> return s
-                        _         -> report fail "text" p t
-freetext = do (p,t) <- next
-              case t of TokFreeText s -> return s
-                        _             -> report fail "text" p t
-
-maybe :: HParser a -> HParser (Maybe a)
-maybe p =
-    ( p >>= return . Just) `onFail`
-    ( return Nothing)
-
-either :: HParser a -> HParser b -> HParser (Either a b)
-either p q =
-    ( p >>= return . Left) `onFail`
-    ( q >>= return . Right)
-
-word :: String -> HParser ()
-word s = do { x <- next
-            ; case x of
-                (p,TokName n)     | s==n -> return ()
-                (p,TokFreeText n) | s==n -> return ()
-                (p,t@(TokError _)) -> report failBad (show s) p t
-                (p,t) -> report fail (show s) p t
-            }
-
-posn :: HParser Posn
-posn = do { x@(p,_) <- next
-          ; reparse [x]
-          ; return p
-          } `onFail` return noPos
-
-nmtoken :: HParser NmToken
-nmtoken = (string `onFail` freetext)
-
-failP, failBadP :: String -> HParser a
-failP msg    = do { p <- posn; fail (msg++"\n    at "++show p) }
-failBadP msg = do { p <- posn; failBad (msg++"\n    at "++show p) }
-
-report :: (String->HParser a) -> String -> Posn -> TokenT -> HParser a
-report fail exp p t = fail ("Expected "++show exp++" but found "++show t
-                           ++"\n  at "++show p)
-
-adjustErrP :: HParser a -> (String->String) -> HParser a
-p `adjustErrP` f = p `onFail` do pn <- posn
-                                 (p `adjustErr` f) `adjustErr` (++show pn)
-
----- XML Parsing Functions ----
-
-document :: HParser (Document Posn)
-document = do
-    p     <- prolog `adjustErr` ("unrecognisable XML prolog\n"++)
-    es    <- many1 (element "HTML document")
-    ms    <- many misc
-    return (Document p emptyST (case map snd es of
-                                  [e] -> e
-                                  es  -> Elem "html" [] (map mkCElem es))
-                               ms)
-  where mkCElem e = CElem e noPos
-
-comment :: HParser Comment
-comment = do
-    bracket (tok TokCommentOpen) (tok TokCommentClose) freetext
-
-processinginstruction :: HParser ProcessingInstruction
-processinginstruction = do
-    tok TokPIOpen
-    commit $ do
-      n <- string  `onFail` failP "processing instruction has no target"
-      f <- freetext
-      (tok TokPIClose `onFail` tok TokAnyClose) `onFail` failP "missing ?> or >"
-      return (n, f)
-
-cdsect :: HParser CDSect
-cdsect = do
-    tok TokSectionOpen
-    bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata
-
-prolog :: HParser Prolog
-prolog = do
-    x <- maybe xmldecl
-    m1 <- many misc
-    dtd <- maybe doctypedecl
-    m2 <- many misc
-    return (Prolog x m1 dtd m2)
-
-xmldecl :: HParser XMLDecl
-xmldecl = do
-    tok TokPIOpen
-    (word "xml" `onFail` word "XML")
-    p <- posn
-    s <- freetext
-    tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"
-    (Prelude.either failP return . fst . runParser aux . xmlReLex p) s
-  where
-    aux = do
-      v <- versioninfo  `onFail` failP "missing XML version info"
-      e <- maybe encodingdecl
-      s <- maybe sddecl
-      return (XMLDecl v e s)
-
-versioninfo :: HParser VersionInfo
-versioninfo = do
-    (word "version" `onFail` word "VERSION")
-    tok TokEqual
-    bracket (tok TokQuote) (tok TokQuote) freetext
-
-misc :: HParser Misc
-misc = 
-    oneOf' [ ("<!--comment-->", comment >>= return . Comment)
-           , ("<?PI?>",         processinginstruction >>= return . PI)
-           ]
-
-
--- Question: for HTML, should we disallow in-line DTDs, allowing only externals?
--- Answer: I think so.
-
-doctypedecl :: HParser DocTypeDecl
-doctypedecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial DOCTYPEx)
-    commit $ do
-      n <- name
-      eid <- maybe externalid
---    es <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)) (many markupdecl)
-      tok TokAnyClose  `onFail` failP "missing > in DOCTYPE decl"
---    return (DTD n eid (case es of { Nothing -> []; Just e -> e }))
-      return (DTD n eid [])
-
---markupdecl :: HParser MarkupDecl
---markupdecl =
---    ( elementdecl >>= return . Element) `onFail`
---    ( attlistdecl >>= return . AttList) `onFail`
---    ( entitydecl >>= return . Entity) `onFail`
---    ( notationdecl >>= return . Notation) `onFail`
---    ( misc >>= return . MarkupMisc) `onFail`
---    PEREF(MarkupPE,markupdecl)
---
---extsubset :: HParser ExtSubset
---extsubset = do
---    td <- maybe textdecl
---    ds <- many extsubsetdecl
---    return (ExtSubset td ds)
---
---extsubsetdecl :: HParser ExtSubsetDecl
---extsubsetdecl =
---    ( markupdecl >>= return . ExtMarkupDecl) `onFail`
---    ( conditionalsect >>= return . ExtConditionalSect) `onFail`
---    PEREF(ExtPEReference,extsubsetdecl)
-
-sddecl :: HParser SDDecl
-sddecl = do
-    (word "standalone" `onFail` word "STANDALONE")
-    commit $ do
-      tok TokEqual `onFail` failP "missing = in 'standalone' decl"
-      bracket (tok TokQuote) (tok TokQuote)
-              ( (word "yes" >> return True) `onFail`
-                (word "no" >> return False) `onFail`
-                failP "'standalone' decl requires 'yes' or 'no' value" )
-
-
-
-
-----
--- VERY IMPORTANT NOTE: The stack returned here contains those tags which
--- have been closed implicitly and need to be reopened again at the
--- earliest opportunity.
-type Stack = [(Name,[Attribute])]
-
-element :: Name -> HParser (Stack,Element Posn)
-element ctx =
-  do
-    tok TokAnyOpen
-    (ElemTag e avs) <- elemtag
-    ( if e `closes` ctx then
-         -- insert the missing close-tag, fail forward, and reparse.
-         ( do debug ("/")
-              unparse ([TokEndOpen, TokName ctx, TokAnyClose,
-                        TokAnyOpen, TokName e] ++ reformatAttrs avs)
-              return ([], Elem "null" [] []))
-      else if e `elem` selfclosingtags then
-         -- complete the parse straightaway.
-         ( do tok TokEndClose	-- self-closing <tag /> 
-              debug (e++"[+]")
-              return ([], Elem e avs [])) `onFail`
-     --  ( do tok TokAnyClose	-- sequence <tag></tag>	(**not HTML?**)
-     --       debug (e++"[+")
-     --       n <- bracket (tok TokEndOpen) (tok TokAnyClose) name
-     --       debug "]"
-     --       if e == (map toLower n :: Name) 
-     --         then return ([], Elem e avs [])      
-     --         else return (error "no nesting in empty tag")) `onFail`
-         ( do tok TokAnyClose	-- <tag> with no close (e.g. <IMG>)
-              debug (e++"[+]")
-              return ([], Elem e avs []))
-      else
-        (( do tok TokEndClose
-              debug (e++"[]")
-              return ([], Elem e avs [])) `onFail`
-         ( do tok TokAnyClose `onFail` failP "missing > or /> in element tag"
-              debug (e++"[")
-           -- zz <- many (content e)
-           -- n <- bracket (tok TokEndOpen) (tok TokAnyClose) name
-              zz <- manyFinally (content e)
-                                (tok TokEndOpen)
-              n <- name
-              commit (tok TokAnyClose)
-              debug "]"
-              let (ss,cs) = unzip zz
-              let s       = if null ss then [] else last ss
-              ( if e == (map toLower n :: Name) then
-                  do unparse (reformatTags (closeInner e s))
-                     debug "^"
-                     return ([], Elem e avs cs)
-                else
-                  do unparse [TokEndOpen, TokName n, TokAnyClose]
-                     debug "-"
-                     return (((e,avs):s), Elem e avs cs))
-         ) `onFail` failP ("failed to repair non-matching tags in context: "++ctx)))
-
-closeInner :: Name -> [(Name,[Attribute])] -> [(Name,[Attribute])]
-closeInner c ts =
-    case lookup c closeInnerTags of
-      (Just these) -> filter ((`notElem` these).fst) ts
-      Nothing      -> ts
-
-unparse ts = do p <- posn
-                reparse (zip (repeat p) ts)
-
-reformatAttrs avs = concatMap f0 avs
-    where f0 (a, v@(AttValue _)) = [TokName a, TokEqual, TokQuote,
-                                       TokFreeText (show v), TokQuote]
-reformatTags ts = concatMap f0 ts
-    where f0 (t,avs) = [TokAnyOpen, TokName t]++reformatAttrs avs++[TokAnyClose]
-
-content :: Name -> HParser (Stack,Content Posn)
-content ctx = do { p <- posn ; content' p ctx }
-  where content' p ctx = oneOf'
-          [ ( "element", element ctx >>= \(s,e)-> return (s, CElem e p))
-          , ( "chardata", chardata >>= \s-> return ([], CString False s p))
-          , ( "reference", reference >>= \r-> return ([], CRef r p))
-          , ( "cdsect", cdsect >>= \c-> return ([], CString True c p))
-          , ( "misc", misc >>= \m->  return ([], CMisc m p))
-          ] `adjustErrP` ("when looking for a content item,\n"++)
-
-----
-elemtag :: HParser ElemTag
-elemtag = do
-    n <- name `adjustErrBad` ("malformed element tag\n"++)
-    as <- many attribute
-    return (ElemTag (map toLower n) as)
-
-attribute :: HParser Attribute
-attribute = do
-    n <- name
-    v <- (do tok TokEqual
-             attvalue) `onFail`
-         (return (AttValue [Left "TRUE"]))
-    return (map toLower n,v)
-
---elementdecl :: HParser ElementDecl
---elementdecl = do
---    tok TokSpecialOpen
---    tok (TokSpecial ELEMENTx)
---    n <- name `onFail` failP "missing identifier in ELEMENT decl"
---    c <- contentspec `onFail` failP "missing content spec in ELEMENT decl"
---    tok TokAnyClose `onFail` failP "expected > terminating ELEMENT decl"
---    return (ElementDecl n c)
---
---contentspec :: HParser ContentSpec
---contentspec =
---    ( word "EMPTY" >> return EMPTY) `onFail`
---    ( word "ANY" >> return ANY) `onFail`
---    ( mixed >>= return . Mixed) `onFail`
---    ( cp >>= return . ContentSpec) `onFail`
---    PEREF(ContentPE,contentspec)
---
---choice :: HParser [CP]
---choice = do
---    bracket (tok TokBraOpen) (tok TokBraClose)
---            (cp `sepby1` (tok TokPipe))
---
---sequence :: HParser [CP]
---sequence = do
---    bracket (tok TokBraOpen) (tok TokBraClose)
---            (cp `sepby1` (tok TokComma))
---
---cp :: HParser CP
---cp =
---    ( do n <- name
---         m <- modifier
---         return (TagName n m)) `onFail`
---    ( do ss <- sequence
---         m <- modifier
---         return (Seq ss m)) `onFail`
---    ( do cs <- choice
---         m <- modifier
---         return (Choice cs m)) `onFail`
---    PEREF(CPPE,cp)
---
---modifier :: HParser Modifier
---modifier =
---    ( tok TokStar >> return Star) `onFail`
---    ( tok TokQuery >> return Query) `onFail`
---    ( tok TokPlus >> return Plus) `onFail`
---    ( return None)
---
---mixed :: HParser Mixed
---mixed = do
---    tok TokBraOpen
---    tok TokHash
---    word "PCDATA"
---    cont
---  where
---    cont = ( tok TokBraClose >> return PCDATA) `onFail`
---           ( do cs <- many ( do tok TokPipe
---                                n <- name
---                                return n)
---                tok TokBraClose
---                tok TokStar
---                return (PCDATAplus cs))
---
---attlistdecl :: HParser AttListDecl
---attlistdecl = do
---    tok TokSpecialOpen
---    tok (TokSpecial ATTLISTx)
---    n <- name `onFail` failP "missing identifier in ATTLIST"
---    ds <- many attdef
---    tok TokAnyClose `onFail` failP "missing > terminating ATTLIST"
---    return (AttListDecl n ds)
---
---attdef :: HParser AttDef
---attdef = do
---    n <- name
---    t <- atttype `onFail` failP "missing attribute type in attlist defn"
---    d <- defaultdecl
---    return (AttDef n t d)
---
---atttype :: HParser AttType
---atttype =
---    ( word "CDATA" >> return StringType) `onFail`
---    ( tokenizedtype >>= return . TokenizedType) `onFail`
---    ( enumeratedtype >>= return . EnumeratedType)
---
---tokenizedtype :: HParser TokenizedType
---tokenizedtype =
---    ( word "ID" >> return ID) `onFail`
---    ( word "IDREF" >> return IDREF) `onFail`
---    ( word "IDREFS" >> return IDREFS) `onFail`
---    ( word "ENTITY" >> return ENTITY) `onFail`
---    ( word "ENTITIES" >> return ENTITIES) `onFail`
---    ( word "NMTOKEN" >> return NMTOKEN) `onFail`
---    ( word "NMTOKENS" >> return NMTOKENS)
---
---enumeratedtype :: HParser EnumeratedType
---enumeratedtype =
---    ( notationtype >>= return . NotationType) `onFail`
---    ( enumeration >>= return . Enumeration)
---
---notationtype :: HParser NotationType
---notationtype = do
---    word "NOTATION"
---    bracket (tok TokBraOpen) (tok TokBraClose)
---            (name `sepby1` (tok TokPipe))
---
---enumeration :: HParser Enumeration
---enumeration =
---    bracket (tok TokBraOpen) (tok TokBraClose)
---            (nmtoken `sepby1` (tok TokPipe))
---
---defaultdecl :: HParser DefaultDecl
---defaultdecl =
---    ( tok TokHash >> word "REQUIRED" >> return REQUIRED) `onFail`
---    ( tok TokHash >> word "IMPLIED" >> return IMPLIED) `onFail`
---    ( do f <- maybe (tok TokHash >> word "FIXED" >> return FIXED)
---         a <- attvalue
---         return (DefaultTo a f))
---
---conditionalsect :: HParser ConditionalSect
---conditionalsect =
---    ( do tok TokSectionOpen
---         tok (TokSection INCLUDEx)
---         tok TokSqOpen `onFail` failP "missing [ after INCLUDE"
---         i <- extsubsetdecl `onFail` failP "missing ExtSubsetDecl in INCLUDE"
---         tok TokSectionClose `onFail` failP "missing ] after INCLUDE"
---         return (IncludeSect i)) `onFail`
---    ( do tok TokSectionOpen
---         tok (TokSection IGNOREx)
---         tok TokSqOpen `onFail` failP "missing [ after IGNORE"
---         i <- many ignoresectcontents
---         tok TokSectionClose `onFail` failP "missing ] after IGNORE"
---         return (IgnoreSect i))
---
---ignoresectcontents :: HParser IgnoreSectContents
---ignoresectcontents = do
---    i <- ignore
---    is <- many (do tok TokSectionOpen
---                   ic <- ignoresectcontents
---                   tok TokSectionClose
---                   ig <- ignore
---                   return (ic,ig))
---    return (IgnoreSectContents i is)
---
---ignore :: HParser Ignore
---ignore = freetext >>= return . Ignore
-
-reference :: HParser Reference
-reference = do
-    bracket (tok TokAmp) (tok TokSemi) (freetext >>= val)
-  where
-    val ('#':'x':i) | all isHexDigit i
-                    = return . RefChar . fst . head . readHex $ i
-    val ('#':i)     | all isDigit i
-                    = return . RefChar . fst . head . readDec $ i
-    val name        = return . RefEntity $ name
-
-{-
-reference :: HParser Reference
-reference =
-    ( charref >>= return . RefChar) `onFail`
-    ( entityref >>= return . RefEntity)
-
-entityref :: HParser EntityRef
-entityref = do
-    n <- bracket (tok TokAmp) (tok TokSemi) name
-    return n
-
-charref :: HParser CharRef
-charref = do
-    bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal)
-  where
-    readCharVal ('#':'x':i) = return . fst . head . readHex $ i
-    readCharVal ('#':i)     = return . fst . head . readDec $ i
-    readCharVal _           = mzero
--}
-
---pereference :: HParser PEReference
---pereference = do
---    bracket (tok TokPercent) (tok TokSemi) nmtoken
---
---entitydecl :: HParser EntityDecl
---entitydecl =
---    ( gedecl >>= return . EntityGEDecl) `onFail`
---    ( pedecl >>= return . EntityPEDecl)
---
---gedecl :: HParser GEDecl
---gedecl = do
---    tok TokSpecialOpen
---    tok (TokSpecial ENTITYx)
---    n <- name
---    e <- entitydef `onFail` failP "missing entity defn in G ENTITY decl"
---    tok TokAnyClose `onFail` failP "expected > terminating G ENTITY decl"
---    return (GEDecl n e)
---
---pedecl :: HParser PEDecl
---pedecl = do
---    tok TokSpecialOpen
---    tok (TokSpecial ENTITYx)
---    tok TokPercent
---    n <- name
---    e <- pedef `onFail` failP "missing entity defn in P ENTITY decl"
---    tok TokAnyClose `onFail` failP "expected > terminating P ENTITY decl"
---    return (PEDecl n e)
---
---entitydef :: HParser EntityDef
---entitydef =
---    ( entityvalue >>= return . DefEntityValue) `onFail`
---    ( do eid <- externalid
---         ndd <- maybe ndatadecl
---         return (DefExternalID eid ndd))
---
---pedef :: HParser PEDef
---pedef =
---    ( entityvalue >>= return . PEDefEntityValue) `onFail`
---    ( externalid >>= return . PEDefExternalID)
-
-externalid :: HParser ExternalID
-externalid =
-    ( do word "SYSTEM"
-         s <- systemliteral
-         return (SYSTEM s)) `onFail`
-    ( do word "PUBLIC"
-         p <- pubidliteral
-         s <- (systemliteral `onFail` return (SystemLiteral ""))
-         return (PUBLIC p s))
-
---ndatadecl :: HParser NDataDecl
---ndatadecl = do
---    word "NDATA"
---    n <- name
---    return (NDATA n)
-
-textdecl :: HParser TextDecl
-textdecl = do
-    tok TokPIOpen
-    (word "xml" `onFail` word "XML")
-    v <- maybe versioninfo
-    e <- encodingdecl
-    tok TokPIClose `onFail` failP "expected ?> terminating text decl"
-    return (TextDecl v e)
-
---extparsedent :: HParser ExtParsedEnt
---extparsedent = do
---    t <- maybe textdecl
---    (_,c) <- (content "")
---    return (ExtParsedEnt t c)
---
---extpe :: HParser ExtPE
---extpe = do
---    t <- maybe textdecl
---    e <- extsubsetdecl
---    return (ExtPE t e)
-
-encodingdecl :: HParser EncodingDecl
-encodingdecl = do
-    (word "encoding" `onFail` word "ENCODING")
-    tok TokEqual `onFail` failBadP "expected = in 'encoding' decl"
-    f <- bracket (tok TokQuote) (tok TokQuote) freetext
-    return (EncodingDecl f)
-
---notationdecl :: HParser NotationDecl
---notationdecl = do
---    tok TokSpecialOpen
---    word "NOTATION"
---    n <- name
---    e <- either externalid publicid
---    tok TokAnyClose `onFail` failP "expected > terminating NOTATION decl"
---    return (NOTATION n e)
-
-publicid :: HParser PublicID
-publicid = do
-    word "PUBLICID"
-    p <- pubidliteral
-    return (PUBLICID p)
-
-entityvalue :: HParser EntityValue
-entityvalue = do
-    evs <- bracket (tok TokQuote) (tok TokQuote) (many ev)
-    return (EntityValue evs)
-
-ev :: HParser EV
-ev =
-    ( freetext >>= return . EVString) `onFail`
---  PEREF(EVPERef,ev) `onFail`
-    ( reference >>= return . EVRef)
-
-attvalue :: HParser AttValue
-attvalue =
-  ( do avs <- bracket (tok TokQuote) (tok TokQuote)
-                      (many (either freetext reference))
-       return (AttValue avs) ) `onFail`
-  ( do v <- nmtoken
-       s <- (tok TokPercent >> return "%") `onFail` return ""
-       return (AttValue [Left (v++s)]) ) `onFail`
-  ( do s <- oneOf [ tok TokPlus >> return "+"
-                  , tok TokHash >> return "#"
-                  ]
-       v <- nmtoken
-       return (AttValue [Left (s++v)]) ) `onFail`
-  failP "Badly formatted attribute value"
-
-systemliteral :: HParser SystemLiteral
-systemliteral = do
-    s <- bracket (tok TokQuote) (tok TokQuote) freetext
-    return (SystemLiteral s)		-- note: need to fold &...; escapes
-
-pubidliteral :: HParser PubidLiteral
-pubidliteral = do
-    s <- bracket (tok TokQuote) (tok TokQuote) freetext
-    return (PubidLiteral s)		-- note: need to fold &...; escapes
-
-chardata :: HParser CharData
-chardata = freetext -- >>= return . CharData
-
-

+
+
+src/Text/XML/HaXml/Html/Parse.hs
+
+
+
-- | This is a parser for HTML documents.  Unlike for XML documents, it
+--   must include a certain amount of error-correction to account for
+--   HTML features like self-terminating tags, unterminated tags, and
+--   incorrect nesting.  The input is tokenised by the
+--   XML lexer (a separate lexer is not required for HTML).
+
+-- It uses a slightly extended version of the Hutton/Meijer parser
+-- combinators.
+
+module Text.XML.HaXml.Html.Parse
+  ( htmlParse
+  ) where
+
+import Prelude hiding (either,maybe,sequence)
+import qualified Prelude (either)
+import Maybe hiding (maybe)
+import Char (toLower, isSpace, isDigit, isHexDigit)
+import Numeric (readDec,readHex)
+import Monad
+
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.Lex
+import Text.XML.HaXml.Posn
+import Text.ParserCombinators.Poly.NoLeak.Plain
+
+--  #define DEBUG
+ 
+#if defined(DEBUG)
+#  if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
+      ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
+import Debug.Trace(trace)
+#  elif defined(__GLASGOW_HASKELL__)
+import IOExts(trace)
+#  elif defined(__NHC__) || defined(__HBC__)
+import NonStdTrace
+#  endif
+debug :: Monad m => String -> m ()
+debug s = trace s (return ())
+#else
+debug :: Monad m => String -> m ()
+debug s = return ()
+#endif
+
+
+-- | The first argument is the name of the file, the second is the string
+--   contents of the file.  The result is the generic representation of
+--   an XML document.  Any errors cause program failure with message to stderr.
+htmlParse :: String -> String -> Document Posn
+htmlParse name = Prelude.either error id . htmlParse' name
+
+-- | The first argument is the name of the file, the second is the string
+--   contents of the file.  The result is the generic representation of
+--   an XML document.  Any parsing errors are returned in the @Either@ type.
+htmlParse' :: String -> String -> Either String (Document Posn)
+htmlParse' name = Prelude.either Left (Right . simplify) . fst
+                  . runParser document . xmlLex name
+
+---- Document simplification ----
+
+simplify :: Document i -> Document i
+simplify (Document p st (Elem n avs cs) ms) =
+    Document p st (Elem n avs (deepfilter simp cs)) ms
+  where
+    simp (CElem (Elem "null" [] []) _) = False
+    simp (CElem (Elem  n     _  []) _) | n `elem` ["font","p","i","b","em"
+                                                  ,"tt","big","small"] = False
+ -- simp (CString False s _) | all isSpace s = False
+    simp _ = True
+    deepfilter p =
+        filter p . map (\c-> case c of
+                          CElem (Elem n avs cs) i
+                                  -> CElem (Elem n avs (deepfilter p cs)) i
+                          _       -> c)
+
+-- opening any of these, they close again immediately
+selfclosingtags = ["img","hr","br","meta","col","link","base"
+                  ,"param","area","frame","input"]
+
+--closing this, implicitly closes any of those which are contained in it
+closeInnerTags =
+  [ ("ul",      ["li"])
+  , ("ol",      ["li"])
+  , ("dl",      ["dt","dd"])
+  , ("tr",      ["th","td"])
+  , ("div",     ["p"])
+  , ("thead",   ["th","tr","td"])
+  , ("tfoot",   ["th","tr","td"])
+  , ("tbody",   ["th","tr","td"])
+  , ("table",   ["th","tr","td","thead","tfoot","tbody"])
+  , ("caption", ["p"])
+  , ("th",      ["p"])
+  , ("td",      ["p"])
+  , ("li",      ["p"])
+  , ("dt",      ["p"])
+  , ("dd",      ["p"])
+  , ("object",  ["p"])
+  , ("map",     ["p"])
+  , ("body",    ["p"])
+  ]
+
+--opening this, implicitly closes that
+closes :: Name -> Name -> Bool
+"a"  `closes` "a"   =  True
+"li" `closes` "li"  =  True
+"th" `closes`  t    | t `elem` ["th","td"]      =  True
+"td" `closes`  t    | t `elem` ["th","td"]      =  True
+"tr" `closes`  t    | t `elem` ["th","td","tr"] =  True
+"dt" `closes`  t    | t `elem` ["dt","dd"]      =  True
+"dd" `closes`  t    | t `elem` ["dt","dd"]      =  True
+"form"  `closes` "form"      = True
+"label" `closes` "label"     = True
+_       `closes` "option"    = True
+"thead" `closes` t  | t `elem` ["colgroup"]          = True
+"tfoot" `closes` t  | t `elem` ["thead","colgroup"]  = True
+"tbody" `closes` t  | t `elem` ["tbody","tfoot","thead","colgroup"] = True
+"colgroup" `closes` "colgroup"  = True
+t `closes` "p"
+    | t `elem` ["p","h1","h2","h3","h4","h5","h6"
+               ,"hr","div","ul","dl","ol","table"]  =  True
+_ `closes` _ = False
+
+
+
+---- Misc ----
+
+fst3 (a,_,_) = a
+snd3 (_,a,_) = a
+thd3 (_,_,a) = a
+
+
+
+---- Auxiliary Parsing Functions ----
+
+type HParser a = Parser (Posn,TokenT) a
+
+tok :: TokenT -> HParser TokenT
+tok t = do (p,t') <- next
+           case t' of TokError s    -> report failBad (show t) p t'
+                      _ | t'==t     -> return t
+                        | otherwise -> report fail (show t) p t'
+
+name :: HParser Name
+--name = do {(p,TokName s) <- next; return s}
+name = do (p,tok) <- next
+          case tok of 
+            TokName s  -> return s 
+            TokError s -> report failBad "a name" p tok
+            _          -> report fail "a name" p tok
+
+string, freetext :: HParser String
+string   = do (p,t) <- next
+              case t of TokName s -> return s
+                        _         -> report fail "text" p t
+freetext = do (p,t) <- next
+              case t of TokFreeText s -> return s
+                        _             -> report fail "text" p t
+
+maybe :: HParser a -> HParser (Maybe a)
+maybe p =
+    ( p >>= return . Just) `onFail`
+    ( return Nothing)
+
+either :: HParser a -> HParser b -> HParser (Either a b)
+either p q =
+    ( p >>= return . Left) `onFail`
+    ( q >>= return . Right)
+
+word :: String -> HParser ()
+word s = do { x <- next
+            ; case x of
+                (p,TokName n)     | s==n -> return ()
+                (p,TokFreeText n) | s==n -> return ()
+                (p,t@(TokError _)) -> report failBad (show s) p t
+                (p,t) -> report fail (show s) p t
+            }
+
+posn :: HParser Posn
+posn = do { x@(p,_) <- next
+          ; reparse [x]
+          ; return p
+          } `onFail` return noPos
+
+nmtoken :: HParser NmToken
+nmtoken = (string `onFail` freetext)
+
+failP, failBadP :: String -> HParser a
+failP msg    = do { p <- posn; fail (msg++"\n    at "++show p) }
+failBadP msg = do { p <- posn; failBad (msg++"\n    at "++show p) }
+
+report :: (String->HParser a) -> String -> Posn -> TokenT -> HParser a
+report fail exp p t = fail ("Expected "++show exp++" but found "++show t
+                           ++"\n  at "++show p)
+
+adjustErrP :: HParser a -> (String->String) -> HParser a
+p `adjustErrP` f = p `onFail` do pn <- posn
+                                 (p `adjustErr` f) `adjustErr` (++show pn)
+
+---- XML Parsing Functions ----
+
+document :: HParser (Document Posn)
+document = do
+    p     <- prolog `adjustErr` ("unrecognisable XML prolog\n"++)
+    es    <- many1 (element "HTML document")
+    ms    <- many misc
+    return (Document p emptyST (case map snd es of
+                                  [e] -> e
+                                  es  -> Elem "html" [] (map mkCElem es))
+                               ms)
+  where mkCElem e = CElem e noPos
+
+comment :: HParser Comment
+comment = do
+    bracket (tok TokCommentOpen) (tok TokCommentClose) freetext
+
+processinginstruction :: HParser ProcessingInstruction
+processinginstruction = do
+    tok TokPIOpen
+    commit $ do
+      n <- string  `onFail` failP "processing instruction has no target"
+      f <- freetext
+      (tok TokPIClose `onFail` tok TokAnyClose) `onFail` failP "missing ?> or >"
+      return (n, f)
+
+cdsect :: HParser CDSect
+cdsect = do
+    tok TokSectionOpen
+    bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata
+
+prolog :: HParser Prolog
+prolog = do
+    x <- maybe xmldecl
+    m1 <- many misc
+    dtd <- maybe doctypedecl
+    m2 <- many misc
+    return (Prolog x m1 dtd m2)
+
+xmldecl :: HParser XMLDecl
+xmldecl = do
+    tok TokPIOpen
+    (word "xml" `onFail` word "XML")
+    p <- posn
+    s <- freetext
+    tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"
+    (Prelude.either failP return . fst . runParser aux . xmlReLex p) s
+  where
+    aux = do
+      v <- versioninfo  `onFail` failP "missing XML version info"
+      e <- maybe encodingdecl
+      s <- maybe sddecl
+      return (XMLDecl v e s)
+
+versioninfo :: HParser VersionInfo
+versioninfo = do
+    (word "version" `onFail` word "VERSION")
+    tok TokEqual
+    bracket (tok TokQuote) (tok TokQuote) freetext
+
+misc :: HParser Misc
+misc = 
+    oneOf' [ ("<!--comment-->", comment >>= return . Comment)
+           , ("<?PI?>",         processinginstruction >>= return . PI)
+           ]
+
+
+-- Question: for HTML, should we disallow in-line DTDs, allowing only externals?
+-- Answer: I think so.
+
+doctypedecl :: HParser DocTypeDecl
+doctypedecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial DOCTYPEx)
+    commit $ do
+      n <- name
+      eid <- maybe externalid
+--    es <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)) (many markupdecl)
+      tok TokAnyClose  `onFail` failP "missing > in DOCTYPE decl"
+--    return (DTD n eid (case es of { Nothing -> []; Just e -> e }))
+      return (DTD n eid [])
+
+--markupdecl :: HParser MarkupDecl
+--markupdecl =
+--    ( elementdecl >>= return . Element) `onFail`
+--    ( attlistdecl >>= return . AttList) `onFail`
+--    ( entitydecl >>= return . Entity) `onFail`
+--    ( notationdecl >>= return . Notation) `onFail`
+--    ( misc >>= return . MarkupMisc) `onFail`
+--    PEREF(MarkupPE,markupdecl)
+--
+--extsubset :: HParser ExtSubset
+--extsubset = do
+--    td <- maybe textdecl
+--    ds <- many extsubsetdecl
+--    return (ExtSubset td ds)
+--
+--extsubsetdecl :: HParser ExtSubsetDecl
+--extsubsetdecl =
+--    ( markupdecl >>= return . ExtMarkupDecl) `onFail`
+--    ( conditionalsect >>= return . ExtConditionalSect) `onFail`
+--    PEREF(ExtPEReference,extsubsetdecl)
+
+sddecl :: HParser SDDecl
+sddecl = do
+    (word "standalone" `onFail` word "STANDALONE")
+    commit $ do
+      tok TokEqual `onFail` failP "missing = in 'standalone' decl"
+      bracket (tok TokQuote) (tok TokQuote)
+              ( (word "yes" >> return True) `onFail`
+                (word "no" >> return False) `onFail`
+                failP "'standalone' decl requires 'yes' or 'no' value" )
+
+
+
+
+----
+-- VERY IMPORTANT NOTE: The stack returned here contains those tags which
+-- have been closed implicitly and need to be reopened again at the
+-- earliest opportunity.
+type Stack = [(Name,[Attribute])]
+
+element :: Name -> HParser (Stack,Element Posn)
+element ctx =
+  do
+    tok TokAnyOpen
+    (ElemTag e avs) <- elemtag
+    ( if e `closes` ctx then
+         -- insert the missing close-tag, fail forward, and reparse.
+         ( do debug ("/")
+              unparse ([TokEndOpen, TokName ctx, TokAnyClose,
+                        TokAnyOpen, TokName e] ++ reformatAttrs avs)
+              return ([], Elem "null" [] []))
+      else if e `elem` selfclosingtags then
+         -- complete the parse straightaway.
+         ( do tok TokEndClose	-- self-closing <tag /> 
+              debug (e++"[+]")
+              return ([], Elem e avs [])) `onFail`
+     --  ( do tok TokAnyClose	-- sequence <tag></tag>	(**not HTML?**)
+     --       debug (e++"[+")
+     --       n <- bracket (tok TokEndOpen) (tok TokAnyClose) name
+     --       debug "]"
+     --       if e == (map toLower n :: Name) 
+     --         then return ([], Elem e avs [])      
+     --         else return (error "no nesting in empty tag")) `onFail`
+         ( do tok TokAnyClose	-- <tag> with no close (e.g. <IMG>)
+              debug (e++"[+]")
+              return ([], Elem e avs []))
+      else
+        (( do tok TokEndClose
+              debug (e++"[]")
+              return ([], Elem e avs [])) `onFail`
+         ( do tok TokAnyClose `onFail` failP "missing > or /> in element tag"
+              debug (e++"[")
+           -- zz <- many (content e)
+           -- n <- bracket (tok TokEndOpen) (tok TokAnyClose) name
+              zz <- manyFinally (content e)
+                                (tok TokEndOpen)
+              n <- name
+              commit (tok TokAnyClose)
+              debug "]"
+              let (ss,cs) = unzip zz
+              let s       = if null ss then [] else last ss
+              ( if e == (map toLower n :: Name) then
+                  do unparse (reformatTags (closeInner e s))
+                     debug "^"
+                     return ([], Elem e avs cs)
+                else
+                  do unparse [TokEndOpen, TokName n, TokAnyClose]
+                     debug "-"
+                     return (((e,avs):s), Elem e avs cs))
+         ) `onFail` failP ("failed to repair non-matching tags in context: "++ctx)))
+
+closeInner :: Name -> [(Name,[Attribute])] -> [(Name,[Attribute])]
+closeInner c ts =
+    case lookup c closeInnerTags of
+      (Just these) -> filter ((`notElem` these).fst) ts
+      Nothing      -> ts
+
+unparse ts = do p <- posn
+                reparse (zip (repeat p) ts)
+
+reformatAttrs avs = concatMap f0 avs
+    where f0 (a, v@(AttValue _)) = [TokName a, TokEqual, TokQuote,
+                                       TokFreeText (show v), TokQuote]
+reformatTags ts = concatMap f0 ts
+    where f0 (t,avs) = [TokAnyOpen, TokName t]++reformatAttrs avs++[TokAnyClose]
+
+content :: Name -> HParser (Stack,Content Posn)
+content ctx = do { p <- posn ; content' p ctx }
+  where content' p ctx = oneOf'
+          [ ( "element", element ctx >>= \(s,e)-> return (s, CElem e p))
+          , ( "chardata", chardata >>= \s-> return ([], CString False s p))
+          , ( "reference", reference >>= \r-> return ([], CRef r p))
+          , ( "cdsect", cdsect >>= \c-> return ([], CString True c p))
+          , ( "misc", misc >>= \m->  return ([], CMisc m p))
+          ] `adjustErrP` ("when looking for a content item,\n"++)
+
+----
+elemtag :: HParser ElemTag
+elemtag = do
+    n <- name `adjustErrBad` ("malformed element tag\n"++)
+    as <- many attribute
+    return (ElemTag (map toLower n) as)
+
+attribute :: HParser Attribute
+attribute = do
+    n <- name
+    v <- (do tok TokEqual
+             attvalue) `onFail`
+         (return (AttValue [Left "TRUE"]))
+    return (map toLower n,v)
+
+--elementdecl :: HParser ElementDecl
+--elementdecl = do
+--    tok TokSpecialOpen
+--    tok (TokSpecial ELEMENTx)
+--    n <- name `onFail` failP "missing identifier in ELEMENT decl"
+--    c <- contentspec `onFail` failP "missing content spec in ELEMENT decl"
+--    tok TokAnyClose `onFail` failP "expected > terminating ELEMENT decl"
+--    return (ElementDecl n c)
+--
+--contentspec :: HParser ContentSpec
+--contentspec =
+--    ( word "EMPTY" >> return EMPTY) `onFail`
+--    ( word "ANY" >> return ANY) `onFail`
+--    ( mixed >>= return . Mixed) `onFail`
+--    ( cp >>= return . ContentSpec) `onFail`
+--    PEREF(ContentPE,contentspec)
+--
+--choice :: HParser [CP]
+--choice = do
+--    bracket (tok TokBraOpen) (tok TokBraClose)
+--            (cp `sepby1` (tok TokPipe))
+--
+--sequence :: HParser [CP]
+--sequence = do
+--    bracket (tok TokBraOpen) (tok TokBraClose)
+--            (cp `sepby1` (tok TokComma))
+--
+--cp :: HParser CP
+--cp =
+--    ( do n <- name
+--         m <- modifier
+--         return (TagName n m)) `onFail`
+--    ( do ss <- sequence
+--         m <- modifier
+--         return (Seq ss m)) `onFail`
+--    ( do cs <- choice
+--         m <- modifier
+--         return (Choice cs m)) `onFail`
+--    PEREF(CPPE,cp)
+--
+--modifier :: HParser Modifier
+--modifier =
+--    ( tok TokStar >> return Star) `onFail`
+--    ( tok TokQuery >> return Query) `onFail`
+--    ( tok TokPlus >> return Plus) `onFail`
+--    ( return None)
+--
+--mixed :: HParser Mixed
+--mixed = do
+--    tok TokBraOpen
+--    tok TokHash
+--    word "PCDATA"
+--    cont
+--  where
+--    cont = ( tok TokBraClose >> return PCDATA) `onFail`
+--           ( do cs <- many ( do tok TokPipe
+--                                n <- name
+--                                return n)
+--                tok TokBraClose
+--                tok TokStar
+--                return (PCDATAplus cs))
+--
+--attlistdecl :: HParser AttListDecl
+--attlistdecl = do
+--    tok TokSpecialOpen
+--    tok (TokSpecial ATTLISTx)
+--    n <- name `onFail` failP "missing identifier in ATTLIST"
+--    ds <- many attdef
+--    tok TokAnyClose `onFail` failP "missing > terminating ATTLIST"
+--    return (AttListDecl n ds)
+--
+--attdef :: HParser AttDef
+--attdef = do
+--    n <- name
+--    t <- atttype `onFail` failP "missing attribute type in attlist defn"
+--    d <- defaultdecl
+--    return (AttDef n t d)
+--
+--atttype :: HParser AttType
+--atttype =
+--    ( word "CDATA" >> return StringType) `onFail`
+--    ( tokenizedtype >>= return . TokenizedType) `onFail`
+--    ( enumeratedtype >>= return . EnumeratedType)
+--
+--tokenizedtype :: HParser TokenizedType
+--tokenizedtype =
+--    ( word "ID" >> return ID) `onFail`
+--    ( word "IDREF" >> return IDREF) `onFail`
+--    ( word "IDREFS" >> return IDREFS) `onFail`
+--    ( word "ENTITY" >> return ENTITY) `onFail`
+--    ( word "ENTITIES" >> return ENTITIES) `onFail`
+--    ( word "NMTOKEN" >> return NMTOKEN) `onFail`
+--    ( word "NMTOKENS" >> return NMTOKENS)
+--
+--enumeratedtype :: HParser EnumeratedType
+--enumeratedtype =
+--    ( notationtype >>= return . NotationType) `onFail`
+--    ( enumeration >>= return . Enumeration)
+--
+--notationtype :: HParser NotationType
+--notationtype = do
+--    word "NOTATION"
+--    bracket (tok TokBraOpen) (tok TokBraClose)
+--            (name `sepby1` (tok TokPipe))
+--
+--enumeration :: HParser Enumeration
+--enumeration =
+--    bracket (tok TokBraOpen) (tok TokBraClose)
+--            (nmtoken `sepby1` (tok TokPipe))
+--
+--defaultdecl :: HParser DefaultDecl
+--defaultdecl =
+--    ( tok TokHash >> word "REQUIRED" >> return REQUIRED) `onFail`
+--    ( tok TokHash >> word "IMPLIED" >> return IMPLIED) `onFail`
+--    ( do f <- maybe (tok TokHash >> word "FIXED" >> return FIXED)
+--         a <- attvalue
+--         return (DefaultTo a f))
+--
+--conditionalsect :: HParser ConditionalSect
+--conditionalsect =
+--    ( do tok TokSectionOpen
+--         tok (TokSection INCLUDEx)
+--         tok TokSqOpen `onFail` failP "missing [ after INCLUDE"
+--         i <- extsubsetdecl `onFail` failP "missing ExtSubsetDecl in INCLUDE"
+--         tok TokSectionClose `onFail` failP "missing ] after INCLUDE"
+--         return (IncludeSect i)) `onFail`
+--    ( do tok TokSectionOpen
+--         tok (TokSection IGNOREx)
+--         tok TokSqOpen `onFail` failP "missing [ after IGNORE"
+--         i <- many ignoresectcontents
+--         tok TokSectionClose `onFail` failP "missing ] after IGNORE"
+--         return (IgnoreSect i))
+--
+--ignoresectcontents :: HParser IgnoreSectContents
+--ignoresectcontents = do
+--    i <- ignore
+--    is <- many (do tok TokSectionOpen
+--                   ic <- ignoresectcontents
+--                   tok TokSectionClose
+--                   ig <- ignore
+--                   return (ic,ig))
+--    return (IgnoreSectContents i is)
+--
+--ignore :: HParser Ignore
+--ignore = freetext >>= return . Ignore
+
+reference :: HParser Reference
+reference = do
+    bracket (tok TokAmp) (tok TokSemi) (freetext >>= val)
+  where
+    val ('#':'x':i) | all isHexDigit i
+                    = return . RefChar . fst . head . readHex $ i
+    val ('#':i)     | all isDigit i
+                    = return . RefChar . fst . head . readDec $ i
+    val name        = return . RefEntity $ name
+
+{-
+reference :: HParser Reference
+reference =
+    ( charref >>= return . RefChar) `onFail`
+    ( entityref >>= return . RefEntity)
+
+entityref :: HParser EntityRef
+entityref = do
+    n <- bracket (tok TokAmp) (tok TokSemi) name
+    return n
+
+charref :: HParser CharRef
+charref = do
+    bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal)
+  where
+    readCharVal ('#':'x':i) = return . fst . head . readHex $ i
+    readCharVal ('#':i)     = return . fst . head . readDec $ i
+    readCharVal _           = mzero
+-}
+
+--pereference :: HParser PEReference
+--pereference = do
+--    bracket (tok TokPercent) (tok TokSemi) nmtoken
+--
+--entitydecl :: HParser EntityDecl
+--entitydecl =
+--    ( gedecl >>= return . EntityGEDecl) `onFail`
+--    ( pedecl >>= return . EntityPEDecl)
+--
+--gedecl :: HParser GEDecl
+--gedecl = do
+--    tok TokSpecialOpen
+--    tok (TokSpecial ENTITYx)
+--    n <- name
+--    e <- entitydef `onFail` failP "missing entity defn in G ENTITY decl"
+--    tok TokAnyClose `onFail` failP "expected > terminating G ENTITY decl"
+--    return (GEDecl n e)
+--
+--pedecl :: HParser PEDecl
+--pedecl = do
+--    tok TokSpecialOpen
+--    tok (TokSpecial ENTITYx)
+--    tok TokPercent
+--    n <- name
+--    e <- pedef `onFail` failP "missing entity defn in P ENTITY decl"
+--    tok TokAnyClose `onFail` failP "expected > terminating P ENTITY decl"
+--    return (PEDecl n e)
+--
+--entitydef :: HParser EntityDef
+--entitydef =
+--    ( entityvalue >>= return . DefEntityValue) `onFail`
+--    ( do eid <- externalid
+--         ndd <- maybe ndatadecl
+--         return (DefExternalID eid ndd))
+--
+--pedef :: HParser PEDef
+--pedef =
+--    ( entityvalue >>= return . PEDefEntityValue) `onFail`
+--    ( externalid >>= return . PEDefExternalID)
+
+externalid :: HParser ExternalID
+externalid =
+    ( do word "SYSTEM"
+         s <- systemliteral
+         return (SYSTEM s)) `onFail`
+    ( do word "PUBLIC"
+         p <- pubidliteral
+         s <- (systemliteral `onFail` return (SystemLiteral ""))
+         return (PUBLIC p s))
+
+--ndatadecl :: HParser NDataDecl
+--ndatadecl = do
+--    word "NDATA"
+--    n <- name
+--    return (NDATA n)
+
+textdecl :: HParser TextDecl
+textdecl = do
+    tok TokPIOpen
+    (word "xml" `onFail` word "XML")
+    v <- maybe versioninfo
+    e <- encodingdecl
+    tok TokPIClose `onFail` failP "expected ?> terminating text decl"
+    return (TextDecl v e)
+
+--extparsedent :: HParser ExtParsedEnt
+--extparsedent = do
+--    t <- maybe textdecl
+--    (_,c) <- (content "")
+--    return (ExtParsedEnt t c)
+--
+--extpe :: HParser ExtPE
+--extpe = do
+--    t <- maybe textdecl
+--    e <- extsubsetdecl
+--    return (ExtPE t e)
+
+encodingdecl :: HParser EncodingDecl
+encodingdecl = do
+    (word "encoding" `onFail` word "ENCODING")
+    tok TokEqual `onFail` failBadP "expected = in 'encoding' decl"
+    f <- bracket (tok TokQuote) (tok TokQuote) freetext
+    return (EncodingDecl f)
+
+--notationdecl :: HParser NotationDecl
+--notationdecl = do
+--    tok TokSpecialOpen
+--    word "NOTATION"
+--    n <- name
+--    e <- either externalid publicid
+--    tok TokAnyClose `onFail` failP "expected > terminating NOTATION decl"
+--    return (NOTATION n e)
+
+publicid :: HParser PublicID
+publicid = do
+    word "PUBLICID"
+    p <- pubidliteral
+    return (PUBLICID p)
+
+entityvalue :: HParser EntityValue
+entityvalue = do
+    evs <- bracket (tok TokQuote) (tok TokQuote) (many ev)
+    return (EntityValue evs)
+
+ev :: HParser EV
+ev =
+    ( freetext >>= return . EVString) `onFail`
+--  PEREF(EVPERef,ev) `onFail`
+    ( reference >>= return . EVRef)
+
+attvalue :: HParser AttValue
+attvalue =
+  ( do avs <- bracket (tok TokQuote) (tok TokQuote)
+                      (many (either freetext reference))
+       return (AttValue avs) ) `onFail`
+  ( do v <- nmtoken
+       s <- (tok TokPercent >> return "%") `onFail` return ""
+       return (AttValue [Left (v++s)]) ) `onFail`
+  ( do s <- oneOf [ tok TokPlus >> return "+"
+                  , tok TokHash >> return "#"
+                  ]
+       v <- nmtoken
+       return (AttValue [Left (s++v)]) ) `onFail`
+  failP "Badly formatted attribute value"
+
+systemliteral :: HParser SystemLiteral
+systemliteral = do
+    s <- bracket (tok TokQuote) (tok TokQuote) freetext
+    return (SystemLiteral s)		-- note: need to fold &...; escapes
+
+pubidliteral :: HParser PubidLiteral
+pubidliteral = do
+    s <- bracket (tok TokQuote) (tok TokQuote) freetext
+    return (PubidLiteral s)		-- note: need to fold &...; escapes
+
+chardata :: HParser CharData
+chardata = freetext -- >>= return . CharData
+
+

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Html/ParseLazy.html b/docs/HaXml/src/Text/XML/HaXml/Html/ParseLazy.html
--- a/docs/HaXml/src/Text/XML/HaXml/Html/ParseLazy.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Html/ParseLazy.html
@@ -1,732 +1,738 @@
 
 
-
-- | This is a parser for HTML documents.  Unlike for XML documents, it
---   must include a certain amount of error-correction to account for
---   HTML features like self-terminating tags, unterminated tags, and
---   incorrect nesting.  The input is tokenised by the
---   XML lexer (a separate lexer is not required for HTML).
-
--- It uses a slightly extended version of the Hutton/Meijer parser
--- combinators.
-
-module Text.XML.HaXml.Html.ParseLazy
-  ( htmlParse
-  ) where
-
-import Prelude hiding (either,maybe,sequence)
-import qualified Prelude (either)
-import Maybe hiding (maybe)
-import Char (toLower, isSpace, isDigit, isHexDigit)
-import Numeric (readDec,readHex)
-import Monad
-
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.Lex
-import Text.XML.HaXml.Posn
-import Text.ParserCombinators.Poly.NoLeak.Lazy
-
---  #define DEBUG
- 
-#if defined(DEBUG)
-#  if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
-      ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
-import Debug.Trace(trace)
-#  elif defined(__GLASGOW_HASKELL__)
-import IOExts(trace)
-#  elif defined(__NHC__) || defined(__HBC__)
-import NonStdTrace
-#  endif
-debug :: Monad m => String -> m ()
-debug s = trace s (return ())
-#else
-debug :: Monad m => String -> m ()
-debug s = return ()
-#endif
-
-
--- | The first argument is the name of the file, the second is the string
---   contents of the file.  The result is the generic representation of
---   an XML document.  Any errors cause program failure with message to stderr.
-htmlParse :: String -> String -> Document Posn
-htmlParse name = {-simplify .-} fst . runParser document . xmlLex name
-
-{-
--- | The first argument is the name of the file, the second is the string
---   contents of the file.  The result is the generic representation of
---   an XML document.  Any parsing errors are returned in the @Either@ type.
-htmlParse' :: String -> String -> Either String (Document Posn)
-htmlParse' name = Prelude.either Left (Right . simplify) . fst
-                  . runParser document . xmlLex name
--}
-
----- Document simplification ----
-
-simplify :: Document i -> Document i
-simplify (Document p st (Elem n avs cs) ms) =
-    Document p st (Elem n avs (deepfilter simp cs)) ms
-  where
-    simp (CElem (Elem "null" [] []) _) = False
-    simp (CElem (Elem  n     _  []) _) | n `elem` ["font","p","i","b","em"
-                                                  ,"tt","big","small"] = False
- -- simp (CString False s _) | all isSpace s = False
-    simp _ = True
-    deepfilter p =
-        filter p . map (\c-> case c of
-                          CElem (Elem n avs cs) i
-                                  -> CElem (Elem n avs (deepfilter p cs)) i
-                          _       -> c)
-
--- opening any of these, they close again immediately
-selfclosingtags = ["img","hr","br","meta","col","link","base"
-                  ,"param","area","frame","input"]
-
---closing this, implicitly closes any of those which are contained in it
-closeInnerTags =
-  [ ("ul",      ["li"])
-  , ("ol",      ["li"])
-  , ("dl",      ["dt","dd"])
-  , ("tr",      ["th","td"])
-  , ("div",     ["p"])
-  , ("thead",   ["th","tr","td"])
-  , ("tfoot",   ["th","tr","td"])
-  , ("tbody",   ["th","tr","td"])
-  , ("table",   ["th","tr","td","thead","tfoot","tbody"])
-  , ("caption", ["p"])
-  , ("th",      ["p"])
-  , ("td",      ["p"])
-  , ("li",      ["p"])
-  , ("dt",      ["p"])
-  , ("dd",      ["p"])
-  , ("object",  ["p"])
-  , ("map",     ["p"])
-  , ("body",    ["p"])
-  ]
-
---opening this, implicitly closes that
-closes :: Name -> Name -> Bool
-"a"  `closes` "a"   =  True
-"li" `closes` "li"  =  True
-"th" `closes`  t    | t `elem` ["th","td"]      =  True
-"td" `closes`  t    | t `elem` ["th","td"]      =  True
-"tr" `closes`  t    | t `elem` ["th","td","tr"] =  True
-"dt" `closes`  t    | t `elem` ["dt","dd"]      =  True
-"dd" `closes`  t    | t `elem` ["dt","dd"]      =  True
-"form"  `closes` "form"      = True
-"label" `closes` "label"     = True
-_       `closes` "option"    = True
-"thead" `closes` t  | t `elem` ["colgroup"]          = True
-"tfoot" `closes` t  | t `elem` ["thead","colgroup"]  = True
-"tbody" `closes` t  | t `elem` ["tbody","tfoot","thead","colgroup"] = True
-"colgroup" `closes` "colgroup"  = True
-t `closes` "p"
-    | t `elem` ["p","h1","h2","h3","h4","h5","h6"
-               ,"hr","div","ul","dl","ol","table"]  =  True
-_ `closes` _ = False
-
-
-
----- Misc ----
-
-fst3 (a,_,_) = a
-snd3 (_,a,_) = a
-thd3 (_,_,a) = a
-
-
-
----- Auxiliary Parsing Functions ----
-
-type HParser a = Parser (Posn,TokenT) a
-
-tok :: TokenT -> HParser TokenT
-tok t = do (p,t') <- next
-           case t' of TokError s    -> report failBad (show t) p t'
-                      _ | t'==t     -> return t
-                        | otherwise -> report fail (show t) p t'
-
-name :: HParser Name
---name = do {(p,TokName s) <- next; return s}
-name = do (p,tok) <- next
-          case tok of 
-            TokName s  -> return s 
-            TokError s -> report failBad "a name" p tok
-            _          -> report fail "a name" p tok
-
-string, freetext :: HParser String
-string   = do (p,t) <- next
-              case t of TokName s -> return s
-                        _         -> report fail "text" p t
-freetext = do (p,t) <- next
-              case t of TokFreeText s -> return s
-                        _             -> report fail "text" p t
-
-maybe :: HParser a -> HParser (Maybe a)
-maybe p =
-    ( p >>= return . Just) `onFail`
-    ( return Nothing)
-
-either :: HParser a -> HParser b -> HParser (Either a b)
-either p q =
-    ( p >>= return . Left) `onFail`
-    ( q >>= return . Right)
-
-word :: String -> HParser ()
-word s = do { x <- next
-            ; case x of
-                (p,TokName n)     | s==n -> return ()
-                (p,TokFreeText n) | s==n -> return ()
-                (p,t@(TokError _)) -> report failBad (show s) p t
-                (p,t) -> report fail (show s) p t
-            }
-
-posn :: HParser Posn
-posn = do { x@(p,_) <- next
-          ; reparse [x]
-          ; return p
-          } `onFail` return noPos
-
-nmtoken :: HParser NmToken
-nmtoken = (string `onFail` freetext)
-
-failP, failBadP :: String -> HParser a
-failP msg    = do { p <- posn; fail (msg++"\n    at "++show p) }
-failBadP msg = do { p <- posn; failBad (msg++"\n    at "++show p) }
-
-report :: (String->HParser a) -> String -> Posn -> TokenT -> HParser a
-report fail exp p t = fail ("Expected "++show exp++" but found "++show t
-                           ++"\n  at "++show p)
-
-adjustErrP :: HParser a -> (String->String) -> HParser a
-p `adjustErrP` f = p `onFail` do pn <- posn
-                                 (p `adjustErr` f) `adjustErr` (++show pn)
-
----- XML Parsing Functions ----
-
-document :: HParser (Document Posn)
-document = do
-    return Document
-        `apply` (prolog `adjustErr` ("unrecognisable XML prolog\n"++))
-        `apply` (return emptyST)
-        `apply` (do es <- many1 (element "HTML document")
-                    return (case map snd es of
-                                [e] -> e
-                                es  -> Elem "html" [] (map mkCElem es)))
-        `apply` (many misc)
-  where mkCElem e = CElem e noPos
-
-comment :: HParser Comment
-comment = do
-    bracket (tok TokCommentOpen) (tok TokCommentClose) freetext
-
-processinginstruction :: HParser ProcessingInstruction
-processinginstruction = do
-    tok TokPIOpen
-    commit $ do
-      n <- string  `onFail` failP "processing instruction has no target"
-      f <- freetext
-      (tok TokPIClose `onFail` tok TokAnyClose) `onFail` failP "missing ?> or >"
-      return (n, f)
-
-cdsect :: HParser CDSect
-cdsect = do
-    tok TokSectionOpen
-    bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata
-
-prolog :: HParser Prolog
-prolog = do
-    x <- maybe xmldecl
-    m1 <- many misc
-    dtd <- maybe doctypedecl
-    m2 <- many misc
-    return (Prolog x m1 dtd m2)
-
-xmldecl :: HParser XMLDecl
-xmldecl = do
-    tok TokPIOpen
-    (word "xml" `onFail` word "XML")
-    p <- posn
-    s <- freetext
-    tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"
-    (return . fst . runParser aux . xmlReLex p) s
-  where
-    aux = do
-      v <- versioninfo  `onFail` failP "missing XML version info"
-      e <- maybe encodingdecl
-      s <- maybe sddecl
-      return (XMLDecl v e s)
-
-versioninfo :: HParser VersionInfo
-versioninfo = do
-    (word "version" `onFail` word "VERSION")
-    tok TokEqual
-    bracket (tok TokQuote) (tok TokQuote) freetext
-
-misc :: HParser Misc
-misc = 
-    oneOf' [ ("<!--comment-->", comment >>= return . Comment)
-           , ("<?PI?>",         processinginstruction >>= return . PI)
-           ]
-
-
--- Question: for HTML, should we disallow in-line DTDs, allowing only externals?
--- Answer: I think so.
-
-doctypedecl :: HParser DocTypeDecl
-doctypedecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial DOCTYPEx)
-    commit $ do
-      n <- name
-      eid <- maybe externalid
---    es <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)) (many markupdecl)
-      tok TokAnyClose  `onFail` failP "missing > in DOCTYPE decl"
---    return (DTD n eid (case es of { Nothing -> []; Just e -> e }))
-      return (DTD n eid [])
-
---markupdecl :: HParser MarkupDecl
---markupdecl =
---    ( elementdecl >>= return . Element) `onFail`
---    ( attlistdecl >>= return . AttList) `onFail`
---    ( entitydecl >>= return . Entity) `onFail`
---    ( notationdecl >>= return . Notation) `onFail`
---    ( misc >>= return . MarkupMisc) `onFail`
---    PEREF(MarkupPE,markupdecl)
---
---extsubset :: HParser ExtSubset
---extsubset = do
---    td <- maybe textdecl
---    ds <- many extsubsetdecl
---    return (ExtSubset td ds)
---
---extsubsetdecl :: HParser ExtSubsetDecl
---extsubsetdecl =
---    ( markupdecl >>= return . ExtMarkupDecl) `onFail`
---    ( conditionalsect >>= return . ExtConditionalSect) `onFail`
---    PEREF(ExtPEReference,extsubsetdecl)
-
-sddecl :: HParser SDDecl
-sddecl = do
-    (word "standalone" `onFail` word "STANDALONE")
-    commit $ do
-      tok TokEqual `onFail` failP "missing = in 'standalone' decl"
-      bracket (tok TokQuote) (tok TokQuote)
-              ( (word "yes" >> return True) `onFail`
-                (word "no" >> return False) `onFail`
-                failP "'standalone' decl requires 'yes' or 'no' value" )
-
-
-
-
-----
--- VERY IMPORTANT NOTE: The stack returned here contains those tags which
--- have been closed implicitly and need to be reopened again at the
--- earliest opportunity.
-type Stack = [(Name,[Attribute])]
-
-element :: Name -> HParser (Stack,Element Posn)
-element ctx =
-  do
-    tok TokAnyOpen
-    (ElemTag e avs) <- elemtag
-    ( if e `closes` ctx then
-         -- insert the missing close-tag, fail forward, and reparse.
-         ( do debug ("/")
-              unparse ([TokEndOpen, TokName ctx, TokAnyClose,
-                        TokAnyOpen, TokName e] ++ reformatAttrs avs)
-              return ([], Elem "null" [] []))
-      else if e `elem` selfclosingtags then
-         -- complete the parse straightaway.
-         ( do tok TokEndClose	-- self-closing <tag /> 
-              debug (e++"[+]")
-              return ([], Elem e avs [])) `onFail`
-     --  ( do tok TokAnyClose	-- sequence <tag></tag>	(**not HTML?**)
-     --       debug (e++"[+")
-     --       n <- bracket (tok TokEndOpen) (tok TokAnyClose) name
-     --       debug "]"
-     --       if e == (map toLower n :: Name) 
-     --         then return ([], Elem e avs [])      
-     --         else return (error "no nesting in empty tag")) `onFail`
-         ( do tok TokAnyClose	-- <tag> with no close (e.g. <IMG>)
-              debug (e++"[+]")
-              return ([], Elem e avs []))
-      else
-        (( do tok TokEndClose
-              debug (e++"[]")
-              return ([], Elem e avs [])) `onFail`
-         ( do tok TokAnyClose `onFail` failP "missing > or /> in element tag"
-              debug (e++"[")
-              return (\ interior-> let (stack,contained) = interior
-                                   in  (stack, Elem e avs contained))
-                  `apply`
-                  (do zz <- manyFinally (content e)
-                                        (tok TokEndOpen)
-                      n <- name
-                      commit (tok TokAnyClose)
-                      debug "]"
-                      let (ss,cs) = unzip zz
-                      let s       = if null ss then [] else last ss
-                      ( if e == (map toLower n :: Name) then
-                          do unparse (reformatTags (closeInner e s))
-                             debug "^"
-                             return ([], cs)
-                        else
-                          do unparse [TokEndOpen, TokName n, TokAnyClose]
-                             debug "-"
-                             return (((e,avs):s), cs)))
-         ) `onFail` failP ("failed to repair non-matching tags in context: "++ctx)))
-
-closeInner :: Name -> [(Name,[Attribute])] -> [(Name,[Attribute])]
-closeInner c ts =
-    case lookup c closeInnerTags of
-      (Just these) -> filter ((`notElem` these).fst) ts
-      Nothing      -> ts
-
-unparse ts = do p <- posn
-                reparse (zip (repeat p) ts)
-
-reformatAttrs avs = concatMap f0 avs
-    where f0 (a, v@(AttValue _)) = [TokName a, TokEqual, TokQuote,
-                                       TokFreeText (show v), TokQuote]
-reformatTags ts = concatMap f0 ts
-    where f0 (t,avs) = [TokAnyOpen, TokName t]++reformatAttrs avs++[TokAnyClose]
-
-content :: Name -> HParser (Stack,Content Posn)
-content ctx = do { p <- posn ; content' p ctx }
-  where content' p ctx = oneOf'
-          [ ( "element", element ctx >>= \(s,e)-> return (s, CElem e p))
-          , ( "chardata", chardata >>= \s-> return ([], CString False s p))
-          , ( "reference", reference >>= \r-> return ([], CRef r p))
-          , ( "cdsect", cdsect >>= \c-> return ([], CString True c p))
-          , ( "misc", misc >>= \m->  return ([], CMisc m p))
-          ] `adjustErrP` ("when looking for a content item,\n"++)
-
-----
-elemtag :: HParser ElemTag
-elemtag = do
-    n <- name `adjustErrBad` ("malformed element tag\n"++)
-    as <- many attribute
-    return (ElemTag (map toLower n) as)
-
-attribute :: HParser Attribute
-attribute = do
-    n <- name
-    v <- (do tok TokEqual
-             attvalue) `onFail`
-         (return (AttValue [Left "TRUE"]))
-    return (map toLower n,v)
-
---elementdecl :: HParser ElementDecl
---elementdecl = do
---    tok TokSpecialOpen
---    tok (TokSpecial ELEMENTx)
---    n <- name `onFail` failP "missing identifier in ELEMENT decl"
---    c <- contentspec `onFail` failP "missing content spec in ELEMENT decl"
---    tok TokAnyClose `onFail` failP "expected > terminating ELEMENT decl"
---    return (ElementDecl n c)
---
---contentspec :: HParser ContentSpec
---contentspec =
---    ( word "EMPTY" >> return EMPTY) `onFail`
---    ( word "ANY" >> return ANY) `onFail`
---    ( mixed >>= return . Mixed) `onFail`
---    ( cp >>= return . ContentSpec) `onFail`
---    PEREF(ContentPE,contentspec)
---
---choice :: HParser [CP]
---choice = do
---    bracket (tok TokBraOpen) (tok TokBraClose)
---            (cp `sepby1` (tok TokPipe))
---
---sequence :: HParser [CP]
---sequence = do
---    bracket (tok TokBraOpen) (tok TokBraClose)
---            (cp `sepby1` (tok TokComma))
---
---cp :: HParser CP
---cp =
---    ( do n <- name
---         m <- modifier
---         return (TagName n m)) `onFail`
---    ( do ss <- sequence
---         m <- modifier
---         return (Seq ss m)) `onFail`
---    ( do cs <- choice
---         m <- modifier
---         return (Choice cs m)) `onFail`
---    PEREF(CPPE,cp)
---
---modifier :: HParser Modifier
---modifier =
---    ( tok TokStar >> return Star) `onFail`
---    ( tok TokQuery >> return Query) `onFail`
---    ( tok TokPlus >> return Plus) `onFail`
---    ( return None)
---
---mixed :: HParser Mixed
---mixed = do
---    tok TokBraOpen
---    tok TokHash
---    word "PCDATA"
---    cont
---  where
---    cont = ( tok TokBraClose >> return PCDATA) `onFail`
---           ( do cs <- many ( do tok TokPipe
---                                n <- name
---                                return n)
---                tok TokBraClose
---                tok TokStar
---                return (PCDATAplus cs))
---
---attlistdecl :: HParser AttListDecl
---attlistdecl = do
---    tok TokSpecialOpen
---    tok (TokSpecial ATTLISTx)
---    n <- name `onFail` failP "missing identifier in ATTLIST"
---    ds <- many attdef
---    tok TokAnyClose `onFail` failP "missing > terminating ATTLIST"
---    return (AttListDecl n ds)
---
---attdef :: HParser AttDef
---attdef = do
---    n <- name
---    t <- atttype `onFail` failP "missing attribute type in attlist defn"
---    d <- defaultdecl
---    return (AttDef n t d)
---
---atttype :: HParser AttType
---atttype =
---    ( word "CDATA" >> return StringType) `onFail`
---    ( tokenizedtype >>= return . TokenizedType) `onFail`
---    ( enumeratedtype >>= return . EnumeratedType)
---
---tokenizedtype :: HParser TokenizedType
---tokenizedtype =
---    ( word "ID" >> return ID) `onFail`
---    ( word "IDREF" >> return IDREF) `onFail`
---    ( word "IDREFS" >> return IDREFS) `onFail`
---    ( word "ENTITY" >> return ENTITY) `onFail`
---    ( word "ENTITIES" >> return ENTITIES) `onFail`
---    ( word "NMTOKEN" >> return NMTOKEN) `onFail`
---    ( word "NMTOKENS" >> return NMTOKENS)
---
---enumeratedtype :: HParser EnumeratedType
---enumeratedtype =
---    ( notationtype >>= return . NotationType) `onFail`
---    ( enumeration >>= return . Enumeration)
---
---notationtype :: HParser NotationType
---notationtype = do
---    word "NOTATION"
---    bracket (tok TokBraOpen) (tok TokBraClose)
---            (name `sepby1` (tok TokPipe))
---
---enumeration :: HParser Enumeration
---enumeration =
---    bracket (tok TokBraOpen) (tok TokBraClose)
---            (nmtoken `sepby1` (tok TokPipe))
---
---defaultdecl :: HParser DefaultDecl
---defaultdecl =
---    ( tok TokHash >> word "REQUIRED" >> return REQUIRED) `onFail`
---    ( tok TokHash >> word "IMPLIED" >> return IMPLIED) `onFail`
---    ( do f <- maybe (tok TokHash >> word "FIXED" >> return FIXED)
---         a <- attvalue
---         return (DefaultTo a f))
---
---conditionalsect :: HParser ConditionalSect
---conditionalsect =
---    ( do tok TokSectionOpen
---         tok (TokSection INCLUDEx)
---         tok TokSqOpen `onFail` failP "missing [ after INCLUDE"
---         i <- extsubsetdecl `onFail` failP "missing ExtSubsetDecl in INCLUDE"
---         tok TokSectionClose `onFail` failP "missing ] after INCLUDE"
---         return (IncludeSect i)) `onFail`
---    ( do tok TokSectionOpen
---         tok (TokSection IGNOREx)
---         tok TokSqOpen `onFail` failP "missing [ after IGNORE"
---         i <- many ignoresectcontents
---         tok TokSectionClose `onFail` failP "missing ] after IGNORE"
---         return (IgnoreSect i))
---
---ignoresectcontents :: HParser IgnoreSectContents
---ignoresectcontents = do
---    i <- ignore
---    is <- many (do tok TokSectionOpen
---                   ic <- ignoresectcontents
---                   tok TokSectionClose
---                   ig <- ignore
---                   return (ic,ig))
---    return (IgnoreSectContents i is)
---
---ignore :: HParser Ignore
---ignore = freetext >>= return . Ignore
-
-reference :: HParser Reference
-reference = do
-    bracket (tok TokAmp) (tok TokSemi) (freetext >>= val)
-  where
-    val ('#':'x':i) | all isHexDigit i
-                    = return . RefChar . fst . head . readHex $ i
-    val ('#':i)     | all isDigit i
-                    = return . RefChar . fst . head . readDec $ i
-    val name        = return . RefEntity $ name
-
-{-
-reference :: HParser Reference
-reference =
-    ( charref >>= return . RefChar) `onFail`
-    ( entityref >>= return . RefEntity)
-
-entityref :: HParser EntityRef
-entityref = do
-    n <- bracket (tok TokAmp) (tok TokSemi) name
-    return n
-
-charref :: HParser CharRef
-charref = do
-    bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal)
-  where
-    readCharVal ('#':'x':i) = return . fst . head . readHex $ i
-    readCharVal ('#':i)     = return . fst . head . readDec $ i
-    readCharVal _           = mzero
--}
-
---pereference :: HParser PEReference
---pereference = do
---    bracket (tok TokPercent) (tok TokSemi) nmtoken
---
---entitydecl :: HParser EntityDecl
---entitydecl =
---    ( gedecl >>= return . EntityGEDecl) `onFail`
---    ( pedecl >>= return . EntityPEDecl)
---
---gedecl :: HParser GEDecl
---gedecl = do
---    tok TokSpecialOpen
---    tok (TokSpecial ENTITYx)
---    n <- name
---    e <- entitydef `onFail` failP "missing entity defn in G ENTITY decl"
---    tok TokAnyClose `onFail` failP "expected > terminating G ENTITY decl"
---    return (GEDecl n e)
---
---pedecl :: HParser PEDecl
---pedecl = do
---    tok TokSpecialOpen
---    tok (TokSpecial ENTITYx)
---    tok TokPercent
---    n <- name
---    e <- pedef `onFail` failP "missing entity defn in P ENTITY decl"
---    tok TokAnyClose `onFail` failP "expected > terminating P ENTITY decl"
---    return (PEDecl n e)
---
---entitydef :: HParser EntityDef
---entitydef =
---    ( entityvalue >>= return . DefEntityValue) `onFail`
---    ( do eid <- externalid
---         ndd <- maybe ndatadecl
---         return (DefExternalID eid ndd))
---
---pedef :: HParser PEDef
---pedef =
---    ( entityvalue >>= return . PEDefEntityValue) `onFail`
---    ( externalid >>= return . PEDefExternalID)
-
-externalid :: HParser ExternalID
-externalid =
-    ( do word "SYSTEM"
-         s <- systemliteral
-         return (SYSTEM s)) `onFail`
-    ( do word "PUBLIC"
-         p <- pubidliteral
-         s <- (systemliteral `onFail` return (SystemLiteral ""))
-         return (PUBLIC p s))
-
---ndatadecl :: HParser NDataDecl
---ndatadecl = do
---    word "NDATA"
---    n <- name
---    return (NDATA n)
-
-textdecl :: HParser TextDecl
-textdecl = do
-    tok TokPIOpen
-    (word "xml" `onFail` word "XML")
-    v <- maybe versioninfo
-    e <- encodingdecl
-    tok TokPIClose `onFail` failP "expected ?> terminating text decl"
-    return (TextDecl v e)
-
---extparsedent :: HParser ExtParsedEnt
---extparsedent = do
---    t <- maybe textdecl
---    (_,c) <- (content "")
---    return (ExtParsedEnt t c)
---
---extpe :: HParser ExtPE
---extpe = do
---    t <- maybe textdecl
---    e <- extsubsetdecl
---    return (ExtPE t e)
-
-encodingdecl :: HParser EncodingDecl
-encodingdecl = do
-    (word "encoding" `onFail` word "ENCODING")
-    tok TokEqual `onFail` failBadP "expected = in 'encoding' decl"
-    f <- bracket (tok TokQuote) (tok TokQuote) freetext
-    return (EncodingDecl f)
-
---notationdecl :: HParser NotationDecl
---notationdecl = do
---    tok TokSpecialOpen
---    word "NOTATION"
---    n <- name
---    e <- either externalid publicid
---    tok TokAnyClose `onFail` failP "expected > terminating NOTATION decl"
---    return (NOTATION n e)
-
-publicid :: HParser PublicID
-publicid = do
-    word "PUBLICID"
-    p <- pubidliteral
-    return (PUBLICID p)
-
-entityvalue :: HParser EntityValue
-entityvalue = do
-    evs <- bracket (tok TokQuote) (tok TokQuote) (many ev)
-    return (EntityValue evs)
-
-ev :: HParser EV
-ev =
-    ( freetext >>= return . EVString) `onFail`
---  PEREF(EVPERef,ev) `onFail`
-    ( reference >>= return . EVRef)
-
-attvalue :: HParser AttValue
-attvalue =
-  ( do avs <- bracket (tok TokQuote) (tok TokQuote)
-                      (many (either freetext reference))
-       return (AttValue avs) ) `onFail`
-  ( do v <- nmtoken
-       s <- (tok TokPercent >> return "%") `onFail` return ""
-       return (AttValue [Left (v++s)]) ) `onFail`
-  ( do s <- oneOf [ tok TokPlus >> return "+"
-                  , tok TokHash >> return "#"
-                  ]
-       v <- nmtoken
-       return (AttValue [Left (s++v)]) ) `onFail`
-  failP "Badly formatted attribute value"
-
-systemliteral :: HParser SystemLiteral
-systemliteral = do
-    s <- bracket (tok TokQuote) (tok TokQuote) freetext
-    return (SystemLiteral s)		-- note: need to fold &...; escapes
-
-pubidliteral :: HParser PubidLiteral
-pubidliteral = do
-    s <- bracket (tok TokQuote) (tok TokQuote) freetext
-    return (PubidLiteral s)		-- note: need to fold &...; escapes
-
-chardata :: HParser CharData
-chardata = freetext -- >>= return . CharData
-
-

+
+
+src/Text/XML/HaXml/Html/ParseLazy.hs
+
+
+
-- | This is a parser for HTML documents.  Unlike for XML documents, it
+--   must include a certain amount of error-correction to account for
+--   HTML features like self-terminating tags, unterminated tags, and
+--   incorrect nesting.  The input is tokenised by the
+--   XML lexer (a separate lexer is not required for HTML).
+
+-- It uses a slightly extended version of the Hutton/Meijer parser
+-- combinators.
+
+module Text.XML.HaXml.Html.ParseLazy
+  ( htmlParse
+  ) where
+
+import Prelude hiding (either,maybe,sequence)
+import qualified Prelude (either)
+import Maybe hiding (maybe)
+import Char (toLower, isSpace, isDigit, isHexDigit)
+import Numeric (readDec,readHex)
+import Monad
+
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.Lex
+import Text.XML.HaXml.Posn
+import Text.ParserCombinators.Poly.NoLeak.Lazy
+
+--  #define DEBUG
+ 
+#if defined(DEBUG)
+#  if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
+      ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
+import Debug.Trace(trace)
+#  elif defined(__GLASGOW_HASKELL__)
+import IOExts(trace)
+#  elif defined(__NHC__) || defined(__HBC__)
+import NonStdTrace
+#  endif
+debug :: Monad m => String -> m ()
+debug s = trace s (return ())
+#else
+debug :: Monad m => String -> m ()
+debug s = return ()
+#endif
+
+
+-- | The first argument is the name of the file, the second is the string
+--   contents of the file.  The result is the generic representation of
+--   an XML document.  Any errors cause program failure with message to stderr.
+htmlParse :: String -> String -> Document Posn
+htmlParse name = {-simplify .-} fst . runParser document . xmlLex name
+
+{-
+-- | The first argument is the name of the file, the second is the string
+--   contents of the file.  The result is the generic representation of
+--   an XML document.  Any parsing errors are returned in the @Either@ type.
+htmlParse' :: String -> String -> Either String (Document Posn)
+htmlParse' name = Prelude.either Left (Right . simplify) . fst
+                  . runParser document . xmlLex name
+-}
+
+---- Document simplification ----
+
+simplify :: Document i -> Document i
+simplify (Document p st (Elem n avs cs) ms) =
+    Document p st (Elem n avs (deepfilter simp cs)) ms
+  where
+    simp (CElem (Elem "null" [] []) _) = False
+    simp (CElem (Elem  n     _  []) _) | n `elem` ["font","p","i","b","em"
+                                                  ,"tt","big","small"] = False
+ -- simp (CString False s _) | all isSpace s = False
+    simp _ = True
+    deepfilter p =
+        filter p . map (\c-> case c of
+                          CElem (Elem n avs cs) i
+                                  -> CElem (Elem n avs (deepfilter p cs)) i
+                          _       -> c)
+
+-- opening any of these, they close again immediately
+selfclosingtags = ["img","hr","br","meta","col","link","base"
+                  ,"param","area","frame","input"]
+
+--closing this, implicitly closes any of those which are contained in it
+closeInnerTags =
+  [ ("ul",      ["li"])
+  , ("ol",      ["li"])
+  , ("dl",      ["dt","dd"])
+  , ("tr",      ["th","td"])
+  , ("div",     ["p"])
+  , ("thead",   ["th","tr","td"])
+  , ("tfoot",   ["th","tr","td"])
+  , ("tbody",   ["th","tr","td"])
+  , ("table",   ["th","tr","td","thead","tfoot","tbody"])
+  , ("caption", ["p"])
+  , ("th",      ["p"])
+  , ("td",      ["p"])
+  , ("li",      ["p"])
+  , ("dt",      ["p"])
+  , ("dd",      ["p"])
+  , ("object",  ["p"])
+  , ("map",     ["p"])
+  , ("body",    ["p"])
+  ]
+
+--opening this, implicitly closes that
+closes :: Name -> Name -> Bool
+"a"  `closes` "a"   =  True
+"li" `closes` "li"  =  True
+"th" `closes`  t    | t `elem` ["th","td"]      =  True
+"td" `closes`  t    | t `elem` ["th","td"]      =  True
+"tr" `closes`  t    | t `elem` ["th","td","tr"] =  True
+"dt" `closes`  t    | t `elem` ["dt","dd"]      =  True
+"dd" `closes`  t    | t `elem` ["dt","dd"]      =  True
+"form"  `closes` "form"      = True
+"label" `closes` "label"     = True
+_       `closes` "option"    = True
+"thead" `closes` t  | t `elem` ["colgroup"]          = True
+"tfoot" `closes` t  | t `elem` ["thead","colgroup"]  = True
+"tbody" `closes` t  | t `elem` ["tbody","tfoot","thead","colgroup"] = True
+"colgroup" `closes` "colgroup"  = True
+t `closes` "p"
+    | t `elem` ["p","h1","h2","h3","h4","h5","h6"
+               ,"hr","div","ul","dl","ol","table"]  =  True
+_ `closes` _ = False
+
+
+
+---- Misc ----
+
+fst3 (a,_,_) = a
+snd3 (_,a,_) = a
+thd3 (_,_,a) = a
+
+
+
+---- Auxiliary Parsing Functions ----
+
+type HParser a = Parser (Posn,TokenT) a
+
+tok :: TokenT -> HParser TokenT
+tok t = do (p,t') <- next
+           case t' of TokError s    -> report failBad (show t) p t'
+                      _ | t'==t     -> return t
+                        | otherwise -> report fail (show t) p t'
+
+name :: HParser Name
+--name = do {(p,TokName s) <- next; return s}
+name = do (p,tok) <- next
+          case tok of 
+            TokName s  -> return s 
+            TokError s -> report failBad "a name" p tok
+            _          -> report fail "a name" p tok
+
+string, freetext :: HParser String
+string   = do (p,t) <- next
+              case t of TokName s -> return s
+                        _         -> report fail "text" p t
+freetext = do (p,t) <- next
+              case t of TokFreeText s -> return s
+                        _             -> report fail "text" p t
+
+maybe :: HParser a -> HParser (Maybe a)
+maybe p =
+    ( p >>= return . Just) `onFail`
+    ( return Nothing)
+
+either :: HParser a -> HParser b -> HParser (Either a b)
+either p q =
+    ( p >>= return . Left) `onFail`
+    ( q >>= return . Right)
+
+word :: String -> HParser ()
+word s = do { x <- next
+            ; case x of
+                (p,TokName n)     | s==n -> return ()
+                (p,TokFreeText n) | s==n -> return ()
+                (p,t@(TokError _)) -> report failBad (show s) p t
+                (p,t) -> report fail (show s) p t
+            }
+
+posn :: HParser Posn
+posn = do { x@(p,_) <- next
+          ; reparse [x]
+          ; return p
+          } `onFail` return noPos
+
+nmtoken :: HParser NmToken
+nmtoken = (string `onFail` freetext)
+
+failP, failBadP :: String -> HParser a
+failP msg    = do { p <- posn; fail (msg++"\n    at "++show p) }
+failBadP msg = do { p <- posn; failBad (msg++"\n    at "++show p) }
+
+report :: (String->HParser a) -> String -> Posn -> TokenT -> HParser a
+report fail exp p t = fail ("Expected "++show exp++" but found "++show t
+                           ++"\n  at "++show p)
+
+adjustErrP :: HParser a -> (String->String) -> HParser a
+p `adjustErrP` f = p `onFail` do pn <- posn
+                                 (p `adjustErr` f) `adjustErr` (++show pn)
+
+---- XML Parsing Functions ----
+
+document :: HParser (Document Posn)
+document = do
+    return Document
+        `apply` (prolog `adjustErr` ("unrecognisable XML prolog\n"++))
+        `apply` (return emptyST)
+        `apply` (do es <- many1 (element "HTML document")
+                    return (case map snd es of
+                                [e] -> e
+                                es  -> Elem "html" [] (map mkCElem es)))
+        `apply` (many misc)
+  where mkCElem e = CElem e noPos
+
+comment :: HParser Comment
+comment = do
+    bracket (tok TokCommentOpen) (tok TokCommentClose) freetext
+
+processinginstruction :: HParser ProcessingInstruction
+processinginstruction = do
+    tok TokPIOpen
+    commit $ do
+      n <- string  `onFail` failP "processing instruction has no target"
+      f <- freetext
+      (tok TokPIClose `onFail` tok TokAnyClose) `onFail` failP "missing ?> or >"
+      return (n, f)
+
+cdsect :: HParser CDSect
+cdsect = do
+    tok TokSectionOpen
+    bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata
+
+prolog :: HParser Prolog
+prolog = do
+    x <- maybe xmldecl
+    m1 <- many misc
+    dtd <- maybe doctypedecl
+    m2 <- many misc
+    return (Prolog x m1 dtd m2)
+
+xmldecl :: HParser XMLDecl
+xmldecl = do
+    tok TokPIOpen
+    (word "xml" `onFail` word "XML")
+    p <- posn
+    s <- freetext
+    tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"
+    (return . fst . runParser aux . xmlReLex p) s
+  where
+    aux = do
+      v <- versioninfo  `onFail` failP "missing XML version info"
+      e <- maybe encodingdecl
+      s <- maybe sddecl
+      return (XMLDecl v e s)
+
+versioninfo :: HParser VersionInfo
+versioninfo = do
+    (word "version" `onFail` word "VERSION")
+    tok TokEqual
+    bracket (tok TokQuote) (tok TokQuote) freetext
+
+misc :: HParser Misc
+misc = 
+    oneOf' [ ("<!--comment-->", comment >>= return . Comment)
+           , ("<?PI?>",         processinginstruction >>= return . PI)
+           ]
+
+
+-- Question: for HTML, should we disallow in-line DTDs, allowing only externals?
+-- Answer: I think so.
+
+doctypedecl :: HParser DocTypeDecl
+doctypedecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial DOCTYPEx)
+    commit $ do
+      n <- name
+      eid <- maybe externalid
+--    es <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)) (many markupdecl)
+      tok TokAnyClose  `onFail` failP "missing > in DOCTYPE decl"
+--    return (DTD n eid (case es of { Nothing -> []; Just e -> e }))
+      return (DTD n eid [])
+
+--markupdecl :: HParser MarkupDecl
+--markupdecl =
+--    ( elementdecl >>= return . Element) `onFail`
+--    ( attlistdecl >>= return . AttList) `onFail`
+--    ( entitydecl >>= return . Entity) `onFail`
+--    ( notationdecl >>= return . Notation) `onFail`
+--    ( misc >>= return . MarkupMisc) `onFail`
+--    PEREF(MarkupPE,markupdecl)
+--
+--extsubset :: HParser ExtSubset
+--extsubset = do
+--    td <- maybe textdecl
+--    ds <- many extsubsetdecl
+--    return (ExtSubset td ds)
+--
+--extsubsetdecl :: HParser ExtSubsetDecl
+--extsubsetdecl =
+--    ( markupdecl >>= return . ExtMarkupDecl) `onFail`
+--    ( conditionalsect >>= return . ExtConditionalSect) `onFail`
+--    PEREF(ExtPEReference,extsubsetdecl)
+
+sddecl :: HParser SDDecl
+sddecl = do
+    (word "standalone" `onFail` word "STANDALONE")
+    commit $ do
+      tok TokEqual `onFail` failP "missing = in 'standalone' decl"
+      bracket (tok TokQuote) (tok TokQuote)
+              ( (word "yes" >> return True) `onFail`
+                (word "no" >> return False) `onFail`
+                failP "'standalone' decl requires 'yes' or 'no' value" )
+
+
+
+
+----
+-- VERY IMPORTANT NOTE: The stack returned here contains those tags which
+-- have been closed implicitly and need to be reopened again at the
+-- earliest opportunity.
+type Stack = [(Name,[Attribute])]
+
+element :: Name -> HParser (Stack,Element Posn)
+element ctx =
+  do
+    tok TokAnyOpen
+    (ElemTag e avs) <- elemtag
+    ( if e `closes` ctx then
+         -- insert the missing close-tag, fail forward, and reparse.
+         ( do debug ("/")
+              unparse ([TokEndOpen, TokName ctx, TokAnyClose,
+                        TokAnyOpen, TokName e] ++ reformatAttrs avs)
+              return ([], Elem "null" [] []))
+      else if e `elem` selfclosingtags then
+         -- complete the parse straightaway.
+         ( do tok TokEndClose	-- self-closing <tag /> 
+              debug (e++"[+]")
+              return ([], Elem e avs [])) `onFail`
+     --  ( do tok TokAnyClose	-- sequence <tag></tag>	(**not HTML?**)
+     --       debug (e++"[+")
+     --       n <- bracket (tok TokEndOpen) (tok TokAnyClose) name
+     --       debug "]"
+     --       if e == (map toLower n :: Name) 
+     --         then return ([], Elem e avs [])      
+     --         else return (error "no nesting in empty tag")) `onFail`
+         ( do tok TokAnyClose	-- <tag> with no close (e.g. <IMG>)
+              debug (e++"[+]")
+              return ([], Elem e avs []))
+      else
+        (( do tok TokEndClose
+              debug (e++"[]")
+              return ([], Elem e avs [])) `onFail`
+         ( do tok TokAnyClose `onFail` failP "missing > or /> in element tag"
+              debug (e++"[")
+              return (\ interior-> let (stack,contained) = interior
+                                   in  (stack, Elem e avs contained))
+                  `apply`
+                  (do zz <- manyFinally (content e)
+                                        (tok TokEndOpen)
+                      n <- name
+                      commit (tok TokAnyClose)
+                      debug "]"
+                      let (ss,cs) = unzip zz
+                      let s       = if null ss then [] else last ss
+                      ( if e == (map toLower n :: Name) then
+                          do unparse (reformatTags (closeInner e s))
+                             debug "^"
+                             return ([], cs)
+                        else
+                          do unparse [TokEndOpen, TokName n, TokAnyClose]
+                             debug "-"
+                             return (((e,avs):s), cs)))
+         ) `onFail` failP ("failed to repair non-matching tags in context: "++ctx)))
+
+closeInner :: Name -> [(Name,[Attribute])] -> [(Name,[Attribute])]
+closeInner c ts =
+    case lookup c closeInnerTags of
+      (Just these) -> filter ((`notElem` these).fst) ts
+      Nothing      -> ts
+
+unparse ts = do p <- posn
+                reparse (zip (repeat p) ts)
+
+reformatAttrs avs = concatMap f0 avs
+    where f0 (a, v@(AttValue _)) = [TokName a, TokEqual, TokQuote,
+                                       TokFreeText (show v), TokQuote]
+reformatTags ts = concatMap f0 ts
+    where f0 (t,avs) = [TokAnyOpen, TokName t]++reformatAttrs avs++[TokAnyClose]
+
+content :: Name -> HParser (Stack,Content Posn)
+content ctx = do { p <- posn ; content' p ctx }
+  where content' p ctx = oneOf'
+          [ ( "element", element ctx >>= \(s,e)-> return (s, CElem e p))
+          , ( "chardata", chardata >>= \s-> return ([], CString False s p))
+          , ( "reference", reference >>= \r-> return ([], CRef r p))
+          , ( "cdsect", cdsect >>= \c-> return ([], CString True c p))
+          , ( "misc", misc >>= \m->  return ([], CMisc m p))
+          ] `adjustErrP` ("when looking for a content item,\n"++)
+
+----
+elemtag :: HParser ElemTag
+elemtag = do
+    n <- name `adjustErrBad` ("malformed element tag\n"++)
+    as <- many attribute
+    return (ElemTag (map toLower n) as)
+
+attribute :: HParser Attribute
+attribute = do
+    n <- name
+    v <- (do tok TokEqual
+             attvalue) `onFail`
+         (return (AttValue [Left "TRUE"]))
+    return (map toLower n,v)
+
+--elementdecl :: HParser ElementDecl
+--elementdecl = do
+--    tok TokSpecialOpen
+--    tok (TokSpecial ELEMENTx)
+--    n <- name `onFail` failP "missing identifier in ELEMENT decl"
+--    c <- contentspec `onFail` failP "missing content spec in ELEMENT decl"
+--    tok TokAnyClose `onFail` failP "expected > terminating ELEMENT decl"
+--    return (ElementDecl n c)
+--
+--contentspec :: HParser ContentSpec
+--contentspec =
+--    ( word "EMPTY" >> return EMPTY) `onFail`
+--    ( word "ANY" >> return ANY) `onFail`
+--    ( mixed >>= return . Mixed) `onFail`
+--    ( cp >>= return . ContentSpec) `onFail`
+--    PEREF(ContentPE,contentspec)
+--
+--choice :: HParser [CP]
+--choice = do
+--    bracket (tok TokBraOpen) (tok TokBraClose)
+--            (cp `sepby1` (tok TokPipe))
+--
+--sequence :: HParser [CP]
+--sequence = do
+--    bracket (tok TokBraOpen) (tok TokBraClose)
+--            (cp `sepby1` (tok TokComma))
+--
+--cp :: HParser CP
+--cp =
+--    ( do n <- name
+--         m <- modifier
+--         return (TagName n m)) `onFail`
+--    ( do ss <- sequence
+--         m <- modifier
+--         return (Seq ss m)) `onFail`
+--    ( do cs <- choice
+--         m <- modifier
+--         return (Choice cs m)) `onFail`
+--    PEREF(CPPE,cp)
+--
+--modifier :: HParser Modifier
+--modifier =
+--    ( tok TokStar >> return Star) `onFail`
+--    ( tok TokQuery >> return Query) `onFail`
+--    ( tok TokPlus >> return Plus) `onFail`
+--    ( return None)
+--
+--mixed :: HParser Mixed
+--mixed = do
+--    tok TokBraOpen
+--    tok TokHash
+--    word "PCDATA"
+--    cont
+--  where
+--    cont = ( tok TokBraClose >> return PCDATA) `onFail`
+--           ( do cs <- many ( do tok TokPipe
+--                                n <- name
+--                                return n)
+--                tok TokBraClose
+--                tok TokStar
+--                return (PCDATAplus cs))
+--
+--attlistdecl :: HParser AttListDecl
+--attlistdecl = do
+--    tok TokSpecialOpen
+--    tok (TokSpecial ATTLISTx)
+--    n <- name `onFail` failP "missing identifier in ATTLIST"
+--    ds <- many attdef
+--    tok TokAnyClose `onFail` failP "missing > terminating ATTLIST"
+--    return (AttListDecl n ds)
+--
+--attdef :: HParser AttDef
+--attdef = do
+--    n <- name
+--    t <- atttype `onFail` failP "missing attribute type in attlist defn"
+--    d <- defaultdecl
+--    return (AttDef n t d)
+--
+--atttype :: HParser AttType
+--atttype =
+--    ( word "CDATA" >> return StringType) `onFail`
+--    ( tokenizedtype >>= return . TokenizedType) `onFail`
+--    ( enumeratedtype >>= return . EnumeratedType)
+--
+--tokenizedtype :: HParser TokenizedType
+--tokenizedtype =
+--    ( word "ID" >> return ID) `onFail`
+--    ( word "IDREF" >> return IDREF) `onFail`
+--    ( word "IDREFS" >> return IDREFS) `onFail`
+--    ( word "ENTITY" >> return ENTITY) `onFail`
+--    ( word "ENTITIES" >> return ENTITIES) `onFail`
+--    ( word "NMTOKEN" >> return NMTOKEN) `onFail`
+--    ( word "NMTOKENS" >> return NMTOKENS)
+--
+--enumeratedtype :: HParser EnumeratedType
+--enumeratedtype =
+--    ( notationtype >>= return . NotationType) `onFail`
+--    ( enumeration >>= return . Enumeration)
+--
+--notationtype :: HParser NotationType
+--notationtype = do
+--    word "NOTATION"
+--    bracket (tok TokBraOpen) (tok TokBraClose)
+--            (name `sepby1` (tok TokPipe))
+--
+--enumeration :: HParser Enumeration
+--enumeration =
+--    bracket (tok TokBraOpen) (tok TokBraClose)
+--            (nmtoken `sepby1` (tok TokPipe))
+--
+--defaultdecl :: HParser DefaultDecl
+--defaultdecl =
+--    ( tok TokHash >> word "REQUIRED" >> return REQUIRED) `onFail`
+--    ( tok TokHash >> word "IMPLIED" >> return IMPLIED) `onFail`
+--    ( do f <- maybe (tok TokHash >> word "FIXED" >> return FIXED)
+--         a <- attvalue
+--         return (DefaultTo a f))
+--
+--conditionalsect :: HParser ConditionalSect
+--conditionalsect =
+--    ( do tok TokSectionOpen
+--         tok (TokSection INCLUDEx)
+--         tok TokSqOpen `onFail` failP "missing [ after INCLUDE"
+--         i <- extsubsetdecl `onFail` failP "missing ExtSubsetDecl in INCLUDE"
+--         tok TokSectionClose `onFail` failP "missing ] after INCLUDE"
+--         return (IncludeSect i)) `onFail`
+--    ( do tok TokSectionOpen
+--         tok (TokSection IGNOREx)
+--         tok TokSqOpen `onFail` failP "missing [ after IGNORE"
+--         i <- many ignoresectcontents
+--         tok TokSectionClose `onFail` failP "missing ] after IGNORE"
+--         return (IgnoreSect i))
+--
+--ignoresectcontents :: HParser IgnoreSectContents
+--ignoresectcontents = do
+--    i <- ignore
+--    is <- many (do tok TokSectionOpen
+--                   ic <- ignoresectcontents
+--                   tok TokSectionClose
+--                   ig <- ignore
+--                   return (ic,ig))
+--    return (IgnoreSectContents i is)
+--
+--ignore :: HParser Ignore
+--ignore = freetext >>= return . Ignore
+
+reference :: HParser Reference
+reference = do
+    bracket (tok TokAmp) (tok TokSemi) (freetext >>= val)
+  where
+    val ('#':'x':i) | all isHexDigit i
+                    = return . RefChar . fst . head . readHex $ i
+    val ('#':i)     | all isDigit i
+                    = return . RefChar . fst . head . readDec $ i
+    val name        = return . RefEntity $ name
+
+{-
+reference :: HParser Reference
+reference =
+    ( charref >>= return . RefChar) `onFail`
+    ( entityref >>= return . RefEntity)
+
+entityref :: HParser EntityRef
+entityref = do
+    n <- bracket (tok TokAmp) (tok TokSemi) name
+    return n
+
+charref :: HParser CharRef
+charref = do
+    bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal)
+  where
+    readCharVal ('#':'x':i) = return . fst . head . readHex $ i
+    readCharVal ('#':i)     = return . fst . head . readDec $ i
+    readCharVal _           = mzero
+-}
+
+--pereference :: HParser PEReference
+--pereference = do
+--    bracket (tok TokPercent) (tok TokSemi) nmtoken
+--
+--entitydecl :: HParser EntityDecl
+--entitydecl =
+--    ( gedecl >>= return . EntityGEDecl) `onFail`
+--    ( pedecl >>= return . EntityPEDecl)
+--
+--gedecl :: HParser GEDecl
+--gedecl = do
+--    tok TokSpecialOpen
+--    tok (TokSpecial ENTITYx)
+--    n <- name
+--    e <- entitydef `onFail` failP "missing entity defn in G ENTITY decl"
+--    tok TokAnyClose `onFail` failP "expected > terminating G ENTITY decl"
+--    return (GEDecl n e)
+--
+--pedecl :: HParser PEDecl
+--pedecl = do
+--    tok TokSpecialOpen
+--    tok (TokSpecial ENTITYx)
+--    tok TokPercent
+--    n <- name
+--    e <- pedef `onFail` failP "missing entity defn in P ENTITY decl"
+--    tok TokAnyClose `onFail` failP "expected > terminating P ENTITY decl"
+--    return (PEDecl n e)
+--
+--entitydef :: HParser EntityDef
+--entitydef =
+--    ( entityvalue >>= return . DefEntityValue) `onFail`
+--    ( do eid <- externalid
+--         ndd <- maybe ndatadecl
+--         return (DefExternalID eid ndd))
+--
+--pedef :: HParser PEDef
+--pedef =
+--    ( entityvalue >>= return . PEDefEntityValue) `onFail`
+--    ( externalid >>= return . PEDefExternalID)
+
+externalid :: HParser ExternalID
+externalid =
+    ( do word "SYSTEM"
+         s <- systemliteral
+         return (SYSTEM s)) `onFail`
+    ( do word "PUBLIC"
+         p <- pubidliteral
+         s <- (systemliteral `onFail` return (SystemLiteral ""))
+         return (PUBLIC p s))
+
+--ndatadecl :: HParser NDataDecl
+--ndatadecl = do
+--    word "NDATA"
+--    n <- name
+--    return (NDATA n)
+
+textdecl :: HParser TextDecl
+textdecl = do
+    tok TokPIOpen
+    (word "xml" `onFail` word "XML")
+    v <- maybe versioninfo
+    e <- encodingdecl
+    tok TokPIClose `onFail` failP "expected ?> terminating text decl"
+    return (TextDecl v e)
+
+--extparsedent :: HParser ExtParsedEnt
+--extparsedent = do
+--    t <- maybe textdecl
+--    (_,c) <- (content "")
+--    return (ExtParsedEnt t c)
+--
+--extpe :: HParser ExtPE
+--extpe = do
+--    t <- maybe textdecl
+--    e <- extsubsetdecl
+--    return (ExtPE t e)
+
+encodingdecl :: HParser EncodingDecl
+encodingdecl = do
+    (word "encoding" `onFail` word "ENCODING")
+    tok TokEqual `onFail` failBadP "expected = in 'encoding' decl"
+    f <- bracket (tok TokQuote) (tok TokQuote) freetext
+    return (EncodingDecl f)
+
+--notationdecl :: HParser NotationDecl
+--notationdecl = do
+--    tok TokSpecialOpen
+--    word "NOTATION"
+--    n <- name
+--    e <- either externalid publicid
+--    tok TokAnyClose `onFail` failP "expected > terminating NOTATION decl"
+--    return (NOTATION n e)
+
+publicid :: HParser PublicID
+publicid = do
+    word "PUBLICID"
+    p <- pubidliteral
+    return (PUBLICID p)
+
+entityvalue :: HParser EntityValue
+entityvalue = do
+    evs <- bracket (tok TokQuote) (tok TokQuote) (many ev)
+    return (EntityValue evs)
+
+ev :: HParser EV
+ev =
+    ( freetext >>= return . EVString) `onFail`
+--  PEREF(EVPERef,ev) `onFail`
+    ( reference >>= return . EVRef)
+
+attvalue :: HParser AttValue
+attvalue =
+  ( do avs <- bracket (tok TokQuote) (tok TokQuote)
+                      (many (either freetext reference))
+       return (AttValue avs) ) `onFail`
+  ( do v <- nmtoken
+       s <- (tok TokPercent >> return "%") `onFail` return ""
+       return (AttValue [Left (v++s)]) ) `onFail`
+  ( do s <- oneOf [ tok TokPlus >> return "+"
+                  , tok TokHash >> return "#"
+                  ]
+       v <- nmtoken
+       return (AttValue [Left (s++v)]) ) `onFail`
+  failP "Badly formatted attribute value"
+
+systemliteral :: HParser SystemLiteral
+systemliteral = do
+    s <- bracket (tok TokQuote) (tok TokQuote) freetext
+    return (SystemLiteral s)		-- note: need to fold &...; escapes
+
+pubidliteral :: HParser PubidLiteral
+pubidliteral = do
+    s <- bracket (tok TokQuote) (tok TokQuote) freetext
+    return (PubidLiteral s)		-- note: need to fold &...; escapes
+
+chardata :: HParser CharData
+chardata = freetext -- >>= return . CharData
+
+

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Html/Pretty.html b/docs/HaXml/src/Text/XML/HaXml/Html/Pretty.html
--- a/docs/HaXml/src/Text/XML/HaXml/Html/Pretty.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Html/Pretty.html
@@ -1,238 +1,244 @@
 
 
-
-- | This is a separate pretty-printer for HTML documents, recognising
---   some of the differences between HTML and true XML.
-
-module Text.XML.HaXml.Html.Pretty
-  ( document
-  , element
-  , attribute
-  , content
-  ) where
-
-import Prelude hiding (maybe,either)
-import Maybe hiding (maybe)
-import List (intersperse)
-import Char (isSpace)
-import Text.PrettyPrint.HughesPJ
-import Text.XML.HaXml.Types
-
-either f g (Left x)  = f x
-either f g (Right x) = g x
-
-maybe f Nothing  = empty
-maybe f (Just x) = f x
-
---peref p   = text "%" <> text p <> text ";"
-
-----
-
-document :: Document i -> Doc
-prolog   :: Prolog -> Doc
-xmldecl  :: XMLDecl -> Doc
-misc     :: Misc -> Doc
-sddecl   :: Bool -> Doc
-
-doctypedecl :: DocTypeDecl -> Doc
-markupdecl  :: MarkupDecl -> Doc
-extsubset   :: ExtSubset -> Doc
-extsubsetdecl :: ExtSubsetDecl -> Doc
-
-element   :: Element i -> Doc
-attribute :: Attribute -> Doc                     --etc
-content   :: Content i -> Doc
-
-----
-
-document (Document p _ e m)= prolog p $$ element e $$ vcat (map misc m)
-prolog (Prolog x m1 dtd m2)= maybe xmldecl x $$
-                             vcat (map misc m1) $$
-                             maybe doctypedecl dtd $$
-                             vcat (map misc m2)
-xmldecl (XMLDecl v e sd)   = text "<?xml version='" <> text v <> text "'" <+>
-                             maybe encodingdecl e <+>
-                             maybe sddecl sd <+>
-                             text "?>"
-misc (Comment s)           = text "<!--" <+> text s <+> text "-->"
-misc (PI (n,s))            = text "<?" <> text n <+> text s <+> text "?>"
-sddecl sd   | sd           = text "standalone='yes'"
-            | otherwise    = text "standalone='no'"
-doctypedecl (DTD n eid ds) = if null ds then 
-                                  hd <> text ">"
-                             else hd <+> text " [" $$
-                                  vcat (map markupdecl ds) $$ text "]>"
-                           where hd = text "<!DOCTYPE" <+> text n <+>
-                                      maybe externalid eid
-markupdecl (Element e)     = elementdecl e
-markupdecl (AttList a)     = attlistdecl a
-markupdecl (Entity e)      = entitydecl e
-markupdecl (Notation n)    = notationdecl n
-markupdecl (MarkupMisc m)  = misc m
---markupdecl (MarkupPE p m)  = peref p
-extsubset (ExtSubset t ds) = maybe textdecl t $$
-                             vcat (map extsubsetdecl ds)
-extsubsetdecl (ExtMarkupDecl m)      = markupdecl m
-extsubsetdecl (ExtConditionalSect c) = conditionalsect c
---extsubsetdecl (ExtPEReference p e)   = peref p
-
-element (Elem n as []) = text "<" <> text n <+>
-                         fsep (map attribute as) <> text "/>"
-element e@(Elem n as cs)
---  | any isText cs    = text "<" <> text n <+> fsep (map attribute as) <>
---                       text ">" <> hcat (map content cs) <>
---                       text "</" <> text n <> text ">"
-    | isText (head cs) = text "<" <> text n <+> fsep (map attribute as) <>
-                         text ">" <> hcat (map content cs) <>
-                         text "</" <> text n <> text ">"
-    | otherwise        = let (d,c) = carryelem e empty
-                         in d <> c
-
-isText (CString _ _ _) = True
-isText (CRef _ _)      = True
-isText _               = False
-
-carryelem (Elem n as []) c
-                       = ( c <>
-                           text "<" <> text n <+> fsep (map attribute as)
-                         , text "/>")
---carryelem e@(Elem n as cs) c
-----  | any isText cs    =  ( c <> element e, empty)
---    | otherwise        =  let (cs',d') = carryscan carrycontent cs (text ">")
---                          in
---                          ( c <>
---                            text "<" <> text n <+> fsep (map attribute as) $$
---                            nest 2 (vcat cs') <> -- $$
---                            c' <> text "</" <> text n
---                          , text ">")
---carrycontent (CElem e) c   = carryelem e c
---carrycontent (CString _ s) c = (c <> chardata s, empty)
---carrycontent (CRef r) c    = (c <> reference r, empty)
---carrycontent (CMisc m) c   = (c <> misc m, empty)
---
---carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c)
---carryscan f []     c = ([],c)
---carryscan f (a:as) c = let (b, c')   = f a c
---                           (bs,c'') = carryscan f as c'
---                       in (b:bs, c'')
-
-carryelem e@(Elem n as cs) c
-  | isText (head cs) =
-        ( start <>
-          text ">" <> hcat (map content cs) <> text "</" <> text n
-        , text ">")
-  | otherwise =
-        let (d,c') = foldl carrycontent (start, text ">") cs in
-        ( d <> c' <> text "</" <> text n
-        , text ">")
-  where start = c <> text "<" <> text n <+> fsep (map attribute as)
-
-carrycontent (d,c) (CElem e _)     = let (d',c') = carryelem e c in
-                                     (d $$ nest 2 d',       c')
-carrycontent (d,c) (CString _ s _) = (d <> c <> chardata s, empty)
-carrycontent (d,c) (CRef r _)      = (d <> c <> reference r,empty)
-carrycontent (d,c) (CMisc m _)     = (d $$ c <> misc m,     empty)
-
-
-attribute (n,v)          = text n <> text "=" <> attvalue v
-content (CElem e _)      = element e
-content (CString _ s _)  = chardata s
-content (CRef r _)       = reference r
-content (CMisc m _)      = misc m
-
-elementdecl (ElementDecl n cs) = text "<!ELEMENT" <+> text n <+>
-                                 contentspec cs <> text ">"
-contentspec EMPTY              = text "EMPTY"
-contentspec ANY                = text "ANY"
-contentspec (Mixed m)          = mixed m
-contentspec (ContentSpec c)    = cp c
---contentspec (ContentPE p cs)   = peref p
-cp (TagName n m)       = text n <> modifier m
-cp (Choice cs m)       = parens (hcat (intersperse (text "|") (map cp cs))) <>
-                           modifier m
-cp (Seq cs m)          = parens (hcat (intersperse (text ",") (map cp cs))) <>
-                           modifier m
---cp (CPPE p c)          = peref p
-modifier None          = empty
-modifier Query         = text "?"
-modifier Star          = text "*"
-modifier Plus          = text "+"
-mixed  PCDATA          = text "(#PCDATA)"
-mixed (PCDATAplus ns)  = text "(#PCDATA |" <+>
-                         hcat (intersperse (text "|") (map text ns)) <>
-                         text ")*"
-
-attlistdecl (AttListDecl n ds) = text "<!ATTLIST" <+> text n <+>
-                                 fsep (map attdef ds) <> text ">"
-attdef (AttDef n t d)          = text n <+> atttype t <+> defaultdecl d
-atttype  StringType            = text "CDATA"
-atttype (TokenizedType t)      = tokenizedtype t
-atttype (EnumeratedType t)     = enumeratedtype t
-tokenizedtype ID               = text "ID"
-tokenizedtype IDREF            = text "IDREF"
-tokenizedtype IDREFS           = text "IDREFS"
-tokenizedtype ENTITY           = text "ENTITY"
-tokenizedtype ENTITIES         = text "ENTITIES"
-tokenizedtype NMTOKEN          = text "NMTOKEN"
-tokenizedtype NMTOKENS         = text "NMTOKENS"
-enumeratedtype (NotationType n)= notationtype n
-enumeratedtype (Enumeration e) = enumeration e
-notationtype ns                = text "NOTATION" <+>
-                                 parens (hcat (intersperse (text "|") (map text ns)))
-enumeration ns                 = parens (hcat (intersperse (text "|") (map nmtoken ns)))
-defaultdecl  REQUIRED          = text "#REQUIRED"
-defaultdecl  IMPLIED           = text "#IMPLIED"
-defaultdecl (DefaultTo a f)    = maybe (const (text "#FIXED")) f <+> attvalue a
-conditionalsect (IncludeSect i)= text "<![INCLUDE [" <+>
-                                 vcat (map extsubsetdecl i) <+> text "]]>"
-conditionalsect (IgnoreSect i) = text "<![IGNORE [" <+>
-                                 fsep (map ignoresectcontents i) <+> text "]]>"
-ignore (Ignore)                = empty
-ignoresectcontents (IgnoreSectContents i is)
-                               = ignore i <+> vcat (map internal is)
-                          where internal (ics,i) = text "<![[" <+>
-                                                   ignoresectcontents ics <+>
-                                                   text "]]>" <+> ignore i
-reference (RefEntity er)       = entityref er
-reference (RefChar cr)         = charref cr
-entityref n                    = text "&" <> text n <> text ";"
-charref c                      = text "&#" <> text (show c) <> text ";"
-entitydecl (EntityGEDecl d)    = gedecl d
-entitydecl (EntityPEDecl d)    = pedecl d
-gedecl (GEDecl n ed)           = text "<!ENTITY" <+> text n <+> entitydef ed <>
-                                 text ">"
-pedecl (PEDecl n pd)           = text "<!ENTITY %" <> text n <+> pedef pd <>
-                                 text ">"
-entitydef (DefEntityValue ev)  = entityvalue ev
-entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd
-pedef (PEDefEntityValue ev)    = entityvalue ev
-pedef (PEDefExternalID eid)    = externalid eid
-externalid (SYSTEM sl)         = text "SYSTEM" <+> systemliteral sl
-externalid (PUBLIC i sl)       = text "PUBLIC" <+> pubidliteral i <+>
-                                 systemliteral sl
-ndatadecl (NDATA n)            = text "NDATA" <+> text n
-textdecl (TextDecl vi ed)      = text "<?xml" <+> maybe text vi <+>
-                                 encodingdecl ed <> text "?>"
-extparsedent (ExtParsedEnt t c)= maybe textdecl t <+> content c
-extpe (ExtPE t esd)            = maybe textdecl t <+>
-                                 vcat (map extsubsetdecl esd)
-notationdecl (NOTATION n e)    = text "<!NOTATION" <+> text n <+>
-                                 either externalid publicid e <>
-                                 text ">"
-publicid (PUBLICID p)          = text "PUBLICID" <+> pubidliteral p
-encodingdecl (EncodingDecl s)  = text "encoding='" <> text s <> text "'"
-nmtoken s                      = text s
-attvalue (AttValue esr)        = text "\"" <>
-                                 hcat (map (either text reference) esr) <>
-                                 text "\""
-entityvalue (EntityValue evs)  = text "'" <> hcat (map ev evs) <> text "'"
-ev (EVString s)                = text s
---ev (EVPERef p e)               = peref p
-ev (EVRef r)                   = reference r
-pubidliteral (PubidLiteral s)  = text "'" <> text s <> text "'"
-systemliteral (SystemLiteral s)= text "'" <> text s <> text "'"
-chardata s                     = if all isSpace s then empty else text s
-cdsect c                       = text "<![CDATA[" <> chardata c <> text "]]>"
-
-----
+
+
+src/Text/XML/HaXml/Html/Pretty.hs
+
+
+
-- | This is a separate pretty-printer for HTML documents, recognising
+--   some of the differences between HTML and true XML.
+
+module Text.XML.HaXml.Html.Pretty
+  ( document
+  , element
+  , attribute
+  , content
+  ) where
+
+import Prelude hiding (maybe,either)
+import Maybe hiding (maybe)
+import List (intersperse)
+import Char (isSpace)
+import Text.PrettyPrint.HughesPJ
+import Text.XML.HaXml.Types
+
+either f g (Left x)  = f x
+either f g (Right x) = g x
+
+maybe f Nothing  = empty
+maybe f (Just x) = f x
+
+--peref p   = text "%" <> text p <> text ";"
+
+----
+
+document :: Document i -> Doc
+prolog   :: Prolog -> Doc
+xmldecl  :: XMLDecl -> Doc
+misc     :: Misc -> Doc
+sddecl   :: Bool -> Doc
+
+doctypedecl :: DocTypeDecl -> Doc
+markupdecl  :: MarkupDecl -> Doc
+extsubset   :: ExtSubset -> Doc
+extsubsetdecl :: ExtSubsetDecl -> Doc
+
+element   :: Element i -> Doc
+attribute :: Attribute -> Doc                     --etc
+content   :: Content i -> Doc
+
+----
+
+document (Document p _ e m)= prolog p $$ element e $$ vcat (map misc m)
+prolog (Prolog x m1 dtd m2)= maybe xmldecl x $$
+                             vcat (map misc m1) $$
+                             maybe doctypedecl dtd $$
+                             vcat (map misc m2)
+xmldecl (XMLDecl v e sd)   = text "<?xml version='" <> text v <> text "'" <+>
+                             maybe encodingdecl e <+>
+                             maybe sddecl sd <+>
+                             text "?>"
+misc (Comment s)           = text "<!--" <+> text s <+> text "-->"
+misc (PI (n,s))            = text "<?" <> text n <+> text s <+> text "?>"
+sddecl sd   | sd           = text "standalone='yes'"
+            | otherwise    = text "standalone='no'"
+doctypedecl (DTD n eid ds) = if null ds then 
+                                  hd <> text ">"
+                             else hd <+> text " [" $$
+                                  vcat (map markupdecl ds) $$ text "]>"
+                           where hd = text "<!DOCTYPE" <+> text n <+>
+                                      maybe externalid eid
+markupdecl (Element e)     = elementdecl e
+markupdecl (AttList a)     = attlistdecl a
+markupdecl (Entity e)      = entitydecl e
+markupdecl (Notation n)    = notationdecl n
+markupdecl (MarkupMisc m)  = misc m
+--markupdecl (MarkupPE p m)  = peref p
+extsubset (ExtSubset t ds) = maybe textdecl t $$
+                             vcat (map extsubsetdecl ds)
+extsubsetdecl (ExtMarkupDecl m)      = markupdecl m
+extsubsetdecl (ExtConditionalSect c) = conditionalsect c
+--extsubsetdecl (ExtPEReference p e)   = peref p
+
+element (Elem n as []) = text "<" <> text n <+>
+                         fsep (map attribute as) <> text "/>"
+element e@(Elem n as cs)
+--  | any isText cs    = text "<" <> text n <+> fsep (map attribute as) <>
+--                       text ">" <> hcat (map content cs) <>
+--                       text "</" <> text n <> text ">"
+    | isText (head cs) = text "<" <> text n <+> fsep (map attribute as) <>
+                         text ">" <> hcat (map content cs) <>
+                         text "</" <> text n <> text ">"
+    | otherwise        = let (d,c) = carryelem e empty
+                         in d <> c
+
+isText (CString _ _ _) = True
+isText (CRef _ _)      = True
+isText _               = False
+
+carryelem (Elem n as []) c
+                       = ( c <>
+                           text "<" <> text n <+> fsep (map attribute as)
+                         , text "/>")
+--carryelem e@(Elem n as cs) c
+----  | any isText cs    =  ( c <> element e, empty)
+--    | otherwise        =  let (cs',d') = carryscan carrycontent cs (text ">")
+--                          in
+--                          ( c <>
+--                            text "<" <> text n <+> fsep (map attribute as) $$
+--                            nest 2 (vcat cs') <> -- $$
+--                            c' <> text "</" <> text n
+--                          , text ">")
+--carrycontent (CElem e) c   = carryelem e c
+--carrycontent (CString _ s) c = (c <> chardata s, empty)
+--carrycontent (CRef r) c    = (c <> reference r, empty)
+--carrycontent (CMisc m) c   = (c <> misc m, empty)
+--
+--carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c)
+--carryscan f []     c = ([],c)
+--carryscan f (a:as) c = let (b, c')   = f a c
+--                           (bs,c'') = carryscan f as c'
+--                       in (b:bs, c'')
+
+carryelem e@(Elem n as cs) c
+  | isText (head cs) =
+        ( start <>
+          text ">" <> hcat (map content cs) <> text "</" <> text n
+        , text ">")
+  | otherwise =
+        let (d,c') = foldl carrycontent (start, text ">") cs in
+        ( d <> c' <> text "</" <> text n
+        , text ">")
+  where start = c <> text "<" <> text n <+> fsep (map attribute as)
+
+carrycontent (d,c) (CElem e _)     = let (d',c') = carryelem e c in
+                                     (d $$ nest 2 d',       c')
+carrycontent (d,c) (CString _ s _) = (d <> c <> chardata s, empty)
+carrycontent (d,c) (CRef r _)      = (d <> c <> reference r,empty)
+carrycontent (d,c) (CMisc m _)     = (d $$ c <> misc m,     empty)
+
+
+attribute (n,v)          = text n <> text "=" <> attvalue v
+content (CElem e _)      = element e
+content (CString _ s _)  = chardata s
+content (CRef r _)       = reference r
+content (CMisc m _)      = misc m
+
+elementdecl (ElementDecl n cs) = text "<!ELEMENT" <+> text n <+>
+                                 contentspec cs <> text ">"
+contentspec EMPTY              = text "EMPTY"
+contentspec ANY                = text "ANY"
+contentspec (Mixed m)          = mixed m
+contentspec (ContentSpec c)    = cp c
+--contentspec (ContentPE p cs)   = peref p
+cp (TagName n m)       = text n <> modifier m
+cp (Choice cs m)       = parens (hcat (intersperse (text "|") (map cp cs))) <>
+                           modifier m
+cp (Seq cs m)          = parens (hcat (intersperse (text ",") (map cp cs))) <>
+                           modifier m
+--cp (CPPE p c)          = peref p
+modifier None          = empty
+modifier Query         = text "?"
+modifier Star          = text "*"
+modifier Plus          = text "+"
+mixed  PCDATA          = text "(#PCDATA)"
+mixed (PCDATAplus ns)  = text "(#PCDATA |" <+>
+                         hcat (intersperse (text "|") (map text ns)) <>
+                         text ")*"
+
+attlistdecl (AttListDecl n ds) = text "<!ATTLIST" <+> text n <+>
+                                 fsep (map attdef ds) <> text ">"
+attdef (AttDef n t d)          = text n <+> atttype t <+> defaultdecl d
+atttype  StringType            = text "CDATA"
+atttype (TokenizedType t)      = tokenizedtype t
+atttype (EnumeratedType t)     = enumeratedtype t
+tokenizedtype ID               = text "ID"
+tokenizedtype IDREF            = text "IDREF"
+tokenizedtype IDREFS           = text "IDREFS"
+tokenizedtype ENTITY           = text "ENTITY"
+tokenizedtype ENTITIES         = text "ENTITIES"
+tokenizedtype NMTOKEN          = text "NMTOKEN"
+tokenizedtype NMTOKENS         = text "NMTOKENS"
+enumeratedtype (NotationType n)= notationtype n
+enumeratedtype (Enumeration e) = enumeration e
+notationtype ns                = text "NOTATION" <+>
+                                 parens (hcat (intersperse (text "|") (map text ns)))
+enumeration ns                 = parens (hcat (intersperse (text "|") (map nmtoken ns)))
+defaultdecl  REQUIRED          = text "#REQUIRED"
+defaultdecl  IMPLIED           = text "#IMPLIED"
+defaultdecl (DefaultTo a f)    = maybe (const (text "#FIXED")) f <+> attvalue a
+conditionalsect (IncludeSect i)= text "<![INCLUDE [" <+>
+                                 vcat (map extsubsetdecl i) <+> text "]]>"
+conditionalsect (IgnoreSect i) = text "<![IGNORE [" <+>
+                                 fsep (map ignoresectcontents i) <+> text "]]>"
+ignore (Ignore)                = empty
+ignoresectcontents (IgnoreSectContents i is)
+                               = ignore i <+> vcat (map internal is)
+                          where internal (ics,i) = text "<![[" <+>
+                                                   ignoresectcontents ics <+>
+                                                   text "]]>" <+> ignore i
+reference (RefEntity er)       = entityref er
+reference (RefChar cr)         = charref cr
+entityref n                    = text "&" <> text n <> text ";"
+charref c                      = text "&#" <> text (show c) <> text ";"
+entitydecl (EntityGEDecl d)    = gedecl d
+entitydecl (EntityPEDecl d)    = pedecl d
+gedecl (GEDecl n ed)           = text "<!ENTITY" <+> text n <+> entitydef ed <>
+                                 text ">"
+pedecl (PEDecl n pd)           = text "<!ENTITY %" <> text n <+> pedef pd <>
+                                 text ">"
+entitydef (DefEntityValue ev)  = entityvalue ev
+entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd
+pedef (PEDefEntityValue ev)    = entityvalue ev
+pedef (PEDefExternalID eid)    = externalid eid
+externalid (SYSTEM sl)         = text "SYSTEM" <+> systemliteral sl
+externalid (PUBLIC i sl)       = text "PUBLIC" <+> pubidliteral i <+>
+                                 systemliteral sl
+ndatadecl (NDATA n)            = text "NDATA" <+> text n
+textdecl (TextDecl vi ed)      = text "<?xml" <+> maybe text vi <+>
+                                 encodingdecl ed <> text "?>"
+extparsedent (ExtParsedEnt t c)= maybe textdecl t <+> content c
+extpe (ExtPE t esd)            = maybe textdecl t <+>
+                                 vcat (map extsubsetdecl esd)
+notationdecl (NOTATION n e)    = text "<!NOTATION" <+> text n <+>
+                                 either externalid publicid e <>
+                                 text ">"
+publicid (PUBLICID p)          = text "PUBLICID" <+> pubidliteral p
+encodingdecl (EncodingDecl s)  = text "encoding='" <> text s <> text "'"
+nmtoken s                      = text s
+attvalue (AttValue esr)        = text "\"" <>
+                                 hcat (map (either text reference) esr) <>
+                                 text "\""
+entityvalue (EntityValue evs)  = text "'" <> hcat (map ev evs) <> text "'"
+ev (EVString s)                = text s
+--ev (EVPERef p e)               = peref p
+ev (EVRef r)                   = reference r
+pubidliteral (PubidLiteral s)  = text "'" <> text s <> text "'"
+systemliteral (SystemLiteral s)= text "'" <> text s <> text "'"
+chardata s                     = if all isSpace s then empty else text s
+cdsect c                       = text "<![CDATA[" <> chardata c <> text "]]>"
+
+----
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Lex.html b/docs/HaXml/src/Text/XML/HaXml/Lex.html
--- a/docs/HaXml/src/Text/XML/HaXml/Lex.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Lex.html
@@ -1,337 +1,343 @@
 
 
-
-- | You don't normally need to use this Lex module directly - it is
---   called automatically by the parser.  (This interface is only exposed
---   for debugging purposes.)
---
--- This is a hand-written lexer for tokenising the text of an XML
--- document so that it is ready for parsing.  It attaches position
--- information in (line,column) format to every token.  The main
--- entry point is 'xmlLex'.  A secondary entry point, 'xmlReLex', is
--- provided for when the parser needs to stuff a string back onto
--- the front of the text and re-tokenise it (typically when expanding
--- macros).
---
--- As one would expect, the lexer is essentially a small finite
--- state machine.
-
-module Text.XML.HaXml.Lex
-  (
-  -- * Entry points to the lexer
-    xmlLex         -- :: String -> String -> [Token]
-  , xmlReLex       -- :: Posn   -> String -> [Token]
-  , reLexEntityValue -- :: (String->Maybe String) -> Posn -> String -> [Token]
-  -- * Token types
-  , Token
-  , TokenT(..)
-  , Special(..)
-  , Section(..)
-  ) where
-
-import Char
-import Text.XML.HaXml.Posn
-
-data Where = InTag String | NotInTag
-    deriving (Eq)
-
--- | All tokens are paired up with a source position.
---   Lexical errors are passed back as a special @TokenT@ value.
-type Token = (Posn, TokenT)
-
--- | The basic token type.
-data TokenT =
-      TokCommentOpen		-- ^   \<!--
-    | TokCommentClose		-- ^   -->
-    | TokPIOpen			-- ^   \<?
-    | TokPIClose		-- ^   ?>
-    | TokSectionOpen		-- ^   \<![
-    | TokSectionClose		-- ^   ]]>
-    | TokSection Section	-- ^   CDATA INCLUDE IGNORE etc
-    | TokSpecialOpen		-- ^   \<!
-    | TokSpecial Special	-- ^   DOCTYPE ELEMENT ATTLIST etc
-    | TokEndOpen		-- ^   \<\/
-    | TokEndClose		-- ^   \/>
-    | TokAnyOpen		-- ^   \<
-    | TokAnyClose		-- ^   >
-    | TokSqOpen			-- ^   \[
-    | TokSqClose		-- ^   \]
-    | TokEqual			-- ^   =
-    | TokQuery			-- ^   ?
-    | TokStar			-- ^   \*
-    | TokPlus			-- ^   +
-    | TokAmp			-- ^   &
-    | TokSemi			-- ^   ;
-    | TokHash			-- ^   #
-    | TokBraOpen		-- ^   (
-    | TokBraClose		-- ^   )
-    | TokPipe			-- ^   |
-    | TokPercent		-- ^   %
-    | TokComma			-- ^   ,
-    | TokQuote			-- ^   \'\' or \"\"
-    | TokName      String	-- ^   begins with letter, no spaces
-    | TokFreeText  String	-- ^   any character data
-    | TokNull			-- ^   fake token
-    | TokError     String	-- ^   lexical error
-    deriving (Eq)
-
-data Special =
-      DOCTYPEx
-    | ELEMENTx
-    | ATTLISTx
-    | ENTITYx
-    | NOTATIONx
-    deriving (Eq,Show)
-data Section =
-      CDATAx
-    | INCLUDEx
-    | IGNOREx
-    deriving (Eq,Show)
-
-instance Show TokenT where
-  showsPrec p  TokCommentOpen		= showString     "<!--"
-  showsPrec p  TokCommentClose		= showString     "-->"
-  showsPrec p  TokPIOpen		= showString     "<?"
-  showsPrec p  TokPIClose		= showString     "?>"
-  showsPrec p  TokSectionOpen		= showString     "<!["
-  showsPrec p  TokSectionClose		= showString     "]]>"
-  showsPrec p  (TokSection s)		= showsPrec p s
-  showsPrec p  TokSpecialOpen		= showString     "<!"
-  showsPrec p  (TokSpecial s)		= showsPrec p s
-  showsPrec p  TokEndOpen		= showString     "</"
-  showsPrec p  TokEndClose		= showString     "/>"
-  showsPrec p  TokAnyOpen		= showString     "<"
-  showsPrec p  TokAnyClose		= showString     ">"
-  showsPrec p  TokSqOpen		= showString     "["
-  showsPrec p  TokSqClose		= showString     "]"
-  showsPrec p  TokEqual			= showString     "="
-  showsPrec p  TokQuery			= showString     "?"
-  showsPrec p  TokStar			= showString     "*"
-  showsPrec p  TokPlus			= showString     "+"
-  showsPrec p  TokAmp			= showString     "&"
-  showsPrec p  TokSemi			= showString     ";"
-  showsPrec p  TokHash			= showString     "#"
-  showsPrec p  TokBraOpen		= showString     "("
-  showsPrec p  TokBraClose		= showString     ")"
-  showsPrec p  TokPipe			= showString     "|"
-  showsPrec p  TokPercent		= showString     "%"
-  showsPrec p  TokComma			= showString     ","
-  showsPrec p  TokQuote			= showString     "' or \""
-  showsPrec p  (TokName      s)		= showString     s
-  showsPrec p  (TokFreeText  s)		= showString     s
-  showsPrec p  TokNull			= showString     "(null)"
-  showsPrec p  (TokError     s)		= showString     s
-
---trim, revtrim :: String -> String
---trim    = f . f         where f = reverse . dropWhile isSpace
---revtrim = f.reverse.f   where f = dropWhile isSpace
---revtrim = reverse . dropWhile (=='\n')  -- most recently used defn.
-
-emit :: TokenT -> Posn -> Token
-emit tok p = forcep p `seq` (p,tok)
-
-lexerror :: String -> Posn -> [Token]
-lexerror s p = [(p, TokError ("Lexical error:\n  "++s))]
-
-skip :: Int -> Posn -> String -> (Posn->String->[Token]) -> [Token]
-skip n p s k = k (addcol n p) (drop n s)
-
-blank :: ([Where]->Posn->String->[Token]) -> [Where]-> Posn-> String-> [Token]
-blank k  (InTag t:_) p [] = lexerror ("unexpected EOF within "++t) p
-blank k          _   p [] = []
-blank k      w p (' ': s) = blank k w (addcol 1 p) s
-blank k      w p ('\t':s) = blank k w (tab p) s
-blank k      w p ('\n':s) = blank k w (newline p) s
-blank k      w p ('\r':s) = blank k w  p s
-blank k   w p ('\xa0': s) = blank k w (addcol 1 p) s
-blank k      w p    s     = k w p s
-
-prefixes :: String -> String -> Bool
-[]     `prefixes`   ys   = True
-(x:xs) `prefixes` (y:ys) = x==y && xs `prefixes` ys
-(x:xs) `prefixes`   []   = False --error "unexpected EOF in prefix"
-
-textUntil close tok acc pos p [] k =
-    lexerror ("unexpected EOF while looking for closing token "++close
-              ++"\n  to match the opening token in "++show pos) p
-textUntil close tok acc pos p (s:ss) k
-    | close `prefixes` (s:ss)  = emit (TokFreeText (reverse acc)) pos:
-                                 emit tok p:
-                                 skip (length close-1) (addcol 1 p) ss k
-    | isSpace s  = textUntil close tok (s:acc) pos (white s p) ss k
-    | otherwise  = textUntil close tok (s:acc) pos (addcol 1 p) ss k
-
-textOrRefUntil close tok acc pos p [] k =
-    lexerror ("unexpected EOF while looking for closing token "++close
-              ++"\n  to match the opening token in "++show pos) p
-textOrRefUntil close tok acc pos p (s:ss) k
-    | close `prefixes` (s:ss)  = emit (TokFreeText (reverse acc)) pos:
-                                 emit tok p:
-                                 skip (length close-1) (addcol 1 p) ss k
-    | s=='&'     = (if not (null acc)
-                       then (emit (TokFreeText (reverse acc)) pos:)
-                       else id)
-                   (emit TokAmp p:
-                    textUntil ";" TokSemi "" p (addcol 1 p) ss
-                        (\p' i-> textOrRefUntil close tok "" p p' i k))
-    | isSpace s  = textOrRefUntil close tok (s:acc) pos (white s p) ss k
-    | otherwise  = textOrRefUntil close tok (s:acc) pos (addcol 1 p) ss k
-
-----
-
--- | The first argument to 'xmlLex' is the filename (used for source positions,
---   especially in error messages), and the second is the string content of
---   the XML file.
-xmlLex :: String -> String -> [Token]
-xmlLex filename = xmlAny [] (posInNewCxt ("file "++filename) Nothing)
-
--- | 'xmlReLex' is used when the parser expands a macro (PE reference).
---    The expansion of the macro must be re-lexed as if for the first time.
-xmlReLex :: Posn -> String -> [Token]
-xmlReLex p s
-      | "INCLUDE"  `prefixes` s  = emit (TokSection INCLUDEx) p: k 7
-      | "IGNORE"   `prefixes` s  = emit (TokSection IGNOREx) p:  k 6
-      | otherwise = blank xmlAny [] p s
-  where
-    k n = skip n p s (blank xmlAny [])
-
--- | 'reLexEntityValue' is used solely within parsing an entityvalue.
---   Normally, a PERef is logically separated from its surroundings by
---   whitespace.  But in an entityvalue, a PERef can be juxtaposed to
---   an identifier, so the expansion forms a new identifier.
---   Thus the need to rescan the whole text for possible PERefs.
-reLexEntityValue :: (String->Maybe String) -> Posn -> String -> [Token]
-reLexEntityValue lookup p s =
-    textOrRefUntil "%" TokNull [] p p (expand s++"%") (xmlAny [])
-  where
-    expand []       = []
-    expand ('%':ss) = let (sym,rest) = break (==';') ss in
-                      case lookup sym of
-                        Just val -> expand val ++ expand (tail rest)
-                        Nothing  -> "%"++sym++";"++ expand (tail rest) -- hmmm
-    expand (s:ss)   = s: expand ss
-
---xmltop :: Posn -> String -> [Token]
---xmltop p [] = []
---xmltop p s
---    | "<?"   `prefixes` s = emit TokPIOpen p:      next 2 (xmlPI [InTag "<?...?>"])
---    | "<!--" `prefixes` s = emit TokCommentOpen p: next 4 (xmlComment [])
---    | "<!"   `prefixes` s = emit TokSpecialOpen p: next 2 (xmlSpecial [InTag "<!...>"])
---    | otherwise           = lexerror "expected <?xml?> or <!DOCTYPE>" p
---  where next n k = skip n p s k
-
-xmlPI      w p s = xmlName p s "name of processor in <? ?>" (blank xmlPIEnd w)
-xmlPIEnd   w p s = textUntil "?>"  TokPIClose "" p p s (blank xmlAny (tail w))
-xmlComment w p s = textUntil "-->" TokCommentClose "" p p s (blank xmlAny w)
-
--- Note: the order of the clauses in xmlAny is very important.
--- Some matches must precede the NotInTag test, the rest must follow it.
-xmlAny :: [Where] -> Posn -> String -> [Token]
-xmlAny  (InTag t:_)  p [] = lexerror ("unexpected EOF within "++t) p
-xmlAny          _    p [] = []
-xmlAny w p s@('<':ss)
-    | "?"   `prefixes` ss = emit TokPIOpen p:
-                                         skip 2 p s (xmlPI (InTag "<?...?>":w))
-    | "!--" `prefixes` ss = emit TokCommentOpen p: skip 4 p s (xmlComment w)
-    | "!["  `prefixes` ss = emit TokSectionOpen p: skip 3 p s (xmlSection w)
-    | "!"   `prefixes` ss = emit TokSpecialOpen p:
-                                     skip 2 p s (xmlSpecial (InTag "<!...>":w))
-    | "/"   `prefixes` ss = emit TokEndOpen p: 
-                                    skip 2 p s (xmlTag (InTag "</...>":tail w))
-    | otherwise           = emit TokAnyOpen p:
-                                 skip 1 p s (xmlTag (InTag "<...>":NotInTag:w))
-xmlAny (_:_:w) p s@('/':ss)
-    | ">"   `prefixes` ss = emit TokEndClose p: skip 2 p s (xmlAny w)
-xmlAny w p ('&':ss) = emit TokAmp p:      textUntil ";" TokSemi "" p
-                                                     (addcol 1 p) ss (xmlAny w)
-xmlAny w@(NotInTag:_) p s = xmlContent "" w p p s
--- everything below here is implicitly InTag.
-xmlAny w p ('>':ss) = emit TokAnyClose p: xmlAny (tail w) (addcol 1 p) ss
-xmlAny w p ('[':ss) = emit TokSqOpen p:
-                                 blank xmlAny (InTag "[...]":w) (addcol 1 p) ss
-xmlAny w p (']':ss)
-    | "]>" `prefixes` ss  =
-                 emit TokSectionClose p:  skip 3 p (']':ss) (xmlAny (tail w))
-    | otherwise  =    emit TokSqClose p:  blank xmlAny (tail w) (addcol 1 p) ss
-xmlAny w p ('(':ss) = emit TokBraOpen p:
-                                 blank xmlAny (InTag "(...)":w) (addcol 1 p) ss
-xmlAny w p (')':ss) = emit TokBraClose p: blank xmlAny (tail w) (addcol 1 p) ss
-xmlAny w p ('=':ss) = emit TokEqual p:    blank xmlAny w (addcol 1 p) ss
-xmlAny w p ('*':ss) = emit TokStar p:     blank xmlAny w (addcol 1 p) ss
-xmlAny w p ('+':ss) = emit TokPlus p:     blank xmlAny w (addcol 1 p) ss
-xmlAny w p ('?':ss) = emit TokQuery p:    blank xmlAny w (addcol 1 p) ss
-xmlAny w p ('|':ss) = emit TokPipe p:     blank xmlAny w (addcol 1 p) ss
-xmlAny w p ('%':ss) = emit TokPercent p:  blank xmlAny w (addcol 1 p) ss
-xmlAny w p (';':ss) = emit TokSemi p:     blank xmlAny w (addcol 1 p) ss
-xmlAny w p (',':ss) = emit TokComma p:    blank xmlAny w (addcol 1 p) ss
-xmlAny w p ('#':ss) = emit TokHash p:     blank xmlAny w (addcol 1 p) ss
-xmlAny w p ('"':ss) = emit TokQuote p:    textOrRefUntil "\"" TokQuote "" p1
-                                                          p1 ss (xmlAny w)
-                                             where p1 = addcol 1 p
-xmlAny w p ('\'':ss) = emit TokQuote p:   textOrRefUntil "'" TokQuote "" p1
-                                                          p1 ss (xmlAny w)
-                                             where p1 = addcol 1 p
-xmlAny w p s
-    | isSpace (head s)     = blank xmlAny w p s
-    | isAlphaNum (head s) || (head s)`elem`":_"
-                           = xmlName p s "some kind of name" (blank xmlAny w)
-    | otherwise            = lexerror ("unrecognised token: "++take 4 s) p
-
-xmlTag w p s = xmlName p s "tagname for element in < >" (blank xmlAny w)
-
-xmlSection = blank xmlSection0
-  where
-    xmlSection0 w p s
-      | "CDATA["   `prefixes` s  = emit (TokSection CDATAx) p:  accum w p s 6
-      | "INCLUDE"  `prefixes` s  = emit (TokSection INCLUDEx) p:    k w p s 7
-      | "IGNORE"   `prefixes` s  = emit (TokSection IGNOREx) p:     k w p s 6
-      | "%"        `prefixes` s  = emit TokPercent p:               k w p s 1
-      | otherwise = lexerror ("expected CDATA, IGNORE, or INCLUDE, but got "
-                             ++take 7 s) p
-    accum w p s n =
-      let p0 = addcol n p in
-      textUntil "]]>" TokSectionClose "" p0 p0 (drop n s) (blank xmlAny w)
-    k w p s n =
-      skip n p s (xmlAny ({-InTag "<![section[ ... ]]>": -}w))
-
-xmlSpecial w p s
-    | "DOCTYPE"  `prefixes` s = emit (TokSpecial DOCTYPEx)  p: k 7
-    | "ELEMENT"  `prefixes` s = emit (TokSpecial ELEMENTx)  p: k 7
-    | "ATTLIST"  `prefixes` s = emit (TokSpecial ATTLISTx)  p: k 7
-    | "ENTITY"   `prefixes` s = emit (TokSpecial ENTITYx)   p: k 6
-    | "NOTATION" `prefixes` s = emit (TokSpecial NOTATIONx) p: k 8
-    | otherwise = lexerror
-                    ("expected DOCTYPE, ELEMENT, ENTITY, ATTLIST, or NOTATION,"
-                    ++" but got "++take 7 s) p
-  where k n = skip n p s (blank xmlAny w)
-
-xmlName p (s:ss) cxt k
-    | isAlphaNum s || s==':' || s=='_'  = gatherName (s:[]) p (addcol 1 p) ss k
-    | otherwise   = lexerror ("expected a "++cxt++", but got char "++show s) p
-  where
-    gatherName acc pos p [] k =
-        emit (TokName (reverse acc)) pos: k p []
-    --  lexerror ("unexpected EOF in name at "++show pos) p
-    gatherName acc pos p (s:ss) k
-        | isAlphaNum s || s `elem` ".-_:"
-                      = gatherName (s:acc) pos (addcol 1 p) ss k
-        | otherwise   = emit (TokName (reverse acc)) pos: k p (s:ss)
-xmlName p [] cxt k = lexerror ("expected a "++cxt++", but got end of input") p
-
-xmlContent acc w pos p [] = if all isSpace acc then []
-                            else lexerror "unexpected EOF between tags" p
-xmlContent acc w pos p (s:ss)
-    | elem s "<&"    = {- if all isSpace acc then xmlAny w p (s:ss) else -}
-                       emit (TokFreeText (reverse acc)) pos: xmlAny w p (s:ss)
-    | isSpace s      = xmlContent (s:acc) w pos (white s p) ss
-    | otherwise      = xmlContent (s:acc) w pos (addcol 1 p) ss
-
-
-
---ident :: (String->TokenT) ->
---          Posn -> String -> [String] ->
---         (Posn->String->[String]->[Token]) -> [Token]
---ident tok p s ss k =
---    let (name,s0) = span (\c-> isAlphaNum c || c `elem` "`-_#.'/\\") s
---    in emit (tok name) p: skip (length name) p s ss k
+
+
+src/Text/XML/HaXml/Lex.hs
+
+
+
-- | You don't normally need to use this Lex module directly - it is
+--   called automatically by the parser.  (This interface is only exposed
+--   for debugging purposes.)
+--
+-- This is a hand-written lexer for tokenising the text of an XML
+-- document so that it is ready for parsing.  It attaches position
+-- information in (line,column) format to every token.  The main
+-- entry point is 'xmlLex'.  A secondary entry point, 'xmlReLex', is
+-- provided for when the parser needs to stuff a string back onto
+-- the front of the text and re-tokenise it (typically when expanding
+-- macros).
+--
+-- As one would expect, the lexer is essentially a small finite
+-- state machine.
+
+module Text.XML.HaXml.Lex
+  (
+  -- * Entry points to the lexer
+    xmlLex         -- :: String -> String -> [Token]
+  , xmlReLex       -- :: Posn   -> String -> [Token]
+  , reLexEntityValue -- :: (String->Maybe String) -> Posn -> String -> [Token]
+  -- * Token types
+  , Token
+  , TokenT(..)
+  , Special(..)
+  , Section(..)
+  ) where
+
+import Char
+import Text.XML.HaXml.Posn
+
+data Where = InTag String | NotInTag
+    deriving (Eq)
+
+-- | All tokens are paired up with a source position.
+--   Lexical errors are passed back as a special @TokenT@ value.
+type Token = (Posn, TokenT)
+
+-- | The basic token type.
+data TokenT =
+      TokCommentOpen		-- ^   \<!--
+    | TokCommentClose		-- ^   -->
+    | TokPIOpen			-- ^   \<?
+    | TokPIClose		-- ^   ?>
+    | TokSectionOpen		-- ^   \<![
+    | TokSectionClose		-- ^   ]]>
+    | TokSection Section	-- ^   CDATA INCLUDE IGNORE etc
+    | TokSpecialOpen		-- ^   \<!
+    | TokSpecial Special	-- ^   DOCTYPE ELEMENT ATTLIST etc
+    | TokEndOpen		-- ^   \<\/
+    | TokEndClose		-- ^   \/>
+    | TokAnyOpen		-- ^   \<
+    | TokAnyClose		-- ^   >
+    | TokSqOpen			-- ^   \[
+    | TokSqClose		-- ^   \]
+    | TokEqual			-- ^   =
+    | TokQuery			-- ^   ?
+    | TokStar			-- ^   \*
+    | TokPlus			-- ^   +
+    | TokAmp			-- ^   &
+    | TokSemi			-- ^   ;
+    | TokHash			-- ^   #
+    | TokBraOpen		-- ^   (
+    | TokBraClose		-- ^   )
+    | TokPipe			-- ^   |
+    | TokPercent		-- ^   %
+    | TokComma			-- ^   ,
+    | TokQuote			-- ^   \'\' or \"\"
+    | TokName      String	-- ^   begins with letter, no spaces
+    | TokFreeText  String	-- ^   any character data
+    | TokNull			-- ^   fake token
+    | TokError     String	-- ^   lexical error
+    deriving (Eq)
+
+data Special =
+      DOCTYPEx
+    | ELEMENTx
+    | ATTLISTx
+    | ENTITYx
+    | NOTATIONx
+    deriving (Eq,Show)
+data Section =
+      CDATAx
+    | INCLUDEx
+    | IGNOREx
+    deriving (Eq,Show)
+
+instance Show TokenT where
+  showsPrec p  TokCommentOpen		= showString     "<!--"
+  showsPrec p  TokCommentClose		= showString     "-->"
+  showsPrec p  TokPIOpen		= showString     "<?"
+  showsPrec p  TokPIClose		= showString     "?>"
+  showsPrec p  TokSectionOpen		= showString     "<!["
+  showsPrec p  TokSectionClose		= showString     "]]>"
+  showsPrec p  (TokSection s)		= showsPrec p s
+  showsPrec p  TokSpecialOpen		= showString     "<!"
+  showsPrec p  (TokSpecial s)		= showsPrec p s
+  showsPrec p  TokEndOpen		= showString     "</"
+  showsPrec p  TokEndClose		= showString     "/>"
+  showsPrec p  TokAnyOpen		= showString     "<"
+  showsPrec p  TokAnyClose		= showString     ">"
+  showsPrec p  TokSqOpen		= showString     "["
+  showsPrec p  TokSqClose		= showString     "]"
+  showsPrec p  TokEqual			= showString     "="
+  showsPrec p  TokQuery			= showString     "?"
+  showsPrec p  TokStar			= showString     "*"
+  showsPrec p  TokPlus			= showString     "+"
+  showsPrec p  TokAmp			= showString     "&"
+  showsPrec p  TokSemi			= showString     ";"
+  showsPrec p  TokHash			= showString     "#"
+  showsPrec p  TokBraOpen		= showString     "("
+  showsPrec p  TokBraClose		= showString     ")"
+  showsPrec p  TokPipe			= showString     "|"
+  showsPrec p  TokPercent		= showString     "%"
+  showsPrec p  TokComma			= showString     ","
+  showsPrec p  TokQuote			= showString     "' or \""
+  showsPrec p  (TokName      s)		= showString     s
+  showsPrec p  (TokFreeText  s)		= showString     s
+  showsPrec p  TokNull			= showString     "(null)"
+  showsPrec p  (TokError     s)		= showString     s
+
+--trim, revtrim :: String -> String
+--trim    = f . f         where f = reverse . dropWhile isSpace
+--revtrim = f.reverse.f   where f = dropWhile isSpace
+--revtrim = reverse . dropWhile (=='\n')  -- most recently used defn.
+
+emit :: TokenT -> Posn -> Token
+emit tok p = forcep p `seq` (p,tok)
+
+lexerror :: String -> Posn -> [Token]
+lexerror s p = [(p, TokError ("Lexical error:\n  "++s))]
+
+skip :: Int -> Posn -> String -> (Posn->String->[Token]) -> [Token]
+skip n p s k = k (addcol n p) (drop n s)
+
+blank :: ([Where]->Posn->String->[Token]) -> [Where]-> Posn-> String-> [Token]
+blank k  (InTag t:_) p [] = lexerror ("unexpected EOF within "++t) p
+blank k          _   p [] = []
+blank k      w p (' ': s) = blank k w (addcol 1 p) s
+blank k      w p ('\t':s) = blank k w (tab p) s
+blank k      w p ('\n':s) = blank k w (newline p) s
+blank k      w p ('\r':s) = blank k w  p s
+blank k   w p ('\xa0': s) = blank k w (addcol 1 p) s
+blank k      w p    s     = k w p s
+
+prefixes :: String -> String -> Bool
+[]     `prefixes`   ys   = True
+(x:xs) `prefixes` (y:ys) = x==y && xs `prefixes` ys
+(x:xs) `prefixes`   []   = False --error "unexpected EOF in prefix"
+
+textUntil close tok acc pos p [] k =
+    lexerror ("unexpected EOF while looking for closing token "++close
+              ++"\n  to match the opening token in "++show pos) p
+textUntil close tok acc pos p (s:ss) k
+    | close `prefixes` (s:ss)  = emit (TokFreeText (reverse acc)) pos:
+                                 emit tok p:
+                                 skip (length close-1) (addcol 1 p) ss k
+    | isSpace s  = textUntil close tok (s:acc) pos (white s p) ss k
+    | otherwise  = textUntil close tok (s:acc) pos (addcol 1 p) ss k
+
+textOrRefUntil close tok acc pos p [] k =
+    lexerror ("unexpected EOF while looking for closing token "++close
+              ++"\n  to match the opening token in "++show pos) p
+textOrRefUntil close tok acc pos p (s:ss) k
+    | close `prefixes` (s:ss)  = emit (TokFreeText (reverse acc)) pos:
+                                 emit tok p:
+                                 skip (length close-1) (addcol 1 p) ss k
+    | s=='&'     = (if not (null acc)
+                       then (emit (TokFreeText (reverse acc)) pos:)
+                       else id)
+                   (emit TokAmp p:
+                    textUntil ";" TokSemi "" p (addcol 1 p) ss
+                        (\p' i-> textOrRefUntil close tok "" p p' i k))
+    | isSpace s  = textOrRefUntil close tok (s:acc) pos (white s p) ss k
+    | otherwise  = textOrRefUntil close tok (s:acc) pos (addcol 1 p) ss k
+
+----
+
+-- | The first argument to 'xmlLex' is the filename (used for source positions,
+--   especially in error messages), and the second is the string content of
+--   the XML file.
+xmlLex :: String -> String -> [Token]
+xmlLex filename = xmlAny [] (posInNewCxt filename Nothing)
+
+-- | 'xmlReLex' is used when the parser expands a macro (PE reference).
+--    The expansion of the macro must be re-lexed as if for the first time.
+xmlReLex :: Posn -> String -> [Token]
+xmlReLex p s
+      | "INCLUDE"  `prefixes` s  = emit (TokSection INCLUDEx) p: k 7
+      | "IGNORE"   `prefixes` s  = emit (TokSection IGNOREx) p:  k 6
+      | otherwise = blank xmlAny [] p s
+  where
+    k n = skip n p s (blank xmlAny [])
+
+-- | 'reLexEntityValue' is used solely within parsing an entityvalue.
+--   Normally, a PERef is logically separated from its surroundings by
+--   whitespace.  But in an entityvalue, a PERef can be juxtaposed to
+--   an identifier, so the expansion forms a new identifier.
+--   Thus the need to rescan the whole text for possible PERefs.
+reLexEntityValue :: (String->Maybe String) -> Posn -> String -> [Token]
+reLexEntityValue lookup p s =
+    textOrRefUntil "%" TokNull [] p p (expand s++"%") (xmlAny [])
+  where
+    expand []       = []
+    expand ('%':ss) = let (sym,rest) = break (==';') ss in
+                      case lookup sym of
+                        Just val -> expand val ++ expand (tail rest)
+                        Nothing  -> "%"++sym++";"++ expand (tail rest) -- hmmm
+    expand (s:ss)   = s: expand ss
+
+--xmltop :: Posn -> String -> [Token]
+--xmltop p [] = []
+--xmltop p s
+--    | "<?"   `prefixes` s = emit TokPIOpen p:      next 2 (xmlPI [InTag "<?...?>"])
+--    | "<!--" `prefixes` s = emit TokCommentOpen p: next 4 (xmlComment [])
+--    | "<!"   `prefixes` s = emit TokSpecialOpen p: next 2 (xmlSpecial [InTag "<!...>"])
+--    | otherwise           = lexerror "expected <?xml?> or <!DOCTYPE>" p
+--  where next n k = skip n p s k
+
+xmlPI      w p s = xmlName p s "name of processor in <? ?>" (blank xmlPIEnd w)
+xmlPIEnd   w p s = textUntil "?>"  TokPIClose "" p p s (blank xmlAny (tail w))
+xmlComment w p s = textUntil "-->" TokCommentClose "" p p s (blank xmlAny w)
+
+-- Note: the order of the clauses in xmlAny is very important.
+-- Some matches must precede the NotInTag test, the rest must follow it.
+xmlAny :: [Where] -> Posn -> String -> [Token]
+xmlAny  (InTag t:_)  p [] = lexerror ("unexpected EOF within "++t) p
+xmlAny          _    p [] = []
+xmlAny w p s@('<':ss)
+    | "?"   `prefixes` ss = emit TokPIOpen p:
+                                         skip 2 p s (xmlPI (InTag "<?...?>":w))
+    | "!--" `prefixes` ss = emit TokCommentOpen p: skip 4 p s (xmlComment w)
+    | "!["  `prefixes` ss = emit TokSectionOpen p: skip 3 p s (xmlSection w)
+    | "!"   `prefixes` ss = emit TokSpecialOpen p:
+                                     skip 2 p s (xmlSpecial (InTag "<!...>":w))
+    | "/"   `prefixes` ss = emit TokEndOpen p: 
+                                    skip 2 p s (xmlTag (InTag "</...>":tail w))
+    | otherwise           = emit TokAnyOpen p:
+                                 skip 1 p s (xmlTag (InTag "<...>":NotInTag:w))
+xmlAny (_:_:w) p s@('/':ss)
+    | ">"   `prefixes` ss = emit TokEndClose p: skip 2 p s (xmlAny w)
+xmlAny w p ('&':ss) = emit TokAmp p:      textUntil ";" TokSemi "" p
+                                                     (addcol 1 p) ss (xmlAny w)
+xmlAny w@(NotInTag:_) p s = xmlContent "" w p p s
+-- everything below here is implicitly InTag.
+xmlAny w p ('>':ss) = emit TokAnyClose p: xmlAny (tail w) (addcol 1 p) ss
+xmlAny w p ('[':ss) = emit TokSqOpen p:
+                                 blank xmlAny (InTag "[...]":w) (addcol 1 p) ss
+xmlAny w p (']':ss)
+    | "]>" `prefixes` ss  =
+                 emit TokSectionClose p:  skip 3 p (']':ss) (xmlAny (tail w))
+    | otherwise  =    emit TokSqClose p:  blank xmlAny (tail w) (addcol 1 p) ss
+xmlAny w p ('(':ss) = emit TokBraOpen p:
+                                 blank xmlAny (InTag "(...)":w) (addcol 1 p) ss
+xmlAny w p (')':ss) = emit TokBraClose p: blank xmlAny (tail w) (addcol 1 p) ss
+xmlAny w p ('=':ss) = emit TokEqual p:    blank xmlAny w (addcol 1 p) ss
+xmlAny w p ('*':ss) = emit TokStar p:     blank xmlAny w (addcol 1 p) ss
+xmlAny w p ('+':ss) = emit TokPlus p:     blank xmlAny w (addcol 1 p) ss
+xmlAny w p ('?':ss) = emit TokQuery p:    blank xmlAny w (addcol 1 p) ss
+xmlAny w p ('|':ss) = emit TokPipe p:     blank xmlAny w (addcol 1 p) ss
+xmlAny w p ('%':ss) = emit TokPercent p:  blank xmlAny w (addcol 1 p) ss
+xmlAny w p (';':ss) = emit TokSemi p:     blank xmlAny w (addcol 1 p) ss
+xmlAny w p (',':ss) = emit TokComma p:    blank xmlAny w (addcol 1 p) ss
+xmlAny w p ('#':ss) = emit TokHash p:     blank xmlAny w (addcol 1 p) ss
+xmlAny w p ('"':ss) = emit TokQuote p:    textOrRefUntil "\"" TokQuote "" p1
+                                                          p1 ss (xmlAny w)
+                                             where p1 = addcol 1 p
+xmlAny w p ('\'':ss) = emit TokQuote p:   textOrRefUntil "'" TokQuote "" p1
+                                                          p1 ss (xmlAny w)
+                                             where p1 = addcol 1 p
+xmlAny w p s
+    | isSpace (head s)     = blank xmlAny w p s
+    | isAlphaNum (head s) || (head s)`elem`":_"
+                           = xmlName p s "some kind of name" (blank xmlAny w)
+    | otherwise            = lexerror ("unrecognised token: "++take 4 s) p
+
+xmlTag w p s = xmlName p s "tagname for element in < >" (blank xmlAny w)
+
+xmlSection = blank xmlSection0
+  where
+    xmlSection0 w p s
+      | "CDATA["   `prefixes` s  = emit (TokSection CDATAx) p:  accum w p s 6
+      | "INCLUDE"  `prefixes` s  = emit (TokSection INCLUDEx) p:    k w p s 7
+      | "IGNORE"   `prefixes` s  = emit (TokSection IGNOREx) p:     k w p s 6
+      | "%"        `prefixes` s  = emit TokPercent p:               k w p s 1
+      | otherwise = lexerror ("expected CDATA, IGNORE, or INCLUDE, but got "
+                             ++take 7 s) p
+    accum w p s n =
+      let p0 = addcol n p in
+      textUntil "]]>" TokSectionClose "" p0 p0 (drop n s) (blank xmlAny w)
+    k w p s n =
+      skip n p s (xmlAny ({-InTag "<![section[ ... ]]>": -}w))
+
+xmlSpecial w p s
+    | "DOCTYPE"  `prefixes` s = emit (TokSpecial DOCTYPEx)  p: k 7
+    | "ELEMENT"  `prefixes` s = emit (TokSpecial ELEMENTx)  p: k 7
+    | "ATTLIST"  `prefixes` s = emit (TokSpecial ATTLISTx)  p: k 7
+    | "ENTITY"   `prefixes` s = emit (TokSpecial ENTITYx)   p: k 6
+    | "NOTATION" `prefixes` s = emit (TokSpecial NOTATIONx) p: k 8
+    | otherwise = lexerror
+                    ("expected DOCTYPE, ELEMENT, ENTITY, ATTLIST, or NOTATION,"
+                    ++" but got "++take 7 s) p
+  where k n = skip n p s (blank xmlAny w)
+
+xmlName p (s:ss) cxt k
+    | isAlphaNum s || s==':' || s=='_'  = gatherName (s:[]) p (addcol 1 p) ss k
+    | otherwise   = lexerror ("expected a "++cxt++", but got char "++show s) p
+  where
+    gatherName acc pos p [] k =
+        emit (TokName (reverse acc)) pos: k p []
+    --  lexerror ("unexpected EOF in name at "++show pos) p
+    gatherName acc pos p (s:ss) k
+        | isAlphaNum s || s `elem` ".-_:"
+                      = gatherName (s:acc) pos (addcol 1 p) ss k
+        | otherwise   = emit (TokName (reverse acc)) pos: k p (s:ss)
+xmlName p [] cxt k = lexerror ("expected a "++cxt++", but got end of input") p
+
+xmlContent acc w pos p [] = if all isSpace acc then []
+                            else lexerror "unexpected EOF between tags" p
+xmlContent acc w pos p (s:ss)
+    | elem s "<&"    = {- if all isSpace acc then xmlAny w p (s:ss) else -}
+                       emit (TokFreeText (reverse acc)) pos: xmlAny w p (s:ss)
+    | isSpace s      = xmlContent (s:acc) w pos (white s p) ss
+    | otherwise      = xmlContent (s:acc) w pos (addcol 1 p) ss
+
+
+
+--ident :: (String->TokenT) ->
+--          Posn -> String -> [String] ->
+--         (Posn->String->[String]->[Token]) -> [Token]
+--ident tok p s ss k =
+--    let (name,s0) = span (\c-> isAlphaNum c || c `elem` "`-_#.'/\\") s
+--    in emit (tok name) p: skip (length name) p s ss k
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/OneOfN.html b/docs/HaXml/src/Text/XML/HaXml/OneOfN.html
--- a/docs/HaXml/src/Text/XML/HaXml/OneOfN.html
+++ b/docs/HaXml/src/Text/XML/HaXml/OneOfN.html
@@ -1,667 +1,673 @@
 
 
-
module Text.XML.HaXml.OneOfN where
-
-import Text.XML.HaXml.XmlContent
-
-data OneOf2 a b
-    = OneOf2 a | TwoOf2 b
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b)
-    => HTypeable (OneOf2 a b)
-  where      toHType _ = Defined "OneOf2" [] []
-  --         toHType m = Defined "OneOf2" [a,b] []
-  --            where a = toHType $ (\ (OneOf2 a)->a) $ m
-  --                  b = toHType $ (\ (TwoOf2 b)->b) $ m
-
-
-instance (XmlContent a,XmlContent b)
-    => XmlContent (OneOf2 a b)
-  where
-    parseContents =
-        (choice OneOf2 $ choice TwoOf2
-        $ fail "OneOf2")
-    toContents (OneOf2 x) = toContents x
-    toContents (TwoOf2 x) = toContents x
-
-----
-data OneOf3 a b c
-    = OneOf3 a | TwoOf3 b | ThreeOf3 c
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c)
-    => HTypeable (OneOf3 a b c)
-  where      toHType _ = Defined "OneOf3" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c)
-    => XmlContent (OneOf3 a b c)
-  where
-    parseContents =
-        (choice OneOf3 $ choice TwoOf3 $ choice ThreeOf3
-        $ fail "OneOf3")
-    toContents (OneOf3 x) = toContents x
-    toContents (TwoOf3 x) = toContents x
-    toContents (ThreeOf3 x) = toContents x
-
-----
-data OneOf4 a b c d
-    = OneOf4 a | TwoOf4 b | ThreeOf4 c | FourOf4 d
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d)
-    => HTypeable (OneOf4 a b c d)
-  where      toHType _ = Defined "OneOf4" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d)
-    => XmlContent (OneOf4 a b c d)
-  where
-    parseContents =
-        (choice OneOf4 $ choice TwoOf4 $ choice ThreeOf4 $ choice FourOf4
-        $ fail "OneOf4")
-    toContents (OneOf4 x) = toContents x
-    toContents (TwoOf4 x) = toContents x
-    toContents (ThreeOf4 x) = toContents x
-    toContents (FourOf4 x) = toContents x
-
-----
-data OneOf5 a b c d e
-    = OneOf5 a | TwoOf5 b | ThreeOf5 c | FourOf5 d | FiveOf5 e
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e)
-    => HTypeable (OneOf5 a b c d e)
-  where      toHType _ = Defined "OneOf5" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e)
-    => XmlContent (OneOf5 a b c d e)
-  where
-    parseContents =
-        (choice OneOf5 $ choice TwoOf5 $ choice ThreeOf5 $ choice FourOf5
-        $ choice FiveOf5
-        $ fail "OneOf5")
-    toContents (OneOf5 x) = toContents x
-    toContents (TwoOf5 x) = toContents x
-    toContents (ThreeOf5 x) = toContents x
-    toContents (FourOf5 x) = toContents x
-    toContents (FiveOf5 x) = toContents x
-
-----
-data OneOf6 a b c d e f
-    = OneOf6 a | TwoOf6 b | ThreeOf6 c | FourOf6 d | FiveOf6 e | SixOf6 f
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f)
-    => HTypeable (OneOf6 a b c d e f)
-  where      toHType _ = Defined "OneOf6" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f)
-    => XmlContent (OneOf6 a b c d e f)
-  where
-    parseContents =
-        (choice OneOf6 $ choice TwoOf6 $ choice ThreeOf6 $ choice FourOf6
-        $ choice FiveOf6 $ choice SixOf6
-        $ fail "OneOf6")
-    toContents (OneOf6 x) = toContents x
-    toContents (TwoOf6 x) = toContents x
-    toContents (ThreeOf6 x) = toContents x
-    toContents (FourOf6 x) = toContents x
-    toContents (FiveOf6 x) = toContents x
-    toContents (SixOf6 x) = toContents x
-
-----
-data OneOf7 a b c d e f g
-    = OneOf7 a | TwoOf7 b | ThreeOf7 c | FourOf7 d | FiveOf7 e | SixOf7 f
-    | SevenOf7 g
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g)
-    => HTypeable (OneOf7 a b c d e f g)
-  where      toHType _ = Defined "OneOf7" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g)
-    => XmlContent (OneOf7 a b c d e f g)
-  where
-    parseContents =
-        (choice OneOf7 $ choice TwoOf7 $ choice ThreeOf7 $ choice FourOf7
-        $ choice FiveOf7 $ choice SixOf7 $ choice SevenOf7
-        $ fail "OneOf7")
-    toContents (OneOf7 x) = toContents x
-    toContents (TwoOf7 x) = toContents x
-    toContents (ThreeOf7 x) = toContents x
-    toContents (FourOf7 x) = toContents x
-    toContents (FiveOf7 x) = toContents x
-    toContents (SixOf7 x) = toContents x
-    toContents (SevenOf7 x) = toContents x
-
-----
-data OneOf8 a b c d e f g h
-    = OneOf8 a | TwoOf8 b | ThreeOf8 c | FourOf8 d | FiveOf8 e | SixOf8 f
-    | SevenOf8 g | EightOf8 h
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g,HTypeable h)
-    => HTypeable (OneOf8 a b c d e f g h)
-  where      toHType _ = Defined "OneOf8" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g,XmlContent h)
-    => XmlContent (OneOf8 a b c d e f g h)
-  where
-    parseContents =
-        (choice OneOf8 $ choice TwoOf8 $ choice ThreeOf8 $ choice FourOf8
-        $ choice FiveOf8 $ choice SixOf8 $ choice SevenOf8 $ choice EightOf8
-        $ fail "OneOf8")
-    toContents (OneOf8 x) = toContents x
-    toContents (TwoOf8 x) = toContents x
-    toContents (ThreeOf8 x) = toContents x
-    toContents (FourOf8 x) = toContents x
-    toContents (FiveOf8 x) = toContents x
-    toContents (SixOf8 x) = toContents x
-    toContents (SevenOf8 x) = toContents x
-    toContents (EightOf8 x) = toContents x
-
-----
-data OneOf9 a b c d e f g h i
-    = OneOf9 a | TwoOf9 b | ThreeOf9 c | FourOf9 d | FiveOf9 e | SixOf9 f
-    | SevenOf9 g | EightOf9 h | NineOf9 i
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i)
-    => HTypeable (OneOf9 a b c d e f g h i)
-  where      toHType _ = Defined "OneOf9" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i)
-    => XmlContent (OneOf9 a b c d e f g h i)
-  where
-    parseContents =
-        (choice OneOf9 $ choice TwoOf9 $ choice ThreeOf9 $ choice FourOf9
-        $ choice FiveOf9 $ choice SixOf9 $ choice SevenOf9 $ choice EightOf9
-        $ choice NineOf9
-        $ fail "OneOf9")
-    toContents (OneOf9 x) = toContents x
-    toContents (TwoOf9 x) = toContents x
-    toContents (ThreeOf9 x) = toContents x
-    toContents (FourOf9 x) = toContents x
-    toContents (FiveOf9 x) = toContents x
-    toContents (SixOf9 x) = toContents x
-    toContents (SevenOf9 x) = toContents x
-    toContents (EightOf9 x) = toContents x
-    toContents (NineOf9 x) = toContents x
-
-----
-data OneOf10 a b c d e f g h i j
-    = OneOf10 a | TwoOf10 b | ThreeOf10 c | FourOf10 d | FiveOf10 e
-    | SixOf10 f | SevenOf10 g | EightOf10 h | NineOf10 i | TenOf10 j
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j)
-    => HTypeable (OneOf10 a b c d e f g h i j)
-  where      toHType _ = Defined "OneOf10" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j)
-    => XmlContent (OneOf10 a b c d e f g h i j)
-  where
-    parseContents =
-        (choice OneOf10 $ choice TwoOf10 $ choice ThreeOf10 $ choice FourOf10
-        $ choice FiveOf10 $ choice SixOf10 $ choice SevenOf10
-        $ choice EightOf10 $ choice NineOf10 $ choice TenOf10
-        $ fail "OneOf10")
-    toContents (OneOf10 x) = toContents x
-    toContents (TwoOf10 x) = toContents x
-    toContents (ThreeOf10 x) = toContents x
-    toContents (FourOf10 x) = toContents x
-    toContents (FiveOf10 x) = toContents x
-    toContents (SixOf10 x) = toContents x
-    toContents (SevenOf10 x) = toContents x
-    toContents (EightOf10 x) = toContents x
-    toContents (NineOf10 x) = toContents x
-    toContents (TenOf10 x) = toContents x
-
-----
-data OneOf11 a b c d e f g h i j k
-    = OneOf11 a | TwoOf11 b | ThreeOf11 c | FourOf11 d | FiveOf11 e
-    | SixOf11 f | SevenOf11 g | EightOf11 h | NineOf11 i | TenOf11 j
-    | ElevenOf11 k
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
-          ,HTypeable k)
-    => HTypeable (OneOf11 a b c d e f g h i j k)
-  where      toHType _ = Defined "OneOf11" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
-          ,XmlContent k)
-    => XmlContent (OneOf11 a b c d e f g h i j k)
-  where
-    parseContents =
-        (choice OneOf11 $ choice TwoOf11 $ choice ThreeOf11 $ choice FourOf11
-        $ choice FiveOf11 $ choice SixOf11 $ choice SevenOf11
-        $ choice EightOf11 $ choice NineOf11 $ choice TenOf11
-        $ choice ElevenOf11
-        $ fail "OneOf11")
-    toContents (OneOf11 x) = toContents x
-    toContents (TwoOf11 x) = toContents x
-    toContents (ThreeOf11 x) = toContents x
-    toContents (FourOf11 x) = toContents x
-    toContents (FiveOf11 x) = toContents x
-    toContents (SixOf11 x) = toContents x
-    toContents (SevenOf11 x) = toContents x
-    toContents (EightOf11 x) = toContents x
-    toContents (NineOf11 x) = toContents x
-    toContents (TenOf11 x) = toContents x
-    toContents (ElevenOf11 x) = toContents x
-
-----
-data OneOf12 a b c d e f g h i j k l
-    = OneOf12 a | TwoOf12 b | ThreeOf12 c | FourOf12 d | FiveOf12 e
-    | SixOf12 f | SevenOf12 g | EightOf12 h | NineOf12 i | TenOf12 j
-    | ElevenOf12 k | TwelveOf12 l
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
-          ,HTypeable k,HTypeable l)
-    => HTypeable (OneOf12 a b c d e f g h i j k l)
-  where      toHType _ = Defined "OneOf12" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
-          ,XmlContent k,XmlContent l)
-    => XmlContent (OneOf12 a b c d e f g h i j k l)
-  where
-    parseContents =
-        (choice OneOf12 $ choice TwoOf12 $ choice ThreeOf12 $ choice FourOf12
-        $ choice FiveOf12 $ choice SixOf12 $ choice SevenOf12
-        $ choice EightOf12 $ choice NineOf12 $ choice TenOf12
-        $ choice ElevenOf12 $ choice TwelveOf12
-        $ fail "OneOf12")
-    toContents (OneOf12 x) = toContents x
-    toContents (TwoOf12 x) = toContents x
-    toContents (ThreeOf12 x) = toContents x
-    toContents (FourOf12 x) = toContents x
-    toContents (FiveOf12 x) = toContents x
-    toContents (SixOf12 x) = toContents x
-    toContents (SevenOf12 x) = toContents x
-    toContents (EightOf12 x) = toContents x
-    toContents (NineOf12 x) = toContents x
-    toContents (TenOf12 x) = toContents x
-    toContents (ElevenOf12 x) = toContents x
-    toContents (TwelveOf12 x) = toContents x
-
-----
-data OneOf13 a b c d e f g h i j k l m
-    = OneOf13 a | TwoOf13 b | ThreeOf13 c | FourOf13 d | FiveOf13 e
-    | SixOf13 f | SevenOf13 g | EightOf13 h | NineOf13 i | TenOf13 j
-    | ElevenOf13 k | TwelveOf13 l | ThirteenOf13 m
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
-          ,HTypeable k,HTypeable l,HTypeable m)
-    => HTypeable (OneOf13 a b c d e f g h i j k l m)
-  where      toHType _ = Defined "OneOf13" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
-          ,XmlContent k,XmlContent l,XmlContent m)
-    => XmlContent (OneOf13 a b c d e f g h i j k l m)
-  where
-    parseContents =
-        (choice OneOf13 $ choice TwoOf13 $ choice ThreeOf13 $ choice FourOf13
-        $ choice FiveOf13 $ choice SixOf13 $ choice SevenOf13
-        $ choice EightOf13 $ choice NineOf13 $ choice TenOf13
-        $ choice ElevenOf13 $ choice TwelveOf13 $ choice ThirteenOf13
-        $ fail "OneOf13")
-    toContents (OneOf13 x) = toContents x
-    toContents (TwoOf13 x) = toContents x
-    toContents (ThreeOf13 x) = toContents x
-    toContents (FourOf13 x) = toContents x
-    toContents (FiveOf13 x) = toContents x
-    toContents (SixOf13 x) = toContents x
-    toContents (SevenOf13 x) = toContents x
-    toContents (EightOf13 x) = toContents x
-    toContents (NineOf13 x) = toContents x
-    toContents (TenOf13 x) = toContents x
-    toContents (ElevenOf13 x) = toContents x
-    toContents (TwelveOf13 x) = toContents x
-    toContents (ThirteenOf13 x) = toContents x
-
-----
-data OneOf14 a b c d e f g h i j k l m n
-    = OneOf14 a | TwoOf14 b | ThreeOf14 c | FourOf14 d | FiveOf14 e
-    | SixOf14 f | SevenOf14 g | EightOf14 h | NineOf14 i | TenOf14 j
-    | ElevenOf14 k | TwelveOf14 l | ThirteenOf14 m | FourteenOf14 n
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
-          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n)
-    => HTypeable (OneOf14 a b c d e f g h i j k l m n)
-  where      toHType _ = Defined "OneOf14" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
-          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n)
-    => XmlContent (OneOf14 a b c d e f g h i j k l m n)
-  where
-    parseContents =
-        (choice OneOf14 $ choice TwoOf14 $ choice ThreeOf14 $ choice FourOf14
-        $ choice FiveOf14 $ choice SixOf14 $ choice SevenOf14
-        $ choice EightOf14 $ choice NineOf14 $ choice TenOf14
-        $ choice ElevenOf14 $ choice TwelveOf14 $ choice ThirteenOf14
-        $ choice FourteenOf14
-        $ fail "OneOf14")
-    toContents (OneOf14 x) = toContents x
-    toContents (TwoOf14 x) = toContents x
-    toContents (ThreeOf14 x) = toContents x
-    toContents (FourOf14 x) = toContents x
-    toContents (FiveOf14 x) = toContents x
-    toContents (SixOf14 x) = toContents x
-    toContents (SevenOf14 x) = toContents x
-    toContents (EightOf14 x) = toContents x
-    toContents (NineOf14 x) = toContents x
-    toContents (TenOf14 x) = toContents x
-    toContents (ElevenOf14 x) = toContents x
-    toContents (TwelveOf14 x) = toContents x
-    toContents (ThirteenOf14 x) = toContents x
-    toContents (FourteenOf14 x) = toContents x
-
-----
-data OneOf15 a b c d e f g h i j k l m n o
-    = OneOf15 a | TwoOf15 b | ThreeOf15 c | FourOf15 d | FiveOf15 e
-    | SixOf15 f | SevenOf15 g | EightOf15 h | NineOf15 i | TenOf15 j
-    | ElevenOf15 k | TwelveOf15 l | ThirteenOf15 m | FourteenOf15 n
-    | FifteenOf15 o
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
-          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o)
-    => HTypeable (OneOf15 a b c d e f g h i j k l m n o)
-  where      toHType _ = Defined "OneOf15" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
-          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o)
-    => XmlContent (OneOf15 a b c d e f g h i j k l m n o)
-  where
-    parseContents =
-        (choice OneOf15 $ choice TwoOf15 $ choice ThreeOf15 $ choice FourOf15
-        $ choice FiveOf15 $ choice SixOf15 $ choice SevenOf15
-        $ choice EightOf15 $ choice NineOf15 $ choice TenOf15
-        $ choice ElevenOf15 $ choice TwelveOf15 $ choice ThirteenOf15
-        $ choice FourteenOf15 $ choice FifteenOf15
-        $ fail "OneOf15")
-    toContents (OneOf15 x) = toContents x
-    toContents (TwoOf15 x) = toContents x
-    toContents (ThreeOf15 x) = toContents x
-    toContents (FourOf15 x) = toContents x
-    toContents (FiveOf15 x) = toContents x
-    toContents (SixOf15 x) = toContents x
-    toContents (SevenOf15 x) = toContents x
-    toContents (EightOf15 x) = toContents x
-    toContents (NineOf15 x) = toContents x
-    toContents (TenOf15 x) = toContents x
-    toContents (ElevenOf15 x) = toContents x
-    toContents (TwelveOf15 x) = toContents x
-    toContents (ThirteenOf15 x) = toContents x
-    toContents (FourteenOf15 x) = toContents x
-    toContents (FifteenOf15 x) = toContents x
-
-----
-data OneOf16 a b c d e f g h i j k l m n o p
-    = OneOf16 a | TwoOf16 b | ThreeOf16 c | FourOf16 d | FiveOf16 e
-    | SixOf16 f | SevenOf16 g | EightOf16 h | NineOf16 i | TenOf16 j
-    | ElevenOf16 k | TwelveOf16 l | ThirteenOf16 m | FourteenOf16 n
-    | FifteenOf16 o | SixteenOf16 p
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
-          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o
-          ,HTypeable p)
-    => HTypeable (OneOf16 a b c d e f g h i j k l m n o p)
-  where      toHType _ = Defined "OneOf16" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
-          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o
-          ,XmlContent p)
-    => XmlContent (OneOf16 a b c d e f g h i j k l m n o p)
-  where
-    parseContents =
-        (choice OneOf16 $ choice TwoOf16 $ choice ThreeOf16 $ choice FourOf16
-        $ choice FiveOf16 $ choice SixOf16 $ choice SevenOf16
-        $ choice EightOf16 $ choice NineOf16 $ choice TenOf16
-        $ choice ElevenOf16 $ choice TwelveOf16 $ choice ThirteenOf16
-        $ choice FourteenOf16 $ choice FifteenOf16 $ choice SixteenOf16
-        $ fail "OneOf16")
-    toContents (OneOf16 x) = toContents x
-    toContents (TwoOf16 x) = toContents x
-    toContents (ThreeOf16 x) = toContents x
-    toContents (FourOf16 x) = toContents x
-    toContents (FiveOf16 x) = toContents x
-    toContents (SixOf16 x) = toContents x
-    toContents (SevenOf16 x) = toContents x
-    toContents (EightOf16 x) = toContents x
-    toContents (NineOf16 x) = toContents x
-    toContents (TenOf16 x) = toContents x
-    toContents (ElevenOf16 x) = toContents x
-    toContents (TwelveOf16 x) = toContents x
-    toContents (ThirteenOf16 x) = toContents x
-    toContents (FourteenOf16 x) = toContents x
-    toContents (FifteenOf16 x) = toContents x
-    toContents (SixteenOf16 x) = toContents x
-
-----
-data OneOf17 a b c d e f g h i j k l m n o p q
-    = OneOf17 a | TwoOf17 b | ThreeOf17 c | FourOf17 d | FiveOf17 e
-    | SixOf17 f | SevenOf17 g | EightOf17 h | NineOf17 i | TenOf17 j
-    | ElevenOf17 k | TwelveOf17 l | ThirteenOf17 m | FourteenOf17 n
-    | FifteenOf17 o | SixteenOf17 p | SeventeenOf17 q
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
-          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o
-          ,HTypeable p,HTypeable q)
-    => HTypeable (OneOf17 a b c d e f g h i j k l m n o p q)
-  where      toHType _ = Defined "OneOf17" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
-          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o
-          ,XmlContent p,XmlContent q)
-    => XmlContent (OneOf17 a b c d e f g h i j k l m n o p q)
-  where
-    parseContents =
-        (choice OneOf17 $ choice TwoOf17 $ choice ThreeOf17 $ choice FourOf17
-        $ choice FiveOf17 $ choice SixOf17 $ choice SevenOf17
-        $ choice EightOf17 $ choice NineOf17 $ choice TenOf17
-        $ choice ElevenOf17 $ choice TwelveOf17 $ choice ThirteenOf17
-        $ choice FourteenOf17 $ choice FifteenOf17 $ choice SixteenOf17
-        $ choice SeventeenOf17
-        $ fail "OneOf17")
-    toContents (OneOf17 x) = toContents x
-    toContents (TwoOf17 x) = toContents x
-    toContents (ThreeOf17 x) = toContents x
-    toContents (FourOf17 x) = toContents x
-    toContents (FiveOf17 x) = toContents x
-    toContents (SixOf17 x) = toContents x
-    toContents (SevenOf17 x) = toContents x
-    toContents (EightOf17 x) = toContents x
-    toContents (NineOf17 x) = toContents x
-    toContents (TenOf17 x) = toContents x
-    toContents (ElevenOf17 x) = toContents x
-    toContents (TwelveOf17 x) = toContents x
-    toContents (ThirteenOf17 x) = toContents x
-    toContents (FourteenOf17 x) = toContents x
-    toContents (FifteenOf17 x) = toContents x
-    toContents (SixteenOf17 x) = toContents x
-    toContents (SeventeenOf17 x) = toContents x
-
-----
-data OneOf18 a b c d e f g h i j k l m n o p q r
-    = OneOf18 a | TwoOf18 b | ThreeOf18 c | FourOf18 d | FiveOf18 e
-    | SixOf18 f | SevenOf18 g | EightOf18 h | NineOf18 i | TenOf18 j
-    | ElevenOf18 k | TwelveOf18 l | ThirteenOf18 m | FourteenOf18 n
-    | FifteenOf18 o | SixteenOf18 p | SeventeenOf18 q | EighteenOf18 r
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
-          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o
-          ,HTypeable p,HTypeable q,HTypeable r)
-    => HTypeable (OneOf18 a b c d e f g h i j k l m n o p q r)
-  where      toHType _ = Defined "OneOf18" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
-          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o
-          ,XmlContent p,XmlContent q,XmlContent r)
-    => XmlContent (OneOf18 a b c d e f g h i j k l m n o p q r)
-  where
-    parseContents =
-        (choice OneOf18 $ choice TwoOf18 $ choice ThreeOf18 $ choice FourOf18
-        $ choice FiveOf18 $ choice SixOf18 $ choice SevenOf18
-        $ choice EightOf18 $ choice NineOf18 $ choice TenOf18
-        $ choice ElevenOf18 $ choice TwelveOf18 $ choice ThirteenOf18
-        $ choice FourteenOf18 $ choice FifteenOf18 $ choice SixteenOf18
-        $ choice SeventeenOf18 $ choice EighteenOf18
-        $ fail "OneOf18")
-    toContents (OneOf18 x) = toContents x
-    toContents (TwoOf18 x) = toContents x
-    toContents (ThreeOf18 x) = toContents x
-    toContents (FourOf18 x) = toContents x
-    toContents (FiveOf18 x) = toContents x
-    toContents (SixOf18 x) = toContents x
-    toContents (SevenOf18 x) = toContents x
-    toContents (EightOf18 x) = toContents x
-    toContents (NineOf18 x) = toContents x
-    toContents (TenOf18 x) = toContents x
-    toContents (ElevenOf18 x) = toContents x
-    toContents (TwelveOf18 x) = toContents x
-    toContents (ThirteenOf18 x) = toContents x
-    toContents (FourteenOf18 x) = toContents x
-    toContents (FifteenOf18 x) = toContents x
-    toContents (SixteenOf18 x) = toContents x
-    toContents (SeventeenOf18 x) = toContents x
-    toContents (EighteenOf18 x) = toContents x
-
-----
-data OneOf19 a b c d e f g h i j k l m n o p q r s
-    = OneOf19 a | TwoOf19 b | ThreeOf19 c | FourOf19 d | FiveOf19 e
-    | SixOf19 f | SevenOf19 g | EightOf19 h | NineOf19 i | TenOf19 j
-    | ElevenOf19 k | TwelveOf19 l | ThirteenOf19 m | FourteenOf19 n
-    | FifteenOf19 o | SixteenOf19 p | SeventeenOf19 q | EighteenOf19 r
-    | NineteenOf19 s
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
-          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o
-          ,HTypeable p,HTypeable q,HTypeable r,HTypeable s)
-    => HTypeable (OneOf19 a b c d e f g h i j k l m n o p q r s)
-  where      toHType _ = Defined "OneOf19" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
-          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o
-          ,XmlContent p,XmlContent q,XmlContent r,XmlContent s)
-    => XmlContent (OneOf19 a b c d e f g h i j k l m n o p q r s)
-  where
-    parseContents =
-        (choice OneOf19 $ choice TwoOf19 $ choice ThreeOf19 $ choice FourOf19
-        $ choice FiveOf19 $ choice SixOf19 $ choice SevenOf19
-        $ choice EightOf19 $ choice NineOf19 $ choice TenOf19
-        $ choice ElevenOf19 $ choice TwelveOf19 $ choice ThirteenOf19
-        $ choice FourteenOf19 $ choice FifteenOf19 $ choice SixteenOf19
-        $ choice SeventeenOf19 $ choice EighteenOf19 $ choice NineteenOf19
-        $ fail "OneOf19")
-    toContents (OneOf19 x) = toContents x
-    toContents (TwoOf19 x) = toContents x
-    toContents (ThreeOf19 x) = toContents x
-    toContents (FourOf19 x) = toContents x
-    toContents (FiveOf19 x) = toContents x
-    toContents (SixOf19 x) = toContents x
-    toContents (SevenOf19 x) = toContents x
-    toContents (EightOf19 x) = toContents x
-    toContents (NineOf19 x) = toContents x
-    toContents (TenOf19 x) = toContents x
-    toContents (ElevenOf19 x) = toContents x
-    toContents (TwelveOf19 x) = toContents x
-    toContents (ThirteenOf19 x) = toContents x
-    toContents (FourteenOf19 x) = toContents x
-    toContents (FifteenOf19 x) = toContents x
-    toContents (SixteenOf19 x) = toContents x
-    toContents (SeventeenOf19 x) = toContents x
-    toContents (EighteenOf19 x) = toContents x
-    toContents (NineteenOf19 x) = toContents x
-
-----
-data OneOf20 a b c d e f g h i j k l m n o p q r s t
-    = OneOf20 a | TwoOf20 b | ThreeOf20 c | FourOf20 d | FiveOf20 e
-    | SixOf20 f | SevenOf20 g | EightOf20 h | NineOf20 i | TenOf20 j
-    | ElevenOf20 k | TwelveOf20 l | ThirteenOf20 m | FourteenOf20 n
-    | FifteenOf20 o | SixteenOf20 p | SeventeenOf20 q | EighteenOf20 r
-    | NineteenOf20 s | TwentyOf20 t
-    deriving (Eq,Show)
-
-instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
-          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
-          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o
-          ,HTypeable p,HTypeable q,HTypeable r,HTypeable s,HTypeable t)
-    => HTypeable (OneOf20 a b c d e f g h i j k l m n o p q r s t)
-  where      toHType _ = Defined "OneOf20" [] []
-
-instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
-          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
-          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o
-          ,XmlContent p,XmlContent q,XmlContent r,XmlContent s,XmlContent t)
-    => XmlContent (OneOf20 a b c d e f g h i j k l m n o p q r s t)
-  where
-    parseContents =
-        (choice OneOf20 $ choice TwoOf20 $ choice ThreeOf20 $ choice FourOf20
-        $ choice FiveOf20 $ choice SixOf20 $ choice SevenOf20
-        $ choice EightOf20 $ choice NineOf20 $ choice TenOf20
-        $ choice ElevenOf20 $ choice TwelveOf20 $ choice ThirteenOf20
-        $ choice FourteenOf20 $ choice FifteenOf20 $ choice SixteenOf20
-        $ choice SeventeenOf20 $ choice EighteenOf20 $ choice NineteenOf20
-        $ choice TwentyOf20
-        $ fail "OneOf20")
-    toContents (OneOf20 x) = toContents x
-    toContents (TwoOf20 x) = toContents x
-    toContents (ThreeOf20 x) = toContents x
-    toContents (FourOf20 x) = toContents x
-    toContents (FiveOf20 x) = toContents x
-    toContents (SixOf20 x) = toContents x
-    toContents (SevenOf20 x) = toContents x
-    toContents (EightOf20 x) = toContents x
-    toContents (NineOf20 x) = toContents x
-    toContents (TenOf20 x) = toContents x
-    toContents (ElevenOf20 x) = toContents x
-    toContents (TwelveOf20 x) = toContents x
-    toContents (ThirteenOf20 x) = toContents x
-    toContents (FourteenOf20 x) = toContents x
-    toContents (FifteenOf20 x) = toContents x
-    toContents (SixteenOf20 x) = toContents x
-    toContents (SeventeenOf20 x) = toContents x
-    toContents (EighteenOf20 x) = toContents x
-    toContents (NineteenOf20 x) = toContents x
-    toContents (TwentyOf20 x) = toContents x
-
-----
-

+
+
+src/Text/XML/HaXml/OneOfN.hs
+
+
+
module Text.XML.HaXml.OneOfN where
+
+import Text.XML.HaXml.XmlContent
+
+data OneOf2 a b
+    = OneOf2 a | TwoOf2 b
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b)
+    => HTypeable (OneOf2 a b)
+  where      toHType _ = Defined "OneOf2" [] []
+  --         toHType m = Defined "OneOf2" [a,b] []
+  --            where a = toHType $ (\ (OneOf2 a)->a) $ m
+  --                  b = toHType $ (\ (TwoOf2 b)->b) $ m
+
+
+instance (XmlContent a,XmlContent b)
+    => XmlContent (OneOf2 a b)
+  where
+    parseContents =
+        (choice OneOf2 $ choice TwoOf2
+        $ fail "OneOf2")
+    toContents (OneOf2 x) = toContents x
+    toContents (TwoOf2 x) = toContents x
+
+----
+data OneOf3 a b c
+    = OneOf3 a | TwoOf3 b | ThreeOf3 c
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c)
+    => HTypeable (OneOf3 a b c)
+  where      toHType _ = Defined "OneOf3" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c)
+    => XmlContent (OneOf3 a b c)
+  where
+    parseContents =
+        (choice OneOf3 $ choice TwoOf3 $ choice ThreeOf3
+        $ fail "OneOf3")
+    toContents (OneOf3 x) = toContents x
+    toContents (TwoOf3 x) = toContents x
+    toContents (ThreeOf3 x) = toContents x
+
+----
+data OneOf4 a b c d
+    = OneOf4 a | TwoOf4 b | ThreeOf4 c | FourOf4 d
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d)
+    => HTypeable (OneOf4 a b c d)
+  where      toHType _ = Defined "OneOf4" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d)
+    => XmlContent (OneOf4 a b c d)
+  where
+    parseContents =
+        (choice OneOf4 $ choice TwoOf4 $ choice ThreeOf4 $ choice FourOf4
+        $ fail "OneOf4")
+    toContents (OneOf4 x) = toContents x
+    toContents (TwoOf4 x) = toContents x
+    toContents (ThreeOf4 x) = toContents x
+    toContents (FourOf4 x) = toContents x
+
+----
+data OneOf5 a b c d e
+    = OneOf5 a | TwoOf5 b | ThreeOf5 c | FourOf5 d | FiveOf5 e
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e)
+    => HTypeable (OneOf5 a b c d e)
+  where      toHType _ = Defined "OneOf5" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e)
+    => XmlContent (OneOf5 a b c d e)
+  where
+    parseContents =
+        (choice OneOf5 $ choice TwoOf5 $ choice ThreeOf5 $ choice FourOf5
+        $ choice FiveOf5
+        $ fail "OneOf5")
+    toContents (OneOf5 x) = toContents x
+    toContents (TwoOf5 x) = toContents x
+    toContents (ThreeOf5 x) = toContents x
+    toContents (FourOf5 x) = toContents x
+    toContents (FiveOf5 x) = toContents x
+
+----
+data OneOf6 a b c d e f
+    = OneOf6 a | TwoOf6 b | ThreeOf6 c | FourOf6 d | FiveOf6 e | SixOf6 f
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f)
+    => HTypeable (OneOf6 a b c d e f)
+  where      toHType _ = Defined "OneOf6" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f)
+    => XmlContent (OneOf6 a b c d e f)
+  where
+    parseContents =
+        (choice OneOf6 $ choice TwoOf6 $ choice ThreeOf6 $ choice FourOf6
+        $ choice FiveOf6 $ choice SixOf6
+        $ fail "OneOf6")
+    toContents (OneOf6 x) = toContents x
+    toContents (TwoOf6 x) = toContents x
+    toContents (ThreeOf6 x) = toContents x
+    toContents (FourOf6 x) = toContents x
+    toContents (FiveOf6 x) = toContents x
+    toContents (SixOf6 x) = toContents x
+
+----
+data OneOf7 a b c d e f g
+    = OneOf7 a | TwoOf7 b | ThreeOf7 c | FourOf7 d | FiveOf7 e | SixOf7 f
+    | SevenOf7 g
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g)
+    => HTypeable (OneOf7 a b c d e f g)
+  where      toHType _ = Defined "OneOf7" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g)
+    => XmlContent (OneOf7 a b c d e f g)
+  where
+    parseContents =
+        (choice OneOf7 $ choice TwoOf7 $ choice ThreeOf7 $ choice FourOf7
+        $ choice FiveOf7 $ choice SixOf7 $ choice SevenOf7
+        $ fail "OneOf7")
+    toContents (OneOf7 x) = toContents x
+    toContents (TwoOf7 x) = toContents x
+    toContents (ThreeOf7 x) = toContents x
+    toContents (FourOf7 x) = toContents x
+    toContents (FiveOf7 x) = toContents x
+    toContents (SixOf7 x) = toContents x
+    toContents (SevenOf7 x) = toContents x
+
+----
+data OneOf8 a b c d e f g h
+    = OneOf8 a | TwoOf8 b | ThreeOf8 c | FourOf8 d | FiveOf8 e | SixOf8 f
+    | SevenOf8 g | EightOf8 h
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g,HTypeable h)
+    => HTypeable (OneOf8 a b c d e f g h)
+  where      toHType _ = Defined "OneOf8" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g,XmlContent h)
+    => XmlContent (OneOf8 a b c d e f g h)
+  where
+    parseContents =
+        (choice OneOf8 $ choice TwoOf8 $ choice ThreeOf8 $ choice FourOf8
+        $ choice FiveOf8 $ choice SixOf8 $ choice SevenOf8 $ choice EightOf8
+        $ fail "OneOf8")
+    toContents (OneOf8 x) = toContents x
+    toContents (TwoOf8 x) = toContents x
+    toContents (ThreeOf8 x) = toContents x
+    toContents (FourOf8 x) = toContents x
+    toContents (FiveOf8 x) = toContents x
+    toContents (SixOf8 x) = toContents x
+    toContents (SevenOf8 x) = toContents x
+    toContents (EightOf8 x) = toContents x
+
+----
+data OneOf9 a b c d e f g h i
+    = OneOf9 a | TwoOf9 b | ThreeOf9 c | FourOf9 d | FiveOf9 e | SixOf9 f
+    | SevenOf9 g | EightOf9 h | NineOf9 i
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i)
+    => HTypeable (OneOf9 a b c d e f g h i)
+  where      toHType _ = Defined "OneOf9" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i)
+    => XmlContent (OneOf9 a b c d e f g h i)
+  where
+    parseContents =
+        (choice OneOf9 $ choice TwoOf9 $ choice ThreeOf9 $ choice FourOf9
+        $ choice FiveOf9 $ choice SixOf9 $ choice SevenOf9 $ choice EightOf9
+        $ choice NineOf9
+        $ fail "OneOf9")
+    toContents (OneOf9 x) = toContents x
+    toContents (TwoOf9 x) = toContents x
+    toContents (ThreeOf9 x) = toContents x
+    toContents (FourOf9 x) = toContents x
+    toContents (FiveOf9 x) = toContents x
+    toContents (SixOf9 x) = toContents x
+    toContents (SevenOf9 x) = toContents x
+    toContents (EightOf9 x) = toContents x
+    toContents (NineOf9 x) = toContents x
+
+----
+data OneOf10 a b c d e f g h i j
+    = OneOf10 a | TwoOf10 b | ThreeOf10 c | FourOf10 d | FiveOf10 e
+    | SixOf10 f | SevenOf10 g | EightOf10 h | NineOf10 i | TenOf10 j
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j)
+    => HTypeable (OneOf10 a b c d e f g h i j)
+  where      toHType _ = Defined "OneOf10" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j)
+    => XmlContent (OneOf10 a b c d e f g h i j)
+  where
+    parseContents =
+        (choice OneOf10 $ choice TwoOf10 $ choice ThreeOf10 $ choice FourOf10
+        $ choice FiveOf10 $ choice SixOf10 $ choice SevenOf10
+        $ choice EightOf10 $ choice NineOf10 $ choice TenOf10
+        $ fail "OneOf10")
+    toContents (OneOf10 x) = toContents x
+    toContents (TwoOf10 x) = toContents x
+    toContents (ThreeOf10 x) = toContents x
+    toContents (FourOf10 x) = toContents x
+    toContents (FiveOf10 x) = toContents x
+    toContents (SixOf10 x) = toContents x
+    toContents (SevenOf10 x) = toContents x
+    toContents (EightOf10 x) = toContents x
+    toContents (NineOf10 x) = toContents x
+    toContents (TenOf10 x) = toContents x
+
+----
+data OneOf11 a b c d e f g h i j k
+    = OneOf11 a | TwoOf11 b | ThreeOf11 c | FourOf11 d | FiveOf11 e
+    | SixOf11 f | SevenOf11 g | EightOf11 h | NineOf11 i | TenOf11 j
+    | ElevenOf11 k
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
+          ,HTypeable k)
+    => HTypeable (OneOf11 a b c d e f g h i j k)
+  where      toHType _ = Defined "OneOf11" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
+          ,XmlContent k)
+    => XmlContent (OneOf11 a b c d e f g h i j k)
+  where
+    parseContents =
+        (choice OneOf11 $ choice TwoOf11 $ choice ThreeOf11 $ choice FourOf11
+        $ choice FiveOf11 $ choice SixOf11 $ choice SevenOf11
+        $ choice EightOf11 $ choice NineOf11 $ choice TenOf11
+        $ choice ElevenOf11
+        $ fail "OneOf11")
+    toContents (OneOf11 x) = toContents x
+    toContents (TwoOf11 x) = toContents x
+    toContents (ThreeOf11 x) = toContents x
+    toContents (FourOf11 x) = toContents x
+    toContents (FiveOf11 x) = toContents x
+    toContents (SixOf11 x) = toContents x
+    toContents (SevenOf11 x) = toContents x
+    toContents (EightOf11 x) = toContents x
+    toContents (NineOf11 x) = toContents x
+    toContents (TenOf11 x) = toContents x
+    toContents (ElevenOf11 x) = toContents x
+
+----
+data OneOf12 a b c d e f g h i j k l
+    = OneOf12 a | TwoOf12 b | ThreeOf12 c | FourOf12 d | FiveOf12 e
+    | SixOf12 f | SevenOf12 g | EightOf12 h | NineOf12 i | TenOf12 j
+    | ElevenOf12 k | TwelveOf12 l
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
+          ,HTypeable k,HTypeable l)
+    => HTypeable (OneOf12 a b c d e f g h i j k l)
+  where      toHType _ = Defined "OneOf12" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
+          ,XmlContent k,XmlContent l)
+    => XmlContent (OneOf12 a b c d e f g h i j k l)
+  where
+    parseContents =
+        (choice OneOf12 $ choice TwoOf12 $ choice ThreeOf12 $ choice FourOf12
+        $ choice FiveOf12 $ choice SixOf12 $ choice SevenOf12
+        $ choice EightOf12 $ choice NineOf12 $ choice TenOf12
+        $ choice ElevenOf12 $ choice TwelveOf12
+        $ fail "OneOf12")
+    toContents (OneOf12 x) = toContents x
+    toContents (TwoOf12 x) = toContents x
+    toContents (ThreeOf12 x) = toContents x
+    toContents (FourOf12 x) = toContents x
+    toContents (FiveOf12 x) = toContents x
+    toContents (SixOf12 x) = toContents x
+    toContents (SevenOf12 x) = toContents x
+    toContents (EightOf12 x) = toContents x
+    toContents (NineOf12 x) = toContents x
+    toContents (TenOf12 x) = toContents x
+    toContents (ElevenOf12 x) = toContents x
+    toContents (TwelveOf12 x) = toContents x
+
+----
+data OneOf13 a b c d e f g h i j k l m
+    = OneOf13 a | TwoOf13 b | ThreeOf13 c | FourOf13 d | FiveOf13 e
+    | SixOf13 f | SevenOf13 g | EightOf13 h | NineOf13 i | TenOf13 j
+    | ElevenOf13 k | TwelveOf13 l | ThirteenOf13 m
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
+          ,HTypeable k,HTypeable l,HTypeable m)
+    => HTypeable (OneOf13 a b c d e f g h i j k l m)
+  where      toHType _ = Defined "OneOf13" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
+          ,XmlContent k,XmlContent l,XmlContent m)
+    => XmlContent (OneOf13 a b c d e f g h i j k l m)
+  where
+    parseContents =
+        (choice OneOf13 $ choice TwoOf13 $ choice ThreeOf13 $ choice FourOf13
+        $ choice FiveOf13 $ choice SixOf13 $ choice SevenOf13
+        $ choice EightOf13 $ choice NineOf13 $ choice TenOf13
+        $ choice ElevenOf13 $ choice TwelveOf13 $ choice ThirteenOf13
+        $ fail "OneOf13")
+    toContents (OneOf13 x) = toContents x
+    toContents (TwoOf13 x) = toContents x
+    toContents (ThreeOf13 x) = toContents x
+    toContents (FourOf13 x) = toContents x
+    toContents (FiveOf13 x) = toContents x
+    toContents (SixOf13 x) = toContents x
+    toContents (SevenOf13 x) = toContents x
+    toContents (EightOf13 x) = toContents x
+    toContents (NineOf13 x) = toContents x
+    toContents (TenOf13 x) = toContents x
+    toContents (ElevenOf13 x) = toContents x
+    toContents (TwelveOf13 x) = toContents x
+    toContents (ThirteenOf13 x) = toContents x
+
+----
+data OneOf14 a b c d e f g h i j k l m n
+    = OneOf14 a | TwoOf14 b | ThreeOf14 c | FourOf14 d | FiveOf14 e
+    | SixOf14 f | SevenOf14 g | EightOf14 h | NineOf14 i | TenOf14 j
+    | ElevenOf14 k | TwelveOf14 l | ThirteenOf14 m | FourteenOf14 n
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
+          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n)
+    => HTypeable (OneOf14 a b c d e f g h i j k l m n)
+  where      toHType _ = Defined "OneOf14" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
+          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n)
+    => XmlContent (OneOf14 a b c d e f g h i j k l m n)
+  where
+    parseContents =
+        (choice OneOf14 $ choice TwoOf14 $ choice ThreeOf14 $ choice FourOf14
+        $ choice FiveOf14 $ choice SixOf14 $ choice SevenOf14
+        $ choice EightOf14 $ choice NineOf14 $ choice TenOf14
+        $ choice ElevenOf14 $ choice TwelveOf14 $ choice ThirteenOf14
+        $ choice FourteenOf14
+        $ fail "OneOf14")
+    toContents (OneOf14 x) = toContents x
+    toContents (TwoOf14 x) = toContents x
+    toContents (ThreeOf14 x) = toContents x
+    toContents (FourOf14 x) = toContents x
+    toContents (FiveOf14 x) = toContents x
+    toContents (SixOf14 x) = toContents x
+    toContents (SevenOf14 x) = toContents x
+    toContents (EightOf14 x) = toContents x
+    toContents (NineOf14 x) = toContents x
+    toContents (TenOf14 x) = toContents x
+    toContents (ElevenOf14 x) = toContents x
+    toContents (TwelveOf14 x) = toContents x
+    toContents (ThirteenOf14 x) = toContents x
+    toContents (FourteenOf14 x) = toContents x
+
+----
+data OneOf15 a b c d e f g h i j k l m n o
+    = OneOf15 a | TwoOf15 b | ThreeOf15 c | FourOf15 d | FiveOf15 e
+    | SixOf15 f | SevenOf15 g | EightOf15 h | NineOf15 i | TenOf15 j
+    | ElevenOf15 k | TwelveOf15 l | ThirteenOf15 m | FourteenOf15 n
+    | FifteenOf15 o
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
+          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o)
+    => HTypeable (OneOf15 a b c d e f g h i j k l m n o)
+  where      toHType _ = Defined "OneOf15" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
+          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o)
+    => XmlContent (OneOf15 a b c d e f g h i j k l m n o)
+  where
+    parseContents =
+        (choice OneOf15 $ choice TwoOf15 $ choice ThreeOf15 $ choice FourOf15
+        $ choice FiveOf15 $ choice SixOf15 $ choice SevenOf15
+        $ choice EightOf15 $ choice NineOf15 $ choice TenOf15
+        $ choice ElevenOf15 $ choice TwelveOf15 $ choice ThirteenOf15
+        $ choice FourteenOf15 $ choice FifteenOf15
+        $ fail "OneOf15")
+    toContents (OneOf15 x) = toContents x
+    toContents (TwoOf15 x) = toContents x
+    toContents (ThreeOf15 x) = toContents x
+    toContents (FourOf15 x) = toContents x
+    toContents (FiveOf15 x) = toContents x
+    toContents (SixOf15 x) = toContents x
+    toContents (SevenOf15 x) = toContents x
+    toContents (EightOf15 x) = toContents x
+    toContents (NineOf15 x) = toContents x
+    toContents (TenOf15 x) = toContents x
+    toContents (ElevenOf15 x) = toContents x
+    toContents (TwelveOf15 x) = toContents x
+    toContents (ThirteenOf15 x) = toContents x
+    toContents (FourteenOf15 x) = toContents x
+    toContents (FifteenOf15 x) = toContents x
+
+----
+data OneOf16 a b c d e f g h i j k l m n o p
+    = OneOf16 a | TwoOf16 b | ThreeOf16 c | FourOf16 d | FiveOf16 e
+    | SixOf16 f | SevenOf16 g | EightOf16 h | NineOf16 i | TenOf16 j
+    | ElevenOf16 k | TwelveOf16 l | ThirteenOf16 m | FourteenOf16 n
+    | FifteenOf16 o | SixteenOf16 p
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
+          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o
+          ,HTypeable p)
+    => HTypeable (OneOf16 a b c d e f g h i j k l m n o p)
+  where      toHType _ = Defined "OneOf16" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
+          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o
+          ,XmlContent p)
+    => XmlContent (OneOf16 a b c d e f g h i j k l m n o p)
+  where
+    parseContents =
+        (choice OneOf16 $ choice TwoOf16 $ choice ThreeOf16 $ choice FourOf16
+        $ choice FiveOf16 $ choice SixOf16 $ choice SevenOf16
+        $ choice EightOf16 $ choice NineOf16 $ choice TenOf16
+        $ choice ElevenOf16 $ choice TwelveOf16 $ choice ThirteenOf16
+        $ choice FourteenOf16 $ choice FifteenOf16 $ choice SixteenOf16
+        $ fail "OneOf16")
+    toContents (OneOf16 x) = toContents x
+    toContents (TwoOf16 x) = toContents x
+    toContents (ThreeOf16 x) = toContents x
+    toContents (FourOf16 x) = toContents x
+    toContents (FiveOf16 x) = toContents x
+    toContents (SixOf16 x) = toContents x
+    toContents (SevenOf16 x) = toContents x
+    toContents (EightOf16 x) = toContents x
+    toContents (NineOf16 x) = toContents x
+    toContents (TenOf16 x) = toContents x
+    toContents (ElevenOf16 x) = toContents x
+    toContents (TwelveOf16 x) = toContents x
+    toContents (ThirteenOf16 x) = toContents x
+    toContents (FourteenOf16 x) = toContents x
+    toContents (FifteenOf16 x) = toContents x
+    toContents (SixteenOf16 x) = toContents x
+
+----
+data OneOf17 a b c d e f g h i j k l m n o p q
+    = OneOf17 a | TwoOf17 b | ThreeOf17 c | FourOf17 d | FiveOf17 e
+    | SixOf17 f | SevenOf17 g | EightOf17 h | NineOf17 i | TenOf17 j
+    | ElevenOf17 k | TwelveOf17 l | ThirteenOf17 m | FourteenOf17 n
+    | FifteenOf17 o | SixteenOf17 p | SeventeenOf17 q
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
+          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o
+          ,HTypeable p,HTypeable q)
+    => HTypeable (OneOf17 a b c d e f g h i j k l m n o p q)
+  where      toHType _ = Defined "OneOf17" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
+          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o
+          ,XmlContent p,XmlContent q)
+    => XmlContent (OneOf17 a b c d e f g h i j k l m n o p q)
+  where
+    parseContents =
+        (choice OneOf17 $ choice TwoOf17 $ choice ThreeOf17 $ choice FourOf17
+        $ choice FiveOf17 $ choice SixOf17 $ choice SevenOf17
+        $ choice EightOf17 $ choice NineOf17 $ choice TenOf17
+        $ choice ElevenOf17 $ choice TwelveOf17 $ choice ThirteenOf17
+        $ choice FourteenOf17 $ choice FifteenOf17 $ choice SixteenOf17
+        $ choice SeventeenOf17
+        $ fail "OneOf17")
+    toContents (OneOf17 x) = toContents x
+    toContents (TwoOf17 x) = toContents x
+    toContents (ThreeOf17 x) = toContents x
+    toContents (FourOf17 x) = toContents x
+    toContents (FiveOf17 x) = toContents x
+    toContents (SixOf17 x) = toContents x
+    toContents (SevenOf17 x) = toContents x
+    toContents (EightOf17 x) = toContents x
+    toContents (NineOf17 x) = toContents x
+    toContents (TenOf17 x) = toContents x
+    toContents (ElevenOf17 x) = toContents x
+    toContents (TwelveOf17 x) = toContents x
+    toContents (ThirteenOf17 x) = toContents x
+    toContents (FourteenOf17 x) = toContents x
+    toContents (FifteenOf17 x) = toContents x
+    toContents (SixteenOf17 x) = toContents x
+    toContents (SeventeenOf17 x) = toContents x
+
+----
+data OneOf18 a b c d e f g h i j k l m n o p q r
+    = OneOf18 a | TwoOf18 b | ThreeOf18 c | FourOf18 d | FiveOf18 e
+    | SixOf18 f | SevenOf18 g | EightOf18 h | NineOf18 i | TenOf18 j
+    | ElevenOf18 k | TwelveOf18 l | ThirteenOf18 m | FourteenOf18 n
+    | FifteenOf18 o | SixteenOf18 p | SeventeenOf18 q | EighteenOf18 r
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
+          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o
+          ,HTypeable p,HTypeable q,HTypeable r)
+    => HTypeable (OneOf18 a b c d e f g h i j k l m n o p q r)
+  where      toHType _ = Defined "OneOf18" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
+          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o
+          ,XmlContent p,XmlContent q,XmlContent r)
+    => XmlContent (OneOf18 a b c d e f g h i j k l m n o p q r)
+  where
+    parseContents =
+        (choice OneOf18 $ choice TwoOf18 $ choice ThreeOf18 $ choice FourOf18
+        $ choice FiveOf18 $ choice SixOf18 $ choice SevenOf18
+        $ choice EightOf18 $ choice NineOf18 $ choice TenOf18
+        $ choice ElevenOf18 $ choice TwelveOf18 $ choice ThirteenOf18
+        $ choice FourteenOf18 $ choice FifteenOf18 $ choice SixteenOf18
+        $ choice SeventeenOf18 $ choice EighteenOf18
+        $ fail "OneOf18")
+    toContents (OneOf18 x) = toContents x
+    toContents (TwoOf18 x) = toContents x
+    toContents (ThreeOf18 x) = toContents x
+    toContents (FourOf18 x) = toContents x
+    toContents (FiveOf18 x) = toContents x
+    toContents (SixOf18 x) = toContents x
+    toContents (SevenOf18 x) = toContents x
+    toContents (EightOf18 x) = toContents x
+    toContents (NineOf18 x) = toContents x
+    toContents (TenOf18 x) = toContents x
+    toContents (ElevenOf18 x) = toContents x
+    toContents (TwelveOf18 x) = toContents x
+    toContents (ThirteenOf18 x) = toContents x
+    toContents (FourteenOf18 x) = toContents x
+    toContents (FifteenOf18 x) = toContents x
+    toContents (SixteenOf18 x) = toContents x
+    toContents (SeventeenOf18 x) = toContents x
+    toContents (EighteenOf18 x) = toContents x
+
+----
+data OneOf19 a b c d e f g h i j k l m n o p q r s
+    = OneOf19 a | TwoOf19 b | ThreeOf19 c | FourOf19 d | FiveOf19 e
+    | SixOf19 f | SevenOf19 g | EightOf19 h | NineOf19 i | TenOf19 j
+    | ElevenOf19 k | TwelveOf19 l | ThirteenOf19 m | FourteenOf19 n
+    | FifteenOf19 o | SixteenOf19 p | SeventeenOf19 q | EighteenOf19 r
+    | NineteenOf19 s
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
+          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o
+          ,HTypeable p,HTypeable q,HTypeable r,HTypeable s)
+    => HTypeable (OneOf19 a b c d e f g h i j k l m n o p q r s)
+  where      toHType _ = Defined "OneOf19" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
+          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o
+          ,XmlContent p,XmlContent q,XmlContent r,XmlContent s)
+    => XmlContent (OneOf19 a b c d e f g h i j k l m n o p q r s)
+  where
+    parseContents =
+        (choice OneOf19 $ choice TwoOf19 $ choice ThreeOf19 $ choice FourOf19
+        $ choice FiveOf19 $ choice SixOf19 $ choice SevenOf19
+        $ choice EightOf19 $ choice NineOf19 $ choice TenOf19
+        $ choice ElevenOf19 $ choice TwelveOf19 $ choice ThirteenOf19
+        $ choice FourteenOf19 $ choice FifteenOf19 $ choice SixteenOf19
+        $ choice SeventeenOf19 $ choice EighteenOf19 $ choice NineteenOf19
+        $ fail "OneOf19")
+    toContents (OneOf19 x) = toContents x
+    toContents (TwoOf19 x) = toContents x
+    toContents (ThreeOf19 x) = toContents x
+    toContents (FourOf19 x) = toContents x
+    toContents (FiveOf19 x) = toContents x
+    toContents (SixOf19 x) = toContents x
+    toContents (SevenOf19 x) = toContents x
+    toContents (EightOf19 x) = toContents x
+    toContents (NineOf19 x) = toContents x
+    toContents (TenOf19 x) = toContents x
+    toContents (ElevenOf19 x) = toContents x
+    toContents (TwelveOf19 x) = toContents x
+    toContents (ThirteenOf19 x) = toContents x
+    toContents (FourteenOf19 x) = toContents x
+    toContents (FifteenOf19 x) = toContents x
+    toContents (SixteenOf19 x) = toContents x
+    toContents (SeventeenOf19 x) = toContents x
+    toContents (EighteenOf19 x) = toContents x
+    toContents (NineteenOf19 x) = toContents x
+
+----
+data OneOf20 a b c d e f g h i j k l m n o p q r s t
+    = OneOf20 a | TwoOf20 b | ThreeOf20 c | FourOf20 d | FiveOf20 e
+    | SixOf20 f | SevenOf20 g | EightOf20 h | NineOf20 i | TenOf20 j
+    | ElevenOf20 k | TwelveOf20 l | ThirteenOf20 m | FourteenOf20 n
+    | FifteenOf20 o | SixteenOf20 p | SeventeenOf20 q | EighteenOf20 r
+    | NineteenOf20 s | TwentyOf20 t
+    deriving (Eq,Show)
+
+instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
+          ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j
+          ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o
+          ,HTypeable p,HTypeable q,HTypeable r,HTypeable s,HTypeable t)
+    => HTypeable (OneOf20 a b c d e f g h i j k l m n o p q r s t)
+  where      toHType _ = Defined "OneOf20" [] []
+
+instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
+          ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j
+          ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o
+          ,XmlContent p,XmlContent q,XmlContent r,XmlContent s,XmlContent t)
+    => XmlContent (OneOf20 a b c d e f g h i j k l m n o p q r s t)
+  where
+    parseContents =
+        (choice OneOf20 $ choice TwoOf20 $ choice ThreeOf20 $ choice FourOf20
+        $ choice FiveOf20 $ choice SixOf20 $ choice SevenOf20
+        $ choice EightOf20 $ choice NineOf20 $ choice TenOf20
+        $ choice ElevenOf20 $ choice TwelveOf20 $ choice ThirteenOf20
+        $ choice FourteenOf20 $ choice FifteenOf20 $ choice SixteenOf20
+        $ choice SeventeenOf20 $ choice EighteenOf20 $ choice NineteenOf20
+        $ choice TwentyOf20
+        $ fail "OneOf20")
+    toContents (OneOf20 x) = toContents x
+    toContents (TwoOf20 x) = toContents x
+    toContents (ThreeOf20 x) = toContents x
+    toContents (FourOf20 x) = toContents x
+    toContents (FiveOf20 x) = toContents x
+    toContents (SixOf20 x) = toContents x
+    toContents (SevenOf20 x) = toContents x
+    toContents (EightOf20 x) = toContents x
+    toContents (NineOf20 x) = toContents x
+    toContents (TenOf20 x) = toContents x
+    toContents (ElevenOf20 x) = toContents x
+    toContents (TwelveOf20 x) = toContents x
+    toContents (ThirteenOf20 x) = toContents x
+    toContents (FourteenOf20 x) = toContents x
+    toContents (FifteenOf20 x) = toContents x
+    toContents (SixteenOf20 x) = toContents x
+    toContents (SeventeenOf20 x) = toContents x
+    toContents (EighteenOf20 x) = toContents x
+    toContents (NineteenOf20 x) = toContents x
+    toContents (TwentyOf20 x) = toContents x
+
+----
+

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Parse.html b/docs/HaXml/src/Text/XML/HaXml/Parse.html
--- a/docs/HaXml/src/Text/XML/HaXml/Parse.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Parse.html
@@ -1,887 +1,896 @@
 
 
-
{-# OPTIONS -cpp #-}
--- | A non-validating XML parser.  For the input grammar, see
---   <http://www.w3.org/TR/REC-xml>.
-module Text.XML.HaXml.Parse
-  (
-  -- * Parse a whole document
-    xmlParse, xmlParse'
-  -- * Parse just a DTD
-  , dtdParse, dtdParse'
-  -- * Parse a partial document
-  , xmlParseWith
-  -- * Individual parsers for use with /xmlParseWith/ and module SAX
-  , document, element, content
-  , comment, cdsect, chardata
-  , reference, doctypedecl
-  , processinginstruction
-  , elemtag, name, tok
-  , elemOpenTag, elemCloseTag
-  , emptySTs, XParser
-  -- * These general utility functions don't belong here
-  , fst3, snd3, thd3
-  ) where
-
--- An XML parser, written using a slightly extended version of the
--- Hutton/Meijer parser combinators.  The input is tokenised internally
--- by the lexer xmlLex.  Whilst parsing, we gather a symbol
--- table of entity references.  PERefs must be defined before use, so we
--- expand their uses as we encounter them, forcing the remainder of the
--- input to be re-lexed and re-parsed.  GERefs are simply stored for
--- later retrieval.
-
-import Prelude hiding (either,maybe,sequence)
-import qualified Prelude (either)
-import Maybe hiding (maybe)
-import List (intersperse)       -- debugging only
-import Char (isSpace,isDigit,isHexDigit)
-import Monad hiding (sequence)
-import Numeric (readDec,readHex)
-
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.Posn
-import Text.XML.HaXml.Lex
-import Text.ParserCombinators.Poly.NoLeak.State
-
-
-#if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
-    ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
-import System.IO.Unsafe (unsafePerformIO)
-#elif defined(__GLASGOW_HASKELL__)
-import IOExts (unsafePerformIO)
-#elif defined(__NHC__)
-import IOExtras (unsafePerformIO)
-#elif defined(__HBC__)
-import UnsafePerformIO
-#endif
-
---  #define DEBUG
-
-#if defined(DEBUG)
-#  if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
-      ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
-import Debug.Trace(trace)
-#  elif defined(__GLASGOW_HASKELL__)
-import IOExts(trace)
-#  elif defined(__NHC__) || defined(__HBC__)
-import NonStdTrace
-#  endif
-debug :: a -> String -> a
-v `debug` s = trace s v
-#else
-v `debug` s = v
-#endif
-
-
--- | To parse a whole document, @xmlParse file content@ takes a filename
---   (for generating error reports) and the string content of that file.
---   A parse error causes program failure, with message to stderr.
-xmlParse :: String -> String -> Document Posn
-
--- | To parse a whole document, @xmlParse' file content@ takes a filename
---   (for generating error reports) and the string content of that file.
---   Any parse error message is passed back to the caller through the
---   @Either@ type.
-xmlParse' :: String -> String -> Either String (Document Posn)
-
--- | To parse just a DTD, @dtdParse file content@ takes a filename
---   (for generating error reports) and the string content of that
---   file.  If no DTD was found, you get @Nothing@ rather than an error.
---   However, if a DTD is found but contains errors, the program crashes.
-dtdParse  :: String -> String -> Maybe DocTypeDecl
-
--- | To parse just a DTD, @dtdParse' file content@ takes a filename
---   (for generating error reports) and the string content of that
---   file.  If no DTD was found, you get @Right Nothing@.
---   If a DTD was found but contains errors, you get a @Left message@.
-dtdParse' :: String -> String -> Either String (Maybe DocTypeDecl)
-
-xmlParse  name  = Prelude.either error id . xmlParse' name
-dtdParse  name  = Prelude.either error id . dtdParse' name
-
-xmlParse' name  = fst3 . runParser (toEOF document) emptySTs . xmlLex name
-dtdParse' name  = fst3 . runParser justDTD  emptySTs . xmlLex name
-
-toEOF = id	-- there are other possible implementations...
-
--- | To parse a partial document, e.g. from an XML-based stream protocol,
---   where you may later want to get more document elements from the same
---   stream.  Arguments are: a parser for the item you want, and the
---   already-lexed input to parse from.  Returns the item you wanted
---   (or an error message), plus the remainder of the input.
-xmlParseWith :: XParser a -> [(Posn,TokenT)]
-                -> (Either String a, [(Posn,TokenT)])
-xmlParseWith p = (\(v,_,s)->(v,s)) . runParser p emptySTs
-
-
----- Symbol table stuff ----
-
-type SymTabs = (SymTab PEDef, SymTab EntityDef)
-
--- | Some empty symbol tables for GE and PE references.
-emptySTs :: SymTabs
-emptySTs = (emptyST, emptyST)
-
-addPE :: String -> PEDef -> SymTabs -> SymTabs
-addPE n v (pe,ge) = (addST n v pe, ge)
-
-addGE :: String -> EntityDef -> SymTabs -> SymTabs
-addGE n v (pe,ge) = let newge = addST n v ge in newge `seq` (pe, newge)
-
-lookupPE :: String -> SymTabs -> Maybe PEDef
-lookupPE s (pe,ge) = lookupST s pe
-
-flattenEV :: EntityValue -> String
-flattenEV (EntityValue evs) = concatMap flatten evs
-  where
-    flatten (EVString s)          = s
-    flatten (EVRef (RefEntity r)) = "&" ++r++";"
-    flatten (EVRef (RefChar r))   = "&#"++show r++";"
- -- flatten (EVPERef n)           = "%" ++n++";"
-
-
----- Misc ----
-fst3 :: (a,b,c) -> a
-snd3 :: (a,b,c) -> b
-thd3 :: (a,b,c) -> c
-
-fst3 (a,_,_) = a
-snd3 (_,a,_) = a
-thd3 (_,_,a) = a
-
-
----- Auxiliary Parsing Functions ----
-
--- | XParser is just a specialisation of the PolyState parser.
-type XParser a = Parser SymTabs (Posn,TokenT) a
-
--- | Return the next token from the input only if it matches the given token.
-tok :: TokenT -> XParser TokenT
-tok t = do (p,t') <- next
-           case t' of TokError _    -> report failBad (show t) p t'
-                      _ | t'==t     -> return t
-                        | otherwise -> report fail (show t) p t'
-nottok :: [TokenT] -> XParser TokenT
-nottok ts = do (p,t) <- next
-               if t`elem`ts then report fail ("no "++show t) p t
-                            else return t
-
--- | Return just a name, e.g. element name, attribute name.
-name :: XParser Name
-name = do (p,tok) <- next
-          case tok of
-            TokName s  -> return s
-            TokError _ -> report failBad "a name" p tok
-            _          -> report fail "a name" p tok
-
-string, freetext :: XParser String
-string   = do (p,t) <- next
-              case t of TokName s -> return s
-                        _         -> report fail "text" p t
-freetext = do (p,t) <- next
-              case t of TokFreeText s -> return s
-                        _             -> report fail "text" p t
-
-maybe :: XParser a -> XParser (Maybe a)
-maybe p =
-    ( p >>= return . Just) `onFail`
-    ( return Nothing)
-
-either :: XParser a -> XParser b -> XParser (Either a b)
-either p q =
-    ( p >>= return . Left) `onFail`
-    ( q >>= return . Right)
-
-word :: String -> XParser ()
-word s = do { x <- next
-            ; case x of
-                (p,TokName n)     | s==n -> return ()
-                (p,TokFreeText n) | s==n -> return ()
-                (p,t@(TokError _)) -> report failBad (show s) p t
-                (p,t) -> report fail (show s) p t
-            }
-
-posn = do { x@(p,_) <- next
-          ; reparse [x]
-          ; return p
-          }
-
-nmtoken :: XParser NmToken
-nmtoken = (string `onFail` freetext)
-
-failP, failBadP :: String -> XParser a
-failP msg = do { p <- posn; fail (msg++"\n    at "++show p) }
-failBadP msg = do { p <- posn; failBad (msg++"\n    at "++show p) }
-
-report :: (String->XParser a) -> String -> Posn -> TokenT -> XParser a
-report fail exp p t = fail ("Expected "++exp++" but found "++show t
-                           ++"\n  in "++show p)
-
-adjustErrP :: XParser a -> (String->String) -> XParser a
-p `adjustErrP` f = p `onFail` do pn <- posn
-                                 (p `adjustErr` f) `adjustErr` (++show pn)
-
-peRef :: XParser a -> XParser a
-peRef p =
-    p `onFail`
-    do pn <- posn
-       n <- pereference
-       tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n)
-       case tr of
-           Just (PEDefEntityValue ev) ->
-                      do reparse (xmlReLex (posInNewCxt ("macro %"++n++";")
-                                                        (Just pn))
-                                           (flattenEV ev))
-                               `debug` ("  defn:  "++flattenEV ev)
-                         peRef p
-           Just (PEDefExternalID (PUBLIC _ (SystemLiteral f))) ->
-                      do let val = unsafePerformIO (readFile f)
-                         reparse (xmlReLex (posInNewCxt ("file "++f)
-                                                        (Just pn)) val)
-                               `debug` ("  reading from file "++f)
-                         peRef p
-           Just (PEDefExternalID (SYSTEM (SystemLiteral f))) ->
-                      do let val = unsafePerformIO (readFile f)
-                         reparse (xmlReLex (posInNewCxt ("file "++f)
-                                                        (Just pn)) val)
-                               `debug` ("  reading from file "++f)
-                         peRef p
-           Nothing -> fail ("PEReference use before definition: "++"%"++n++";"
-                           ++"\n    at "++show pn)
-
-blank :: XParser a -> XParser a
-blank p =
-    p `onFail`
-    do n <- pereference
-       tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n++" (is blank?)")
-       case tr of
-           Just (PEDefEntityValue ev)
-                    | all isSpace (flattenEV ev)  ->
-                            do blank p `debug` "Empty macro definition"
-           Just _  -> failP ("expected a blank PERef macro: "++"%"++n++";")
-           Nothing -> failP ("PEReference use before definition: "++"%"++n++";")
-
-
-
----- XML Parsing Functions ----
-
-justDTD :: XParser (Maybe DocTypeDecl)
-justDTD =
-  do (ExtSubset _ ds) <- extsubset `debug` "Trying external subset"
-     if null ds then fail "empty"
-         else return (Just (DTD "extsubset" Nothing (concatMap extract ds)))
-  `onFail`
-  do (Prolog _ _ dtd _) <- prolog
-     return dtd
- where extract (ExtMarkupDecl m) = [m]
-       extract (ExtConditionalSect (IncludeSect i)) = concatMap extract i
-       extract (ExtConditionalSect (IgnoreSect i)) = []
-
--- | Return an entire XML document including prolog and trailing junk.
-document :: XParser (Document Posn)
-document = do
-    p <- prolog `adjustErr` ("unrecognisable XML prolog\n"++)
-    e <- element
-    ms <- many misc
-    (_,ge) <- stGet
-    return (Document p ge e ms)
-
--- | Return an XML comment.
-comment :: XParser Comment
-comment = do
-    bracket (tok TokCommentOpen) (tok TokCommentClose) freetext
---  tok TokCommentOpen
---  commit $ do
---    c <- freetext
---    tok TokCommentClose
---    return c
-
--- | Parse a processing instruction.
-processinginstruction :: XParser ProcessingInstruction
-processinginstruction = do
-    tok TokPIOpen
-    commit $ do
-      n <- string  `onFail` failP "processing instruction has no target"
-      f <- freetext
-      tok TokPIClose `onFail` failP ("missing ?> in <?"++n)
-      return (n, f)
-
-cdsect :: XParser CDSect
-cdsect = do
-    tok TokSectionOpen
-    bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata
-
-prolog :: XParser Prolog
-prolog = do
-    x   <- maybe xmldecl
-    m1  <- many misc
-    dtd <- maybe doctypedecl
-    m2  <- many misc
-    return (Prolog x m1 dtd m2)
-
-xmldecl :: XParser XMLDecl
-xmldecl = do
-    tok TokPIOpen
-    (word "xml" `onFail` word "XML")
-    p <- posn
-    s <- freetext
-    tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"
-    raise ((runParser aux emptySTs . xmlReLex p) s)
-  where
-    aux = do
-        v <- versioninfo  `onFail` failP "missing XML version info"
-        e <- maybe encodingdecl
-        s <- maybe sddecl
-        return (XMLDecl v e s)
-    raise (Left err, _, _) = failP err
-    raise (Right ok, _, _) = return ok
-
-versioninfo :: XParser VersionInfo
-versioninfo = do
-    (word "version" `onFail` word "VERSION")
-    tok TokEqual
-    bracket (tok TokQuote) (tok TokQuote) freetext
-
-misc :: XParser Misc
-misc =
-    oneOf' [ ("<!--comment-->",  comment >>= return . Comment)
-           , ("<?PI?>",          processinginstruction >>= return . PI)
-           ]
-
--- | Return a DOCTYPE decl, indicating a DTD.
-doctypedecl :: XParser DocTypeDecl
-doctypedecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial DOCTYPEx)
-    commit $ do
-      n   <- name
-      eid <- maybe externalid
-      es  <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)
-                            (many (peRef markupdecl)))
-      blank (tok TokAnyClose)  `onFail` failP "missing > in DOCTYPE decl"
-      return (DTD n eid (case es of { Nothing -> []; Just e -> e }))
-
--- | Return a DTD markup decl, e.g. ELEMENT, ATTLIST, etc
-markupdecl :: XParser MarkupDecl
-markupdecl =
-  oneOf' [ ("ELEMENT",  elementdecl  >>= return . Element)
-         , ("ATTLIST",  attlistdecl  >>= return . AttList)
-         , ("ENTITY",   entitydecl   >>= return . Entity)
-         , ("NOTATION", notationdecl >>= return . Notation)
-         , ("misc",     misc         >>= return . MarkupMisc)
-         ]
-    `adjustErrP`
-          ("when looking for a markup decl,\n"++)
- --       (\  (ELEMENT, ATTLIST, ENTITY, NOTATION, <!--comment-->, or <?PI?>")
-
-extsubset :: XParser ExtSubset
-extsubset = do
-    td <- maybe textdecl
-    ds <- many (peRef extsubsetdecl)
-    return (ExtSubset td ds)
-
-extsubsetdecl :: XParser ExtSubsetDecl
-extsubsetdecl =
-    ( markupdecl >>= return . ExtMarkupDecl) `onFail`
-    ( conditionalsect >>= return . ExtConditionalSect)
-
-sddecl :: XParser SDDecl
-sddecl = do
-    (word "standalone" `onFail` word "STANDALONE")
-    commit $ do
-      tok TokEqual `onFail` failP "missing = in 'standalone' decl"
-      bracket (tok TokQuote) (tok TokQuote)
-              ( (word "yes" >> return True) `onFail`
-                (word "no" >> return False) `onFail`
-                failP "'standalone' decl requires 'yes' or 'no' value" )
-
-{-
-element :: XParser (Element Posn)
-element = do
-    tok TokAnyOpen
-    (ElemTag n as) <- elemtag
-    oneOf' [ ("self-closing tag <"++n++"/>"
-             ,  do tok TokEndClose
-                   return (Elem n as []))
-           , ("after open tag <"++n++">"
-             ,  do tok TokAnyClose
-                   cs <- many content
-                   p  <- posn
-                   m  <- bracket (tok TokEndOpen) (tok TokAnyClose) name
-                   checkmatch p n m
-                   return (Elem n as cs))
-           ] `adjustErr` (("in element tag "++n++",\n")++)
--}
-
--- | Return a complete element including all its inner content.
-element :: XParser (Element Posn)
-element = do
-    tok TokAnyOpen
-    (ElemTag n as) <- elemtag
-    ( do tok TokEndClose
-         commit (return (Elem n as []))
-        `onFail`
-      do tok TokAnyClose
-         commit $ do
-           return (Elem n as) `apply`
-                 manyFinally content
-                             (do p <- posn
-                                 m <- bracket (tok TokEndOpen)
-                                              (tok TokAnyClose) name
-                                 checkmatch p n m)
-      ) `adjustErrBad` (("in element tag "++n++",\n")++)
-
-checkmatch :: Posn -> Name -> Name -> XParser ()
-checkmatch p n m =
-  if n == m then return ()
-  else failBadP ("tag <"++n++"> terminated by </"++m++">")
-
--- | Parse only the parts between angle brackets in an element tag.
-elemtag :: XParser ElemTag
-elemtag = do
-    n  <- name `adjustErrBad` ("malformed element tag\n"++)
-    as <- many attribute
-    return (ElemTag n as)
-
--- | For use with stream parsers - returns the complete opening element tag.
-elemOpenTag :: XParser ElemTag
-elemOpenTag = do
-    tok TokAnyOpen
-    e <- elemtag
-    tok TokAnyClose
-    return e
-
--- | For use with stream parsers - accepts a closing tag, provided it
---   matches the given element name.
-elemCloseTag :: Name -> XParser ()
-elemCloseTag n = do
-    tok TokEndOpen
-    p <- posn
-    m <- name
-    tok TokAnyClose
-    checkmatch p n m
-
-attribute :: XParser Attribute
-attribute = do
-    n <- name `adjustErr` ("malformed attribute name\n"++)
-    tok TokEqual `onFail` failBadP "missing = in attribute"
-    v <- attvalue `onFail` failBadP "missing attvalue"
-    return (n,v)
-
--- | Return a content particle, e.g. text, element, reference, etc
-content :: XParser (Content Posn)
-content =
-  do { p  <- posn
-     ; c' <- content'
-     ; return (c' p)
-     }
-  where
-     content' = oneOf' [ ("element",   element   >>= return . CElem)
-                       , ("chardata",  chardata  >>= return . CString False)
-                       , ("reference", reference >>= return . CRef)
-                       , ("CDATA",     cdsect    >>= return . CString True)
-                       , ("misc",      misc      >>= return . CMisc)
-                       ]
-                  `adjustErrP` ("when looking for a content item,\n"++)
--- (\    (element, text, reference, CDATA section, <!--comment-->, or <?PI?>")
-
-elementdecl :: XParser ElementDecl
-elementdecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial ELEMENTx)
-    n <- peRef name `adjustErrBad` ("expecting identifier in ELEMENT decl\n"++)
-    c <- peRef contentspec
-             `adjustErrBad` (("in content spec of ELEMENT decl: "++n++"\n")++)
-    blank (tok TokAnyClose) `onFail` failBadP
-       ("expected > terminating ELEMENT decl"
-       ++"\n    element name was "++show n
-       ++"\n    contentspec was "++(\ (ContentSpec p)-> show p) c)
-    return (ElementDecl n c)
-
-contentspec :: XParser ContentSpec
-contentspec =
-    oneOf' [ ("EMPTY",  peRef (word "EMPTY") >> return EMPTY)
-           , ("ANY",    peRef (word "ANY") >> return ANY)
-           , ("mixed",  peRef mixed >>= return . Mixed)
-           , ("simple", peRef cp >>= return . ContentSpec)
-           ]
- --   `adjustErr` ("when looking for content spec,\n"++)
- --   `adjustErr` (++"\nLooking for content spec (EMPTY, ANY, mixed, etc)")
-
-choice :: XParser [CP]
-choice = do
-    bracket (tok TokBraOpen `debug` "Trying choice")
-            (blank (tok TokBraClose `debug` "Succeeded with choice"))
-            (peRef cp `sepBy1` blank (tok TokPipe))
-
-sequence :: XParser [CP]
-sequence = do	-- bracket is inappropriate because of inner failBad
- -- bracket (tok TokBraOpen `debug` "Trying sequence")
- --         (blank (tok TokBraClose `debug` "Succeeded with sequence"))
- --         (peRef cp `sepBy1` blank (tok TokComma))
-    tok TokBraOpen `debug` "Trying sequence"
-    cps <- peRef cp `sepBy1` blank (tok TokComma)
-    blank (tok TokBraClose `debug` "Succeeded with sequence")
-    return cps
-
-cp :: XParser CP
-cp = oneOf [ ( do n <- name
-                  m <- modifier
-                  let c = TagName n m
-                  return c `debug` ("ContentSpec: name "++show c))
-           , ( do ss <- sequence
-                  m <- modifier
-                  let c = Seq ss m
-                  return c `debug` ("ContentSpec: sequence "++show c))
-           , ( do cs <- choice
-                  m <- modifier
-                  let c = Choice cs m
-                  return c `debug` ("ContentSpec: choice "++show c))
-           ] `adjustErr` (++"\nwhen looking for a content particle")
-
-modifier :: XParser Modifier
-modifier = oneOf [ ( tok TokStar >> return Star )
-                 , ( tok TokQuery >> return Query )
-                 , ( tok TokPlus >> return Plus )
-                 , ( return None )
-                 ]
-
--- just for debugging
-instance Show CP where
-    show (TagName n m) = n++show m
-    show (Choice cps m) = '(': concat (intersperse "|" (map show cps))
-                          ++")"++show m
-    show (Seq cps m) = '(': concat (intersperse "," (map show cps))
-                          ++")"++show m
-instance Show Modifier where
-    show None = ""
-    show Query = "?"
-    show Star = "*"
-    show Plus = "+"
-----
-
-mixed :: XParser Mixed
-mixed = do
-    tok TokBraOpen
-    peRef (do tok TokHash
-              word "PCDATA")
-    commit $
-      oneOf [ ( do cs <- many (peRef (do tok TokPipe
-                                         peRef name))
-                   blank (tok TokBraClose >> tok TokStar)
-                   return (PCDATAplus cs))
-            , ( blank (tok TokBraClose >> tok TokStar) >> return PCDATA)
-            , ( blank (tok TokBraClose) >> return PCDATA)
-            ]
-        `adjustErrP` (++"\nLooking for mixed content spec (#PCDATA | ...)*\n")
-
-attlistdecl :: XParser AttListDecl
-attlistdecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial ATTLISTx)
-    n <- peRef name `adjustErrBad` ("expecting identifier in ATTLIST\n"++)
-    ds <- peRef (many1 (peRef attdef))
-    blank (tok TokAnyClose) `onFail` failBadP "missing > terminating ATTLIST"
-    return (AttListDecl n ds)
-
-attdef :: XParser AttDef
-attdef =
-  do n <- peRef name `adjustErr` ("expecting attribute name\n"++)
-     t <- peRef atttype `adjustErr` (("within attlist defn: "++n++",\n")++)
-     d <- peRef defaultdecl `adjustErr` (("in attlist defn: "++n++",\n")++)
-     return (AttDef n t d)
-
-atttype :: XParser AttType
-atttype =
-    oneOf' [ ("CDATA",      word "CDATA" >> return StringType)
-           , ("tokenized",  tokenizedtype >>= return . TokenizedType)
-           , ("enumerated", enumeratedtype >>= return . EnumeratedType)
-           ]
-      `adjustErr` ("looking for ATTTYPE,\n"++)
- --   `adjustErr` (++"\nLooking for ATTTYPE (CDATA, tokenized, or enumerated")
-
-tokenizedtype :: XParser TokenizedType
-tokenizedtype =
-    oneOf [ ( word "ID" >> return ID)
-          , ( word "IDREF" >> return IDREF)
-          , ( word "IDREFS" >> return IDREFS)
-          , ( word "ENTITY" >> return ENTITY)
-          , ( word "ENTITIES" >> return ENTITIES)
-          , ( word "NMTOKEN" >> return NMTOKEN)
-          , ( word "NMTOKENS" >> return NMTOKENS)
-          ] `onFail`
-    do { t <- next
-       ; failP ("Expected one of"
-               ++" (ID, IDREF, IDREFS, ENTITY, ENTITIES, NMTOKEN, NMTOKENS)"
-               ++"\nbut got "++show t)
-       }
--- `adjustErr` (++"\nLooking for a tokenized type:\n\ 
--- \    (ID, IDREF, IDREFS, ENTITY, ENTITIES, NMTOKEN, NMTOKENS)")
-
-enumeratedtype :: XParser EnumeratedType
-enumeratedtype =
-    oneOf' [ ("NOTATION",   notationtype >>= return . NotationType)
-           , ("enumerated", enumeration >>= return . Enumeration)
-           ]
-      `adjustErr` ("looking for an enumerated or NOTATION type,\n"++)
-
-notationtype :: XParser NotationType
-notationtype = do
-    word "NOTATION"
-    bracket (tok TokBraOpen) (blank (tok TokBraClose))
-            (peRef name `sepBy1` peRef (tok TokPipe))
-
-enumeration :: XParser Enumeration
-enumeration =
-    bracket (tok TokBraOpen) (blank (tok TokBraClose))
-            (peRef nmtoken `sepBy1` blank (peRef (tok TokPipe)))
-
-defaultdecl :: XParser DefaultDecl
-defaultdecl =
-    oneOf' [ ("REQUIRED",  tok TokHash >> word "REQUIRED" >> return REQUIRED)
-           , ("IMPLIED",   tok TokHash >> word "IMPLIED" >> return IMPLIED)
-           , ("FIXED",     do f <- maybe (tok TokHash >> word "FIXED"
-                                                      >> return FIXED)
-                              a <- peRef attvalue
-                              return (DefaultTo a f) )
-           ]
-        `adjustErr` ("looking for an attribute default decl,\n"++)
---      `adjustErr` (++"\nLooking for an attribute default decl:\n\ 
--- \    (REQUIRED, IMPLIED, FIXED)")
-
-conditionalsect :: XParser ConditionalSect
-conditionalsect = oneOf'
-    [ ( "INCLUDE"
-      , do tok TokSectionOpen
-           peRef (tok (TokSection INCLUDEx))
-           p <- posn
-           tok TokSqOpen `onFail` failBadP "missing [ after INCLUDE"
-           i <- many (peRef extsubsetdecl)
-           tok TokSectionClose
-                   `onFail` failBadP ("missing ]]> for INCLUDE section"
-                                     ++"\n    begun at "++show p)
-           return (IncludeSect i))
-    , ( "IGNORE"
-      , do tok TokSectionOpen
-           peRef (tok (TokSection IGNOREx))
-           p <- posn
-           tok TokSqOpen `onFail` failBadP "missing [ after IGNORE"
-           i <- many newIgnore  -- many ignoresectcontents
-           tok TokSectionClose
-                   `onFail` failBadP ("missing ]]> for IGNORE section"
-                                     ++"\n    begun at "++show p)
-           return (IgnoreSect []))
-    ] `adjustErr` ("in a conditional section,\n"++)
-
-newIgnore :: XParser Ignore
-newIgnore =
-    ( do tok TokSectionOpen
-         many newIgnore `debug` "IGNORING conditional section"
-         tok TokSectionClose
-         return Ignore `debug` "end of IGNORED conditional section") `onFail`
-    ( do t <- nottok [TokSectionOpen,TokSectionClose]
-         return Ignore  `debug` ("ignoring: "++show t))
-
---- obsolete?
-ignoresectcontents :: XParser IgnoreSectContents
-ignoresectcontents = do
-    i <- ignore
-    is <- many (do tok TokSectionOpen
-                   ic <- ignoresectcontents
-                   tok TokSectionClose
-                   ig <- ignore
-                   return (ic,ig))
-    return (IgnoreSectContents i is)
-
-ignore :: XParser Ignore
-ignore = do
-  is <- many1 (nottok [TokSectionOpen,TokSectionClose])
-  return Ignore  `debug` ("ignored all of: "++show is)
-----
-
--- | Return either a general entity reference, or a character reference.
-reference :: XParser Reference
-reference = do
-    bracket (tok TokAmp) (tok TokSemi) (freetext >>= val)
-  where
-    val ('#':'x':i) | all isHexDigit i
-                    = return . RefChar . fst . head . readHex $ i
-    val ('#':i)     | all isDigit i
-                    = return . RefChar . fst . head . readDec $ i
-    val name        = return . RefEntity $ name
-
-{- -- following is incorrect
-reference =
-    ( charref >>= return . RefChar) `onFail`
-    ( entityref >>= return . RefEntity)
-
-entityref :: XParser EntityRef
-entityref = do
-    bracket (tok TokAmp) (tok TokSemi) name
-
-charref :: XParser CharRef
-charref = do
-    bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal)
-  where
-    readCharVal ('#':'x':i) = return . fst . head . readHex $ i
-    readCharVal ('#':i)     = return . fst . head . readDec $ i
-    readCharVal _           = mzero
--}
-
-pereference :: XParser PEReference
-pereference = do
---  bracket (tok TokPercent) (tok TokSemi) nmtoken
-    tok TokPercent
-    p <- nmtoken
-    tok TokSemi
-    return p
-
-entitydecl :: XParser EntityDecl
-entitydecl =
-    ( gedecl >>= return . EntityGEDecl) `onFail`
-    ( pedecl >>= return . EntityPEDecl)
-
-gedecl :: XParser GEDecl
-gedecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial ENTITYx)
-    n <- name
-    e <- entitydef `adjustErrBad` (("in general entity defn "++n++",\n")++)
-    tok TokAnyClose `onFail` failBadP ("expected > terminating G ENTITY decl "++n)
-    stUpdate (addGE n e) `debug` ("added GE defn &"++n++";")
-    return (GEDecl n e)
-
-pedecl :: XParser PEDecl
-pedecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial ENTITYx)
-    tok TokPercent
-    n <- name
-    e <- pedef `adjustErrBad` (("in parameter entity defn "++n++",\n")++)
-    tok TokAnyClose `onFail` failBadP ("expected > terminating P ENTITY decl "++n)
-    stUpdate (addPE n e) `debug` ("added PE defn %"++n++";\n"++show e)
-    return (PEDecl n e)
-
-entitydef :: XParser EntityDef
-entitydef =
-    oneOf' [ ("entityvalue", entityvalue >>= return . DefEntityValue)
-           , ("external",    do eid <- externalid
-                                ndd <- maybe ndatadecl
-                                return (DefExternalID eid ndd))
-           ]
-
-pedef :: XParser PEDef
-pedef =
-    oneOf' [ ("entityvalue", entityvalue >>= return . PEDefEntityValue)
-           , ("externalid",  externalid  >>= return . PEDefExternalID)
-           ]
-
-externalid :: XParser ExternalID
-externalid =
-    oneOf' [ ("SYSTEM", do word "SYSTEM"
-                           s <- systemliteral
-                           return (SYSTEM s) )
-           , ("PUBLIC", do word "PUBLIC"
-                           p <- pubidliteral
-                           s <- systemliteral
-                           return (PUBLIC p s) )
-           ]
-      `adjustErr` ("looking for an external id,\n"++)
-
-ndatadecl :: XParser NDataDecl
-ndatadecl = do
-    word "NDATA"
-    n <- name
-    return (NDATA n)
-
-textdecl :: XParser TextDecl
-textdecl = do
-    tok TokPIOpen
-    (word "xml" `onFail` word "XML")
-    v <- maybe versioninfo
-    e <- encodingdecl
-    tok TokPIClose `onFail` failP "expected ?> terminating text decl"
-    return (TextDecl v e)
-
-extparsedent :: XParser (ExtParsedEnt Posn)
-extparsedent = do
-    t <- maybe textdecl
-    c <- content
-    return (ExtParsedEnt t c)
-
-extpe :: XParser ExtPE
-extpe = do
-    t <- maybe textdecl
-    e <- many (peRef extsubsetdecl)
-    return (ExtPE t e)
-
-encodingdecl :: XParser EncodingDecl
-encodingdecl = do
-    (word "encoding" `onFail` word "ENCODING")
-    tok TokEqual `onFail` failBadP "expected = in 'encoding' decl"
-    f <- bracket (tok TokQuote) (tok TokQuote) freetext
-    return (EncodingDecl f)
-
-notationdecl :: XParser NotationDecl
-notationdecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial NOTATIONx)
-    n <- name
-    e <- either externalid publicid
-    tok TokAnyClose `onFail` failBadP ("expected > terminating NOTATION decl "++n)
-    return (NOTATION n e)
-
-publicid :: XParser PublicID
-publicid = do
-    word "PUBLIC"
-    p <- pubidliteral
-    return (PUBLICID p)
-
-entityvalue :: XParser EntityValue
-entityvalue = do
- -- evs <- bracket (tok TokQuote) (tok TokQuote) (many (peRef ev))
-    tok TokQuote
-    pn <- posn
-    evs <- many ev
-    tok TokQuote `onFail` failBadP "expected quote to terminate entityvalue"
-    -- quoted text must be rescanned for possible PERefs
-    st <- stGet
-    Prelude.either failBad (return . EntityValue) . fst3 $
-                (runParser (many ev) st
-                         (reLexEntityValue (\s-> stringify (lookupPE s st))
-                                           pn
-                                           (flattenEV (EntityValue evs))))
-  where
-    stringify (Just (PEDefEntityValue ev)) = Just (flattenEV ev)
-    stringify _ = Nothing
-
-ev :: XParser EV
-ev =
-    oneOf' [ ("string",    (string`onFail`freetext) >>= return . EVString)
-           , ("reference", reference >>= return . EVRef)
-           ]
-      `adjustErr` ("looking for entity value,\n"++)
-
-attvalue :: XParser AttValue
-attvalue = do
-    avs <- bracket (tok TokQuote) (tok TokQuote)
-                   (many (either freetext reference))
-    return (AttValue avs)
-
-systemliteral :: XParser SystemLiteral
-systemliteral = do
-    s <- bracket (tok TokQuote) (tok TokQuote) freetext
-    return (SystemLiteral s)            -- note: refs &...; not permitted
-
-pubidliteral :: XParser PubidLiteral
-pubidliteral = do
-    s <- bracket (tok TokQuote) (tok TokQuote) freetext
-    return (PubidLiteral s)             -- note: freetext is too liberal here
-
--- | Return parsed freetext (i.e. until the next markup)
-chardata :: XParser CharData
-chardata = freetext
-
-

+
+
+src/Text/XML/HaXml/Parse.hs
+
+
+
{-# OPTIONS -cpp #-}
+-- | A non-validating XML parser.  For the input grammar, see
+--   <http://www.w3.org/TR/REC-xml>.
+module Text.XML.HaXml.Parse
+  (
+  -- * Parse a whole document
+    xmlParse, xmlParse'
+  -- * Parse just a DTD
+  , dtdParse, dtdParse'
+  -- * Parse a partial document
+  , xmlParseWith
+  -- * Individual parsers for use with /xmlParseWith/ and module SAX
+  , document, element, content
+  , comment, cdsect, chardata
+  , reference, doctypedecl
+  , processinginstruction
+  , elemtag, name, tok
+  , elemOpenTag, elemCloseTag
+  , emptySTs, XParser
+  -- * These general utility functions don't belong here
+  , fst3, snd3, thd3
+  ) where
+
+-- An XML parser, written using a slightly extended version of the
+-- Hutton/Meijer parser combinators.  The input is tokenised internally
+-- by the lexer xmlLex.  Whilst parsing, we gather a symbol
+-- table of entity references.  PERefs must be defined before use, so we
+-- expand their uses as we encounter them, forcing the remainder of the
+-- input to be re-lexed and re-parsed.  GERefs are simply stored for
+-- later retrieval.
+
+import Prelude hiding (either,maybe,sequence)
+import qualified Prelude (either)
+import Maybe hiding (maybe)
+import List (intersperse)       -- debugging only
+import Char (isSpace,isDigit,isHexDigit)
+import Monad hiding (sequence)
+import Numeric (readDec,readHex)
+
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.Posn
+import Text.XML.HaXml.Lex
+import Text.ParserCombinators.Poly.NoLeak.State
+
+import System.FilePath (combine, dropFileName)
+
+
+#if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
+    ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
+import System.IO.Unsafe (unsafePerformIO)
+#elif defined(__GLASGOW_HASKELL__)
+import IOExts (unsafePerformIO)
+#elif defined(__NHC__)
+import IOExtras (unsafePerformIO)
+#elif defined(__HBC__)
+import UnsafePerformIO
+#endif
+
+--  #define DEBUG
+
+#if defined(DEBUG)
+#  if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
+      ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
+import Debug.Trace(trace)
+#  elif defined(__GLASGOW_HASKELL__)
+import IOExts(trace)
+#  elif defined(__NHC__) || defined(__HBC__)
+import NonStdTrace
+#  endif
+debug :: a -> String -> a
+v `debug` s = trace s v
+#else
+v `debug` s = v
+#endif
+
+
+-- | To parse a whole document, @xmlParse file content@ takes a filename
+--   (for generating error reports) and the string content of that file.
+--   A parse error causes program failure, with message to stderr.
+xmlParse :: String -> String -> Document Posn
+
+-- | To parse a whole document, @xmlParse' file content@ takes a filename
+--   (for generating error reports) and the string content of that file.
+--   Any parse error message is passed back to the caller through the
+--   @Either@ type.
+xmlParse' :: String -> String -> Either String (Document Posn)
+
+-- | To parse just a DTD, @dtdParse file content@ takes a filename
+--   (for generating error reports) and the string content of that
+--   file.  If no DTD was found, you get @Nothing@ rather than an error.
+--   However, if a DTD is found but contains errors, the program crashes.
+dtdParse  :: String -> String -> Maybe DocTypeDecl
+
+-- | To parse just a DTD, @dtdParse' file content@ takes a filename
+--   (for generating error reports) and the string content of that
+--   file.  If no DTD was found, you get @Right Nothing@.
+--   If a DTD was found but contains errors, you get a @Left message@.
+dtdParse' :: String -> String -> Either String (Maybe DocTypeDecl)
+
+xmlParse  name  = Prelude.either error id . xmlParse' name
+dtdParse  name  = Prelude.either error id . dtdParse' name
+
+xmlParse' name  = fst3 . runParser (toEOF document) emptySTs . xmlLex name
+dtdParse' name  = fst3 . runParser justDTD  emptySTs . xmlLex name
+
+toEOF = id	-- there are other possible implementations...
+
+-- | To parse a partial document, e.g. from an XML-based stream protocol,
+--   where you may later want to get more document elements from the same
+--   stream.  Arguments are: a parser for the item you want, and the
+--   already-lexed input to parse from.  Returns the item you wanted
+--   (or an error message), plus the remainder of the input.
+xmlParseWith :: XParser a -> [(Posn,TokenT)]
+                -> (Either String a, [(Posn,TokenT)])
+xmlParseWith p = (\(v,_,s)->(v,s)) . runParser p emptySTs
+
+
+---- Symbol table stuff ----
+
+type SymTabs = (SymTab PEDef, SymTab EntityDef)
+
+-- | Some empty symbol tables for GE and PE references.
+emptySTs :: SymTabs
+emptySTs = (emptyST, emptyST)
+
+addPE :: String -> PEDef -> SymTabs -> SymTabs
+addPE n v (pe,ge) = (addST n v pe, ge)
+
+addGE :: String -> EntityDef -> SymTabs -> SymTabs
+addGE n v (pe,ge) = let newge = addST n v ge in newge `seq` (pe, newge)
+
+lookupPE :: String -> SymTabs -> Maybe PEDef
+lookupPE s (pe,ge) = lookupST s pe
+
+flattenEV :: EntityValue -> String
+flattenEV (EntityValue evs) = concatMap flatten evs
+  where
+    flatten (EVString s)          = s
+    flatten (EVRef (RefEntity r)) = "&" ++r++";"
+    flatten (EVRef (RefChar r))   = "&#"++show r++";"
+ -- flatten (EVPERef n)           = "%" ++n++";"
+
+
+---- Misc ----
+fst3 :: (a,b,c) -> a
+snd3 :: (a,b,c) -> b
+thd3 :: (a,b,c) -> c
+
+fst3 (a,_,_) = a
+snd3 (_,a,_) = a
+thd3 (_,_,a) = a
+
+
+---- Auxiliary Parsing Functions ----
+
+-- | Parse a bracketed item, discarding the brackets AND NOT using adjustErrBad
+myBracket :: PolyParse p => p bra -> p ket -> p a -> p a
+myBracket open close p = do
+    do { open    `adjustErr` ("Missing opening bracket:\n\t"++)
+       ; p `discard` (close `adjustErr` ("Missing closing bracket:\n\t"++))
+       }
+
+-- | XParser is just a specialisation of the PolyState parser.
+type XParser a = Parser SymTabs (Posn,TokenT) a
+
+-- | Return the next token from the input only if it matches the given token.
+tok :: TokenT -> XParser TokenT
+tok t = do (p,t') <- next
+           case t' of TokError _    -> report failBad (show t) p t'
+                      _ | t'==t     -> return t
+                        | otherwise -> report fail (show t) p t'
+nottok :: [TokenT] -> XParser TokenT
+nottok ts = do (p,t) <- next
+               if t`elem`ts then report fail ("no "++show t) p t
+                            else return t
+
+-- | Return just a name, e.g. element name, attribute name.
+name :: XParser Name
+name = do (p,tok) <- next
+          case tok of
+            TokName s  -> return s
+            TokError _ -> report failBad "a name" p tok
+            _          -> report fail "a name" p tok
+
+string, freetext :: XParser String
+string   = do (p,t) <- next
+              case t of TokName s -> return s
+                        _         -> report fail "text" p t
+freetext = do (p,t) <- next
+              case t of TokFreeText s -> return s
+                        _             -> report fail "text" p t
+
+maybe :: XParser a -> XParser (Maybe a)
+maybe p =
+    ( p >>= return . Just) `onFail`
+    ( return Nothing)
+
+either :: XParser a -> XParser b -> XParser (Either a b)
+either p q =
+    ( p >>= return . Left) `onFail`
+    ( q >>= return . Right)
+
+word :: String -> XParser ()
+word s = do { x <- next
+            ; case x of
+                (p,TokName n)     | s==n -> return ()
+                (p,TokFreeText n) | s==n -> return ()
+                (p,t@(TokError _)) -> report failBad (show s) p t
+                (p,t) -> report fail (show s) p t
+            }
+
+posn = do { x@(p,_) <- next
+          ; reparse [x]
+          ; return p
+          }
+
+nmtoken :: XParser NmToken
+nmtoken = (string `onFail` freetext)
+
+failP, failBadP :: String -> XParser a
+failP msg = do { p <- posn; fail (msg++"\n    at "++show p) }
+failBadP msg = do { p <- posn; failBad (msg++"\n    at "++show p) }
+
+report :: (String->XParser a) -> String -> Posn -> TokenT -> XParser a
+report fail exp p t = fail ("Expected "++exp++" but found "++show t
+                           ++"\n  in "++show p)
+
+adjustErrP :: XParser a -> (String->String) -> XParser a
+p `adjustErrP` f = p `onFail` do pn <- posn
+                                 (p `adjustErr` f) `adjustErr` (++show pn)
+
+peRef :: XParser a -> XParser a
+peRef p =
+    p `onFail`
+    do pn <- posn
+       n <- pereference
+       tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n)
+       case tr of
+           Just (PEDefEntityValue ev) ->
+                      do reparse (xmlReLex (posInNewCxt ("macro %"++n++";")
+                                                        (Just pn))
+                                           (flattenEV ev))
+                               `debug` ("  defn:  "++flattenEV ev)
+                         peRef p
+           Just (PEDefExternalID (PUBLIC _ (SystemLiteral f))) ->
+                      do let f' = combine (dropFileName $ posnFilename pn) f
+                             val = unsafePerformIO (readFile f')
+                         reparse (xmlReLex (posInNewCxt f'
+                                                        (Just pn)) val)
+                               `debug` ("  reading from file "++f')
+                         peRef p
+           Just (PEDefExternalID (SYSTEM (SystemLiteral f))) ->
+                      do let f' = combine (dropFileName $ posnFilename pn) f
+                             val = unsafePerformIO (readFile f')
+                         reparse (xmlReLex (posInNewCxt f'
+                                                        (Just pn)) val)
+                               `debug` ("  reading from file "++f')
+                         peRef p
+           Nothing -> fail ("PEReference use before definition: "++"%"++n++";"
+                           ++"\n    at "++show pn)
+
+blank :: XParser a -> XParser a
+blank p =
+    p `onFail`
+    do n <- pereference
+       tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n++" (is blank?)")
+       case tr of
+           Just (PEDefEntityValue ev)
+                    | all isSpace (flattenEV ev)  ->
+                            do blank p `debug` "Empty macro definition"
+           Just _  -> failP ("expected a blank PERef macro: "++"%"++n++";")
+           Nothing -> failP ("PEReference use before definition: "++"%"++n++";")
+
+
+
+---- XML Parsing Functions ----
+
+justDTD :: XParser (Maybe DocTypeDecl)
+justDTD =
+  do (ExtSubset _ ds) <- extsubset `debug` "Trying external subset"
+     if null ds then fail "empty"
+         else return (Just (DTD "extsubset" Nothing (concatMap extract ds)))
+  `onFail`
+  do (Prolog _ _ dtd _) <- prolog
+     return dtd
+ where extract (ExtMarkupDecl m) = [m]
+       extract (ExtConditionalSect (IncludeSect i)) = concatMap extract i
+       extract (ExtConditionalSect (IgnoreSect i)) = []
+
+-- | Return an entire XML document including prolog and trailing junk.
+document :: XParser (Document Posn)
+document = do
+    p <- prolog `adjustErr` ("unrecognisable XML prolog\n"++)
+    e <- element
+    ms <- many misc
+    (_,ge) <- stGet
+    return (Document p ge e ms)
+
+-- | Return an XML comment.
+comment :: XParser Comment
+comment = do
+    myBracket (tok TokCommentOpen) (tok TokCommentClose) freetext
+--  tok TokCommentOpen
+--  commit $ do
+--    c <- freetext
+--    tok TokCommentClose
+--    return c
+
+-- | Parse a processing instruction.
+processinginstruction :: XParser ProcessingInstruction
+processinginstruction = do
+    tok TokPIOpen
+    commit $ do
+      n <- string  `onFail` failP "processing instruction has no target"
+      f <- freetext
+      tok TokPIClose `onFail` failP ("missing ?> in <?"++n)
+      return (n, f)
+
+cdsect :: XParser CDSect
+cdsect = do
+    tok TokSectionOpen
+    bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata
+
+prolog :: XParser Prolog
+prolog = do
+    x   <- maybe xmldecl
+    m1  <- many misc
+    dtd <- maybe doctypedecl
+    m2  <- many misc
+    return (Prolog x m1 dtd m2)
+
+xmldecl :: XParser XMLDecl
+xmldecl = do
+    tok TokPIOpen
+    (word "xml" `onFail` word "XML")
+    p <- posn
+    s <- freetext
+    tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"
+    raise ((runParser aux emptySTs . xmlReLex p) s)
+  where
+    aux = do
+        v <- versioninfo  `onFail` failP "missing XML version info"
+        e <- maybe encodingdecl
+        s <- maybe sddecl
+        return (XMLDecl v e s)
+    raise (Left err, _, _) = failP err
+    raise (Right ok, _, _) = return ok
+
+versioninfo :: XParser VersionInfo
+versioninfo = do
+    (word "version" `onFail` word "VERSION")
+    tok TokEqual
+    bracket (tok TokQuote) (tok TokQuote) freetext
+
+misc :: XParser Misc
+misc =
+    oneOf' [ ("<!--comment-->",  comment >>= return . Comment)
+           , ("<?PI?>",          processinginstruction >>= return . PI)
+           ]
+
+-- | Return a DOCTYPE decl, indicating a DTD.
+doctypedecl :: XParser DocTypeDecl
+doctypedecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial DOCTYPEx)
+    commit $ do
+      n   <- name
+      eid <- maybe externalid
+      es  <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)
+                            (many (peRef markupdecl)))
+      blank (tok TokAnyClose)  `onFail` failP "missing > in DOCTYPE decl"
+      return (DTD n eid (case es of { Nothing -> []; Just e -> e }))
+
+-- | Return a DTD markup decl, e.g. ELEMENT, ATTLIST, etc
+markupdecl :: XParser MarkupDecl
+markupdecl =
+  oneOf' [ ("ELEMENT",  elementdecl  >>= return . Element)
+         , ("ATTLIST",  attlistdecl  >>= return . AttList)
+         , ("ENTITY",   entitydecl   >>= return . Entity)
+         , ("NOTATION", notationdecl >>= return . Notation)
+         , ("misc",     misc         >>= return . MarkupMisc)
+         ]
+    `adjustErrP`
+          ("when looking for a markup decl,\n"++)
+ --       (\  (ELEMENT, ATTLIST, ENTITY, NOTATION, <!--comment-->, or <?PI?>")
+
+extsubset :: XParser ExtSubset
+extsubset = do
+    td <- maybe textdecl
+    ds <- many (peRef extsubsetdecl)
+    return (ExtSubset td ds)
+
+extsubsetdecl :: XParser ExtSubsetDecl
+extsubsetdecl =
+    ( markupdecl >>= return . ExtMarkupDecl) `onFail`
+    ( conditionalsect >>= return . ExtConditionalSect)
+
+sddecl :: XParser SDDecl
+sddecl = do
+    (word "standalone" `onFail` word "STANDALONE")
+    commit $ do
+      tok TokEqual `onFail` failP "missing = in 'standalone' decl"
+      bracket (tok TokQuote) (tok TokQuote)
+              ( (word "yes" >> return True) `onFail`
+                (word "no" >> return False) `onFail`
+                failP "'standalone' decl requires 'yes' or 'no' value" )
+
+{-
+element :: XParser (Element Posn)
+element = do
+    tok TokAnyOpen
+    (ElemTag n as) <- elemtag
+    oneOf' [ ("self-closing tag <"++n++"/>"
+             ,  do tok TokEndClose
+                   return (Elem n as []))
+           , ("after open tag <"++n++">"
+             ,  do tok TokAnyClose
+                   cs <- many content
+                   p  <- posn
+                   m  <- bracket (tok TokEndOpen) (tok TokAnyClose) name
+                   checkmatch p n m
+                   return (Elem n as cs))
+           ] `adjustErr` (("in element tag "++n++",\n")++)
+-}
+
+-- | Return a complete element including all its inner content.
+element :: XParser (Element Posn)
+element = do
+    tok TokAnyOpen
+    (ElemTag n as) <- elemtag
+    ( do tok TokEndClose
+         commit (return (Elem n as []))
+        `onFail`
+      do tok TokAnyClose
+         commit $ do
+           return (Elem n as) `apply`
+                 manyFinally content
+                             (do p <- posn
+                                 m <- bracket (tok TokEndOpen)
+                                              (tok TokAnyClose) name
+                                 checkmatch p n m)
+      ) `adjustErrBad` (("in element tag "++n++",\n")++)
+
+checkmatch :: Posn -> Name -> Name -> XParser ()
+checkmatch p n m =
+  if n == m then return ()
+  else failBadP ("tag <"++n++"> terminated by </"++m++">")
+
+-- | Parse only the parts between angle brackets in an element tag.
+elemtag :: XParser ElemTag
+elemtag = do
+    n  <- name `adjustErrBad` ("malformed element tag\n"++)
+    as <- many attribute
+    return (ElemTag n as)
+
+-- | For use with stream parsers - returns the complete opening element tag.
+elemOpenTag :: XParser ElemTag
+elemOpenTag = do
+    tok TokAnyOpen
+    e <- elemtag
+    tok TokAnyClose
+    return e
+
+-- | For use with stream parsers - accepts a closing tag, provided it
+--   matches the given element name.
+elemCloseTag :: Name -> XParser ()
+elemCloseTag n = do
+    tok TokEndOpen
+    p <- posn
+    m <- name
+    tok TokAnyClose
+    checkmatch p n m
+
+attribute :: XParser Attribute
+attribute = do
+    n <- name `adjustErr` ("malformed attribute name\n"++)
+    tok TokEqual `onFail` failBadP "missing = in attribute"
+    v <- attvalue `onFail` failBadP "missing attvalue"
+    return (n,v)
+
+-- | Return a content particle, e.g. text, element, reference, etc
+content :: XParser (Content Posn)
+content =
+  do { p  <- posn
+     ; c' <- content'
+     ; return (c' p)
+     }
+  where
+     content' = oneOf' [ ("element",   element   >>= return . CElem)
+                       , ("chardata",  chardata  >>= return . CString False)
+                       , ("reference", reference >>= return . CRef)
+                       , ("CDATA",     cdsect    >>= return . CString True)
+                       , ("misc",      misc      >>= return . CMisc)
+                       ]
+                  `adjustErrP` ("when looking for a content item,\n"++)
+-- (\    (element, text, reference, CDATA section, <!--comment-->, or <?PI?>")
+
+elementdecl :: XParser ElementDecl
+elementdecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial ELEMENTx)
+    n <- peRef name `adjustErrBad` ("expecting identifier in ELEMENT decl\n"++)
+    c <- peRef contentspec
+             `adjustErrBad` (("in content spec of ELEMENT decl: "++n++"\n")++)
+    blank (tok TokAnyClose) `onFail` failBadP
+       ("expected > terminating ELEMENT decl"
+       ++"\n    element name was "++show n
+       ++"\n    contentspec was "++(\ (ContentSpec p)-> show p) c)
+    return (ElementDecl n c)
+
+contentspec :: XParser ContentSpec
+contentspec =
+    oneOf' [ ("EMPTY",  peRef (word "EMPTY") >> return EMPTY)
+           , ("ANY",    peRef (word "ANY") >> return ANY)
+           , ("mixed",  peRef mixed >>= return . Mixed)
+           , ("simple", peRef cp >>= return . ContentSpec)
+           ]
+ --   `adjustErr` ("when looking for content spec,\n"++)
+ --   `adjustErr` (++"\nLooking for content spec (EMPTY, ANY, mixed, etc)")
+
+choice :: XParser [CP]
+choice = do
+    myBracket (tok TokBraOpen `debug` "Trying choice")
+              (blank (tok TokBraClose `debug` "Succeeded with choice"))
+              (peRef cp `sepBy1` blank (tok TokPipe))
+
+sequence :: XParser [CP]
+sequence = do
+ myBracket (tok TokBraOpen `debug` "Trying sequence")
+           (blank (tok TokBraClose `debug` "Succeeded with sequence"))
+           (peRef cp `sepBy1` blank (tok TokComma))
+
+cp :: XParser CP
+cp = oneOf [ ( do n <- name
+                  m <- modifier
+                  let c = TagName n m
+                  return c `debug` ("ContentSpec: name "++show c))
+           , ( do ss <- sequence
+                  m <- modifier
+                  let c = Seq ss m
+                  return c `debug` ("ContentSpec: sequence "++show c))
+           , ( do cs <- choice
+                  m <- modifier
+                  let c = Choice cs m
+                  return c `debug` ("ContentSpec: choice "++show c))
+           ] `adjustErr` (++"\nwhen looking for a content particle")
+
+modifier :: XParser Modifier
+modifier = oneOf [ ( tok TokStar >> return Star )
+                 , ( tok TokQuery >> return Query )
+                 , ( tok TokPlus >> return Plus )
+                 , ( return None )
+                 ]
+
+-- just for debugging
+instance Show CP where
+    show (TagName n m) = n++show m
+    show (Choice cps m) = '(': concat (intersperse "|" (map show cps))
+                          ++")"++show m
+    show (Seq cps m) = '(': concat (intersperse "," (map show cps))
+                          ++")"++show m
+instance Show Modifier where
+    show None = ""
+    show Query = "?"
+    show Star = "*"
+    show Plus = "+"
+----
+
+mixed :: XParser Mixed
+mixed = do
+    tok TokBraOpen
+    peRef (do tok TokHash
+              word "PCDATA")
+    commit $
+      oneOf [ ( do cs <- many (peRef (do tok TokPipe
+                                         peRef name))
+                   blank (tok TokBraClose >> tok TokStar)
+                   return (PCDATAplus cs))
+            , ( blank (tok TokBraClose >> tok TokStar) >> return PCDATA)
+            , ( blank (tok TokBraClose) >> return PCDATA)
+            ]
+        `adjustErrP` (++"\nLooking for mixed content spec (#PCDATA | ...)*\n")
+
+attlistdecl :: XParser AttListDecl
+attlistdecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial ATTLISTx)
+    n <- peRef name `adjustErrBad` ("expecting identifier in ATTLIST\n"++)
+    ds <- peRef (many1 (peRef attdef))
+    blank (tok TokAnyClose) `onFail` failBadP "missing > terminating ATTLIST"
+    return (AttListDecl n ds)
+
+attdef :: XParser AttDef
+attdef =
+  do n <- peRef name `adjustErr` ("expecting attribute name\n"++)
+     t <- peRef atttype `adjustErr` (("within attlist defn: "++n++",\n")++)
+     d <- peRef defaultdecl `adjustErr` (("in attlist defn: "++n++",\n")++)
+     return (AttDef n t d)
+
+atttype :: XParser AttType
+atttype =
+    oneOf' [ ("CDATA",      word "CDATA" >> return StringType)
+           , ("tokenized",  tokenizedtype >>= return . TokenizedType)
+           , ("enumerated", enumeratedtype >>= return . EnumeratedType)
+           ]
+      `adjustErr` ("looking for ATTTYPE,\n"++)
+ --   `adjustErr` (++"\nLooking for ATTTYPE (CDATA, tokenized, or enumerated")
+
+tokenizedtype :: XParser TokenizedType
+tokenizedtype =
+    oneOf [ ( word "ID" >> return ID)
+          , ( word "IDREF" >> return IDREF)
+          , ( word "IDREFS" >> return IDREFS)
+          , ( word "ENTITY" >> return ENTITY)
+          , ( word "ENTITIES" >> return ENTITIES)
+          , ( word "NMTOKEN" >> return NMTOKEN)
+          , ( word "NMTOKENS" >> return NMTOKENS)
+          ] `onFail`
+    do { t <- next
+       ; failP ("Expected one of"
+               ++" (ID, IDREF, IDREFS, ENTITY, ENTITIES, NMTOKEN, NMTOKENS)"
+               ++"\nbut got "++show t)
+       }
+-- `adjustErr` (++"\nLooking for a tokenized type:\n\ 
+-- \    (ID, IDREF, IDREFS, ENTITY, ENTITIES, NMTOKEN, NMTOKENS)")
+
+enumeratedtype :: XParser EnumeratedType
+enumeratedtype =
+    oneOf' [ ("NOTATION",   notationtype >>= return . NotationType)
+           , ("enumerated", enumeration >>= return . Enumeration)
+           ]
+      `adjustErr` ("looking for an enumerated or NOTATION type,\n"++)
+
+notationtype :: XParser NotationType
+notationtype = do
+    word "NOTATION"
+    bracket (tok TokBraOpen) (blank (tok TokBraClose))
+            (peRef name `sepBy1` peRef (tok TokPipe))
+
+enumeration :: XParser Enumeration
+enumeration =
+    bracket (tok TokBraOpen) (blank (tok TokBraClose))
+            (peRef nmtoken `sepBy1` blank (peRef (tok TokPipe)))
+
+defaultdecl :: XParser DefaultDecl
+defaultdecl =
+    oneOf' [ ("REQUIRED",  tok TokHash >> word "REQUIRED" >> return REQUIRED)
+           , ("IMPLIED",   tok TokHash >> word "IMPLIED" >> return IMPLIED)
+           , ("FIXED",     do f <- maybe (tok TokHash >> word "FIXED"
+                                                      >> return FIXED)
+                              a <- peRef attvalue
+                              return (DefaultTo a f) )
+           ]
+        `adjustErr` ("looking for an attribute default decl,\n"++)
+--      `adjustErr` (++"\nLooking for an attribute default decl:\n\ 
+-- \    (REQUIRED, IMPLIED, FIXED)")
+
+conditionalsect :: XParser ConditionalSect
+conditionalsect = oneOf'
+    [ ( "INCLUDE"
+      , do tok TokSectionOpen
+           peRef (tok (TokSection INCLUDEx))
+           p <- posn
+           tok TokSqOpen `onFail` failBadP "missing [ after INCLUDE"
+           i <- many (peRef extsubsetdecl)
+           tok TokSectionClose
+                   `onFail` failBadP ("missing ]]> for INCLUDE section"
+                                     ++"\n    begun at "++show p)
+           return (IncludeSect i))
+    , ( "IGNORE"
+      , do tok TokSectionOpen
+           peRef (tok (TokSection IGNOREx))
+           p <- posn
+           tok TokSqOpen `onFail` failBadP "missing [ after IGNORE"
+           i <- many newIgnore  -- many ignoresectcontents
+           tok TokSectionClose
+                   `onFail` failBadP ("missing ]]> for IGNORE section"
+                                     ++"\n    begun at "++show p)
+           return (IgnoreSect []))
+    ] `adjustErr` ("in a conditional section,\n"++)
+
+newIgnore :: XParser Ignore
+newIgnore =
+    ( do tok TokSectionOpen
+         many newIgnore `debug` "IGNORING conditional section"
+         tok TokSectionClose
+         return Ignore `debug` "end of IGNORED conditional section") `onFail`
+    ( do t <- nottok [TokSectionOpen,TokSectionClose]
+         return Ignore  `debug` ("ignoring: "++show t))
+
+--- obsolete?
+ignoresectcontents :: XParser IgnoreSectContents
+ignoresectcontents = do
+    i <- ignore
+    is <- many (do tok TokSectionOpen
+                   ic <- ignoresectcontents
+                   tok TokSectionClose
+                   ig <- ignore
+                   return (ic,ig))
+    return (IgnoreSectContents i is)
+
+ignore :: XParser Ignore
+ignore = do
+  is <- many1 (nottok [TokSectionOpen,TokSectionClose])
+  return Ignore  `debug` ("ignored all of: "++show is)
+----
+
+-- | Return either a general entity reference, or a character reference.
+reference :: XParser Reference
+reference = do
+    myBracket (tok TokAmp) (tok TokSemi) (freetext >>= val)
+  where
+    val ('#':'x':i) | all isHexDigit i
+                    = return . RefChar . fst . head . readHex $ i
+    val ('#':i)     | all isDigit i
+                    = return . RefChar . fst . head . readDec $ i
+    val name        = return . RefEntity $ name
+
+{- -- following is incorrect
+reference =
+    ( charref >>= return . RefChar) `onFail`
+    ( entityref >>= return . RefEntity)
+
+entityref :: XParser EntityRef
+entityref = do
+    bracket (tok TokAmp) (tok TokSemi) name
+
+charref :: XParser CharRef
+charref = do
+    bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal)
+  where
+    readCharVal ('#':'x':i) = return . fst . head . readHex $ i
+    readCharVal ('#':i)     = return . fst . head . readDec $ i
+    readCharVal _           = mzero
+-}
+
+pereference :: XParser PEReference
+pereference = do
+    myBracket (tok TokPercent) (tok TokSemi) nmtoken
+
+entitydecl :: XParser EntityDecl
+entitydecl =
+    ( gedecl >>= return . EntityGEDecl) `onFail`
+    ( pedecl >>= return . EntityPEDecl)
+
+gedecl :: XParser GEDecl
+gedecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial ENTITYx)
+    n <- name
+    e <- entitydef `adjustErrBad` (("in general entity defn "++n++",\n")++)
+    tok TokAnyClose `onFail` failBadP ("expected > terminating G ENTITY decl "++n)
+    stUpdate (addGE n e) `debug` ("added GE defn &"++n++";")
+    return (GEDecl n e)
+
+pedecl :: XParser PEDecl
+pedecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial ENTITYx)
+    tok TokPercent
+    n <- name
+    e <- pedef `adjustErrBad` (("in parameter entity defn "++n++",\n")++)
+    tok TokAnyClose `onFail` failBadP ("expected > terminating P ENTITY decl "++n)
+    stUpdate (addPE n e) `debug` ("added PE defn %"++n++";\n"++show e)
+    return (PEDecl n e)
+
+entitydef :: XParser EntityDef
+entitydef =
+    oneOf' [ ("entityvalue", entityvalue >>= return . DefEntityValue)
+           , ("external",    do eid <- externalid
+                                ndd <- maybe ndatadecl
+                                return (DefExternalID eid ndd))
+           ]
+
+pedef :: XParser PEDef
+pedef =
+    oneOf' [ ("entityvalue", entityvalue >>= return . PEDefEntityValue)
+           , ("externalid",  externalid  >>= return . PEDefExternalID)
+           ]
+
+externalid :: XParser ExternalID
+externalid =
+    oneOf' [ ("SYSTEM", do word "SYSTEM"
+                           s <- systemliteral
+                           return (SYSTEM s) )
+           , ("PUBLIC", do word "PUBLIC"
+                           p <- pubidliteral
+                           s <- systemliteral
+                           return (PUBLIC p s) )
+           ]
+      `adjustErr` ("looking for an external id,\n"++)
+
+ndatadecl :: XParser NDataDecl
+ndatadecl = do
+    word "NDATA"
+    n <- name
+    return (NDATA n)
+
+textdecl :: XParser TextDecl
+textdecl = do
+    tok TokPIOpen
+    (word "xml" `onFail` word "XML")
+    v <- maybe versioninfo
+    e <- encodingdecl
+    tok TokPIClose `onFail` failP "expected ?> terminating text decl"
+    return (TextDecl v e)
+
+extparsedent :: XParser (ExtParsedEnt Posn)
+extparsedent = do
+    t <- maybe textdecl
+    c <- content
+    return (ExtParsedEnt t c)
+
+extpe :: XParser ExtPE
+extpe = do
+    t <- maybe textdecl
+    e <- many (peRef extsubsetdecl)
+    return (ExtPE t e)
+
+encodingdecl :: XParser EncodingDecl
+encodingdecl = do
+    (word "encoding" `onFail` word "ENCODING")
+    tok TokEqual `onFail` failBadP "expected = in 'encoding' decl"
+    f <- bracket (tok TokQuote) (tok TokQuote) freetext
+    return (EncodingDecl f)
+
+notationdecl :: XParser NotationDecl
+notationdecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial NOTATIONx)
+    n <- name
+    e <- either externalid publicid
+    tok TokAnyClose `onFail` failBadP ("expected > terminating NOTATION decl "++n)
+    return (NOTATION n e)
+
+publicid :: XParser PublicID
+publicid = do
+    word "PUBLIC"
+    p <- pubidliteral
+    return (PUBLICID p)
+
+entityvalue :: XParser EntityValue
+entityvalue = do
+ -- evs <- bracket (tok TokQuote) (tok TokQuote) (many (peRef ev))
+    tok TokQuote
+    pn <- posn
+    evs <- many ev
+    tok TokQuote `onFail` failBadP "expected quote to terminate entityvalue"
+    -- quoted text must be rescanned for possible PERefs
+    st <- stGet
+    Prelude.either failBad (return . EntityValue) . fst3 $
+                (runParser (many ev) st
+                         (reLexEntityValue (\s-> stringify (lookupPE s st))
+                                           pn
+                                           (flattenEV (EntityValue evs))))
+  where
+    stringify (Just (PEDefEntityValue ev)) = Just (flattenEV ev)
+    stringify _ = Nothing
+
+ev :: XParser EV
+ev =
+    oneOf' [ ("string",    (string`onFail`freetext) >>= return . EVString)
+           , ("reference", reference >>= return . EVRef)
+           ]
+      `adjustErr` ("looking for entity value,\n"++)
+
+attvalue :: XParser AttValue
+attvalue = do
+    avs <- bracket (tok TokQuote) (tok TokQuote)
+                   (many (either freetext reference))
+    return (AttValue avs)
+
+systemliteral :: XParser SystemLiteral
+systemliteral = do
+    s <- bracket (tok TokQuote) (tok TokQuote) freetext
+    return (SystemLiteral s)            -- note: refs &...; not permitted
+
+pubidliteral :: XParser PubidLiteral
+pubidliteral = do
+    s <- bracket (tok TokQuote) (tok TokQuote) freetext
+    return (PubidLiteral s)             -- note: freetext is too liberal here
+
+-- | Return parsed freetext (i.e. until the next markup)
+chardata :: XParser CharData
+chardata = freetext
+
+

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/ParseLazy.html b/docs/HaXml/src/Text/XML/HaXml/ParseLazy.html
--- a/docs/HaXml/src/Text/XML/HaXml/ParseLazy.html
+++ b/docs/HaXml/src/Text/XML/HaXml/ParseLazy.html
@@ -1,892 +1,906 @@
 
 
-
-- | A non-validating XML parser.  For the input grammar, see
---   <http://www.w3.org/TR/REC-xml>.
-module Text.XML.HaXml.ParseLazy
-  (
-  -- * Parse a whole document
-    xmlParse  -- , xmlParse'
-  -- * Parse just a DTD
-  , dtdParse  -- , dtdParse'
-  -- * Parse a partial document
-  , xmlParseWith
-  -- * Individual parsers for use with /xmlParseWith/ and module SAX
-  , document, element, content
-  , comment, chardata
-  , reference, doctypedecl
-  , processinginstruction
-  , elemtag, name, tok
-  , elemOpenTag, elemCloseTag
-  , emptySTs, XParser
-  -- * These general utility functions don't belong here
-  , fst3, snd3, thd3
-  ) where
-
--- An XML parser, written using a slightly extended version of the
--- Hutton/Meijer parser combinators.  The input is tokenised internally
--- by the lexer xmlLex.  Whilst parsing, we gather a symbol
--- table of entity references.  PERefs must be defined before use, so we
--- expand their uses as we encounter them, forcing the remainder of the
--- input to be re-lexed and re-parsed.  GERefs are simply stored for
--- later retrieval.
-
-import Prelude hiding (either,maybe,sequence,catch)
-import qualified Prelude (either)
-import Maybe hiding (maybe)
-import List (intersperse)       -- debugging only
-import Char (isSpace,isDigit,isHexDigit)
-import Monad hiding (sequence)
-import Numeric (readDec,readHex)
---import Control.Exception (catch)
-
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.Posn
-import Text.XML.HaXml.Lex
-import Text.ParserCombinators.Poly.NoLeak.StateLazy
-
-
-#if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
-    ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
-import System.IO.Unsafe (unsafePerformIO)
-#elif defined(__GLASGOW_HASKELL__)
-import IOExts (unsafePerformIO)
-#elif defined(__NHC__)
-import IOExtras (unsafePerformIO)
-#elif defined(__HBC__)
-import UnsafePerformIO
-#endif
-
---  #define DEBUG
-
-#if defined(DEBUG)
-#  if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
-      ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
-import Debug.Trace(trace)
-#  elif defined(__GLASGOW_HASKELL__)
-import IOExts(trace)
-#  elif defined(__NHC__) || defined(__HBC__)
-import NonStdTrace
-#  endif
-debug :: a -> String -> a
-v `debug` s = trace s v
-#else
-v `debug` s = v
-#endif
-
-
--- | To parse a whole document, @xmlParse file content@ takes a filename
---   (for generating error reports) and the string content of that file.
---   A parse error causes program failure, with message to stderr.
-xmlParse :: String -> String -> Document Posn
-
-{-
--- | To parse a whole document, @xmlParse' file content@ takes a filename
---   (for generating error reports) and the string content of that file.
---   Any parse error message is passed back to the caller through the
---   @Either@ type.
-xmlParse' :: String -> String -> Either String (Document Posn)
-
--- | To parse just a DTD, @dtdParse file content@ takes a filename
---   (for generating error reports) and the string content of that
---   file.  If no DTD was found, you get @Nothing@ rather than an error.
---   However, if a DTD is found but contains errors, the program crashes.
-dtdParse  :: String -> String -> Maybe DocTypeDecl
-
--- | To parse just a DTD, @dtdParse' file content@ takes a filename
---   (for generating error reports) and the string content of that
---   file.  If no DTD was found, you get @Right Nothing@.
---   If a DTD was found but contains errors, you get a @Left message@.
-dtdParse' :: String -> String -> Either String (Maybe DocTypeDecl)
-
-xmlParse' name inp = xmlParse name inp `catch` (Left . show)
-dtdParse' name inp = dtdParse name inp `catch` (Left . show)
--}
-
-xmlParse  name  = fst3 . runParser (toEOF document) emptySTs . xmlLex name
-dtdParse  name  = fst3 . runParser justDTD  emptySTs . xmlLex name
-
-
-toEOF = id	-- there are other possible implementations...
-
--- | To parse a partial document, e.g. from an XML-based stream protocol,
---   where you may later want to get more document elements from the same
---   stream.  Arguments are: a parser for the item you want, and the
---   already-lexed input to parse from.  Returns the item you wanted
---   (or an error message), plus the remainder of the input.
-xmlParseWith :: XParser a -> [(Posn,TokenT)]
-                -> (Either String a, [(Posn,TokenT)])
-xmlParseWith p = (\(v,_,s)->(Right v,s)) . runParser p emptySTs
-
-
----- Symbol table stuff ----
-
-type SymTabs = (SymTab PEDef, SymTab EntityDef)
-
--- | Some empty symbol tables for GE and PE references.
-emptySTs :: SymTabs
-emptySTs = (emptyST, emptyST)
-
-addPE :: String -> PEDef -> SymTabs -> SymTabs
-addPE n v (pe,ge) = (addST n v pe, ge)
-
-addGE :: String -> EntityDef -> SymTabs -> SymTabs
-addGE n v (pe,ge) = let newge = addST n v ge in newge `seq` (pe, newge)
-
-lookupPE :: String -> SymTabs -> Maybe PEDef
-lookupPE s (pe,ge) = lookupST s pe
-
-flattenEV :: EntityValue -> String
-flattenEV (EntityValue evs) = concatMap flatten evs
-  where
-    flatten (EVString s)          = s
-    flatten (EVRef (RefEntity r)) = "&" ++r++";"
-    flatten (EVRef (RefChar r))   = "&#"++show r++";"
- -- flatten (EVPERef n)           = "%" ++n++";"
-
-
----- Misc ----
-fst3 :: (a,b,c) -> a
-snd3 :: (a,b,c) -> b
-thd3 :: (a,b,c) -> c
-
-fst3 (a,_,_) = a
-snd3 (_,a,_) = a
-thd3 (_,_,a) = a
-
-
----- Auxiliary Parsing Functions ----
-
--- | XParser is just a specialisation of the PolyStateLazy parser.
-type XParser a = Parser SymTabs (Posn,TokenT) a
-
--- | Return the next token from the input only if it matches the given token.
-tok :: TokenT -> XParser TokenT
-tok t = do (p,t') <- next
-           case t' of TokError _    -> report failBad (show t) p t'
-                      _ | t'==t     -> return t
-                        | otherwise -> report fail (show t) p t'
-nottok :: [TokenT] -> XParser TokenT
-nottok ts = do (p,t) <- next
-               if t`elem`ts then report fail ("no "++show t) p t
-                            else return t
-
--- | Return just a name, e.g. element name, attribute name.
-name :: XParser Name
-name = do (p,tok) <- next
-          case tok of
-            TokName s  -> return s
-            TokError _ -> report failBad "a name" p tok
-            _          -> report fail "a name" p tok
-
-string, freetext :: XParser String
-string   = do (p,t) <- next
-              case t of TokName s -> return s
-                        _         -> report fail "text" p t
-freetext = do (p,t) <- next
-              case t of TokFreeText s -> return s
-                        _             -> report fail "text" p t
-
-maybe :: XParser a -> XParser (Maybe a)
-maybe p =
-    ( p >>= return . Just) `onFail`
-    ( return Nothing)
-
-either :: XParser a -> XParser b -> XParser (Either a b)
-either p q =
-    ( p >>= return . Left) `onFail`
-    ( q >>= return . Right)
-
-word :: String -> XParser ()
-word s = do { x <- next
-            ; case x of
-                (p,TokName n)     | s==n -> return ()
-                (p,TokFreeText n) | s==n -> return ()
-                (p,t@(TokError _)) -> report failBad (show s) p t
-                (p,t) -> report fail (show s) p t
-            }
-
-posn = do { x@(p,_) <- next
-          ; reparse [x]
-          ; return p
-          }
-
-nmtoken :: XParser NmToken
-nmtoken = (string `onFail` freetext)
-
-failP, failBadP :: String -> XParser a
-failP msg = do { p <- posn; fail (msg++"\n    at "++show p) }
-failBadP msg = do { p <- posn; failBad (msg++"\n    at "++show p) }
-
-report :: (String->XParser a) -> String -> Posn -> TokenT -> XParser a
-report fail exp p t = fail ("Expected "++exp++" but found "++show t
-                           ++"\n  in "++show p)
-
-adjustErrP :: XParser a -> (String->String) -> XParser a
-p `adjustErrP` f = p `onFail` do pn <- posn
-                                 (p `adjustErr` f) `adjustErr` (++show pn)
-
-peRef :: XParser a -> XParser a
-peRef p =
-    p `onFail`
-    do pn <- posn
-       n <- pereference
-       tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n)
-       case tr of
-           Just (PEDefEntityValue ev) ->
-                      do reparse (xmlReLex (posInNewCxt ("macro %"++n++";")
-                                                        (Just pn))
-                                           (flattenEV ev))
-                               `debug` ("  defn:  "++flattenEV ev)
-                         peRef p
-           Just (PEDefExternalID (PUBLIC _ (SystemLiteral f))) ->
-                      do let val = unsafePerformIO (readFile f)
-                         reparse (xmlReLex (posInNewCxt ("file "++f)
-                                                        (Just pn)) val)
-                               `debug` ("  reading from file "++f)
-                         peRef p
-           Just (PEDefExternalID (SYSTEM (SystemLiteral f))) ->
-                      do let val = unsafePerformIO (readFile f)
-                         reparse (xmlReLex (posInNewCxt ("file "++f)
-                                                        (Just pn)) val)
-                               `debug` ("  reading from file "++f)
-                         peRef p
-           Nothing -> fail ("PEReference use before definition: "++"%"++n++";"
-                           ++"\n    at "++show pn)
-
-blank :: XParser a -> XParser a
-blank p =
-    p `onFail`
-    do n <- pereference
-       tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n++" (is blank?)")
-       case tr of
-           Just (PEDefEntityValue ev)
-                    | all isSpace (flattenEV ev)  ->
-                            do blank p `debug` "Empty macro definition"
-           Just _  -> failP ("expected a blank PERef macro: "++"%"++n++";")
-           Nothing -> failP ("PEReference use before definition: "++"%"++n++";")
-
-
-
----- XML Parsing Functions ----
-
-justDTD :: XParser (Maybe DocTypeDecl)
-justDTD =
-  do (ExtSubset _ ds) <- extsubset `debug` "Trying external subset"
-     if null ds then fail "empty"
-         else return (Just (DTD "extsubset" Nothing (concatMap extract ds)))
-  `onFail`
-  do (Prolog _ _ dtd _) <- prolog
-     return dtd
- where extract (ExtMarkupDecl m) = [m]
-       extract (ExtConditionalSect (IncludeSect i)) = concatMap extract i
-       extract (ExtConditionalSect (IgnoreSect i)) = []
-
--- | Return an entire XML document including prolog and trailing junk.
-document :: XParser (Document Posn)
-document = do
- -- p <- prolog `adjustErr` ("unrecognisable XML prolog\n"++)
- -- e <- element
- -- ms <- many misc
- -- (_,ge) <- stGet
- -- return (Document p ge e ms)
-    return Document `apply` (prolog `adjustErr`
-                                    ("unrecognisable XML prolog\n"++))
-                    `apply` (fmap snd stGet)
-                    `apply` element
-                    `apply` many misc
-
--- | Return an XML comment.
-comment :: XParser Comment
-comment = do
-    bracket (tok TokCommentOpen) (tok TokCommentClose) freetext
---  tok TokCommentOpen
---  commit $ do
---    c <- freetext
---    tok TokCommentClose
---    return c
-
--- | Parse a processing instruction.
-processinginstruction :: XParser ProcessingInstruction
-processinginstruction = do
-    tok TokPIOpen
-    commit $ do
-      n <- string  `onFail` failP "processing instruction has no target"
-      f <- freetext
-      tok TokPIClose `onFail` failP ("missing ?> in <?"++n)
-      return (n, f)
-
-cdsect :: XParser CDSect
-cdsect = do
-    tok TokSectionOpen
-    bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata
-
-prolog :: XParser Prolog
-prolog = do
-    x   <- maybe xmldecl
-    m1  <- many misc
-    dtd <- maybe doctypedecl
-    m2  <- many misc
-    return (Prolog x m1 dtd m2)
-
-xmldecl :: XParser XMLDecl
-xmldecl = do
-    tok TokPIOpen
-    (word "xml" `onFail` word "XML")
-    p <- posn
-    s <- freetext
-    tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"
- -- raise ((runParser aux emptySTs . xmlReLex p) s)
-    return (fst3 ((runParser aux emptySTs . xmlReLex p) s))
-  where
-    aux = do
-        v <- versioninfo  `onFail` failP "missing XML version info"
-        e <- maybe encodingdecl
-        s <- maybe sddecl
-        return (XMLDecl v e s)
- -- raise (Left err, _, _) = failP err
- -- raise (Right ok, _, _) = return ok
-
-versioninfo :: XParser VersionInfo
-versioninfo = do
-    (word "version" `onFail` word "VERSION")
-    tok TokEqual
-    bracket (tok TokQuote) (tok TokQuote) freetext
-
-misc :: XParser Misc
-misc =
-    oneOf' [ ("<!--comment-->",  comment >>= return . Comment)
-           , ("<?PI?>",          processinginstruction >>= return . PI)
-           ]
-
--- | Return a DOCTYPE decl, indicating a DTD.
-doctypedecl :: XParser DocTypeDecl
-doctypedecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial DOCTYPEx)
-    commit $ do
-      n   <- name
-      eid <- maybe externalid
-      es  <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)
-                            (many (peRef markupdecl)))
-      blank (tok TokAnyClose)  `onFail` failP "missing > in DOCTYPE decl"
-      return (DTD n eid (case es of { Nothing -> []; Just e -> e }))
-
--- | Return a DTD markup decl, e.g. ELEMENT, ATTLIST, etc
-markupdecl :: XParser MarkupDecl
-markupdecl =
-  oneOf' [ ("ELEMENT",  elementdecl  >>= return . Element)
-         , ("ATTLIST",  attlistdecl  >>= return . AttList)
-         , ("ENTITY",   entitydecl   >>= return . Entity)
-         , ("NOTATION", notationdecl >>= return . Notation)
-         , ("misc",     misc         >>= return . MarkupMisc)
-         ]
-    `adjustErrP`
-          ("when looking for a markup decl,\n"++)
- --       (\  (ELEMENT, ATTLIST, ENTITY, NOTATION, <!--comment-->, or <?PI?>")
-
-extsubset :: XParser ExtSubset
-extsubset = do
-    td <- maybe textdecl
-    ds <- many (peRef extsubsetdecl)
-    return (ExtSubset td ds)
-
-extsubsetdecl :: XParser ExtSubsetDecl
-extsubsetdecl =
-    ( markupdecl >>= return . ExtMarkupDecl) `onFail`
-    ( conditionalsect >>= return . ExtConditionalSect)
-
-sddecl :: XParser SDDecl
-sddecl = do
-    (word "standalone" `onFail` word "STANDALONE")
-    commit $ do
-      tok TokEqual `onFail` failP "missing = in 'standalone' decl"
-      bracket (tok TokQuote) (tok TokQuote)
-              ( (word "yes" >> return True) `onFail`
-                (word "no" >> return False) `onFail`
-                failP "'standalone' decl requires 'yes' or 'no' value" )
-
-{-
-element :: XParser (Element Posn)
-element = do
-    tok TokAnyOpen
-    (ElemTag n as) <- elemtag
-    oneOf' [ ("self-closing tag <"++n++"/>"
-             ,  do tok TokEndClose
-                   return (Elem n as []))
-           , ("after open tag <"++n++">"
-             ,  do tok TokAnyClose
-                   cs <- many content
-                   p  <- posn
-                   m  <- bracket (tok TokEndOpen) (tok TokAnyClose) name
-                   checkmatch p n m
-                   return (Elem n as cs))
-           ] `adjustErr` (("in element tag "++n++",\n")++)
--}
-
--- | Return a complete element including all its inner content.
-element :: XParser (Element Posn)
-element = do
-    tok TokAnyOpen
-    (ElemTag n as) <- elemtag
-    return (Elem n as) `apply`
-        ( do tok TokEndClose
-             return []
-          `onFail`
-          do tok TokAnyClose
-             commit $ manyFinally content
-                                  (do p <- posn
-                                      m <- bracket (tok TokEndOpen)
-                                                   (tok TokAnyClose) name
-                                      checkmatch p n m)
-          ) `adjustErrBad` (("in element tag "++n++",\n")++)
-
-checkmatch :: Posn -> Name -> Name -> XParser ()
-checkmatch p n m =
-  if n == m then return ()
-  else failBadP ("tag <"++n++"> terminated by </"++m++">")
-
--- | Parse only the parts between angle brackets in an element tag.
-elemtag :: XParser ElemTag
-elemtag = do
-    n  <- name `adjustErrBad` ("malformed element tag\n"++)
-    as <- many attribute
-    return (ElemTag n as)
-
--- | For use with stream parsers - returns the complete opening element tag.
-elemOpenTag :: XParser ElemTag
-elemOpenTag = do
-    tok TokAnyOpen
-    e <- elemtag
-    tok TokAnyClose
-    return e
-
--- | For use with stream parsers - accepts a closing tag, provided it
---   matches the given element name.
-elemCloseTag :: Name -> XParser ()
-elemCloseTag n = do
-    tok TokEndOpen
-    p <- posn
-    m <- name
-    tok TokAnyClose
-    checkmatch p n m
-
-attribute :: XParser Attribute
-attribute = do
-    n <- name `adjustErr` ("malformed attribute name\n"++)
-    tok TokEqual `onFail` failBadP "missing = in attribute"
-    v <- attvalue `onFail` failBadP "missing attvalue"
-    return (n,v)
-
--- | Return a content particle, e.g. text, element, reference, etc
-content :: XParser (Content Posn)
-content =
-  do { p  <- posn
-     ; c' <- content'
-     ; return (c' p)
-     }
-  where
-     content' = oneOf' [ ("element",   element   >>= return . CElem)
-                       , ("chardata",  chardata  >>= return . CString False)
-                       , ("reference", reference >>= return . CRef)
-                       , ("CDATA",     cdsect    >>= return . CString True)
-                       , ("misc",      misc      >>= return . CMisc)
-                       ]
-                  `adjustErrP` ("when looking for a content item,\n"++)
--- (\    (element, text, reference, CDATA section, <!--comment-->, or <?PI?>")
-
-elementdecl :: XParser ElementDecl
-elementdecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial ELEMENTx)
-    n <- peRef name `adjustErrBad` ("expecting identifier in ELEMENT decl\n"++)
-    c <- peRef contentspec
-             `adjustErrBad` (("in content spec of ELEMENT decl: "++n++"\n")++)
-    blank (tok TokAnyClose) `onFail` failBadP
-       ("expected > terminating ELEMENT decl"
-       ++"\n    element name was "++show n
-       ++"\n    contentspec was "++(\ (ContentSpec p)-> show p) c)
-    return (ElementDecl n c)
-
-contentspec :: XParser ContentSpec
-contentspec =
-    oneOf' [ ("EMPTY",  peRef (word "EMPTY") >> return EMPTY)
-           , ("ANY",    peRef (word "ANY") >> return ANY)
-           , ("mixed",  peRef mixed >>= return . Mixed)
-           , ("simple", peRef cp >>= return . ContentSpec)
-           ]
- --   `adjustErr` ("when looking for content spec,\n"++)
- --   `adjustErr` (++"\nLooking for content spec (EMPTY, ANY, mixed, etc)")
-
-choice :: XParser [CP]
-choice = do
-    bracket (tok TokBraOpen `debug` "Trying choice")
-            (blank (tok TokBraClose `debug` "Succeeded with choice"))
-            (peRef cp `sepBy1` blank (tok TokPipe))
-
-sequence :: XParser [CP]
-sequence = do	-- bracket is inappropriate because of inner failBad
- -- bracket (tok TokBraOpen `debug` "Trying sequence")
- --         (blank (tok TokBraClose `debug` "Succeeded with sequence"))
- --         (peRef cp `sepBy1` blank (tok TokComma))
-    tok TokBraOpen `debug` "Trying sequence"
-    cps <- peRef cp `sepBy1` blank (tok TokComma)
-    blank (tok TokBraClose `debug` "Succeeded with sequence")
-    return cps
-
-cp :: XParser CP
-cp = oneOf [ ( do n <- name
-                  m <- modifier
-                  let c = TagName n m
-                  return c `debug` ("ContentSpec: name "++show c))
-           , ( do ss <- sequence
-                  m <- modifier
-                  let c = Seq ss m
-                  return c `debug` ("ContentSpec: sequence "++show c))
-           , ( do cs <- choice
-                  m <- modifier
-                  let c = Choice cs m
-                  return c `debug` ("ContentSpec: choice "++show c))
-           ] `adjustErr` (++"\nwhen looking for a content particle")
-
-modifier :: XParser Modifier
-modifier = oneOf [ ( tok TokStar >> return Star )
-                 , ( tok TokQuery >> return Query )
-                 , ( tok TokPlus >> return Plus )
-                 , ( return None )
-                 ]
-
--- just for debugging
-instance Show CP where
-    show (TagName n m) = n++show m
-    show (Choice cps m) = '(': concat (intersperse "|" (map show cps))
-                          ++")"++show m
-    show (Seq cps m) = '(': concat (intersperse "," (map show cps))
-                          ++")"++show m
-instance Show Modifier where
-    show None = ""
-    show Query = "?"
-    show Star = "*"
-    show Plus = "+"
-----
-
-mixed :: XParser Mixed
-mixed = do
-    tok TokBraOpen
-    peRef (do tok TokHash
-              word "PCDATA")
-    commit $
-      oneOf [ ( do cs <- many (peRef (do tok TokPipe
-                                         peRef name))
-                   blank (tok TokBraClose >> tok TokStar)
-                   return (PCDATAplus cs))
-            , ( blank (tok TokBraClose >> tok TokStar) >> return PCDATA)
-            , ( blank (tok TokBraClose) >> return PCDATA)
-            ]
-        `adjustErrP` (++"\nLooking for mixed content spec (#PCDATA | ...)*\n")
-
-attlistdecl :: XParser AttListDecl
-attlistdecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial ATTLISTx)
-    n <- peRef name `adjustErrBad` ("expecting identifier in ATTLIST\n"++)
-    ds <- peRef (many1 (peRef attdef))
-    blank (tok TokAnyClose) `onFail` failBadP "missing > terminating ATTLIST"
-    return (AttListDecl n ds)
-
-attdef :: XParser AttDef
-attdef =
-  do n <- peRef name `adjustErr` ("expecting attribute name\n"++)
-     t <- peRef atttype `adjustErr` (("within attlist defn: "++n++",\n")++)
-     d <- peRef defaultdecl `adjustErr` (("in attlist defn: "++n++",\n")++)
-     return (AttDef n t d)
-
-atttype :: XParser AttType
-atttype =
-    oneOf' [ ("CDATA",      word "CDATA" >> return StringType)
-           , ("tokenized",  tokenizedtype >>= return . TokenizedType)
-           , ("enumerated", enumeratedtype >>= return . EnumeratedType)
-           ]
-      `adjustErr` ("looking for ATTTYPE,\n"++)
- --   `adjustErr` (++"\nLooking for ATTTYPE (CDATA, tokenized, or enumerated")
-
-tokenizedtype :: XParser TokenizedType
-tokenizedtype =
-    oneOf [ ( word "ID" >> return ID)
-          , ( word "IDREF" >> return IDREF)
-          , ( word "IDREFS" >> return IDREFS)
-          , ( word "ENTITY" >> return ENTITY)
-          , ( word "ENTITIES" >> return ENTITIES)
-          , ( word "NMTOKEN" >> return NMTOKEN)
-          , ( word "NMTOKENS" >> return NMTOKENS)
-          ] `onFail`
-    do { t <- next
-       ; failP ("Expected one of"
-               ++" (ID, IDREF, IDREFS, ENTITY, ENTITIES, NMTOKEN, NMTOKENS)"
-               ++"\nbut got "++show t)
-       }
--- `adjustErr` (++"\nLooking for a tokenized type:\n\ 
--- \    (ID, IDREF, IDREFS, ENTITY, ENTITIES, NMTOKEN, NMTOKENS)")
-
-enumeratedtype :: XParser EnumeratedType
-enumeratedtype =
-    oneOf' [ ("NOTATION",   notationtype >>= return . NotationType)
-           , ("enumerated", enumeration >>= return . Enumeration)
-           ]
-      `adjustErr` ("looking for an enumerated or NOTATION type,\n"++)
-
-notationtype :: XParser NotationType
-notationtype = do
-    word "NOTATION"
-    bracket (tok TokBraOpen) (blank (tok TokBraClose))
-            (peRef name `sepBy1` peRef (tok TokPipe))
-
-enumeration :: XParser Enumeration
-enumeration =
-    bracket (tok TokBraOpen) (blank (tok TokBraClose))
-            (peRef nmtoken `sepBy1` blank (peRef (tok TokPipe)))
-
-defaultdecl :: XParser DefaultDecl
-defaultdecl =
-    oneOf' [ ("REQUIRED",  tok TokHash >> word "REQUIRED" >> return REQUIRED)
-           , ("IMPLIED",   tok TokHash >> word "IMPLIED" >> return IMPLIED)
-           , ("FIXED",     do f <- maybe (tok TokHash >> word "FIXED"
-                                                      >> return FIXED)
-                              a <- peRef attvalue
-                              return (DefaultTo a f) )
-           ]
-        `adjustErr` ("looking for an attribute default decl,\n"++)
---      `adjustErr` (++"\nLooking for an attribute default decl:\n\ 
--- \    (REQUIRED, IMPLIED, FIXED)")
-
-conditionalsect :: XParser ConditionalSect
-conditionalsect = oneOf'
-    [ ( "INCLUDE"
-      , do tok TokSectionOpen
-           peRef (tok (TokSection INCLUDEx))
-           p <- posn
-           tok TokSqOpen `onFail` failBadP "missing [ after INCLUDE"
-           i <- many (peRef extsubsetdecl)
-           tok TokSectionClose
-                   `onFail` failBadP ("missing ]]> for INCLUDE section"
-                                     ++"\n    begun at "++show p)
-           return (IncludeSect i))
-    , ( "IGNORE"
-      , do tok TokSectionOpen
-           peRef (tok (TokSection IGNOREx))
-           p <- posn
-           tok TokSqOpen `onFail` failBadP "missing [ after IGNORE"
-           i <- many newIgnore  -- many ignoresectcontents
-           tok TokSectionClose
-                   `onFail` failBadP ("missing ]]> for IGNORE section"
-                                     ++"\n    begun at "++show p)
-           return (IgnoreSect []))
-    ] `adjustErr` ("in a conditional section,\n"++)
-
-newIgnore :: XParser Ignore
-newIgnore =
-    ( do tok TokSectionOpen
-         many newIgnore `debug` "IGNORING conditional section"
-         tok TokSectionClose
-         return Ignore `debug` "end of IGNORED conditional section") `onFail`
-    ( do t <- nottok [TokSectionOpen,TokSectionClose]
-         return Ignore  `debug` ("ignoring: "++show t))
-
---- obsolete?
-ignoresectcontents :: XParser IgnoreSectContents
-ignoresectcontents = do
-    i <- ignore
-    is <- many (do tok TokSectionOpen
-                   ic <- ignoresectcontents
-                   tok TokSectionClose
-                   ig <- ignore
-                   return (ic,ig))
-    return (IgnoreSectContents i is)
-
-ignore :: XParser Ignore
-ignore = do
-  is <- many1 (nottok [TokSectionOpen,TokSectionClose])
-  return Ignore  `debug` ("ignored all of: "++show is)
-----
-
--- | Return either a general entity reference, or a character reference.
-reference :: XParser Reference
-reference = do
-    bracket (tok TokAmp) (tok TokSemi) (freetext >>= val)
-  where
-    val ('#':'x':i) | all isHexDigit i
-                    = return . RefChar . fst . head . readHex $ i
-    val ('#':i)     | all isDigit i
-                    = return . RefChar . fst . head . readDec $ i
-    val name        = return . RefEntity $ name
-
-{- -- following is incorrect
-reference =
-    ( charref >>= return . RefChar) `onFail`
-    ( entityref >>= return . RefEntity)
-
-entityref :: XParser EntityRef
-entityref = do
-    bracket (tok TokAmp) (tok TokSemi) name
-
-charref :: XParser CharRef
-charref = do
-    bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal)
-  where
-    readCharVal ('#':'x':i) = return . fst . head . readHex $ i
-    readCharVal ('#':i)     = return . fst . head . readDec $ i
-    readCharVal _           = mzero
--}
-
-pereference :: XParser PEReference
-pereference = do
-    bracket (tok TokPercent) (tok TokSemi) nmtoken
-
-entitydecl :: XParser EntityDecl
-entitydecl =
-    ( gedecl >>= return . EntityGEDecl) `onFail`
-    ( pedecl >>= return . EntityPEDecl)
-
-gedecl :: XParser GEDecl
-gedecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial ENTITYx)
-    n <- name
-    e <- entitydef `adjustErrBad` (("in general entity defn "++n++",\n")++)
-    tok TokAnyClose `onFail` failBadP ("expected > terminating G ENTITY decl "++n)
-    stUpdate (addGE n e) `debug` ("added GE defn &"++n++";")
-    return (GEDecl n e)
-
-pedecl :: XParser PEDecl
-pedecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial ENTITYx)
-    tok TokPercent
-    n <- name
-    e <- pedef `adjustErrBad` (("in parameter entity defn "++n++",\n")++)
-    tok TokAnyClose `onFail` failBadP ("expected > terminating P ENTITY decl "++n)
-    stUpdate (addPE n e) `debug` ("added PE defn %"++n++";\n"++show e)
-    return (PEDecl n e)
-
-entitydef :: XParser EntityDef
-entitydef =
-    oneOf' [ ("entityvalue", entityvalue >>= return . DefEntityValue)
-           , ("external",    do eid <- externalid
-                                ndd <- maybe ndatadecl
-                                return (DefExternalID eid ndd))
-           ]
-
-pedef :: XParser PEDef
-pedef =
-    oneOf' [ ("entityvalue", entityvalue >>= return . PEDefEntityValue)
-           , ("externalid",  externalid  >>= return . PEDefExternalID)
-           ]
-
-externalid :: XParser ExternalID
-externalid =
-    oneOf' [ ("SYSTEM", do word "SYSTEM"
-                           s <- systemliteral
-                           return (SYSTEM s) )
-           , ("PUBLIC", do word "PUBLIC"
-                           p <- pubidliteral
-                           s <- systemliteral
-                           return (PUBLIC p s) )
-           ]
-      `adjustErr` ("looking for an external id,\n"++)
-
-ndatadecl :: XParser NDataDecl
-ndatadecl = do
-    word "NDATA"
-    n <- name
-    return (NDATA n)
-
-textdecl :: XParser TextDecl
-textdecl = do
-    tok TokPIOpen
-    (word "xml" `onFail` word "XML")
-    v <- maybe versioninfo
-    e <- encodingdecl
-    tok TokPIClose `onFail` failP "expected ?> terminating text decl"
-    return (TextDecl v e)
-
-extparsedent :: XParser (ExtParsedEnt Posn)
-extparsedent = do
-    t <- maybe textdecl
-    c <- content
-    return (ExtParsedEnt t c)
-
-extpe :: XParser ExtPE
-extpe = do
-    t <- maybe textdecl
-    e <- many (peRef extsubsetdecl)
-    return (ExtPE t e)
-
-encodingdecl :: XParser EncodingDecl
-encodingdecl = do
-    (word "encoding" `onFail` word "ENCODING")
-    tok TokEqual `onFail` failBadP "expected = in 'encoding' decl"
-    f <- bracket (tok TokQuote) (tok TokQuote) freetext
-    return (EncodingDecl f)
-
-notationdecl :: XParser NotationDecl
-notationdecl = do
-    tok TokSpecialOpen
-    tok (TokSpecial NOTATIONx)
-    n <- name
-    e <- either externalid publicid
-    tok TokAnyClose `onFail` failBadP ("expected > terminating NOTATION decl "++n)
-    return (NOTATION n e)
-
-publicid :: XParser PublicID
-publicid = do
-    word "PUBLIC"
-    p <- pubidliteral
-    return (PUBLICID p)
-
-entityvalue :: XParser EntityValue
-entityvalue = do
- -- evs <- bracket (tok TokQuote) (tok TokQuote) (many (peRef ev))
-    tok TokQuote
-    pn <- posn
-    evs <- many ev
-    tok TokQuote `onFail` failBadP "expected quote to terminate entityvalue"
-    -- quoted text must be rescanned for possible PERefs
-    st <- stGet
- -- Prelude.either failBad (return . EntityValue) . fst3 $
-    return . EntityValue . fst3 $
-                (runParser (many ev) st
-                         (reLexEntityValue (\s-> stringify (lookupPE s st))
-                                           pn
-                                           (flattenEV (EntityValue evs))))
-  where
-    stringify (Just (PEDefEntityValue ev)) = Just (flattenEV ev)
-    stringify _ = Nothing
-
-ev :: XParser EV
-ev =
-    oneOf' [ ("string",    (string`onFail`freetext) >>= return . EVString)
-           , ("reference", reference >>= return . EVRef)
-           ]
-      `adjustErr` ("looking for entity value,\n"++)
-
-attvalue :: XParser AttValue
-attvalue = do
-    avs <- bracket (tok TokQuote) (tok TokQuote)
-                   (many (either freetext reference))
-    return (AttValue avs)
-
-systemliteral :: XParser SystemLiteral
-systemliteral = do
-    s <- bracket (tok TokQuote) (tok TokQuote) freetext
-    return (SystemLiteral s)            -- note: refs &...; not permitted
-
-pubidliteral :: XParser PubidLiteral
-pubidliteral = do
-    s <- bracket (tok TokQuote) (tok TokQuote) freetext
-    return (PubidLiteral s)             -- note: freetext is too liberal here
-
--- | Return parsed freetext (i.e. until the next markup)
-chardata :: XParser CharData
-chardata = freetext
-
-

+
+
+src/Text/XML/HaXml/ParseLazy.hs
+
+
+
-- | A non-validating XML parser.  For the input grammar, see
+--   <http://www.w3.org/TR/REC-xml>.
+module Text.XML.HaXml.ParseLazy
+  (
+  -- * Parse a whole document
+    xmlParse  -- , xmlParse'
+  -- * Parse just a DTD
+  , dtdParse  -- , dtdParse'
+  -- * Parse a partial document
+  , xmlParseWith
+  -- * Individual parsers for use with /xmlParseWith/ and module SAX
+  , document, element, content
+  , comment, chardata
+  , reference, doctypedecl
+  , processinginstruction
+  , elemtag, name, tok
+  , elemOpenTag, elemCloseTag
+  , emptySTs, XParser
+  -- * These general utility functions don't belong here
+  , fst3, snd3, thd3
+  ) where
+
+-- An XML parser, written using a slightly extended version of the
+-- Hutton/Meijer parser combinators.  The input is tokenised internally
+-- by the lexer xmlLex.  Whilst parsing, we gather a symbol
+-- table of entity references.  PERefs must be defined before use, so we
+-- expand their uses as we encounter them, forcing the remainder of the
+-- input to be re-lexed and re-parsed.  GERefs are simply stored for
+-- later retrieval.
+
+import Prelude hiding (either,maybe,sequence,catch)
+import qualified Prelude (either)
+import Maybe hiding (maybe)
+import List (intersperse)       -- debugging only
+import Char (isSpace,isDigit,isHexDigit)
+import Monad hiding (sequence)
+import Numeric (readDec,readHex)
+--import Control.Exception (catch)
+
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.Posn
+import Text.XML.HaXml.Lex
+import Text.ParserCombinators.Poly.NoLeak.StateLazy
+
+import System.FilePath (combine, dropFileName)
+
+
+#if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
+    ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
+import System.IO.Unsafe (unsafePerformIO)
+#elif defined(__GLASGOW_HASKELL__)
+import IOExts (unsafePerformIO)
+#elif defined(__NHC__)
+import IOExtras (unsafePerformIO)
+#elif defined(__HBC__)
+import UnsafePerformIO
+#endif
+
+--  #define DEBUG
+
+#if defined(DEBUG)
+#  if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
+      ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
+import Debug.Trace(trace)
+#  elif defined(__GLASGOW_HASKELL__)
+import IOExts(trace)
+#  elif defined(__NHC__) || defined(__HBC__)
+import NonStdTrace
+#  endif
+debug :: a -> String -> a
+v `debug` s = trace s v
+#else
+v `debug` s = v
+#endif
+
+
+-- | To parse a whole document, @xmlParse file content@ takes a filename
+--   (for generating error reports) and the string content of that file.
+--   A parse error causes program failure, with message to stderr.
+xmlParse :: String -> String -> Document Posn
+
+{-
+-- | To parse a whole document, @xmlParse' file content@ takes a filename
+--   (for generating error reports) and the string content of that file.
+--   Any parse error message is passed back to the caller through the
+--   @Either@ type.
+xmlParse' :: String -> String -> Either String (Document Posn)
+
+-- | To parse just a DTD, @dtdParse file content@ takes a filename
+--   (for generating error reports) and the string content of that
+--   file.  If no DTD was found, you get @Nothing@ rather than an error.
+--   However, if a DTD is found but contains errors, the program crashes.
+dtdParse  :: String -> String -> Maybe DocTypeDecl
+
+-- | To parse just a DTD, @dtdParse' file content@ takes a filename
+--   (for generating error reports) and the string content of that
+--   file.  If no DTD was found, you get @Right Nothing@.
+--   If a DTD was found but contains errors, you get a @Left message@.
+dtdParse' :: String -> String -> Either String (Maybe DocTypeDecl)
+
+xmlParse' name inp = xmlParse name inp `catch` (Left . show)
+dtdParse' name inp = dtdParse name inp `catch` (Left . show)
+-}
+
+xmlParse  name  = fst3 . runParser (toEOF document) emptySTs . xmlLex name
+dtdParse  name  = fst3 . runParser justDTD  emptySTs . xmlLex name
+
+
+toEOF = id	-- there are other possible implementations...
+
+-- | To parse a partial document, e.g. from an XML-based stream protocol,
+--   where you may later want to get more document elements from the same
+--   stream.  Arguments are: a parser for the item you want, and the
+--   already-lexed input to parse from.  Returns the item you wanted
+--   (or an error message), plus the remainder of the input.
+xmlParseWith :: XParser a -> [(Posn,TokenT)]
+                -> (Either String a, [(Posn,TokenT)])
+xmlParseWith p = (\(v,_,s)->(Right v,s)) . runParser p emptySTs
+
+
+---- Symbol table stuff ----
+
+type SymTabs = (SymTab PEDef, SymTab EntityDef)
+
+-- | Some empty symbol tables for GE and PE references.
+emptySTs :: SymTabs
+emptySTs = (emptyST, emptyST)
+
+addPE :: String -> PEDef -> SymTabs -> SymTabs
+addPE n v (pe,ge) = (addST n v pe, ge)
+
+addGE :: String -> EntityDef -> SymTabs -> SymTabs
+addGE n v (pe,ge) = let newge = addST n v ge in newge `seq` (pe, newge)
+
+lookupPE :: String -> SymTabs -> Maybe PEDef
+lookupPE s (pe,ge) = lookupST s pe
+
+flattenEV :: EntityValue -> String
+flattenEV (EntityValue evs) = concatMap flatten evs
+  where
+    flatten (EVString s)          = s
+    flatten (EVRef (RefEntity r)) = "&" ++r++";"
+    flatten (EVRef (RefChar r))   = "&#"++show r++";"
+ -- flatten (EVPERef n)           = "%" ++n++";"
+
+
+---- Misc ----
+fst3 :: (a,b,c) -> a
+snd3 :: (a,b,c) -> b
+thd3 :: (a,b,c) -> c
+
+fst3 (a,_,_) = a
+snd3 (_,a,_) = a
+thd3 (_,_,a) = a
+
+
+---- Auxiliary Parsing Functions ----
+
+-- | Parse a bracketed item, discarding the brackets AND NOT using adjustErrBad
+myBracket :: PolyParse p => p bra -> p ket -> p a -> p a
+myBracket open close p = do
+    do { open    `adjustErr` ("Missing opening bracket:\n\t"++)
+       ; p `discard` (close `adjustErr` ("Missing closing bracket:\n\t"++))
+       }
+
+
+-- | XParser is just a specialisation of the PolyStateLazy parser.
+type XParser a = Parser SymTabs (Posn,TokenT) a
+
+-- | Return the next token from the input only if it matches the given token.
+tok :: TokenT -> XParser TokenT
+tok t = do (p,t') <- next
+           case t' of TokError _    -> report failBad (show t) p t'
+                      _ | t'==t     -> return t
+                        | otherwise -> report fail (show t) p t'
+nottok :: [TokenT] -> XParser TokenT
+nottok ts = do (p,t) <- next
+               if t`elem`ts then report fail ("no "++show t) p t
+                            else return t
+
+-- | Return just a name, e.g. element name, attribute name.
+name :: XParser Name
+name = do (p,tok) <- next
+          case tok of
+            TokName s  -> return s
+            TokError _ -> report failBad "a name" p tok
+            _          -> report fail "a name" p tok
+
+string, freetext :: XParser String
+string   = do (p,t) <- next
+              case t of TokName s -> return s
+                        _         -> report fail "text" p t
+freetext = do (p,t) <- next
+              case t of TokFreeText s -> return s
+                        _             -> report fail "text" p t
+
+maybe :: XParser a -> XParser (Maybe a)
+maybe p =
+    ( p >>= return . Just) `onFail`
+    ( return Nothing)
+
+either :: XParser a -> XParser b -> XParser (Either a b)
+either p q =
+    ( p >>= return . Left) `onFail`
+    ( q >>= return . Right)
+
+word :: String -> XParser ()
+word s = do { x <- next
+            ; case x of
+                (p,TokName n)     | s==n -> return ()
+                (p,TokFreeText n) | s==n -> return ()
+                (p,t@(TokError _)) -> report failBad (show s) p t
+                (p,t) -> report fail (show s) p t
+            }
+
+posn = do { x@(p,_) <- next
+          ; reparse [x]
+          ; return p
+          }
+
+nmtoken :: XParser NmToken
+nmtoken = (string `onFail` freetext)
+
+failP, failBadP :: String -> XParser a
+failP msg = do { p <- posn; fail (msg++"\n    at "++show p) }
+failBadP msg = do { p <- posn; failBad (msg++"\n    at "++show p) }
+
+report :: (String->XParser a) -> String -> Posn -> TokenT -> XParser a
+report fail exp p t = fail ("Expected "++exp++" but found "++show t
+                           ++"\n  in "++show p)
+
+adjustErrP :: XParser a -> (String->String) -> XParser a
+p `adjustErrP` f = p `onFail` do pn <- posn
+                                 (p `adjustErr` f) `adjustErr` (++show pn)
+
+peRef :: XParser a -> XParser a
+peRef p =
+    p `onFail`
+    do pn <- posn
+       n <- pereference
+       tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n)
+       case tr of
+           Just (PEDefEntityValue ev) ->
+                      do reparse (xmlReLex (posInNewCxt ("macro %"++n++";")
+                                                        (Just pn))
+                                           (flattenEV ev))
+                               `debug` ("  defn:  "++flattenEV ev)
+                         peRef p
+           Just (PEDefExternalID (PUBLIC _ (SystemLiteral f))) ->
+                      do let f' = combine (dropFileName $ posnFilename pn) f
+                             val = unsafePerformIO (readFile f')
+                         reparse (xmlReLex (posInNewCxt f'
+                                                        (Just pn)) val)
+                               `debug` ("  reading from file "++f')
+                         peRef p
+           Just (PEDefExternalID (SYSTEM (SystemLiteral f))) ->
+                      do let f' = combine (dropFileName $ posnFilename pn) f
+                             val = unsafePerformIO (readFile f')
+                         reparse (xmlReLex (posInNewCxt f'
+                                                        (Just pn)) val)
+                               `debug` ("  reading from file "++f')
+                         peRef p
+           Nothing -> fail ("PEReference use before definition: "++"%"++n++";"
+                           ++"\n    at "++show pn)
+
+blank :: XParser a -> XParser a
+blank p =
+    p `onFail`
+    do n <- pereference
+       tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n++" (is blank?)")
+       case tr of
+           Just (PEDefEntityValue ev)
+                    | all isSpace (flattenEV ev)  ->
+                            do blank p `debug` "Empty macro definition"
+           Just _  -> failP ("expected a blank PERef macro: "++"%"++n++";")
+           Nothing -> failP ("PEReference use before definition: "++"%"++n++";")
+
+
+
+---- XML Parsing Functions ----
+
+justDTD :: XParser (Maybe DocTypeDecl)
+justDTD =
+  do (ExtSubset _ ds) <- extsubset `debug` "Trying external subset"
+     if null ds then fail "empty"
+         else return (Just (DTD "extsubset" Nothing (concatMap extract ds)))
+  `onFail`
+  do (Prolog _ _ dtd _) <- prolog
+     return dtd
+ where extract (ExtMarkupDecl m) = [m]
+       extract (ExtConditionalSect (IncludeSect i)) = concatMap extract i
+       extract (ExtConditionalSect (IgnoreSect i)) = []
+
+-- | Return an entire XML document including prolog and trailing junk.
+document :: XParser (Document Posn)
+document = do
+ -- p <- prolog `adjustErr` ("unrecognisable XML prolog\n"++)
+ -- e <- element
+ -- ms <- many misc
+ -- (_,ge) <- stGet
+ -- return (Document p ge e ms)
+    return Document `apply` (prolog `adjustErr`
+                                    ("unrecognisable XML prolog\n"++))
+                    `apply` (fmap snd stGet)
+                    `apply` element
+                    `apply` many misc
+
+-- | Return an XML comment.
+comment :: XParser Comment
+comment = do
+    myBracket (tok TokCommentOpen) (tok TokCommentClose) freetext
+--  tok TokCommentOpen
+--  commit $ do
+--    c <- freetext
+--    tok TokCommentClose
+--    return c
+
+-- | Parse a processing instruction.
+processinginstruction :: XParser ProcessingInstruction
+processinginstruction = do
+    tok TokPIOpen
+    commit $ do
+      n <- string  `onFail` failP "processing instruction has no target"
+      f <- freetext
+      tok TokPIClose `onFail` failP ("missing ?> in <?"++n)
+      return (n, f)
+
+cdsect :: XParser CDSect
+cdsect = do
+    tok TokSectionOpen
+    bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata
+
+prolog :: XParser Prolog
+prolog = do
+    x   <- maybe xmldecl
+    m1  <- many misc
+    dtd <- maybe doctypedecl
+    m2  <- many misc
+    return (Prolog x m1 dtd m2)
+
+xmldecl :: XParser XMLDecl
+xmldecl = do
+    tok TokPIOpen
+    (word "xml" `onFail` word "XML")
+    p <- posn
+    s <- freetext
+    tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"
+ -- raise ((runParser aux emptySTs . xmlReLex p) s)
+    return (fst3 ((runParser aux emptySTs . xmlReLex p) s))
+  where
+    aux = do
+        v <- versioninfo  `onFail` failP "missing XML version info"
+        e <- maybe encodingdecl
+        s <- maybe sddecl
+        return (XMLDecl v e s)
+ -- raise (Left err, _, _) = failP err
+ -- raise (Right ok, _, _) = return ok
+
+versioninfo :: XParser VersionInfo
+versioninfo = do
+    (word "version" `onFail` word "VERSION")
+    tok TokEqual
+    bracket (tok TokQuote) (tok TokQuote) freetext
+
+misc :: XParser Misc
+misc =
+    oneOf' [ ("<!--comment-->",  comment >>= return . Comment)
+           , ("<?PI?>",          processinginstruction >>= return . PI)
+           ]
+
+-- | Return a DOCTYPE decl, indicating a DTD.
+doctypedecl :: XParser DocTypeDecl
+doctypedecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial DOCTYPEx)
+    commit $ do
+      n   <- name
+      eid <- maybe externalid
+      es  <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)
+                            (many (peRef markupdecl)))
+      blank (tok TokAnyClose)  `onFail` failP "missing > in DOCTYPE decl"
+      return (DTD n eid (case es of { Nothing -> []; Just e -> e }))
+
+-- | Return a DTD markup decl, e.g. ELEMENT, ATTLIST, etc
+markupdecl :: XParser MarkupDecl
+markupdecl =
+  oneOf' [ ("ELEMENT",  elementdecl  >>= return . Element)
+         , ("ATTLIST",  attlistdecl  >>= return . AttList)
+         , ("ENTITY",   entitydecl   >>= return . Entity)
+         , ("NOTATION", notationdecl >>= return . Notation)
+         , ("misc",     misc         >>= return . MarkupMisc)
+         ]
+    `adjustErrP`
+          ("when looking for a markup decl,\n"++)
+ --       (\  (ELEMENT, ATTLIST, ENTITY, NOTATION, <!--comment-->, or <?PI?>")
+
+extsubset :: XParser ExtSubset
+extsubset = do
+    td <- maybe textdecl
+    ds <- many (peRef extsubsetdecl)
+    return (ExtSubset td ds)
+
+extsubsetdecl :: XParser ExtSubsetDecl
+extsubsetdecl =
+    ( markupdecl >>= return . ExtMarkupDecl) `onFail`
+    ( conditionalsect >>= return . ExtConditionalSect)
+
+sddecl :: XParser SDDecl
+sddecl = do
+    (word "standalone" `onFail` word "STANDALONE")
+    commit $ do
+      tok TokEqual `onFail` failP "missing = in 'standalone' decl"
+      bracket (tok TokQuote) (tok TokQuote)
+              ( (word "yes" >> return True) `onFail`
+                (word "no" >> return False) `onFail`
+                failP "'standalone' decl requires 'yes' or 'no' value" )
+
+{-
+element :: XParser (Element Posn)
+element = do
+    tok TokAnyOpen
+    (ElemTag n as) <- elemtag
+    oneOf' [ ("self-closing tag <"++n++"/>"
+             ,  do tok TokEndClose
+                   return (Elem n as []))
+           , ("after open tag <"++n++">"
+             ,  do tok TokAnyClose
+                   cs <- many content
+                   p  <- posn
+                   m  <- bracket (tok TokEndOpen) (tok TokAnyClose) name
+                   checkmatch p n m
+                   return (Elem n as cs))
+           ] `adjustErr` (("in element tag "++n++",\n")++)
+-}
+
+-- | Return a complete element including all its inner content.
+element :: XParser (Element Posn)
+element = do
+    tok TokAnyOpen
+    (ElemTag n as) <- elemtag
+    return (Elem n as) `apply`
+        ( do tok TokEndClose
+             return []
+          `onFail`
+          do tok TokAnyClose
+             commit $ manyFinally content
+                                  (do p <- posn
+                                      m <- bracket (tok TokEndOpen)
+                                                   (tok TokAnyClose) name
+                                      checkmatch p n m)
+          ) `adjustErrBad` (("in element tag "++n++",\n")++)
+
+checkmatch :: Posn -> Name -> Name -> XParser ()
+checkmatch p n m =
+  if n == m then return ()
+  else failBadP ("tag <"++n++"> terminated by </"++m++">")
+
+-- | Parse only the parts between angle brackets in an element tag.
+elemtag :: XParser ElemTag
+elemtag = do
+    n  <- name `adjustErrBad` ("malformed element tag\n"++)
+    as <- many attribute
+    return (ElemTag n as)
+
+-- | For use with stream parsers - returns the complete opening element tag.
+elemOpenTag :: XParser ElemTag
+elemOpenTag = do
+    tok TokAnyOpen
+    e <- elemtag
+    tok TokAnyClose
+    return e
+
+-- | For use with stream parsers - accepts a closing tag, provided it
+--   matches the given element name.
+elemCloseTag :: Name -> XParser ()
+elemCloseTag n = do
+    tok TokEndOpen
+    p <- posn
+    m <- name
+    tok TokAnyClose
+    checkmatch p n m
+
+attribute :: XParser Attribute
+attribute = do
+    n <- name `adjustErr` ("malformed attribute name\n"++)
+    tok TokEqual `onFail` failBadP "missing = in attribute"
+    v <- attvalue `onFail` failBadP "missing attvalue"
+    return (n,v)
+
+-- | Return a content particle, e.g. text, element, reference, etc
+content :: XParser (Content Posn)
+content =
+  do { p  <- posn
+     ; c' <- content'
+     ; return (c' p)
+     }
+  where
+     content' = oneOf' [ ("element",   element   >>= return . CElem)
+                       , ("chardata",  chardata  >>= return . CString False)
+                       , ("reference", reference >>= return . CRef)
+                       , ("CDATA",     cdsect    >>= return . CString True)
+                       , ("misc",      misc      >>= return . CMisc)
+                       ]
+                  `adjustErrP` ("when looking for a content item,\n"++)
+-- (\    (element, text, reference, CDATA section, <!--comment-->, or <?PI?>")
+
+elementdecl :: XParser ElementDecl
+elementdecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial ELEMENTx)
+    n <- peRef name `adjustErrBad` ("expecting identifier in ELEMENT decl\n"++)
+    c <- peRef contentspec
+             `adjustErrBad` (("in content spec of ELEMENT decl: "++n++"\n")++)
+    blank (tok TokAnyClose) `onFail` failBadP
+       ("expected > terminating ELEMENT decl"
+       ++"\n    element name was "++show n
+       ++"\n    contentspec was "++(\ (ContentSpec p)-> show p) c)
+    return (ElementDecl n c)
+
+contentspec :: XParser ContentSpec
+contentspec =
+    oneOf' [ ("EMPTY",  peRef (word "EMPTY") >> return EMPTY)
+           , ("ANY",    peRef (word "ANY") >> return ANY)
+           , ("mixed",  peRef mixed >>= return . Mixed)
+           , ("simple", peRef cp >>= return . ContentSpec)
+           ]
+ --   `adjustErr` ("when looking for content spec,\n"++)
+ --   `adjustErr` (++"\nLooking for content spec (EMPTY, ANY, mixed, etc)")
+
+choice :: XParser [CP]
+choice = do
+    myBracket (tok TokBraOpen `debug` "Trying choice")
+              (blank (tok TokBraClose `debug` "Succeeded with choice"))
+              (peRef cp `sepBy1` blank (tok TokPipe))
+
+sequence :: XParser [CP]
+sequence = do
+ myBracket (tok TokBraOpen `debug` "Trying sequence")
+           (blank (tok TokBraClose `debug` "Succeeded with sequence"))
+           (peRef cp `sepBy1` blank (tok TokComma))
+
+cp :: XParser CP
+cp = oneOf [ ( do n <- name
+                  m <- modifier
+                  let c = TagName n m
+                  return c `debug` ("ContentSpec: name "++show c))
+           , ( do ss <- sequence
+                  m <- modifier
+                  let c = Seq ss m
+                  return c `debug` ("ContentSpec: sequence "++show c))
+           , ( do cs <- choice
+                  m <- modifier
+                  let c = Choice cs m
+                  return c `debug` ("ContentSpec: choice "++show c))
+           ] `adjustErr` (++"\nwhen looking for a content particle")
+
+modifier :: XParser Modifier
+modifier = oneOf [ ( tok TokStar >> return Star )
+                 , ( tok TokQuery >> return Query )
+                 , ( tok TokPlus >> return Plus )
+                 , ( return None )
+                 ]
+
+-- just for debugging
+instance Show CP where
+    show (TagName n m) = n++show m
+    show (Choice cps m) = '(': concat (intersperse "|" (map show cps))
+                          ++")"++show m
+    show (Seq cps m) = '(': concat (intersperse "," (map show cps))
+                          ++")"++show m
+instance Show Modifier where
+    show None = ""
+    show Query = "?"
+    show Star = "*"
+    show Plus = "+"
+----
+
+mixed :: XParser Mixed
+mixed = do
+    tok TokBraOpen
+    peRef (do tok TokHash
+              word "PCDATA")
+    commit $
+      oneOf [ ( do cs <- many (peRef (do tok TokPipe
+                                         peRef name))
+                   blank (tok TokBraClose >> tok TokStar)
+                   return (PCDATAplus cs))
+            , ( blank (tok TokBraClose >> tok TokStar) >> return PCDATA)
+            , ( blank (tok TokBraClose) >> return PCDATA)
+            ]
+        `adjustErrP` (++"\nLooking for mixed content spec (#PCDATA | ...)*\n")
+
+attlistdecl :: XParser AttListDecl
+attlistdecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial ATTLISTx)
+    n <- peRef name `adjustErrBad` ("expecting identifier in ATTLIST\n"++)
+    ds <- peRef (many1 (peRef attdef))
+    blank (tok TokAnyClose) `onFail` failBadP "missing > terminating ATTLIST"
+    return (AttListDecl n ds)
+
+attdef :: XParser AttDef
+attdef =
+  do n <- peRef name `adjustErr` ("expecting attribute name\n"++)
+     t <- peRef atttype `adjustErr` (("within attlist defn: "++n++",\n")++)
+     d <- peRef defaultdecl `adjustErr` (("in attlist defn: "++n++",\n")++)
+     return (AttDef n t d)
+
+atttype :: XParser AttType
+atttype =
+    oneOf' [ ("CDATA",      word "CDATA" >> return StringType)
+           , ("tokenized",  tokenizedtype >>= return . TokenizedType)
+           , ("enumerated", enumeratedtype >>= return . EnumeratedType)
+           ]
+      `adjustErr` ("looking for ATTTYPE,\n"++)
+ --   `adjustErr` (++"\nLooking for ATTTYPE (CDATA, tokenized, or enumerated")
+
+tokenizedtype :: XParser TokenizedType
+tokenizedtype =
+    oneOf [ ( word "ID" >> return ID)
+          , ( word "IDREF" >> return IDREF)
+          , ( word "IDREFS" >> return IDREFS)
+          , ( word "ENTITY" >> return ENTITY)
+          , ( word "ENTITIES" >> return ENTITIES)
+          , ( word "NMTOKEN" >> return NMTOKEN)
+          , ( word "NMTOKENS" >> return NMTOKENS)
+          ] `onFail`
+    do { t <- next
+       ; failP ("Expected one of"
+               ++" (ID, IDREF, IDREFS, ENTITY, ENTITIES, NMTOKEN, NMTOKENS)"
+               ++"\nbut got "++show t)
+       }
+-- `adjustErr` (++"\nLooking for a tokenized type:\n\ 
+-- \    (ID, IDREF, IDREFS, ENTITY, ENTITIES, NMTOKEN, NMTOKENS)")
+
+enumeratedtype :: XParser EnumeratedType
+enumeratedtype =
+    oneOf' [ ("NOTATION",   notationtype >>= return . NotationType)
+           , ("enumerated", enumeration >>= return . Enumeration)
+           ]
+      `adjustErr` ("looking for an enumerated or NOTATION type,\n"++)
+
+notationtype :: XParser NotationType
+notationtype = do
+    word "NOTATION"
+    bracket (tok TokBraOpen) (blank (tok TokBraClose))
+            (peRef name `sepBy1` peRef (tok TokPipe))
+
+enumeration :: XParser Enumeration
+enumeration =
+    bracket (tok TokBraOpen) (blank (tok TokBraClose))
+            (peRef nmtoken `sepBy1` blank (peRef (tok TokPipe)))
+
+defaultdecl :: XParser DefaultDecl
+defaultdecl =
+    oneOf' [ ("REQUIRED",  tok TokHash >> word "REQUIRED" >> return REQUIRED)
+           , ("IMPLIED",   tok TokHash >> word "IMPLIED" >> return IMPLIED)
+           , ("FIXED",     do f <- maybe (tok TokHash >> word "FIXED"
+                                                      >> return FIXED)
+                              a <- peRef attvalue
+                              return (DefaultTo a f) )
+           ]
+        `adjustErr` ("looking for an attribute default decl,\n"++)
+--      `adjustErr` (++"\nLooking for an attribute default decl:\n\ 
+-- \    (REQUIRED, IMPLIED, FIXED)")
+
+conditionalsect :: XParser ConditionalSect
+conditionalsect = oneOf'
+    [ ( "INCLUDE"
+      , do tok TokSectionOpen
+           peRef (tok (TokSection INCLUDEx))
+           p <- posn
+           tok TokSqOpen `onFail` failBadP "missing [ after INCLUDE"
+           i <- many (peRef extsubsetdecl)
+           tok TokSectionClose
+                   `onFail` failBadP ("missing ]]> for INCLUDE section"
+                                     ++"\n    begun at "++show p)
+           return (IncludeSect i))
+    , ( "IGNORE"
+      , do tok TokSectionOpen
+           peRef (tok (TokSection IGNOREx))
+           p <- posn
+           tok TokSqOpen `onFail` failBadP "missing [ after IGNORE"
+           i <- many newIgnore  -- many ignoresectcontents
+           tok TokSectionClose
+                   `onFail` failBadP ("missing ]]> for IGNORE section"
+                                     ++"\n    begun at "++show p)
+           return (IgnoreSect []))
+    ] `adjustErr` ("in a conditional section,\n"++)
+
+newIgnore :: XParser Ignore
+newIgnore =
+    ( do tok TokSectionOpen
+         many newIgnore `debug` "IGNORING conditional section"
+         tok TokSectionClose
+         return Ignore `debug` "end of IGNORED conditional section") `onFail`
+    ( do t <- nottok [TokSectionOpen,TokSectionClose]
+         return Ignore  `debug` ("ignoring: "++show t))
+
+--- obsolete?
+ignoresectcontents :: XParser IgnoreSectContents
+ignoresectcontents = do
+    i <- ignore
+    is <- many (do tok TokSectionOpen
+                   ic <- ignoresectcontents
+                   tok TokSectionClose
+                   ig <- ignore
+                   return (ic,ig))
+    return (IgnoreSectContents i is)
+
+ignore :: XParser Ignore
+ignore = do
+  is <- many1 (nottok [TokSectionOpen,TokSectionClose])
+  return Ignore  `debug` ("ignored all of: "++show is)
+----
+
+-- | Return either a general entity reference, or a character reference.
+reference :: XParser Reference
+reference = do
+    bracket (tok TokAmp) (tok TokSemi) (freetext >>= val)
+  where
+    val ('#':'x':i) | all isHexDigit i
+                    = return . RefChar . fst . head . readHex $ i
+    val ('#':i)     | all isDigit i
+                    = return . RefChar . fst . head . readDec $ i
+    val name        = return . RefEntity $ name
+
+{- -- following is incorrect
+reference =
+    ( charref >>= return . RefChar) `onFail`
+    ( entityref >>= return . RefEntity)
+
+entityref :: XParser EntityRef
+entityref = do
+    bracket (tok TokAmp) (tok TokSemi) name
+
+charref :: XParser CharRef
+charref = do
+    bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal)
+  where
+    readCharVal ('#':'x':i) = return . fst . head . readHex $ i
+    readCharVal ('#':i)     = return . fst . head . readDec $ i
+    readCharVal _           = mzero
+-}
+
+pereference :: XParser PEReference
+pereference = do
+    myBracket (tok TokPercent) (tok TokSemi) nmtoken
+
+entitydecl :: XParser EntityDecl
+entitydecl =
+    ( gedecl >>= return . EntityGEDecl) `onFail`
+    ( pedecl >>= return . EntityPEDecl)
+
+gedecl :: XParser GEDecl
+gedecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial ENTITYx)
+    n <- name
+    e <- entitydef `adjustErrBad` (("in general entity defn "++n++",\n")++)
+    tok TokAnyClose `onFail` failBadP ("expected > terminating G ENTITY decl "++n)
+    stUpdate (addGE n e) `debug` ("added GE defn &"++n++";")
+    return (GEDecl n e)
+
+pedecl :: XParser PEDecl
+pedecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial ENTITYx)
+    tok TokPercent
+    n <- name
+    e <- pedef `adjustErrBad` (("in parameter entity defn "++n++",\n")++)
+    tok TokAnyClose `onFail` failBadP ("expected > terminating P ENTITY decl "++n)
+    stUpdate (addPE n e) `debug` ("added PE defn %"++n++";\n"++show e)
+    return (PEDecl n e)
+
+entitydef :: XParser EntityDef
+entitydef =
+    oneOf' [ ("entityvalue", entityvalue >>= return . DefEntityValue)
+           , ("external",    do eid <- externalid
+                                ndd <- maybe ndatadecl
+                                return (DefExternalID eid ndd))
+           ]
+
+pedef :: XParser PEDef
+pedef =
+    oneOf' [ ("entityvalue", entityvalue >>= return . PEDefEntityValue)
+           , ("externalid",  externalid  >>= return . PEDefExternalID)
+           ]
+
+externalid :: XParser ExternalID
+externalid =
+    oneOf' [ ("SYSTEM", do word "SYSTEM"
+                           s <- systemliteral
+                           return (SYSTEM s) )
+           , ("PUBLIC", do word "PUBLIC"
+                           p <- pubidliteral
+                           s <- systemliteral
+                           return (PUBLIC p s) )
+           ]
+      `adjustErr` ("looking for an external id,\n"++)
+
+ndatadecl :: XParser NDataDecl
+ndatadecl = do
+    word "NDATA"
+    n <- name
+    return (NDATA n)
+
+textdecl :: XParser TextDecl
+textdecl = do
+    tok TokPIOpen
+    (word "xml" `onFail` word "XML")
+    v <- maybe versioninfo
+    e <- encodingdecl
+    tok TokPIClose `onFail` failP "expected ?> terminating text decl"
+    return (TextDecl v e)
+
+extparsedent :: XParser (ExtParsedEnt Posn)
+extparsedent = do
+    t <- maybe textdecl
+    c <- content
+    return (ExtParsedEnt t c)
+
+extpe :: XParser ExtPE
+extpe = do
+    t <- maybe textdecl
+    e <- many (peRef extsubsetdecl)
+    return (ExtPE t e)
+
+encodingdecl :: XParser EncodingDecl
+encodingdecl = do
+    (word "encoding" `onFail` word "ENCODING")
+    tok TokEqual `onFail` failBadP "expected = in 'encoding' decl"
+    f <- bracket (tok TokQuote) (tok TokQuote) freetext
+    return (EncodingDecl f)
+
+notationdecl :: XParser NotationDecl
+notationdecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial NOTATIONx)
+    n <- name
+    e <- either externalid publicid
+    tok TokAnyClose `onFail` failBadP ("expected > terminating NOTATION decl "++n)
+    return (NOTATION n e)
+
+publicid :: XParser PublicID
+publicid = do
+    word "PUBLIC"
+    p <- pubidliteral
+    return (PUBLICID p)
+
+entityvalue :: XParser EntityValue
+entityvalue = do
+ -- evs <- bracket (tok TokQuote) (tok TokQuote) (many (peRef ev))
+    tok TokQuote
+    pn <- posn
+    evs <- many ev
+    tok TokQuote `onFail` failBadP "expected quote to terminate entityvalue"
+    -- quoted text must be rescanned for possible PERefs
+    st <- stGet
+ -- Prelude.either failBad (return . EntityValue) . fst3 $
+    return . EntityValue . fst3 $
+                (runParser (many ev) st
+                         (reLexEntityValue (\s-> stringify (lookupPE s st))
+                                           pn
+                                           (flattenEV (EntityValue evs))))
+  where
+    stringify (Just (PEDefEntityValue ev)) = Just (flattenEV ev)
+    stringify _ = Nothing
+
+ev :: XParser EV
+ev =
+    oneOf' [ ("string",    (string`onFail`freetext) >>= return . EVString)
+           , ("reference", reference >>= return . EVRef)
+           ]
+      `adjustErr` ("looking for entity value,\n"++)
+
+attvalue :: XParser AttValue
+attvalue = do
+    avs <- bracket (tok TokQuote) (tok TokQuote)
+                   (many (either freetext reference))
+    return (AttValue avs)
+
+systemliteral :: XParser SystemLiteral
+systemliteral = do
+    s <- bracket (tok TokQuote) (tok TokQuote) freetext
+    return (SystemLiteral s)            -- note: refs &...; not permitted
+
+pubidliteral :: XParser PubidLiteral
+pubidliteral = do
+    s <- bracket (tok TokQuote) (tok TokQuote) freetext
+    return (PubidLiteral s)             -- note: freetext is too liberal here
+
+-- | Return parsed freetext (i.e. until the next markup)
+chardata :: XParser CharData
+chardata = freetext
+
+

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Posn.html b/docs/HaXml/src/Text/XML/HaXml/Posn.html
--- a/docs/HaXml/src/Text/XML/HaXml/Posn.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Posn.html
@@ -1,79 +1,86 @@
 
 
-
-- | Define a position datatype for giving locations in error messages.
-module Text.XML.HaXml.Posn
-  (
-  -- * Position type
-    Posn()
-  -- ** Constructors of a new position
-  , posInNewCxt    -- :: String -> Maybe Posn -> Posn
-  , noPos          -- :: Posn
-  -- ** Strictifier
-  , forcep
-  -- ** Modifiers
-  , addcol, newline, tab, white
-  -- ** Accessors
-  , posnFilename, posnLine, posnColumn
-  ) where
-
-import Char
-
--- | Source positions contain a filename, line, column, and an
---   inclusion point, which is itself another source position,
---   recursively.
-data Posn = Pn String !Int !Int (Maybe Posn)
-        deriving (Eq)
-
-posnFilename :: Posn -> FilePath
-posnFilename (Pn f _ _ _) = f
-
-posnLine, posnColumn :: Posn -> Int
-posnLine   (Pn _ x _ _) = x
-posnColumn (Pn _ _ x _) = x
-
--- | Dummy value for generated data, where a true source position does
---   not exist.
-noPos :: Posn
-noPos = Pn "no recorded position" 0 0 Nothing
-
--- | @posInNewCxt name pos@ creates a new source position from an old one.
---   It is used when opening a new file (e.g. a DTD inclusion), to denote
---   the start of the file @name@, but retain the stacked information that
---   it was included from the old @pos@.
-posInNewCxt :: String -> Maybe Posn -> Posn
-posInNewCxt name pos = Pn name 1 1 pos
-
-instance Show Posn where
-      showsPrec _ (Pn f l c i) = showString f .
-                                 showString "  at line " . shows l .
-                                 showString " col " . shows c .
-                                 ( case i of
-                                    Nothing -> id
-                                    Just p  -> showString "\n    used by  " .
-                                               shows p )
-
--- | Just used to strictify the internal values of a position, to avoid
---   space leaks.
-forcep :: Posn -> Int
-forcep (Pn _ n m _) = m `seq` n
-
--- | Add n character positions to the given position.
-addcol :: Int -> Posn -> Posn
-addcol n (Pn f r c i) = Pn f r (c+n) i
-
--- | Add a newline or tab to the given position.
-newline, tab :: Posn -> Posn
-newline (Pn f r _ i) = Pn f (r+1) 1 i
-tab     (Pn f r c i) = Pn f r (((c`div`8)+1)*8) i
-
--- | Add the given whitespace char to the given position.
---   Precondition: @white c | isSpace c = True@
-white :: Char -> Posn -> Posn
-white ' '  = addcol 1
-white '\n' = newline
-white '\r' = id
-white '\t' = tab
-white '\xa0' = addcol 1
-
+
+
+src/Text/XML/HaXml/Posn.hs
+
+
+
-- | Define a position datatype for giving locations in error messages.
+module Text.XML.HaXml.Posn
+  (
+  -- * Position type
+    Posn()
+  -- ** Constructors of a new position
+  , posInNewCxt    -- :: String -> Maybe Posn -> Posn
+  , noPos          -- :: Posn
+  -- ** Strictifier
+  , forcep
+  -- ** Modifiers
+  , addcol, newline, tab, white
+  -- ** Accessors
+  , posnFilename, posnLine, posnColumn
+  ) where
+
+import Char
+
+-- | Source positions contain a filename, line, column, and an
+--   inclusion point, which is itself another source position,
+--   recursively.
+data Posn = Pn String !Int !Int (Maybe Posn)
+        deriving (Eq)
+
+posnFilename :: Posn -> FilePath
+posnFilename (Pn f _ _ _) = f
+
+posnLine, posnColumn :: Posn -> Int
+posnLine   (Pn _ x _ _) = x
+posnColumn (Pn _ _ x _) = x
+
+-- | Dummy value for generated data, where a true source position does
+--   not exist.
+noPos :: Posn
+noPos = Pn "no recorded position" 0 0 Nothing
+
+-- | @posInNewCxt name pos@ creates a new source position from an old one.
+--   It is used when opening a new file (e.g. a DTD inclusion), to denote
+--   the start of the file @name@, but retain the stacked information that
+--   it was included from the old @pos@.
+posInNewCxt :: String -> Maybe Posn -> Posn
+posInNewCxt name pos = Pn name 1 1 pos
+
+instance Show Posn where
+      showsPrec _ (Pn f l c i) = showString "file " .
+                                 showString f .
+                                 showString "  at line " . shows l .
+                                 showString " col " . shows c .
+                                 ( case i of
+                                    Nothing -> id
+                                    Just p  -> showString "\n    used by  " .
+                                               shows p )
+
+-- | Just used to strictify the internal values of a position, to avoid
+--   space leaks.
+forcep :: Posn -> Int
+forcep (Pn _ n m _) = m `seq` n
+
+-- | Add n character positions to the given position.
+addcol :: Int -> Posn -> Posn
+addcol n (Pn f r c i) = Pn f r (c+n) i
+
+-- | Add a newline or tab to the given position.
+newline, tab :: Posn -> Posn
+newline (Pn f r _ i) = Pn f (r+1) 1 i
+tab     (Pn f r c i) = Pn f r (((c`div`8)+1)*8) i
+
+-- | Add the given whitespace char to the given position.
+--   Precondition: @white c | isSpace c = True@
+white :: Char -> Posn -> Posn
+white ' '  = addcol 1
+white '\n' = newline
+white '\r' = id
+white '\t' = tab
+white '\xa0' = addcol 1
+
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Pretty.html b/docs/HaXml/src/Text/XML/HaXml/Pretty.html
--- a/docs/HaXml/src/Text/XML/HaXml/Pretty.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Pretty.html
@@ -1,302 +1,308 @@
 
 
-
-- | This is a pretty-printer for turning the internal representation
---   of generic structured XML documents into the Doc type (which can
---   later be rendered using Text.PrettyPrint.HughesPJ.render).
---   Essentially there is one pp function for each type in
---   Text.Xml.HaXml.Types, so you can pretty-print as much or as little
---   of the document as you wish.
-
-module Text.XML.HaXml.Pretty
-  (
-  -- * Pretty-print a whole document
-    document
-  -- ** Just one content
-  ,   content
-  -- ** Just one tagged element
-  ,   element
-  -- * Pretty-print just a DTD
-  , doctypedecl
-  -- ** The prolog
-  ,   prolog
-  -- ** A content particle description
-  ,   cp
-  ) where
-
-import Prelude hiding (maybe,either)
-import Maybe hiding (maybe)
-import List (intersperse)
---import Char (isSpace)
-import Text.PrettyPrint.HughesPJ
-import Text.XML.HaXml.Types
-
-either :: (t -> t1) -> (t2 -> t1) -> Either t t2 -> t1
-either f _ (Left x)  = f x
-either _ g (Right x) = g x
-
-maybe :: (t -> Doc) -> Maybe t -> Doc
-maybe _ Nothing  = empty
-maybe f (Just x) = f x
-
---peref p   = text "%" <> text p <> text ";"
-
-----
-
-document :: Document i -> Doc
-prolog   :: Prolog -> Doc
-xmldecl  :: XMLDecl -> Doc
-misc     :: Misc -> Doc
-sddecl   :: Bool -> Doc
-
-doctypedecl :: DocTypeDecl -> Doc
-markupdecl  :: MarkupDecl -> Doc
-extsubset   :: ExtSubset -> Doc
-extsubsetdecl :: ExtSubsetDecl -> Doc
-cp          :: CP -> Doc
-
-element   :: Element i -> Doc
-attribute :: Attribute -> Doc                     --etc
-content   :: Content i -> Doc
-
-----
-
-document (Document p _ e m)= prolog p $$ element e $$ vcat (map misc m)
-prolog (Prolog x m1 dtd m2)= maybe xmldecl x $$
-                             vcat (map misc m1) $$
-                             maybe doctypedecl dtd $$
-                             vcat (map misc m2)
-xmldecl (XMLDecl v e sd)   = text "<?xml version='" <> text v <> text "'" <+>
-                             maybe encodingdecl e <+>
-                             maybe sddecl sd <+>
-                             text "?>"
-misc (Comment s)           = text "<!--" <> text s <> text "-->"
-misc (PI (n,s))            = text "<?" <> text n <+> text s <> text "?>"
-sddecl sd   | sd           = text "standalone='yes'"
-            | otherwise    = text "standalone='no'"
-doctypedecl (DTD n eid ds) = if null ds then
-                                  hd <> text ">"
-                             else hd <+> text " [" $$
-                                  vcat (map markupdecl ds) $$ text "]>"
-                           where hd = text "<!DOCTYPE" <+> text n <+>
-                                      maybe externalid eid
-markupdecl (Element e)     = elementdecl e
-markupdecl (AttList a)     = attlistdecl a
-markupdecl (Entity e)      = entitydecl e
-markupdecl (Notation n)    = notationdecl n
-markupdecl (MarkupMisc m)  = misc m
--- markupdecl (MarkupPE p m)  = peref p
-extsubset (ExtSubset t ds) = maybe textdecl t $$
-                             vcat (map extsubsetdecl ds)
-extmarkupdecl (ExtMarkupDecl m)      = markupdecl m
-extsubsetdecl (ExtConditionalSect c) = conditionalsect c
--- extsubsetdecl (ExtPEReference p e)   = peref p
-
-element (Elem n as []) = text "<" <> text n <+>
-                         fsep (map attribute as) <> text "/>"
-element e@(Elem n as cs)
---  | any isText cs    = text "<" <> text n <+> fsep (map attribute as) <>
---                       text ">" <> hcat (map content cs) <>
---                       text "</" <> text n <> text ">"
-    | isText (head cs) = text "<" <> text n <+> fsep (map attribute as) <>
-                         text ">" <> hcat (map content cs) <>
-                         text "</" <> text n <> text ">"
-    | otherwise        = let (d,c) = carryelem e empty
-                         in d <> c
-
-isText :: Content t -> Bool
-isText (CString _ _ _) = True
-isText (CRef _ _)      = True
-isText _               = False
-
-carryelem :: Element t -> Doc -> (Doc, Doc)
-carrycontent ::  Content t -> Doc -> (Doc, Doc)
-carryelem (Elem n as []) c
-                       = ( c <>
-                           text "<" <> text n <+> fsep (map attribute as)
-                         , text "/>")
-carryelem (Elem n as cs) c
---  | any isText cs    =  ( c <> element e, empty)
-    | otherwise        =  let (cs0,d0) = carryscan carrycontent cs (text ">")
-                          in
-                          ( c <>
-                            text "<" <> text n <+> fsep (map attribute as) $$
-                            nest 2 (vcat cs0) <> --- $$
-                            d0 <> text "</" <> text n
-                          , text ">")
-carrycontent (CElem e _) c   = carryelem e c
-carrycontent (CString False s _) c = (c <> chardata s, empty)
-carrycontent (CString True  s _) c = (c <> cdsect s, empty)
-carrycontent (CRef r _) c    = (c <> reference r, empty)
-carrycontent (CMisc m _) c   = (c <> misc m, empty)
-
-carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c)
-carryscan _ []     c = ([],c)
-carryscan f (a:as) c = let (b, c0) = f a c
-                           (bs,c1) = carryscan f as c0
-                       in (b:bs, c1)
-
---carryelem e@(Elem n as cs) c
---  | isText (head cs) =
---        ( start <>
---          text ">" <> hcat (map content cs) <> text "</" <> text n
---        , text ">")
---  | otherwise =
---        let (d,c0) = foldl carrycontent (start, text ">") cs in
---        ( d <> c0 <> text "</" <> text n
---        , text ">")
---  where start = c <> text "<" <> text n <+> fsep (map attribute as)
---
---carrycontent (d,c) (CElem e)   = let (d',c') = carryelem e c in
---                                 (d $$ nest 2 d',       c')
---carrycontent (d,c) (CString _ s) = (d <> c <> chardata s, empty)
---carrycontent (d,c) (CRef r)    = (d <> c <> reference r,empty)
---carrycontent (d,c) (CMisc m)   = (d $$ c <> misc m,     empty)
-
-
-attribute (n,v)             = text n <> text "=" <> attvalue v
-content (CElem e _)         = element e
-content (CString False s _) = chardata s
-content (CString True s _)  = cdsect s
-content (CRef r _)          = reference r
-content (CMisc m _)         = misc m
-
-elementdecl :: ElementDecl -> Doc
-elementdecl (ElementDecl n cs) = text "<!ELEMENT" <+> text n <+>
-                                 contentspec cs <> text ">"
-contentspec :: ContentSpec -> Doc
-contentspec EMPTY              = text "EMPTY"
-contentspec ANY                = text "ANY"
-contentspec (Mixed m)          = mixed m
-contentspec (ContentSpec c)    = cp c
---contentspec (ContentPE p cs)   = peref p
-cp (TagName n m)       = parens (text n) <> modifier m
-cp (Choice cs m)       = parens (hcat (intersperse (text "|") (map cp cs))) <>
-                           modifier m
-cp (Seq cs m)          = parens (hcat (intersperse (text ",") (map cp cs))) <>
-                           modifier m
---cp (CPPE p c)          = peref p
-modifier :: Modifier -> Doc
-modifier None          = empty
-modifier Query         = text "?"
-modifier Star          = text "*"
-modifier Plus          = text "+"
-mixed :: Mixed -> Doc
-mixed  PCDATA          = text "(#PCDATA)"
-mixed (PCDATAplus ns)  = text "(#PCDATA |" <+>
-                         hcat (intersperse (text "|") (map text ns)) <>
-                         text ")*"
-
-attlistdecl :: AttListDecl -> Doc
-attlistdecl (AttListDecl n ds) = text "<!ATTLIST" <+> text n <+>
-                                 fsep (map attdef ds) <> text ">"
-attdef :: AttDef -> Doc
-attdef (AttDef n t d)          = text n <+> atttype t <+> defaultdecl d
-atttype :: AttType -> Doc
-atttype  StringType            = text "CDATA"
-atttype (TokenizedType t)      = tokenizedtype t
-atttype (EnumeratedType t)     = enumeratedtype t
-tokenizedtype :: TokenizedType -> Doc
-tokenizedtype ID               = text "ID"
-tokenizedtype IDREF            = text "IDREF"
-tokenizedtype IDREFS           = text "IDREFS"
-tokenizedtype ENTITY           = text "ENTITY"
-tokenizedtype ENTITIES         = text "ENTITIES"
-tokenizedtype NMTOKEN          = text "NMTOKEN"
-tokenizedtype NMTOKENS         = text "NMTOKENS"
-enumeratedtype :: EnumeratedType -> Doc
-enumeratedtype (NotationType n)= notationtype n
-enumeratedtype (Enumeration e) = enumeration e
-notationtype :: [String] -> Doc
-notationtype ns                = text "NOTATION" <+>
-                                 parens (hcat (intersperse (text "|") (map text ns)))
-enumeration :: [String] -> Doc
-enumeration ns                 = parens (hcat (intersperse (text "|") (map nmtoken ns)))
-defaultdecl :: DefaultDecl -> Doc
-defaultdecl  REQUIRED          = text "#REQUIRED"
-defaultdecl  IMPLIED           = text "#IMPLIED"
-defaultdecl (DefaultTo a f)    = maybe (const (text "#FIXED")) f <+> attvalue a
-conditionalsect (IncludeSect i)= text "<![INCLUDE [" <+>
-                                 vcat (map extsubsetdecl i) <+> text "]]>"
-conditionalsect (IgnoreSect i) = text "<![IGNORE [" <+>
-                                 fsep (map ignoresectcontents i) <+> text "]]>"
-ignore (Ignore)                = empty
-ignoresectcontents (IgnoreSectContents i is)
-                               = ignore i <+> vcat (map internal is)
-                          where internal (ics,i) = text "<![[" <+>
-                                                   ignoresectcontents ics <+>
-                                                   text "]]>" <+> ignore i
-reference :: Reference -> Doc
-reference (RefEntity er)       = entityref er
-reference (RefChar cr)         = charref cr
-entityref :: String -> Doc
-entityref n                    = text "&" <> text n <> text ";"
-charref :: (Show a) => a -> Doc
-charref c                      = text "&#" <> text (show c) <> text ";"
-entitydecl :: EntityDecl -> Doc
-entitydecl (EntityGEDecl d)    = gedecl d
-entitydecl (EntityPEDecl d)    = pedecl d
-gedecl :: GEDecl -> Doc
-gedecl (GEDecl n ed)           = text "<!ENTITY" <+> text n <+> entitydef ed <>
-                                 text ">"
-pedecl :: PEDecl -> Doc
-pedecl (PEDecl n pd)           = text "<!ENTITY %" <+> text n <+> pedef pd <>
-                                 text ">"
-entitydef :: EntityDef -> Doc
-entitydef (DefEntityValue ew)  = entityvalue ew
-entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd
-pedef :: PEDef -> Doc
-pedef (PEDefEntityValue ew)    = entityvalue ew
-pedef (PEDefExternalID eid)    = externalid eid
-externalid :: ExternalID -> Doc
-externalid (SYSTEM sl)         = text "SYSTEM" <+> systemliteral sl
-externalid (PUBLIC i sl)       = text "PUBLIC" <+> pubidliteral i <+>
-                                 systemliteral sl
-ndatadecl :: NDataDecl -> Doc
-ndatadecl (NDATA n)            = text "NDATA" <+> text n
-textdecl (TextDecl vi ed)      = text "<?xml" <+> maybe text vi <+>
-                                 encodingdecl ed <+> text "?>"
-extparsedent (ExtParsedEnt t c)= maybe textdecl t <+> content c
-extpe (ExtPE t esd)            = maybe textdecl t <+>
-                                 vcat (map extsubsetdecl esd)
-notationdecl :: NotationDecl -> Doc
-notationdecl (NOTATION n e)    = text "<!NOTATION" <+> text n <+>
-                                 either externalid publicid e <>
-                                 text ">"
-publicid :: PublicID -> Doc
-publicid (PUBLICID p)          = text "PUBLIC" <+> pubidliteral p
-encodingdecl :: EncodingDecl -> Doc
-encodingdecl (EncodingDecl s)  = text "encoding='" <> text s <> text "'"
-nmtoken :: String -> Doc
-nmtoken s                      = text s
-attvalue :: AttValue -> Doc
-attvalue (AttValue esr)        = text "\"" <>
-                                 hcat (map (either text reference) esr) <>
-                                 text "\""
-entityvalue :: EntityValue -> Doc
-entityvalue (EntityValue evs)
-  | containsDoubleQuote evs    = text "'"  <> hcat (map ev evs) <> text "'"
-  | otherwise                  = text "\"" <> hcat (map ev evs) <> text "\""
-ev :: EV -> Doc
-ev (EVString s)                = text s
---ev (EVPERef p e)               = peref p
-ev (EVRef r)                   = reference r
-pubidliteral :: PubidLiteral -> Doc
-pubidliteral (PubidLiteral s)
-    | '"' `elem` s             = text "'" <> text s <> text "'"
-    | otherwise                = text "\"" <> text s <> text "\""
-systemliteral :: SystemLiteral -> Doc
-systemliteral (SystemLiteral s)
-    | '"' `elem` s             = text "'" <> text s <> text "'"
-    | otherwise                = text "\"" <> text s <> text "\""
-chardata :: String -> Doc
-chardata s                     = {-if all isSpace s then empty else-} text s
-cdsect :: String -> Doc
-cdsect c                       = text "<![CDATA[" <> chardata c <> text "]]>"
-
-----
-containsDoubleQuote :: [EV] -> Bool
-containsDoubleQuote evs = any csq evs
-    where csq (EVString s) = '"' `elem` s
-          csq _            = False
+
+
+src/Text/XML/HaXml/Pretty.hs
+
+
+
-- | This is a pretty-printer for turning the internal representation
+--   of generic structured XML documents into the Doc type (which can
+--   later be rendered using Text.PrettyPrint.HughesPJ.render).
+--   Essentially there is one pp function for each type in
+--   Text.Xml.HaXml.Types, so you can pretty-print as much or as little
+--   of the document as you wish.
+
+module Text.XML.HaXml.Pretty
+  (
+  -- * Pretty-print a whole document
+    document
+  -- ** Just one content
+  ,   content
+  -- ** Just one tagged element
+  ,   element
+  -- * Pretty-print just a DTD
+  , doctypedecl
+  -- ** The prolog
+  ,   prolog
+  -- ** A content particle description
+  ,   cp
+  ) where
+
+import Prelude hiding (maybe,either)
+import Maybe hiding (maybe)
+import List (intersperse)
+--import Char (isSpace)
+import Text.PrettyPrint.HughesPJ
+import Text.XML.HaXml.Types
+
+either :: (t -> t1) -> (t2 -> t1) -> Either t t2 -> t1
+either f _ (Left x)  = f x
+either _ g (Right x) = g x
+
+maybe :: (t -> Doc) -> Maybe t -> Doc
+maybe _ Nothing  = empty
+maybe f (Just x) = f x
+
+--peref p   = text "%" <> text p <> text ";"
+
+----
+
+document :: Document i -> Doc
+prolog   :: Prolog -> Doc
+xmldecl  :: XMLDecl -> Doc
+misc     :: Misc -> Doc
+sddecl   :: Bool -> Doc
+
+doctypedecl :: DocTypeDecl -> Doc
+markupdecl  :: MarkupDecl -> Doc
+extsubset   :: ExtSubset -> Doc
+extsubsetdecl :: ExtSubsetDecl -> Doc
+cp          :: CP -> Doc
+
+element   :: Element i -> Doc
+attribute :: Attribute -> Doc                     --etc
+content   :: Content i -> Doc
+
+----
+
+document (Document p _ e m)= prolog p $$ element e $$ vcat (map misc m)
+prolog (Prolog x m1 dtd m2)= maybe xmldecl x $$
+                             vcat (map misc m1) $$
+                             maybe doctypedecl dtd $$
+                             vcat (map misc m2)
+xmldecl (XMLDecl v e sd)   = text "<?xml version='" <> text v <> text "'" <+>
+                             maybe encodingdecl e <+>
+                             maybe sddecl sd <+>
+                             text "?>"
+misc (Comment s)           = text "<!--" <> text s <> text "-->"
+misc (PI (n,s))            = text "<?" <> text n <+> text s <> text "?>"
+sddecl sd   | sd           = text "standalone='yes'"
+            | otherwise    = text "standalone='no'"
+doctypedecl (DTD n eid ds) = if null ds then
+                                  hd <> text ">"
+                             else hd <+> text " [" $$
+                                  vcat (map markupdecl ds) $$ text "]>"
+                           where hd = text "<!DOCTYPE" <+> text n <+>
+                                      maybe externalid eid
+markupdecl (Element e)     = elementdecl e
+markupdecl (AttList a)     = attlistdecl a
+markupdecl (Entity e)      = entitydecl e
+markupdecl (Notation n)    = notationdecl n
+markupdecl (MarkupMisc m)  = misc m
+-- markupdecl (MarkupPE p m)  = peref p
+extsubset (ExtSubset t ds) = maybe textdecl t $$
+                             vcat (map extsubsetdecl ds)
+extmarkupdecl (ExtMarkupDecl m)      = markupdecl m
+extsubsetdecl (ExtConditionalSect c) = conditionalsect c
+-- extsubsetdecl (ExtPEReference p e)   = peref p
+
+element (Elem n as []) = text "<" <> text n <+>
+                         fsep (map attribute as) <> text "/>"
+element e@(Elem n as cs)
+--  | any isText cs    = text "<" <> text n <+> fsep (map attribute as) <>
+--                       text ">" <> hcat (map content cs) <>
+--                       text "</" <> text n <> text ">"
+    | isText (head cs) = text "<" <> text n <+> fsep (map attribute as) <>
+                         text ">" <> hcat (map content cs) <>
+                         text "</" <> text n <> text ">"
+    | otherwise        = let (d,c) = carryelem e empty
+                         in d <> c
+
+isText :: Content t -> Bool
+isText (CString _ _ _) = True
+isText (CRef _ _)      = True
+isText _               = False
+
+carryelem :: Element t -> Doc -> (Doc, Doc)
+carrycontent ::  Content t -> Doc -> (Doc, Doc)
+carryelem (Elem n as []) c
+                       = ( c <>
+                           text "<" <> text n <+> fsep (map attribute as)
+                         , text "/>")
+carryelem (Elem n as cs) c
+--  | any isText cs    =  ( c <> element e, empty)
+    | otherwise        =  let (cs0,d0) = carryscan carrycontent cs (text ">")
+                          in
+                          ( c <>
+                            text "<" <> text n <+> fsep (map attribute as) $$
+                            nest 2 (vcat cs0) <> --- $$
+                            d0 <> text "</" <> text n
+                          , text ">")
+carrycontent (CElem e _) c   = carryelem e c
+carrycontent (CString False s _) c = (c <> chardata s, empty)
+carrycontent (CString True  s _) c = (c <> cdsect s, empty)
+carrycontent (CRef r _) c    = (c <> reference r, empty)
+carrycontent (CMisc m _) c   = (c <> misc m, empty)
+
+carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c)
+carryscan _ []     c = ([],c)
+carryscan f (a:as) c = let (b, c0) = f a c
+                           (bs,c1) = carryscan f as c0
+                       in (b:bs, c1)
+
+--carryelem e@(Elem n as cs) c
+--  | isText (head cs) =
+--        ( start <>
+--          text ">" <> hcat (map content cs) <> text "</" <> text n
+--        , text ">")
+--  | otherwise =
+--        let (d,c0) = foldl carrycontent (start, text ">") cs in
+--        ( d <> c0 <> text "</" <> text n
+--        , text ">")
+--  where start = c <> text "<" <> text n <+> fsep (map attribute as)
+--
+--carrycontent (d,c) (CElem e)   = let (d',c') = carryelem e c in
+--                                 (d $$ nest 2 d',       c')
+--carrycontent (d,c) (CString _ s) = (d <> c <> chardata s, empty)
+--carrycontent (d,c) (CRef r)    = (d <> c <> reference r,empty)
+--carrycontent (d,c) (CMisc m)   = (d $$ c <> misc m,     empty)
+
+
+attribute (n,v)             = text n <> text "=" <> attvalue v
+content (CElem e _)         = element e
+content (CString False s _) = chardata s
+content (CString True s _)  = cdsect s
+content (CRef r _)          = reference r
+content (CMisc m _)         = misc m
+
+elementdecl :: ElementDecl -> Doc
+elementdecl (ElementDecl n cs) = text "<!ELEMENT" <+> text n <+>
+                                 contentspec cs <> text ">"
+contentspec :: ContentSpec -> Doc
+contentspec EMPTY              = text "EMPTY"
+contentspec ANY                = text "ANY"
+contentspec (Mixed m)          = mixed m
+contentspec (ContentSpec c)    = cp c
+--contentspec (ContentPE p cs)   = peref p
+cp (TagName n m)       = parens (text n) <> modifier m
+cp (Choice cs m)       = parens (hcat (intersperse (text "|") (map cp cs))) <>
+                           modifier m
+cp (Seq cs m)          = parens (hcat (intersperse (text ",") (map cp cs))) <>
+                           modifier m
+--cp (CPPE p c)          = peref p
+modifier :: Modifier -> Doc
+modifier None          = empty
+modifier Query         = text "?"
+modifier Star          = text "*"
+modifier Plus          = text "+"
+mixed :: Mixed -> Doc
+mixed  PCDATA          = text "(#PCDATA)"
+mixed (PCDATAplus ns)  = text "(#PCDATA |" <+>
+                         hcat (intersperse (text "|") (map text ns)) <>
+                         text ")*"
+
+attlistdecl :: AttListDecl -> Doc
+attlistdecl (AttListDecl n ds) = text "<!ATTLIST" <+> text n <+>
+                                 fsep (map attdef ds) <> text ">"
+attdef :: AttDef -> Doc
+attdef (AttDef n t d)          = text n <+> atttype t <+> defaultdecl d
+atttype :: AttType -> Doc
+atttype  StringType            = text "CDATA"
+atttype (TokenizedType t)      = tokenizedtype t
+atttype (EnumeratedType t)     = enumeratedtype t
+tokenizedtype :: TokenizedType -> Doc
+tokenizedtype ID               = text "ID"
+tokenizedtype IDREF            = text "IDREF"
+tokenizedtype IDREFS           = text "IDREFS"
+tokenizedtype ENTITY           = text "ENTITY"
+tokenizedtype ENTITIES         = text "ENTITIES"
+tokenizedtype NMTOKEN          = text "NMTOKEN"
+tokenizedtype NMTOKENS         = text "NMTOKENS"
+enumeratedtype :: EnumeratedType -> Doc
+enumeratedtype (NotationType n)= notationtype n
+enumeratedtype (Enumeration e) = enumeration e
+notationtype :: [String] -> Doc
+notationtype ns                = text "NOTATION" <+>
+                                 parens (hcat (intersperse (text "|") (map text ns)))
+enumeration :: [String] -> Doc
+enumeration ns                 = parens (hcat (intersperse (text "|") (map nmtoken ns)))
+defaultdecl :: DefaultDecl -> Doc
+defaultdecl  REQUIRED          = text "#REQUIRED"
+defaultdecl  IMPLIED           = text "#IMPLIED"
+defaultdecl (DefaultTo a f)    = maybe (const (text "#FIXED")) f <+> attvalue a
+conditionalsect (IncludeSect i)= text "<![INCLUDE [" <+>
+                                 vcat (map extsubsetdecl i) <+> text "]]>"
+conditionalsect (IgnoreSect i) = text "<![IGNORE [" <+>
+                                 fsep (map ignoresectcontents i) <+> text "]]>"
+ignore (Ignore)                = empty
+ignoresectcontents (IgnoreSectContents i is)
+                               = ignore i <+> vcat (map internal is)
+                          where internal (ics,i) = text "<![[" <+>
+                                                   ignoresectcontents ics <+>
+                                                   text "]]>" <+> ignore i
+reference :: Reference -> Doc
+reference (RefEntity er)       = entityref er
+reference (RefChar cr)         = charref cr
+entityref :: String -> Doc
+entityref n                    = text "&" <> text n <> text ";"
+charref :: (Show a) => a -> Doc
+charref c                      = text "&#" <> text (show c) <> text ";"
+entitydecl :: EntityDecl -> Doc
+entitydecl (EntityGEDecl d)    = gedecl d
+entitydecl (EntityPEDecl d)    = pedecl d
+gedecl :: GEDecl -> Doc
+gedecl (GEDecl n ed)           = text "<!ENTITY" <+> text n <+> entitydef ed <>
+                                 text ">"
+pedecl :: PEDecl -> Doc
+pedecl (PEDecl n pd)           = text "<!ENTITY %" <+> text n <+> pedef pd <>
+                                 text ">"
+entitydef :: EntityDef -> Doc
+entitydef (DefEntityValue ew)  = entityvalue ew
+entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd
+pedef :: PEDef -> Doc
+pedef (PEDefEntityValue ew)    = entityvalue ew
+pedef (PEDefExternalID eid)    = externalid eid
+externalid :: ExternalID -> Doc
+externalid (SYSTEM sl)         = text "SYSTEM" <+> systemliteral sl
+externalid (PUBLIC i sl)       = text "PUBLIC" <+> pubidliteral i <+>
+                                 systemliteral sl
+ndatadecl :: NDataDecl -> Doc
+ndatadecl (NDATA n)            = text "NDATA" <+> text n
+textdecl (TextDecl vi ed)      = text "<?xml" <+> maybe text vi <+>
+                                 encodingdecl ed <+> text "?>"
+extparsedent (ExtParsedEnt t c)= maybe textdecl t <+> content c
+extpe (ExtPE t esd)            = maybe textdecl t <+>
+                                 vcat (map extsubsetdecl esd)
+notationdecl :: NotationDecl -> Doc
+notationdecl (NOTATION n e)    = text "<!NOTATION" <+> text n <+>
+                                 either externalid publicid e <>
+                                 text ">"
+publicid :: PublicID -> Doc
+publicid (PUBLICID p)          = text "PUBLIC" <+> pubidliteral p
+encodingdecl :: EncodingDecl -> Doc
+encodingdecl (EncodingDecl s)  = text "encoding='" <> text s <> text "'"
+nmtoken :: String -> Doc
+nmtoken s                      = text s
+attvalue :: AttValue -> Doc
+attvalue (AttValue esr)        = text "\"" <>
+                                 hcat (map (either text reference) esr) <>
+                                 text "\""
+entityvalue :: EntityValue -> Doc
+entityvalue (EntityValue evs)
+  | containsDoubleQuote evs    = text "'"  <> hcat (map ev evs) <> text "'"
+  | otherwise                  = text "\"" <> hcat (map ev evs) <> text "\""
+ev :: EV -> Doc
+ev (EVString s)                = text s
+--ev (EVPERef p e)               = peref p
+ev (EVRef r)                   = reference r
+pubidliteral :: PubidLiteral -> Doc
+pubidliteral (PubidLiteral s)
+    | '"' `elem` s             = text "'" <> text s <> text "'"
+    | otherwise                = text "\"" <> text s <> text "\""
+systemliteral :: SystemLiteral -> Doc
+systemliteral (SystemLiteral s)
+    | '"' `elem` s             = text "'" <> text s <> text "'"
+    | otherwise                = text "\"" <> text s <> text "\""
+chardata :: String -> Doc
+chardata s                     = {-if all isSpace s then empty else-} text s
+cdsect :: String -> Doc
+cdsect c                       = text "<![CDATA[" <> chardata c <> text "]]>"
+
+----
+containsDoubleQuote :: [EV] -> Bool
+containsDoubleQuote evs = any csq evs
+    where csq (EVString s) = '"' `elem` s
+          csq _            = False
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/SAX.html b/docs/HaXml/src/Text/XML/HaXml/SAX.html
--- a/docs/HaXml/src/Text/XML/HaXml/SAX.html
+++ b/docs/HaXml/src/Text/XML/HaXml/SAX.html
@@ -1,97 +1,103 @@
 
 
-
-- | A streaming XML parser, using a method known as SAX. SAX isn't really a
---   standard, but an implementation, so it's just an \"SAX-like\" parser.
---   This module allows you parse an XML document without having to evaluate
---   it as a whole. This is needed for protocols like jabber, which use xml
---   streams for communication.
-
-module Text.XML.HaXml.SAX
-	( SaxElement(..)
-	, saxParse
-	) where
-
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.Parse
-import Text.XML.HaXml.Lex
-import Text.ParserCombinators.Poly.NoLeak.State
-
-data SaxElement
-	= SaxDocTypeDecl DocTypeDecl
-		-- ^ A doctype declaration occured(\<!DOCTYPE\>)
-	| SaxProcessingInstruction ProcessingInstruction
-		-- ^ A processing instruction occured (\<??\>)
-	| SaxComment String		-- ^ A comment occured (\<!-- --\>)
-	| SaxElementOpen Name [Attribute] -- ^ An element was opened (\<\>)
-	| SaxElementClose Name		-- ^ An element was closed (\<\/\>)
-	| SaxElementTag Name [Attribute]
-		-- ^ An element without content occured (\<\/\>)
-	| SaxCharData CharData		-- ^ Some string data occured
-	| SaxReference Reference	-- ^ A reference occured
-
--- | @saxParse file content@ takes a filename and the string content of that
---   file and generates a stream of @SaxElement@s. If an error occurs, the
---   parsing stops and a string is returned using the @Maybe@ type.
-saxParse :: String -- ^ The filename
-	 -> String -- ^ The content of the file
-	 -> ([SaxElement],Maybe String)
-		-- ^ A tuple of the parsed elements and @Nothing@, if no
-		--   error occured, or @Just@ @String@ if an error occured.
-saxParse file cntnt = parseStream sax emptySTs
-                                    (xmlLex file cntnt)
-
-parseStream :: Parser s t a -> s -> [t] -> ([a], Maybe String)
-parseStream _ _ [] = ([],Nothing)
-parseStream p state toks = case runParser p state toks of
-	(Left err, _, _) -> ([],Just err)
-	(Right res, nstate, rest) -> (res:moreres, err)
-            where (moreres,err) = parseStream p nstate rest
-
-sax :: XParser SaxElement
-sax = oneOf [ saxelementopen
-            , saxelementclose
-            , saxprocessinginstruction
-            , saxcomment
-            , saxdoctypedecl
-            , saxreference
-            , saxchardata
-            ]
-	`adjustErr` (++("\nLooking for a SAX event:\n"
-               ++"  elem-open, elem-close, PI, comment, DTD, ref, or chardata"))
-
-saxelementopen :: XParser SaxElement
-saxelementopen = do
-	tok TokAnyOpen
-	(ElemTag n as) <- elemtag
-	(( do tok TokEndClose
-	      return (SaxElementTag n as)) `onFail`
-	 ( do tok TokAnyClose
-	      return (SaxElementOpen n as))
-	 `onFail` fail "missing > or /> in element tag")
-
-saxelementclose :: XParser SaxElement
-saxelementclose = do
-	tok TokEndOpen
-	n <- name
-	tok TokAnyClose
-	return (SaxElementClose n)
-
-saxcomment :: XParser SaxElement
-saxcomment = comment >>= return . SaxComment
-
-saxchardata :: XParser SaxElement
-saxchardata =
-  (cdsect >>= return . SaxCharData)
-  `onFail`
-  (chardata >>= return . SaxCharData)
-
-saxreference :: XParser SaxElement
-saxreference = reference >>= return . SaxReference
-
-saxdoctypedecl :: XParser SaxElement
-saxdoctypedecl = doctypedecl >>= return . SaxDocTypeDecl
-
-saxprocessinginstruction :: XParser SaxElement
-saxprocessinginstruction = fmap SaxProcessingInstruction processinginstruction
+
+
+src/Text/XML/HaXml/SAX.hs
+
+
+
-- | A streaming XML parser, using a method known as SAX. SAX isn't really a
+--   standard, but an implementation, so it's just an \"SAX-like\" parser.
+--   This module allows you parse an XML document without having to evaluate
+--   it as a whole. This is needed for protocols like jabber, which use xml
+--   streams for communication.
+
+module Text.XML.HaXml.SAX
+	( SaxElement(..)
+	, saxParse
+	) where
+
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.Parse
+import Text.XML.HaXml.Lex
+import Text.ParserCombinators.Poly.NoLeak.State
+
+data SaxElement
+	= SaxDocTypeDecl DocTypeDecl
+		-- ^ A doctype declaration occured(\<!DOCTYPE\>)
+	| SaxProcessingInstruction ProcessingInstruction
+		-- ^ A processing instruction occured (\<??\>)
+	| SaxComment String		-- ^ A comment occured (\<!-- --\>)
+	| SaxElementOpen Name [Attribute] -- ^ An element was opened (\<\>)
+	| SaxElementClose Name		-- ^ An element was closed (\<\/\>)
+	| SaxElementTag Name [Attribute]
+		-- ^ An element without content occured (\<\/\>)
+	| SaxCharData CharData		-- ^ Some string data occured
+	| SaxReference Reference	-- ^ A reference occured
+
+-- | @saxParse file content@ takes a filename and the string content of that
+--   file and generates a stream of @SaxElement@s. If an error occurs, the
+--   parsing stops and a string is returned using the @Maybe@ type.
+saxParse :: String -- ^ The filename
+	 -> String -- ^ The content of the file
+	 -> ([SaxElement],Maybe String)
+		-- ^ A tuple of the parsed elements and @Nothing@, if no
+		--   error occured, or @Just@ @String@ if an error occured.
+saxParse file cntnt = parseStream sax emptySTs
+                                    (xmlLex file cntnt)
+
+parseStream :: Parser s t a -> s -> [t] -> ([a], Maybe String)
+parseStream _ _ [] = ([],Nothing)
+parseStream p state toks = case runParser p state toks of
+	(Left err, _, _) -> ([],Just err)
+	(Right res, nstate, rest) -> (res:moreres, err)
+            where (moreres,err) = parseStream p nstate rest
+
+sax :: XParser SaxElement
+sax = oneOf [ saxelementopen
+            , saxelementclose
+            , saxprocessinginstruction
+            , saxcomment
+            , saxdoctypedecl
+            , saxreference
+            , saxchardata
+            ]
+	`adjustErr` (++("\nLooking for a SAX event:\n"
+               ++"  elem-open, elem-close, PI, comment, DTD, ref, or chardata"))
+
+saxelementopen :: XParser SaxElement
+saxelementopen = do
+	tok TokAnyOpen
+	(ElemTag n as) <- elemtag
+	(( do tok TokEndClose
+	      return (SaxElementTag n as)) `onFail`
+	 ( do tok TokAnyClose
+	      return (SaxElementOpen n as))
+	 `onFail` fail "missing > or /> in element tag")
+
+saxelementclose :: XParser SaxElement
+saxelementclose = do
+	tok TokEndOpen
+	n <- name
+	tok TokAnyClose
+	return (SaxElementClose n)
+
+saxcomment :: XParser SaxElement
+saxcomment = comment >>= return . SaxComment
+
+saxchardata :: XParser SaxElement
+saxchardata =
+  (cdsect >>= return . SaxCharData)
+  `onFail`
+  (chardata >>= return . SaxCharData)
+
+saxreference :: XParser SaxElement
+saxreference = reference >>= return . SaxReference
+
+saxdoctypedecl :: XParser SaxElement
+saxdoctypedecl = doctypedecl >>= return . SaxDocTypeDecl
+
+saxprocessinginstruction :: XParser SaxElement
+saxprocessinginstruction = fmap SaxProcessingInstruction processinginstruction
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/ShowXmlLazy.html b/docs/HaXml/src/Text/XML/HaXml/ShowXmlLazy.html
--- a/docs/HaXml/src/Text/XML/HaXml/ShowXmlLazy.html
+++ b/docs/HaXml/src/Text/XML/HaXml/ShowXmlLazy.html
@@ -1,331 +1,337 @@
 
 
-
module Text.XML.HaXml.ShowXmlLazy (showXmlLazy) where
-
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.TypeMapping -- (toHType, toDTD, Tuple(), Defined, showHType)
-
-import qualified Text.XML.HaXml.XmlContent as X
-import Prelude hiding (maybe,either)
-import Maybe hiding (maybe)
-import Data.List
-
--- | Convert a fully-typed XML document to a string (without DTD).
-showXmlLazy :: X.XmlContent a => Bool -> a -> String
-showXmlLazy dtd x =
-    case X.toContents x of
-      [CElem _ _] -> document $ toXmlLazy dtd x
-      _ -> ""
-
-
--- | Convert a fully-typed XML document to a string (with or without DTD).
-toXmlLazy :: X.XmlContent a => Bool -> a -> Document ()
-toXmlLazy dtd value =
-    let ht = toHType value in
-    Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing))
-                     [] (if dtd then Just (toDTD ht) else Nothing) [])
-             emptyST
-             ( case (ht, X.toContents value) of
-                 (Tuple _, cs)       -> Elem (showHType ht "") [] cs
-                 (Defined _ _ _, cs) -> Elem (showHType ht "-XML") [] cs
-                 (_, [CElem e ()])   -> e )
-             []
-
-
-
-
-type Doc = String
-empty :: [Char]
-empty = ""
-($$) :: [Char] -> [Char] -> [Char]
-($$) a b = a ++ "\n" ++ b
-vcat :: [[Char]] -> [Char]
-vcat a = foldr ($$) [] a
-hcat :: [[a]] -> [a]
-hcat = concat
-(<>) :: [a] -> [a] -> [a]
-(<>) = (++)
-(<+>) :: [Char] -> [Char] -> [Char]
-(<+>) a b = a ++ " " ++ b
-fsep :: [[Char]] -> [Char]
-fsep = vcat
-text :: t -> t
-text string = string
-parens :: [Char] -> [Char]
-parens string = "("++string++")"
-nest :: t -> t1 -> t1
-nest _ string = string
-
-
-
-either :: (t -> t1) -> (t2 -> t1) -> Either t t2 -> t1
-either f _ (Left x)  = f x
-either _ g (Right x) = g x
-
-maybe :: (t -> [Char]) -> Maybe t -> [Char]
-maybe _ Nothing  = empty
-maybe f (Just x) = f x
-
---peref p   = text "%" <> text p <> text ";"
-
-----
-
-document :: Document i -> Doc
-prolog   :: Prolog -> Doc
-xmldecl  :: XMLDecl -> Doc
-misc     :: Misc -> Doc
-sddecl   :: Bool -> Doc
-
-doctypedecl :: DocTypeDecl -> Doc
-markupdecl  :: MarkupDecl -> Doc
--- extsubset   :: ExtSubset -> Doc
--- extsubsetdecl :: ExtSubsetDecl -> Doc
-cp          :: CP -> Doc
-
-element   :: Element i -> Doc
-attribute :: Attribute -> Doc                     --etc
-content   :: Content i -> Doc
-
-----
-
-document (Document p _ e m)= prolog p $$ element e $$ vcat (map misc m)
-prolog (Prolog x m1 dtd m2)= maybe xmldecl x $$
-                             vcat (map misc m1) $$
-                             maybe doctypedecl dtd $$
-                             vcat (map misc m2)
-xmldecl (XMLDecl v e sd)   = text "<?xml version='" <> text v <> text "'" <+>
-                             maybe encodingdecl e <+>
-                             maybe sddecl sd <+>
-                             text "?>"
-misc (Comment s)           = text "<!--" <+> text s <+> text "-->"
-misc (PI (n,s))            = text "<?" <> text n <+> text s <+> text "?>"
-sddecl sd   | sd           = text "standalone='yes'"
-            | otherwise    = text "standalone='no'"
-doctypedecl (DTD n eid ds) = if null ds then
-                                  hd <> text ">"
-                             else hd <+> text " [" $$
-                                  vcat (map markupdecl ds) $$ text "]>"
-                           where hd = text "<!DOCTYPE" <+> text n <+>
-                                      maybe externalid eid
-markupdecl (Element e)     = elementdecl e
-markupdecl (AttList a)     = attlistdecl a
-markupdecl (Entity e)      = entitydecl e
-markupdecl (Notation n)    = notationdecl n
-markupdecl (MarkupMisc m)  = misc m
---markupdecl (MarkupPE p m)  = peref p
--- _ (ExtSubset t ds) = maybe textdecl t $$
---                              vcat (map extsubsetdecl ds)
--- _ (ExtMarkupDecl m)      = markupdecl m
--- extsubsetdecl (ExtConditionalSect c) = conditionalsect c
---extsubsetdecl (ExtPEReference p e)   = peref p
-
-element (Elem n as []) = text "<" <> text n <+>
-                         fsep (map attribute as) <> text "/>"
-element e@(Elem n as cs)
---  | any isText cs    = text "<" <> text n <+> fsep (map attribute as) <>
---                       text ">" <> hcat (map content cs) <>
---                       text "</" <> text n <> text ">"
-    | isText (head cs) = text "<" <> text n <+> fsep (map attribute as) <>
-                         text ">" <> hcat (map content cs) <>
-                         text "</" <> text n <> text ">"
-    | otherwise        = let (d,c) = carryelem e empty
-                         in d <> c
-
-isText :: Content t -> Bool
-isText (CString _ _ _) = True
-isText (CRef _ _)      = True
-isText _               = False
-
-carryelem (Elem n as []) c
-                       = ( c <>
-                           text "<" <> text n <+> fsep (map attribute as)
-                         , text "/>")
-carryelem (Elem n as cs) c
---  | any isText cs    =  ( c <> element e, empty)
-    | otherwise        =  let (cs0,d0) = carryscan carrycontent cs (text ">")
-                          in
-                          ( c <>
-                            text "<" <> text n <+> fsep (map attribute as) $$
-                            nest (2 :: Int) (vcat cs0) <> --- $$
-                            d0 <> text "</" <> text n
-                          , text ">")
-carrycontent :: Content t -> [Char] -> ([Char], [Char])
-carryelem :: Element t -> [Char] -> ([Char], [Char])
-carrycontent (CElem e _) c   = carryelem e c
-carrycontent (CString False s _) c = (c <> chardata s, empty)
-carrycontent (CString True  s _) c = (c <> cdsect s, empty)
-carrycontent (CRef r _) c    = (c <> reference r, empty)
-carrycontent (CMisc m _) c   = (c <> misc m, empty)
-
-carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c)
-carryscan _ []     c = ([],c)
-carryscan f (a:as) c = let (b, c0) = f a c
-                           (bs,c1) = carryscan f as c0
-                       in (b:bs, c1)
-
---carryelem e@(Elem n as cs) c
---  | isText (head cs) =
---        ( start <>
---          text ">" <> hcat (map content cs) <> text "</" <> text n
---        , text ">")
---  | otherwise =
---        let (d,c0) = foldl carrycontent (start, text ">") cs in
---        ( d <> c0 <> text "</" <> text n
---        , text ">")
---  where start = c <> text "<" <> text n <+> fsep (map attribute as)
---
---carrycontent (d,c) (CElem e)   = let (d',c') = carryelem e c in
---                                 (d $$ nest 2 d',       c')
---carrycontent (d,c) (CString _ s) = (d <> c <> chardata s, empty)
---carrycontent (d,c) (CRef r)    = (d <> c <> reference r,empty)
---carrycontent (d,c) (CMisc m)   = (d $$ c <> misc m,     empty)
-
-
-attribute (n,v)             = text n <> text "=" <> attvalue v
-content (CElem e _)         = element e
-content (CString False s _) = chardata s
-content (CString True s _)  = cdsect s
-content (CRef r _)          = reference r
-content (CMisc m _)         = misc m
-
-elementdecl :: ElementDecl -> [Char]
-elementdecl (ElementDecl n cs) = text "<!ELEMENT" <+> text n <+>
-                                 contentspec cs <> text ">"
-contentspec :: ContentSpec -> [Char]
-contentspec EMPTY              = text "EMPTY"
-contentspec ANY                = text "ANY"
-contentspec (Mixed m)          = mixed m
-contentspec (ContentSpec c)    = cp c
---contentspec (ContentPE p cs)   = peref p
-cp (TagName n m)       = text n <> modifier m
-cp (Choice cs m)       = parens (hcat (intersperse (text "|") (map cp cs))) <>
-                           modifier m
-cp (Seq cs m)          = parens (hcat (intersperse (text ",") (map cp cs))) <>
-                           modifier m
---cp (CPPE p c)          = peref p
-modifier :: Modifier -> [Char]
-modifier None          = empty
-modifier Query         = text "?"
-modifier Star          = text "*"
-modifier Plus          = text "+"
-mixed :: Mixed -> [Char]
-mixed  PCDATA          = text "(#PCDATA)"
-mixed (PCDATAplus ns)  = text "(#PCDATA |" <+>
-                         hcat (intersperse (text "|") (map text ns)) <>
-                         text ")*"
-
-attlistdecl :: AttListDecl -> [Char]
-attlistdecl (AttListDecl n ds) = text "<!ATTLIST" <+> text n <+>
-                                 fsep (map attdef ds) <> text ">"
-attdef :: AttDef -> [Char]
-attdef (AttDef n t d)          = text n <+> atttype t <+> defaultdecl d
-atttype :: AttType -> [Char]
-atttype  StringType            = text "CDATA"
-atttype (TokenizedType t)      = tokenizedtype t
-atttype (EnumeratedType t)     = enumeratedtype t
-tokenizedtype :: TokenizedType -> [Char]
-tokenizedtype ID               = text "ID"
-tokenizedtype IDREF            = text "IDREF"
-tokenizedtype IDREFS           = text "IDREFS"
-tokenizedtype ENTITY           = text "ENTITY"
-tokenizedtype ENTITIES         = text "ENTITIES"
-tokenizedtype NMTOKEN          = text "NMTOKEN"
-tokenizedtype NMTOKENS         = text "NMTOKENS"
-enumeratedtype :: EnumeratedType -> [Char]
-enumeratedtype (NotationType n)= notationtype n
-enumeratedtype (Enumeration e) = enumeration e
-notationtype :: [[Char]] -> [Char]
-notationtype ns                = text "NOTATION" <+>
-                                 parens (hcat (intersperse (text "|") (map text ns)))
-enumeration :: [[Char]] -> [Char]
-enumeration ns                 = parens (hcat (intersperse (text "|") (map nmtoken ns)))
-defaultdecl :: DefaultDecl -> [Char]
-defaultdecl  REQUIRED          = text "#REQUIRED"
-defaultdecl  IMPLIED           = text "#IMPLIED"
-defaultdecl (DefaultTo a f)    = maybe (const (text "#FIXED")) f <+> attvalue a
--- _ (IncludeSect i)= text "<![INCLUDE [" <+>
---                                  vcat (map extsubsetdecl i) <+> text "]]>"
--- conditionalsect (IgnoreSect i) = text "<![IGNORE [" <+>
---                                  fsep (map ignoresectcontents i) <+> text "]]>"
--- _ (Ignore)                = empty
--- _ (IgnoreSectContents i is)
---                                = ignore i <+> vcat (map internal is)
---                           where internal (ics,i) = text "<![[" <+>
---                                                    ignoresectcontents ics <+>
---                                                    text "]]>" <+> ignore i
-reference :: Reference -> [Char]
-reference (RefEntity er)       = entityref er
-reference (RefChar cr)         = charref cr
-entityref :: [Char] -> [Char]
-entityref n                    = text "&" <> text n <> text ";"
-charref :: (Show a) => a -> [Char]
-charref c                      = text "&#" <> text (show c) <> text ";"
-entitydecl :: EntityDecl -> [Char]
-entitydecl (EntityGEDecl d)    = gedecl d
-entitydecl (EntityPEDecl d)    = pedecl d
-gedecl :: GEDecl -> [Char]
-gedecl (GEDecl n ed)           = text "<!ENTITY" <+> text n <+> entitydef ed <>
-                                 text ">"
-pedecl :: PEDecl -> [Char]
-pedecl (PEDecl n pd)           = text "<!ENTITY %" <> text n <+> pedef pd <>
-                                 text ">"
-entitydef :: EntityDef -> [Char]
-entitydef (DefEntityValue ew)  = entityvalue ew
-entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd
-pedef :: PEDef -> [Char]
-pedef (PEDefEntityValue ew)    = entityvalue ew
-pedef (PEDefExternalID eid)    = externalid eid
-externalid :: ExternalID -> [Char]
-externalid (SYSTEM sl)         = text "SYSTEM" <+> systemliteral sl
-externalid (PUBLIC i sl)       = text "PUBLIC" <+> pubidliteral i <+>
-                                 systemliteral sl
-ndatadecl :: NDataDecl -> [Char]
-ndatadecl (NDATA n)            = text "NDATA" <+> text n
--- _ (TextDecl vi ed)      = text "<?xml" <+> maybe text vi <+>
---                                  encodingdecl ed <> text "?>"
--- _ (ExtParsedEnt t c)= maybe textdecl t <+> content c
--- _ (ExtPE t esd)            = maybe textdecl t <+>
---                                  vcat (map extsubsetdecl esd)
-notationdecl :: NotationDecl -> [Char]
-notationdecl (NOTATION n e)    = text "<!NOTATION" <+> text n <+>
-                                 either externalid publicid e <>
-                                 text ">"
-publicid :: PublicID -> [Char]
-publicid (PUBLICID p)          = text "PUBLICID" <+> pubidliteral p
-encodingdecl :: EncodingDecl -> [Char]
-encodingdecl (EncodingDecl s)  = text "encoding='" <> text s <> text "'"
-nmtoken :: t -> t
-nmtoken s                      = text s
-attvalue :: AttValue -> [Char]
-attvalue (AttValue esr)        = text "\"" <>
-                                 hcat (map (either text reference) esr) <>
-                                 text "\""
-entityvalue :: EntityValue -> [Char]
-entityvalue (EntityValue evs)
-  | containsDoubleQuote evs    = text "'"  <> hcat (map ev evs) <> text "'"
-  | otherwise                  = text "\"" <> hcat (map ev evs) <> text "\""
-ev :: EV -> String
-ev (EVString s)                = text s
---ev (EVPERef p e)               = peref p
-ev (EVRef r)                   = reference r
-pubidliteral :: PubidLiteral -> [Char]
-pubidliteral (PubidLiteral s)
-    | '"' `elem` s             = text "'" <> text s <> text "'"
-    | otherwise                = text "\"" <> text s <> text "\""
-systemliteral :: SystemLiteral -> [Char]
-systemliteral (SystemLiteral s)
-    | '"' `elem` s             = text "'" <> text s <> text "'"
-    | otherwise                = text "\"" <> text s <> text "\""
-chardata :: t -> t
-chardata s                     = {-if all isSpace s then empty else-} text s
-cdsect :: [Char] -> [Char]
-cdsect c                       = text "<![CDATA[" <> chardata c <> text "]]>"
-
-----
-containsDoubleQuote :: [EV] -> Bool
-containsDoubleQuote evs = any csq evs
-    where csq (EVString s) = '"' `elem` s
-          csq _            = False
-
+
+
+src/Text/XML/HaXml/ShowXmlLazy.hs
+
+
+
module Text.XML.HaXml.ShowXmlLazy (showXmlLazy) where
+
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.TypeMapping -- (toHType, toDTD, Tuple(), Defined, showHType)
+
+import qualified Text.XML.HaXml.XmlContent as X
+import Prelude hiding (maybe,either)
+import Maybe hiding (maybe)
+import Data.List
+
+-- | Convert a fully-typed XML document to a string (without DTD).
+showXmlLazy :: X.XmlContent a => Bool -> a -> String
+showXmlLazy dtd x =
+    case X.toContents x of
+      [CElem _ _] -> document $ toXmlLazy dtd x
+      _ -> ""
+
+
+-- | Convert a fully-typed XML document to a string (with or without DTD).
+toXmlLazy :: X.XmlContent a => Bool -> a -> Document ()
+toXmlLazy dtd value =
+    let ht = toHType value in
+    Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing))
+                     [] (if dtd then Just (toDTD ht) else Nothing) [])
+             emptyST
+             ( case (ht, X.toContents value) of
+                 (Tuple _, cs)       -> Elem (showHType ht "") [] cs
+                 (Defined _ _ _, cs) -> Elem (showHType ht "-XML") [] cs
+                 (_, [CElem e ()])   -> e )
+             []
+
+
+
+
+type Doc = String
+empty :: [Char]
+empty = ""
+($$) :: [Char] -> [Char] -> [Char]
+($$) a b = a ++ "\n" ++ b
+vcat :: [[Char]] -> [Char]
+vcat a = foldr ($$) [] a
+hcat :: [[a]] -> [a]
+hcat = concat
+(<>) :: [a] -> [a] -> [a]
+(<>) = (++)
+(<+>) :: [Char] -> [Char] -> [Char]
+(<+>) a b = a ++ " " ++ b
+fsep :: [[Char]] -> [Char]
+fsep = vcat
+text :: t -> t
+text string = string
+parens :: [Char] -> [Char]
+parens string = "("++string++")"
+nest :: t -> t1 -> t1
+nest _ string = string
+
+
+
+either :: (t -> t1) -> (t2 -> t1) -> Either t t2 -> t1
+either f _ (Left x)  = f x
+either _ g (Right x) = g x
+
+maybe :: (t -> [Char]) -> Maybe t -> [Char]
+maybe _ Nothing  = empty
+maybe f (Just x) = f x
+
+--peref p   = text "%" <> text p <> text ";"
+
+----
+
+document :: Document i -> Doc
+prolog   :: Prolog -> Doc
+xmldecl  :: XMLDecl -> Doc
+misc     :: Misc -> Doc
+sddecl   :: Bool -> Doc
+
+doctypedecl :: DocTypeDecl -> Doc
+markupdecl  :: MarkupDecl -> Doc
+-- extsubset   :: ExtSubset -> Doc
+-- extsubsetdecl :: ExtSubsetDecl -> Doc
+cp          :: CP -> Doc
+
+element   :: Element i -> Doc
+attribute :: Attribute -> Doc                     --etc
+content   :: Content i -> Doc
+
+----
+
+document (Document p _ e m)= prolog p $$ element e $$ vcat (map misc m)
+prolog (Prolog x m1 dtd m2)= maybe xmldecl x $$
+                             vcat (map misc m1) $$
+                             maybe doctypedecl dtd $$
+                             vcat (map misc m2)
+xmldecl (XMLDecl v e sd)   = text "<?xml version='" <> text v <> text "'" <+>
+                             maybe encodingdecl e <+>
+                             maybe sddecl sd <+>
+                             text "?>"
+misc (Comment s)           = text "<!--" <+> text s <+> text "-->"
+misc (PI (n,s))            = text "<?" <> text n <+> text s <+> text "?>"
+sddecl sd   | sd           = text "standalone='yes'"
+            | otherwise    = text "standalone='no'"
+doctypedecl (DTD n eid ds) = if null ds then
+                                  hd <> text ">"
+                             else hd <+> text " [" $$
+                                  vcat (map markupdecl ds) $$ text "]>"
+                           where hd = text "<!DOCTYPE" <+> text n <+>
+                                      maybe externalid eid
+markupdecl (Element e)     = elementdecl e
+markupdecl (AttList a)     = attlistdecl a
+markupdecl (Entity e)      = entitydecl e
+markupdecl (Notation n)    = notationdecl n
+markupdecl (MarkupMisc m)  = misc m
+--markupdecl (MarkupPE p m)  = peref p
+-- _ (ExtSubset t ds) = maybe textdecl t $$
+--                              vcat (map extsubsetdecl ds)
+-- _ (ExtMarkupDecl m)      = markupdecl m
+-- extsubsetdecl (ExtConditionalSect c) = conditionalsect c
+--extsubsetdecl (ExtPEReference p e)   = peref p
+
+element (Elem n as []) = text "<" <> text n <+>
+                         fsep (map attribute as) <> text "/>"
+element e@(Elem n as cs)
+--  | any isText cs    = text "<" <> text n <+> fsep (map attribute as) <>
+--                       text ">" <> hcat (map content cs) <>
+--                       text "</" <> text n <> text ">"
+    | isText (head cs) = text "<" <> text n <+> fsep (map attribute as) <>
+                         text ">" <> hcat (map content cs) <>
+                         text "</" <> text n <> text ">"
+    | otherwise        = let (d,c) = carryelem e empty
+                         in d <> c
+
+isText :: Content t -> Bool
+isText (CString _ _ _) = True
+isText (CRef _ _)      = True
+isText _               = False
+
+carryelem (Elem n as []) c
+                       = ( c <>
+                           text "<" <> text n <+> fsep (map attribute as)
+                         , text "/>")
+carryelem (Elem n as cs) c
+--  | any isText cs    =  ( c <> element e, empty)
+    | otherwise        =  let (cs0,d0) = carryscan carrycontent cs (text ">")
+                          in
+                          ( c <>
+                            text "<" <> text n <+> fsep (map attribute as) $$
+                            nest (2 :: Int) (vcat cs0) <> --- $$
+                            d0 <> text "</" <> text n
+                          , text ">")
+carrycontent :: Content t -> [Char] -> ([Char], [Char])
+carryelem :: Element t -> [Char] -> ([Char], [Char])
+carrycontent (CElem e _) c   = carryelem e c
+carrycontent (CString False s _) c = (c <> chardata s, empty)
+carrycontent (CString True  s _) c = (c <> cdsect s, empty)
+carrycontent (CRef r _) c    = (c <> reference r, empty)
+carrycontent (CMisc m _) c   = (c <> misc m, empty)
+
+carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c)
+carryscan _ []     c = ([],c)
+carryscan f (a:as) c = let (b, c0) = f a c
+                           (bs,c1) = carryscan f as c0
+                       in (b:bs, c1)
+
+--carryelem e@(Elem n as cs) c
+--  | isText (head cs) =
+--        ( start <>
+--          text ">" <> hcat (map content cs) <> text "</" <> text n
+--        , text ">")
+--  | otherwise =
+--        let (d,c0) = foldl carrycontent (start, text ">") cs in
+--        ( d <> c0 <> text "</" <> text n
+--        , text ">")
+--  where start = c <> text "<" <> text n <+> fsep (map attribute as)
+--
+--carrycontent (d,c) (CElem e)   = let (d',c') = carryelem e c in
+--                                 (d $$ nest 2 d',       c')
+--carrycontent (d,c) (CString _ s) = (d <> c <> chardata s, empty)
+--carrycontent (d,c) (CRef r)    = (d <> c <> reference r,empty)
+--carrycontent (d,c) (CMisc m)   = (d $$ c <> misc m,     empty)
+
+
+attribute (n,v)             = text n <> text "=" <> attvalue v
+content (CElem e _)         = element e
+content (CString False s _) = chardata s
+content (CString True s _)  = cdsect s
+content (CRef r _)          = reference r
+content (CMisc m _)         = misc m
+
+elementdecl :: ElementDecl -> [Char]
+elementdecl (ElementDecl n cs) = text "<!ELEMENT" <+> text n <+>
+                                 contentspec cs <> text ">"
+contentspec :: ContentSpec -> [Char]
+contentspec EMPTY              = text "EMPTY"
+contentspec ANY                = text "ANY"
+contentspec (Mixed m)          = mixed m
+contentspec (ContentSpec c)    = cp c
+--contentspec (ContentPE p cs)   = peref p
+cp (TagName n m)       = text n <> modifier m
+cp (Choice cs m)       = parens (hcat (intersperse (text "|") (map cp cs))) <>
+                           modifier m
+cp (Seq cs m)          = parens (hcat (intersperse (text ",") (map cp cs))) <>
+                           modifier m
+--cp (CPPE p c)          = peref p
+modifier :: Modifier -> [Char]
+modifier None          = empty
+modifier Query         = text "?"
+modifier Star          = text "*"
+modifier Plus          = text "+"
+mixed :: Mixed -> [Char]
+mixed  PCDATA          = text "(#PCDATA)"
+mixed (PCDATAplus ns)  = text "(#PCDATA |" <+>
+                         hcat (intersperse (text "|") (map text ns)) <>
+                         text ")*"
+
+attlistdecl :: AttListDecl -> [Char]
+attlistdecl (AttListDecl n ds) = text "<!ATTLIST" <+> text n <+>
+                                 fsep (map attdef ds) <> text ">"
+attdef :: AttDef -> [Char]
+attdef (AttDef n t d)          = text n <+> atttype t <+> defaultdecl d
+atttype :: AttType -> [Char]
+atttype  StringType            = text "CDATA"
+atttype (TokenizedType t)      = tokenizedtype t
+atttype (EnumeratedType t)     = enumeratedtype t
+tokenizedtype :: TokenizedType -> [Char]
+tokenizedtype ID               = text "ID"
+tokenizedtype IDREF            = text "IDREF"
+tokenizedtype IDREFS           = text "IDREFS"
+tokenizedtype ENTITY           = text "ENTITY"
+tokenizedtype ENTITIES         = text "ENTITIES"
+tokenizedtype NMTOKEN          = text "NMTOKEN"
+tokenizedtype NMTOKENS         = text "NMTOKENS"
+enumeratedtype :: EnumeratedType -> [Char]
+enumeratedtype (NotationType n)= notationtype n
+enumeratedtype (Enumeration e) = enumeration e
+notationtype :: [[Char]] -> [Char]
+notationtype ns                = text "NOTATION" <+>
+                                 parens (hcat (intersperse (text "|") (map text ns)))
+enumeration :: [[Char]] -> [Char]
+enumeration ns                 = parens (hcat (intersperse (text "|") (map nmtoken ns)))
+defaultdecl :: DefaultDecl -> [Char]
+defaultdecl  REQUIRED          = text "#REQUIRED"
+defaultdecl  IMPLIED           = text "#IMPLIED"
+defaultdecl (DefaultTo a f)    = maybe (const (text "#FIXED")) f <+> attvalue a
+-- _ (IncludeSect i)= text "<![INCLUDE [" <+>
+--                                  vcat (map extsubsetdecl i) <+> text "]]>"
+-- conditionalsect (IgnoreSect i) = text "<![IGNORE [" <+>
+--                                  fsep (map ignoresectcontents i) <+> text "]]>"
+-- _ (Ignore)                = empty
+-- _ (IgnoreSectContents i is)
+--                                = ignore i <+> vcat (map internal is)
+--                           where internal (ics,i) = text "<![[" <+>
+--                                                    ignoresectcontents ics <+>
+--                                                    text "]]>" <+> ignore i
+reference :: Reference -> [Char]
+reference (RefEntity er)       = entityref er
+reference (RefChar cr)         = charref cr
+entityref :: [Char] -> [Char]
+entityref n                    = text "&" <> text n <> text ";"
+charref :: (Show a) => a -> [Char]
+charref c                      = text "&#" <> text (show c) <> text ";"
+entitydecl :: EntityDecl -> [Char]
+entitydecl (EntityGEDecl d)    = gedecl d
+entitydecl (EntityPEDecl d)    = pedecl d
+gedecl :: GEDecl -> [Char]
+gedecl (GEDecl n ed)           = text "<!ENTITY" <+> text n <+> entitydef ed <>
+                                 text ">"
+pedecl :: PEDecl -> [Char]
+pedecl (PEDecl n pd)           = text "<!ENTITY %" <> text n <+> pedef pd <>
+                                 text ">"
+entitydef :: EntityDef -> [Char]
+entitydef (DefEntityValue ew)  = entityvalue ew
+entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd
+pedef :: PEDef -> [Char]
+pedef (PEDefEntityValue ew)    = entityvalue ew
+pedef (PEDefExternalID eid)    = externalid eid
+externalid :: ExternalID -> [Char]
+externalid (SYSTEM sl)         = text "SYSTEM" <+> systemliteral sl
+externalid (PUBLIC i sl)       = text "PUBLIC" <+> pubidliteral i <+>
+                                 systemliteral sl
+ndatadecl :: NDataDecl -> [Char]
+ndatadecl (NDATA n)            = text "NDATA" <+> text n
+-- _ (TextDecl vi ed)      = text "<?xml" <+> maybe text vi <+>
+--                                  encodingdecl ed <> text "?>"
+-- _ (ExtParsedEnt t c)= maybe textdecl t <+> content c
+-- _ (ExtPE t esd)            = maybe textdecl t <+>
+--                                  vcat (map extsubsetdecl esd)
+notationdecl :: NotationDecl -> [Char]
+notationdecl (NOTATION n e)    = text "<!NOTATION" <+> text n <+>
+                                 either externalid publicid e <>
+                                 text ">"
+publicid :: PublicID -> [Char]
+publicid (PUBLICID p)          = text "PUBLICID" <+> pubidliteral p
+encodingdecl :: EncodingDecl -> [Char]
+encodingdecl (EncodingDecl s)  = text "encoding='" <> text s <> text "'"
+nmtoken :: t -> t
+nmtoken s                      = text s
+attvalue :: AttValue -> [Char]
+attvalue (AttValue esr)        = text "\"" <>
+                                 hcat (map (either text reference) esr) <>
+                                 text "\""
+entityvalue :: EntityValue -> [Char]
+entityvalue (EntityValue evs)
+  | containsDoubleQuote evs    = text "'"  <> hcat (map ev evs) <> text "'"
+  | otherwise                  = text "\"" <> hcat (map ev evs) <> text "\""
+ev :: EV -> String
+ev (EVString s)                = text s
+--ev (EVPERef p e)               = peref p
+ev (EVRef r)                   = reference r
+pubidliteral :: PubidLiteral -> [Char]
+pubidliteral (PubidLiteral s)
+    | '"' `elem` s             = text "'" <> text s <> text "'"
+    | otherwise                = text "\"" <> text s <> text "\""
+systemliteral :: SystemLiteral -> [Char]
+systemliteral (SystemLiteral s)
+    | '"' `elem` s             = text "'" <> text s <> text "'"
+    | otherwise                = text "\"" <> text s <> text "\""
+chardata :: t -> t
+chardata s                     = {-if all isSpace s then empty else-} text s
+cdsect :: [Char] -> [Char]
+cdsect c                       = text "<![CDATA[" <> chardata c <> text "]]>"
+
+----
+containsDoubleQuote :: [EV] -> Bool
+containsDoubleQuote evs = any csq evs
+    where csq (EVString s) = '"' `elem` s
+          csq _            = False
+
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/TypeMapping.html b/docs/HaXml/src/Text/XML/HaXml/TypeMapping.html
--- a/docs/HaXml/src/Text/XML/HaXml/TypeMapping.html
+++ b/docs/HaXml/src/Text/XML/HaXml/TypeMapping.html
@@ -1,224 +1,300 @@
 
 
-
module Text.XML.HaXml.TypeMapping
-  (
-  -- * A class to get an explicit type representation for any value
-    HTypeable(..)	-- sole method, toHType
-  -- * Explicit representation of Haskell datatype information
-  , HType(..)		-- instance of Eq, Show
-  , Constr(..)		-- instance of Eq, Show
-  -- * Helper functions to extract type info as strings
-  , showHType		-- :: HType -> ShowS
-  , showConstr		-- :: Int -> HType -> String
-  -- * Conversion from Haskell datatype to DTD
-  , toDTD
-  ) where
-
-import Text.XML.HaXml.Types
-import Data.List (partition, intersperse)
-import Text.PrettyPrint.HughesPJ (render)
-import qualified Text.XML.HaXml.Pretty as PP
-
-
-------------------------------------------------------------------------
-        -- idea: in DrIFT,
-        --      named field == primitive type, becomes an attribute
-        --      named field == single-constructor type, renames the tag
-        --      named field == multi-constructor type, as normal
-        -- if prefix of all named fields is roughly typename, delete it
-
--- | @HTypeable@ promises that we can create an explicit representation of
---   of the type of any value.
-class HTypeable a where
-    toHType :: a -> HType
-
--- | A concrete representation of any Haskell type.
-data HType =
-      Maybe HType
-    | List HType
-    | Tuple [HType]
-    | Prim String String        -- ^ separate Haskell name and XML name
-    | String
-    | Defined String [HType] [Constr]
-	-- ^ A user-defined type has a name, a sequence of type variables,
-	--   and a set of constructors.  (The variables might already be
-	--   instantiated to actual types.)
-    deriving (Show)
-
-instance Eq HType where
-    (Maybe x)  == (Maybe y)  =  x==y
-    (List x)   == (List y)   =  x==y
-    (Tuple xs) == (Tuple ys) =  xs==ys
-    (Prim x _) == (Prim y _) =  x==y
-    String     == String     =  True
-    (Defined n xs _) == (Defined m ys _)  =  n==m 	-- && xs==ys
-    _          == _          =  False
-
--- | A concrete representation of any user-defined Haskell constructor.
---   The constructor has a name, and a sequence of component types.  The
---   first sequence of types represents the minimum set of free type
---   variables occurring in the (second) list of real component types.
---   If there are fieldnames, they are contained in the final list, and
---   correspond one-to-one with the component types.
-data Constr = Constr String [HType] [HType] -- (Maybe [String])
-    deriving (Eq,Show)
-
--- | Project the n'th constructor from an HType and convert it to a string
---   suitable for an XML tagname.
-showConstr :: Int -> HType -> String
-showConstr n (Defined _ _ cs) = flatConstr (cs!!n) ""
-showConstr n _ = error "no constructors for builtin types"
-
-------------------------------------------------------------------------
--- Some instances
-instance HTypeable Bool where
-    toHType   _    = Prim "Bool" "bool"
-instance HTypeable Int where
-    toHType   _    = Prim "Int" "int"
-instance HTypeable Integer where
-    toHType   _    = Prim "Integer" "integer"
-instance HTypeable Float where
-    toHType   _    = Prim "Float" "float"
-instance HTypeable Double where
-    toHType   _    = Prim "Double" "double"
-instance HTypeable Char where
-    toHType   _    = Prim "Char" "char"
-
-instance HTypeable () where
-    toHType _      = Prim "unit" "unit"
-instance (HTypeable a, HTypeable b) => HTypeable (a,b) where
-    toHType p      = Tuple [toHType a, toHType b]
-                   where  (a,b) = p
-instance (HTypeable a, HTypeable b, HTypeable c) => HTypeable (a,b,c) where
-    toHType p      = Tuple [toHType a, toHType b, toHType c]
-                   where  (a,b,c) = p
-instance (HTypeable a, HTypeable b, HTypeable c, HTypeable d) =>
-         HTypeable (a,b,c,d) where
-    toHType p      = Tuple [toHType a, toHType b, toHType c, toHType d]
-                   where  (a,b,c,d) = p
-instance (HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e) =>
-         HTypeable (a,b,c,d,e) where
-    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
-                           , toHType e ]
-                   where  (a,b,c,d,e) = p
-instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
-         , HTypeable f) =>
-         HTypeable (a,b,c,d,e,f) where
-    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
-                           , toHType e, toHType f ]
-                   where  (a,b,c,d,e,f) = p
-instance (HTypeable a) => HTypeable (Maybe a) where
-    toHType m      = Maybe (toHType x)   where   (Just x) = m
-instance (HTypeable a, HTypeable b) => HTypeable (Either a b) where
-    toHType m      = Defined "Either" [hx, hy]
-                         [ Constr "Left" [hx] [hx] {-Nothing-}
-                         , Constr "Right" [hy] [hy] {-Nothing-}]
-                   where (Left x)  = m
-                         (Right y) = m
-                         hx = toHType x
-                         hy = toHType y
-
-instance HTypeable a => HTypeable [a] where
-    toHType xs     = case toHType x of (Prim "Char" _) -> String
-                                       _ -> List (toHType x)
-                   where  (x:_) = xs
-
-------------------------------------------------------------------------
-
--- | 'toDTD' converts a concrete representation of the Haskell type of
---   a value (obtained by the method 'toHType') into a real DocTypeDecl.
---   It ensures that PERefs are defined before they are used, and that no
---   element or attribute-list is declared more than once.
-toDTD :: HType -> DocTypeDecl
-toDTD ht =
-  DTD (toplevel ht) Nothing (macrosFirst (reverse (h2d True [] [] [ht])))
-  where
-    macrosFirst :: [MarkupDecl] -> [MarkupDecl]
-    macrosFirst decls = concat [p, p'] where (p, p') = partition f decls
-                                             f (Entity _) = True
-                                             f _ = False
-    toplevel ht@(Defined _ _ _) = showHType ht "-XML"
-    toplevel ht@_               = showHType ht ""
-    c0 = False
-    h2d :: Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
-    -- toplevel?   history    history   remainingwork     result
-    h2d c history chist []       = []
-    h2d c history chist (ht:hts) =
-      if ht `elem` history then h2d c0 history chist hts
-      else
-        case ht of
-          Maybe ht0  -> declelem ht: h2d c0 (ht:history) chist (ht0:hts)
-          List ht0   -> declelem ht: h2d c0 (ht:history) chist (ht0:hts)
-          Tuple hts0 -> (c ? (declelem ht:))
-                                     (h2d c0 history chist (hts0++hts))
-          Prim s t   -> declprim ht ++ h2d c0 (ht:history) chist hts
-          String     -> declstring:    h2d c0 (ht:history) chist hts
-          Defined s _ cs ->
-               let hts0 = concatMap grab cs in
-               (c ? (decltopelem ht:)) (declmacro ht chist)
-               ++ h2d c0 (ht:history) (cs++chist) (hts0++hts)
-    declelem ht =
-      Element (ElementDecl (showHType ht "") (ContentSpec (outerHtExpr ht)))
-    decltopelem ht =    -- hack to avoid peref at toplevel
-      Element (ElementDecl (showHType ht "-XML") (ContentSpec (innerHtExpr ht None)))
-    declmacro ht@(Defined _ _ cs) chist =
-      Entity (EntityPEDecl (PEDecl (showHType ht "") (PEDefEntityValue ev))):
-      concatMap (declConstr chist) cs
-      where ev = EntityValue [EVString (render (PP.cp (outerHtExpr ht)))]
-    declConstr chist c@(Constr s fv hts)
-      | c `notElem` chist =
-          [Element (ElementDecl (flatConstr c "") (ContentSpec (constrHtExpr c)))]
-      | otherwise = [] 
-    declprim (Prim s t) =
-      [ Element (ElementDecl t EMPTY)
-      , AttList (AttListDecl t [AttDef "value" StringType REQUIRED])]
-    declstring =
-      Element (ElementDecl "string" (Mixed PCDATA))
-    grab (Constr _ _ hts) = hts
-
-(?) :: Bool -> (a->a) -> (a->a)
-b ? f | b     = f
-      | not b = id
-
--- Flatten an HType to a String suitable for an XML tagname.
-showHType :: HType -> ShowS
-showHType (Maybe ht)  = showString "maybe-" . showHType ht
-showHType (List ht)   = showString "list-" . showHType ht
-showHType (Tuple hts) = showString "tuple" . shows (length hts)
-                        . showChar '-'
-                        . foldr1 (.) (intersperse (showChar '-')
-                                                  (map showHType hts))
-showHType (Prim s t)  = showString t
-showHType String      = showString "string"
-showHType (Defined s fv _)
-                      = showString s . ((length fv > 0) ? (showChar '-'))
-                        . foldr (.) id (intersperse (showChar '-')
-                                                    (map showHType fv))
-
-flatConstr :: Constr -> ShowS
-flatConstr (Constr s fv _)
-        = showString s . ((length fv > 0) ? (showChar '-'))
-          . foldr (.) id (intersperse (showChar '-') (map showHType fv))
-
-outerHtExpr :: HType -> CP
-outerHtExpr (Maybe ht)      = innerHtExpr ht Query
-outerHtExpr (List ht)       = innerHtExpr ht Star
-outerHtExpr (Defined s fv cs) =
-    Choice (map (\c->TagName (flatConstr c "") None) cs) None
-outerHtExpr ht              = innerHtExpr ht None
-
-innerHtExpr :: HType -> Modifier -> CP
-innerHtExpr (Prim s t)  m = TagName t m
-innerHtExpr (Tuple hts) m = Seq (map (\c-> innerHtExpr c None) hts) m
-innerHtExpr ht@(Defined s hts cs) m = -- CPPE (showHType ht "") (outerHtExpr ht)
-                                      TagName ('%': showHType ht ";") m
-                                                        --  ***HACK!!!***
-innerHtExpr ht m = TagName (showHType ht "") m
-
-constrHtExpr :: Constr -> CP
-constrHtExpr (Constr s fv [])  = TagName "EMPTY" None   --  ***HACK!!!***
-constrHtExpr (Constr s fv hts) = innerHtExpr (Tuple hts) None
-
-------------------------------------------------------------------------
+
+
+src/Text/XML/HaXml/TypeMapping.hs
+
+
+
module Text.XML.HaXml.TypeMapping
+  (
+  -- * A class to get an explicit type representation for any value
+    HTypeable(..)	-- sole method, toHType
+  -- * Explicit representation of Haskell datatype information
+  , HType(..)		-- instance of Eq, Show
+  , Constr(..)		-- instance of Eq, Show
+  -- * Helper functions to extract type info as strings
+  , showHType		-- :: HType -> ShowS
+  , showConstr		-- :: Int -> HType -> String
+  -- * Conversion from Haskell datatype to DTD
+  , toDTD
+  ) where
+
+import Text.XML.HaXml.Types
+import Data.List (partition, intersperse)
+import Text.PrettyPrint.HughesPJ (render)
+import qualified Text.XML.HaXml.Pretty as PP
+
+
+------------------------------------------------------------------------
+        -- idea: in DrIFT,
+        --      named field == primitive type, becomes an attribute
+        --      named field == single-constructor type, renames the tag
+        --      named field == multi-constructor type, as normal
+        -- if prefix of all named fields is roughly typename, delete it
+
+-- | @HTypeable@ promises that we can create an explicit representation of
+--   of the type of any value.
+class HTypeable a where
+    toHType :: a -> HType
+
+-- | A concrete representation of any Haskell type.
+data HType =
+      Maybe HType
+    | List HType
+    | Tuple [HType]
+    | Prim String String        -- ^ separate Haskell name and XML name
+    | String
+    | Defined String [HType] [Constr]
+	-- ^ A user-defined type has a name, a sequence of type variables,
+	--   and a set of constructors.  (The variables might already be
+	--   instantiated to actual types.)
+    deriving (Show)
+
+instance Eq HType where
+    (Maybe x)  == (Maybe y)  =  x==y
+    (List x)   == (List y)   =  x==y
+    (Tuple xs) == (Tuple ys) =  xs==ys
+    (Prim x _) == (Prim y _) =  x==y
+    String     == String     =  True
+    (Defined n xs _) == (Defined m ys _)  =  n==m 	-- && xs==ys
+    _          == _          =  False
+
+-- | A concrete representation of any user-defined Haskell constructor.
+--   The constructor has a name, and a sequence of component types.  The
+--   first sequence of types represents the minimum set of free type
+--   variables occurring in the (second) list of real component types.
+--   If there are fieldnames, they are contained in the final list, and
+--   correspond one-to-one with the component types.
+data Constr = Constr String [HType] [HType] -- (Maybe [String])
+    deriving (Eq,Show)
+
+-- | Project the n'th constructor from an HType and convert it to a string
+--   suitable for an XML tagname.
+showConstr :: Int -> HType -> String
+showConstr n (Defined _ _ cs) = flatConstr (cs!!n) ""
+showConstr n _ = error "no constructors for builtin types"
+
+------------------------------------------------------------------------
+-- Some instances
+instance HTypeable Bool where
+    toHType   _    = Prim "Bool" "bool"
+instance HTypeable Int where
+    toHType   _    = Prim "Int" "int"
+instance HTypeable Integer where
+    toHType   _    = Prim "Integer" "integer"
+instance HTypeable Float where
+    toHType   _    = Prim "Float" "float"
+instance HTypeable Double where
+    toHType   _    = Prim "Double" "double"
+instance HTypeable Char where
+    toHType   _    = Prim "Char" "char"
+
+instance HTypeable () where
+    toHType _      = Prim "unit" "unit"
+instance (HTypeable a, HTypeable b) => HTypeable (a,b) where
+    toHType p      = Tuple [toHType a, toHType b]
+                   where  (a,b) = p
+instance (HTypeable a, HTypeable b, HTypeable c) => HTypeable (a,b,c) where
+    toHType p      = Tuple [toHType a, toHType b, toHType c]
+                   where  (a,b,c) = p
+instance (HTypeable a, HTypeable b, HTypeable c, HTypeable d) =>
+         HTypeable (a,b,c,d) where
+    toHType p      = Tuple [toHType a, toHType b, toHType c, toHType d]
+                   where  (a,b,c,d) = p
+instance (HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e) =>
+         HTypeable (a,b,c,d,e) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e ]
+                   where  (a,b,c,d,e) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f) =>
+         HTypeable (a,b,c,d,e,f) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f ]
+                   where  (a,b,c,d,e,f) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g) =>
+         HTypeable (a,b,c,d,e,f,g) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g ]
+                   where  (a,b,c,d,e,f,g) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h) =>
+         HTypeable (a,b,c,d,e,f,g,h) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h ]
+                   where  (a,b,c,d,e,f,g,h) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i) =>
+         HTypeable (a,b,c,d,e,f,g,h,i) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i ]
+                   where  (a,b,c,d,e,f,g,h,i) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j) =>
+         HTypeable (a,b,c,d,e,f,g,h,i,j) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i, toHType j ]
+                   where  (a,b,c,d,e,f,g,h,i,j) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
+         , HTypeable k) =>
+         HTypeable (a,b,c,d,e,f,g,h,i,j,k) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i, toHType j, toHType k ]
+                   where  (a,b,c,d,e,f,g,h,i,j,k) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
+         , HTypeable k, HTypeable l) =>
+         HTypeable (a,b,c,d,e,f,g,h,i,j,k,l) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i, toHType j, toHType k, toHType l ]
+                   where  (a,b,c,d,e,f,g,h,i,j,k,l) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
+         , HTypeable k, HTypeable l, HTypeable m) =>
+         HTypeable (a,b,c,d,e,f,g,h,i,j,k,l,m) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i, toHType j, toHType k, toHType l
+                           , toHType m ]
+                   where  (a,b,c,d,e,f,g,h,i,j,k,l,m) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
+         , HTypeable k, HTypeable l, HTypeable m, HTypeable n) =>
+         HTypeable (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i, toHType j, toHType k, toHType l
+                           , toHType m, toHType n ]
+                   where  (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
+         , HTypeable k, HTypeable l, HTypeable m, HTypeable n, HTypeable o) =>
+         HTypeable (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i, toHType j, toHType k, toHType l
+                           , toHType m, toHType n, toHType o ]
+                   where  (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = p
+
+instance (HTypeable a) => HTypeable (Maybe a) where
+    toHType m      = Maybe (toHType x)   where   (Just x) = m
+instance (HTypeable a, HTypeable b) => HTypeable (Either a b) where
+    toHType m      = Defined "Either" [hx, hy]
+                         [ Constr "Left" [hx] [hx] {-Nothing-}
+                         , Constr "Right" [hy] [hy] {-Nothing-}]
+                   where (Left x)  = m
+                         (Right y) = m
+                         hx = toHType x
+                         hy = toHType y
+
+instance HTypeable a => HTypeable [a] where
+    toHType xs     = case toHType x of (Prim "Char" _) -> String
+                                       _ -> List (toHType x)
+                   where  (x:_) = xs
+
+------------------------------------------------------------------------
+
+-- | 'toDTD' converts a concrete representation of the Haskell type of
+--   a value (obtained by the method 'toHType') into a real DocTypeDecl.
+--   It ensures that PERefs are defined before they are used, and that no
+--   element or attribute-list is declared more than once.
+toDTD :: HType -> DocTypeDecl
+toDTD ht =
+  DTD (toplevel ht) Nothing (macrosFirst (reverse (h2d True [] [] [ht])))
+  where
+    macrosFirst :: [MarkupDecl] -> [MarkupDecl]
+    macrosFirst decls = concat [p, p'] where (p, p') = partition f decls
+                                             f (Entity _) = True
+                                             f _ = False
+    toplevel ht@(Defined _ _ _) = showHType ht "-XML"
+    toplevel ht@_               = showHType ht ""
+    c0 = False
+    h2d :: Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
+    -- toplevel?   history    history   remainingwork     result
+    h2d c history chist []       = []
+    h2d c history chist (ht:hts) =
+      if ht `elem` history then h2d c0 history chist hts
+      else
+        case ht of
+          Maybe ht0  -> declelem ht: h2d c0 (ht:history) chist (ht0:hts)
+          List ht0   -> declelem ht: h2d c0 (ht:history) chist (ht0:hts)
+          Tuple hts0 -> (c ? (declelem ht:))
+                                     (h2d c0 history chist (hts0++hts))
+          Prim s t   -> declprim ht ++ h2d c0 (ht:history) chist hts
+          String     -> declstring:    h2d c0 (ht:history) chist hts
+          Defined s _ cs ->
+               let hts0 = concatMap grab cs in
+               (c ? (decltopelem ht:)) (declmacro ht chist)
+               ++ h2d c0 (ht:history) (cs++chist) (hts0++hts)
+    declelem ht =
+      Element (ElementDecl (showHType ht "") (ContentSpec (outerHtExpr ht)))
+    decltopelem ht =    -- hack to avoid peref at toplevel
+      Element (ElementDecl (showHType ht "-XML") (ContentSpec (innerHtExpr ht None)))
+    declmacro ht@(Defined _ _ cs) chist =
+      Entity (EntityPEDecl (PEDecl (showHType ht "") (PEDefEntityValue ev))):
+      concatMap (declConstr chist) cs
+      where ev = EntityValue [EVString (render (PP.cp (outerHtExpr ht)))]
+    declConstr chist c@(Constr s fv hts)
+      | c `notElem` chist =
+          [Element (ElementDecl (flatConstr c "") (ContentSpec (constrHtExpr c)))]
+      | otherwise = [] 
+    declprim (Prim s t) =
+      [ Element (ElementDecl t EMPTY)
+      , AttList (AttListDecl t [AttDef "value" StringType REQUIRED])]
+    declstring =
+      Element (ElementDecl "string" (Mixed PCDATA))
+    grab (Constr _ _ hts) = hts
+
+(?) :: Bool -> (a->a) -> (a->a)
+b ? f | b     = f
+      | not b = id
+
+-- Flatten an HType to a String suitable for an XML tagname.
+showHType :: HType -> ShowS
+showHType (Maybe ht)  = showString "maybe-" . showHType ht
+showHType (List ht)   = showString "list-" . showHType ht
+showHType (Tuple hts) = showString "tuple" . shows (length hts)
+                        . showChar '-'
+                        . foldr1 (.) (intersperse (showChar '-')
+                                                  (map showHType hts))
+showHType (Prim s t)  = showString t
+showHType String      = showString "string"
+showHType (Defined s fv _)
+                      = showString s . ((length fv > 0) ? (showChar '-'))
+                        . foldr (.) id (intersperse (showChar '-')
+                                                    (map showHType fv))
+
+flatConstr :: Constr -> ShowS
+flatConstr (Constr s fv _)
+        = showString s . ((length fv > 0) ? (showChar '-'))
+          . foldr (.) id (intersperse (showChar '-') (map showHType fv))
+
+outerHtExpr :: HType -> CP
+outerHtExpr (Maybe ht)      = innerHtExpr ht Query
+outerHtExpr (List ht)       = innerHtExpr ht Star
+outerHtExpr (Defined s fv cs) =
+    Choice (map (\c->TagName (flatConstr c "") None) cs) None
+outerHtExpr ht              = innerHtExpr ht None
+
+innerHtExpr :: HType -> Modifier -> CP
+innerHtExpr (Prim s t)  m = TagName t m
+innerHtExpr (Tuple hts) m = Seq (map (\c-> innerHtExpr c None) hts) m
+innerHtExpr ht@(Defined s hts cs) m = -- CPPE (showHType ht "") (outerHtExpr ht)
+                                      TagName ('%': showHType ht ";") m
+                                                        --  ***HACK!!!***
+innerHtExpr ht m = TagName (showHType ht "") m
+
+constrHtExpr :: Constr -> CP
+constrHtExpr (Constr s fv [])  = TagName "EMPTY" None   --  ***HACK!!!***
+constrHtExpr (Constr s fv hts) = innerHtExpr (Tuple hts) None
+
+------------------------------------------------------------------------
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Types.html b/docs/HaXml/src/Text/XML/HaXml/Types.html
--- a/docs/HaXml/src/Text/XML/HaXml/Types.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Types.html
@@ -1,296 +1,302 @@
 
 
-
{- |
-   This module defines an internal (generic) representation for XML
-   documents including their DTDs.
-
-   History:
-   The original module was derived by hand from the XML specification,
-   following the grammar precisely.  Then we simplified the types,
-   removing layers of indirection and redundancy, and generally making
-   things easier to work with.  Then we allowed PEReferences to be
-   ubiquitous, by removing them from the types and resolving all
-   PE references at parse-time.  Finally, we added a per-document
-   symbol table for GEReferences, and a whitespace-significance flag
-   for plaintext.
--}
-
-module Text.XML.HaXml.Types
-  (
-  -- * A simple symbol table mapping strings (references) to values.
-    SymTab
-  -- ** Symbol table operations
-  , emptyST
-  , addST
-  , lookupST
-
-  -- * XML Types
-  -- ** The top-level document container
-  , Document(..)
-
-  -- ** The main document content
-  , Element(..)
-  , ElemTag(..)
-  , Content(..)
-  , Attribute
-  , AttValue(..)
-  , info
-
-  -- ** Administrative parts of the document
-  , Prolog(..)
-  , XMLDecl(..)
-  , Misc(..)
-  , ProcessingInstruction
-  , SDDecl
-  , VersionInfo
-  , Comment
-  , PITarget
-
-  -- ** The DTD
-  -- *** content model
-  , DocTypeDecl(..)
-  , MarkupDecl(..)
-  , ExtSubset(..)
-  , ExtSubsetDecl(..)
-  , ElementDecl(..)
-  , ContentSpec(..)
-  , CP(..)
-  , Modifier(..)
-  , Mixed(..)
-
-  -- *** attribute model
-  , AttListDecl(..)
-  , AttDef(..)
-  , AttType(..)
-  , TokenizedType(..)
-  , EnumeratedType(..)
-  , NotationType
-  , Enumeration
-  , DefaultDecl(..)
-  , FIXED(..)
-
-  -- *** conditional sections
-  , ConditionalSect(..)
-  , IncludeSect
-  , IgnoreSect
-  , Ignore(..)
-  , IgnoreSectContents(..)
-
-  -- ** References
-  , Reference(..)
-  , EntityRef
-  , CharRef
-  , PEReference
-
-  -- ** Entities
-  , EntityDecl(..)
-  , GEDecl(..)
-  , PEDecl(..)
-  , EntityDef(..)
-  , PEDef(..)
-  , ExternalID(..)
-  , NDataDecl(..)
-  , TextDecl(..)
-  , ExtParsedEnt(..)
-  , ExtPE(..)
-  , NotationDecl(..)
-  , PublicID(..)
-  , EncodingDecl(..)
-  , EntityValue(..)
-  , EV(..)
-  , PubidLiteral(..)
-  , SystemLiteral(..)
-
-  -- ** Basic value types
-  , Name
-  , Names
-  , NmToken
-  , NmTokens
-  , CharData
-  , CDSect
-  ) where
-
-
-{- A simple symbol table for storing macros whilst parsing. -}
-
-type SymTab a = [(String,a)]
-
-emptyST :: SymTab a
-emptyST  = []
-
-addST :: String -> a -> SymTab a -> SymTab a
-addST n v = ((n,v):)
-
-lookupST :: String -> SymTab a -> Maybe a
-lookupST = lookup
-
-
-
-{- XML types start here -}
-
--- | The symbol table stored in a document holds all its general entity
---   reference definitions.
-data Document i = Document Prolog (SymTab EntityDef) (Element i) [Misc]
-                  deriving Eq
-data Prolog     = Prolog (Maybe XMLDecl) [Misc] (Maybe DocTypeDecl) [Misc]
-                  deriving Eq
-data XMLDecl    = XMLDecl VersionInfo (Maybe EncodingDecl) (Maybe SDDecl)
-                  deriving Eq
-data Misc       = Comment Comment
-                | PI ProcessingInstruction
-                deriving Eq
-
-type ProcessingInstruction = (PITarget,String)
-
-type SDDecl      = Bool
-type VersionInfo = String
-type Comment     = String
-type PITarget    = String
-
-data DocTypeDecl = DTD Name (Maybe ExternalID) [MarkupDecl]  deriving Eq
-data MarkupDecl  = Element  ElementDecl
-                 | AttList  AttListDecl
-                 | Entity   EntityDecl
-                 | Notation NotationDecl
-                 | MarkupMisc Misc
-                 deriving Eq
-
-data ExtSubset     = ExtSubset (Maybe TextDecl) [ExtSubsetDecl]  deriving Eq
-data ExtSubsetDecl = ExtMarkupDecl MarkupDecl
-                   | ExtConditionalSect ConditionalSect
-                   deriving Eq
-
-data Element i = Elem Name [Attribute] [Content i] deriving Eq
-                                        --  intermediate for parsing
-data ElemTag   = ElemTag Name [Attribute]
-type Attribute = (Name, AttValue)
-data Content i = CElem (Element i) i
-               | CString Bool CharData i
-                        -- ^ bool is whether whitespace is significant
-               | CRef Reference i
-               | CMisc Misc i
-               deriving Eq
-
-info :: Content t -> t
-info (CElem _ i) = i
-info (CString _ _ i) = i
-info (CRef _ i) = i
-info (CMisc _ i) = i
-
-instance Functor Document where
-  fmap f (Document p st e ms) = Document p st (fmap f e) ms
-instance Functor Element where
-  fmap f (Elem t as cs) = Elem t as (map (fmap f) cs)
-instance Functor Content where
-  fmap f (CElem e i)     = CElem (fmap f e) (f i)
-  fmap f (CString b s i) = CString b s (f i)
-  fmap f (CRef r i)      = CRef r (f i)
-  fmap f (CMisc m i)     = CMisc m (f i)
-
-data ElementDecl = ElementDecl Name ContentSpec deriving Eq
-data ContentSpec = EMPTY
-                 | ANY
-                 | Mixed Mixed
-                 | ContentSpec CP
-                 deriving Eq
--- FIXME: What is TagName here? Seems to be in disagreement with XML spec.
-data CP = TagName Name Modifier
-        | Choice [CP] Modifier
-        | Seq [CP] Modifier
-        deriving Eq
-data Modifier = None  -- ^ Just One
-              | Query -- ^ Zero Or One
-              | Star  -- ^ Zero Or More
-              | Plus  -- ^ One Or More
-              deriving Eq
-data Mixed = PCDATA
-           | PCDATAplus [Name]
-           deriving Eq
-data AttListDecl = AttListDecl Name [AttDef] deriving Eq
-data AttDef      = AttDef Name AttType DefaultDecl deriving Eq
-data AttType     = StringType
-                 | TokenizedType TokenizedType
-                 | EnumeratedType EnumeratedType
-                 deriving Eq
-data TokenizedType = ID
-                   | IDREF
-                   | IDREFS
-                   | ENTITY
-                   | ENTITIES
-                   | NMTOKEN
-                   | NMTOKENS
-                   deriving Eq
-data EnumeratedType = NotationType NotationType
-                    | Enumeration Enumeration
-                    deriving Eq
-type NotationType   = [Name]    -- nonempty list
-type Enumeration    = [NmToken] -- nonempty list
-data DefaultDecl    = REQUIRED
-                    | IMPLIED
-                    | DefaultTo AttValue (Maybe FIXED)
-                    deriving Eq
-data FIXED          = FIXED deriving Eq
-
-data ConditionalSect = IncludeSect IncludeSect
-                     | IgnoreSect IgnoreSect
-                     deriving Eq
-type IncludeSect = [ExtSubsetDecl]
-type IgnoreSect  = [IgnoreSectContents]
-data Ignore      = Ignore deriving Eq
-data IgnoreSectContents = IgnoreSectContents Ignore [(IgnoreSectContents,Ignore)]  deriving Eq
-
-data Reference    = RefEntity EntityRef
-                  | RefChar CharRef
-                  deriving (Eq,Show)
-type EntityRef    = Name
-type CharRef      = Int
-type PEReference  = Name
-
-data EntityDecl   = EntityGEDecl GEDecl
-                  | EntityPEDecl PEDecl
-                  deriving Eq
-data GEDecl       = GEDecl Name EntityDef deriving Eq
-data PEDecl       = PEDecl Name PEDef deriving Eq
-data EntityDef    = DefEntityValue EntityValue
-                  | DefExternalID ExternalID (Maybe NDataDecl)
-                  deriving Eq
-data PEDef        = PEDefEntityValue EntityValue
-                  | PEDefExternalID ExternalID deriving (Eq,Show)
-data ExternalID   = SYSTEM SystemLiteral
-                  | PUBLIC PubidLiteral SystemLiteral deriving (Eq,Show)
-newtype NDataDecl = NDATA Name  deriving Eq
-
-data TextDecl       = TextDecl (Maybe VersionInfo) EncodingDecl  deriving Eq
-data ExtParsedEnt i = ExtParsedEnt (Maybe TextDecl) (Content i) deriving Eq
-data ExtPE          = ExtPE (Maybe TextDecl) [ExtSubsetDecl] deriving Eq
-
-data NotationDecl    = NOTATION Name (Either ExternalID PublicID) deriving Eq
-newtype PublicID     = PUBLICID PubidLiteral deriving Eq
-newtype EncodingDecl = EncodingDecl String deriving Eq
-
-type Name     = String           -- non-empty string
-type Names    = [Name]           -- non-empty list
-type NmToken  = String           -- non-empty string
-type NmTokens = [NmToken]        -- non-empty list
-
-data AttValue    = AttValue [Either String Reference] deriving Eq
-instance Show AttValue where
-  show (AttValue v) = concatMap decode v
-    where
-      decode (Left  w)               = w
-      decode (Right (RefEntity ent)) = "&"++ent++";"
-      decode (Right (RefChar cref))  = "&"++show cref++";"
-
-data EntityValue = EntityValue [EV] deriving (Eq,Show)
-data EV = EVString String
- --  -- | EVPERef PEReference
-        | EVRef Reference  deriving (Eq,Show)
-newtype PubidLiteral  = PubidLiteral String deriving (Eq,Show)
-newtype SystemLiteral = SystemLiteral String deriving (Eq,Show)
-type CharData         = String
-type CDSect           = CharData
-
-instance Eq ElemTag where
-    (ElemTag n _) == (ElemTag m _)  = n==m
+
+
+src/Text/XML/HaXml/Types.hs
+
+
+
{- |
+   This module defines an internal (generic) representation for XML
+   documents including their DTDs.
+
+   History:
+   The original module was derived by hand from the XML specification,
+   following the grammar precisely.  Then we simplified the types,
+   removing layers of indirection and redundancy, and generally making
+   things easier to work with.  Then we allowed PEReferences to be
+   ubiquitous, by removing them from the types and resolving all
+   PE references at parse-time.  Finally, we added a per-document
+   symbol table for GEReferences, and a whitespace-significance flag
+   for plaintext.
+-}
+
+module Text.XML.HaXml.Types
+  (
+  -- * A simple symbol table mapping strings (references) to values.
+    SymTab
+  -- ** Symbol table operations
+  , emptyST
+  , addST
+  , lookupST
+
+  -- * XML Types
+  -- ** The top-level document container
+  , Document(..)
+
+  -- ** The main document content
+  , Element(..)
+  , ElemTag(..)
+  , Content(..)
+  , Attribute
+  , AttValue(..)
+  , info
+
+  -- ** Administrative parts of the document
+  , Prolog(..)
+  , XMLDecl(..)
+  , Misc(..)
+  , ProcessingInstruction
+  , SDDecl
+  , VersionInfo
+  , Comment
+  , PITarget
+
+  -- ** The DTD
+  -- *** content model
+  , DocTypeDecl(..)
+  , MarkupDecl(..)
+  , ExtSubset(..)
+  , ExtSubsetDecl(..)
+  , ElementDecl(..)
+  , ContentSpec(..)
+  , CP(..)
+  , Modifier(..)
+  , Mixed(..)
+
+  -- *** attribute model
+  , AttListDecl(..)
+  , AttDef(..)
+  , AttType(..)
+  , TokenizedType(..)
+  , EnumeratedType(..)
+  , NotationType
+  , Enumeration
+  , DefaultDecl(..)
+  , FIXED(..)
+
+  -- *** conditional sections
+  , ConditionalSect(..)
+  , IncludeSect
+  , IgnoreSect
+  , Ignore(..)
+  , IgnoreSectContents(..)
+
+  -- ** References
+  , Reference(..)
+  , EntityRef
+  , CharRef
+  , PEReference
+
+  -- ** Entities
+  , EntityDecl(..)
+  , GEDecl(..)
+  , PEDecl(..)
+  , EntityDef(..)
+  , PEDef(..)
+  , ExternalID(..)
+  , NDataDecl(..)
+  , TextDecl(..)
+  , ExtParsedEnt(..)
+  , ExtPE(..)
+  , NotationDecl(..)
+  , PublicID(..)
+  , EncodingDecl(..)
+  , EntityValue(..)
+  , EV(..)
+  , PubidLiteral(..)
+  , SystemLiteral(..)
+
+  -- ** Basic value types
+  , Name
+  , Names
+  , NmToken
+  , NmTokens
+  , CharData
+  , CDSect
+  ) where
+
+
+{- A simple symbol table for storing macros whilst parsing. -}
+
+type SymTab a = [(String,a)]
+
+emptyST :: SymTab a
+emptyST  = []
+
+addST :: String -> a -> SymTab a -> SymTab a
+addST n v = ((n,v):)
+
+lookupST :: String -> SymTab a -> Maybe a
+lookupST = lookup
+
+
+
+{- XML types start here -}
+
+-- | The symbol table stored in a document holds all its general entity
+--   reference definitions.
+data Document i = Document Prolog (SymTab EntityDef) (Element i) [Misc]
+                  deriving Eq
+data Prolog     = Prolog (Maybe XMLDecl) [Misc] (Maybe DocTypeDecl) [Misc]
+                  deriving Eq
+data XMLDecl    = XMLDecl VersionInfo (Maybe EncodingDecl) (Maybe SDDecl)
+                  deriving Eq
+data Misc       = Comment Comment
+                | PI ProcessingInstruction
+                deriving Eq
+
+type ProcessingInstruction = (PITarget,String)
+
+type SDDecl      = Bool
+type VersionInfo = String
+type Comment     = String
+type PITarget    = String
+
+data DocTypeDecl = DTD Name (Maybe ExternalID) [MarkupDecl]  deriving Eq
+data MarkupDecl  = Element  ElementDecl
+                 | AttList  AttListDecl
+                 | Entity   EntityDecl
+                 | Notation NotationDecl
+                 | MarkupMisc Misc
+                 deriving Eq
+
+data ExtSubset     = ExtSubset (Maybe TextDecl) [ExtSubsetDecl]  deriving Eq
+data ExtSubsetDecl = ExtMarkupDecl MarkupDecl
+                   | ExtConditionalSect ConditionalSect
+                   deriving Eq
+
+data Element i = Elem Name [Attribute] [Content i] deriving Eq
+                                        --  intermediate for parsing
+data ElemTag   = ElemTag Name [Attribute]
+type Attribute = (Name, AttValue)
+data Content i = CElem (Element i) i
+               | CString Bool CharData i
+                        -- ^ bool is whether whitespace is significant
+               | CRef Reference i
+               | CMisc Misc i
+               deriving Eq
+
+info :: Content t -> t
+info (CElem _ i) = i
+info (CString _ _ i) = i
+info (CRef _ i) = i
+info (CMisc _ i) = i
+
+instance Functor Document where
+  fmap f (Document p st e ms) = Document p st (fmap f e) ms
+instance Functor Element where
+  fmap f (Elem t as cs) = Elem t as (map (fmap f) cs)
+instance Functor Content where
+  fmap f (CElem e i)     = CElem (fmap f e) (f i)
+  fmap f (CString b s i) = CString b s (f i)
+  fmap f (CRef r i)      = CRef r (f i)
+  fmap f (CMisc m i)     = CMisc m (f i)
+
+data ElementDecl = ElementDecl Name ContentSpec deriving Eq
+data ContentSpec = EMPTY
+                 | ANY
+                 | Mixed Mixed
+                 | ContentSpec CP
+                 deriving Eq
+-- FIXME: What is TagName here? Seems to be in disagreement with XML spec.
+data CP = TagName Name Modifier
+        | Choice [CP] Modifier
+        | Seq [CP] Modifier
+        deriving Eq
+data Modifier = None  -- ^ Just One
+              | Query -- ^ Zero Or One
+              | Star  -- ^ Zero Or More
+              | Plus  -- ^ One Or More
+              deriving Eq
+data Mixed = PCDATA
+           | PCDATAplus [Name]
+           deriving Eq
+data AttListDecl = AttListDecl Name [AttDef] deriving Eq
+data AttDef      = AttDef Name AttType DefaultDecl deriving Eq
+data AttType     = StringType
+                 | TokenizedType TokenizedType
+                 | EnumeratedType EnumeratedType
+                 deriving Eq
+data TokenizedType = ID
+                   | IDREF
+                   | IDREFS
+                   | ENTITY
+                   | ENTITIES
+                   | NMTOKEN
+                   | NMTOKENS
+                   deriving Eq
+data EnumeratedType = NotationType NotationType
+                    | Enumeration Enumeration
+                    deriving Eq
+type NotationType   = [Name]    -- nonempty list
+type Enumeration    = [NmToken] -- nonempty list
+data DefaultDecl    = REQUIRED
+                    | IMPLIED
+                    | DefaultTo AttValue (Maybe FIXED)
+                    deriving Eq
+data FIXED          = FIXED deriving Eq
+
+data ConditionalSect = IncludeSect IncludeSect
+                     | IgnoreSect IgnoreSect
+                     deriving Eq
+type IncludeSect = [ExtSubsetDecl]
+type IgnoreSect  = [IgnoreSectContents]
+data Ignore      = Ignore deriving Eq
+data IgnoreSectContents = IgnoreSectContents Ignore [(IgnoreSectContents,Ignore)]  deriving Eq
+
+data Reference    = RefEntity EntityRef
+                  | RefChar CharRef
+                  deriving (Eq,Show)
+type EntityRef    = Name
+type CharRef      = Int
+type PEReference  = Name
+
+data EntityDecl   = EntityGEDecl GEDecl
+                  | EntityPEDecl PEDecl
+                  deriving Eq
+data GEDecl       = GEDecl Name EntityDef deriving Eq
+data PEDecl       = PEDecl Name PEDef deriving Eq
+data EntityDef    = DefEntityValue EntityValue
+                  | DefExternalID ExternalID (Maybe NDataDecl)
+                  deriving Eq
+data PEDef        = PEDefEntityValue EntityValue
+                  | PEDefExternalID ExternalID deriving (Eq,Show)
+data ExternalID   = SYSTEM SystemLiteral
+                  | PUBLIC PubidLiteral SystemLiteral deriving (Eq,Show)
+newtype NDataDecl = NDATA Name  deriving Eq
+
+data TextDecl       = TextDecl (Maybe VersionInfo) EncodingDecl  deriving Eq
+data ExtParsedEnt i = ExtParsedEnt (Maybe TextDecl) (Content i) deriving Eq
+data ExtPE          = ExtPE (Maybe TextDecl) [ExtSubsetDecl] deriving Eq
+
+data NotationDecl    = NOTATION Name (Either ExternalID PublicID) deriving Eq
+newtype PublicID     = PUBLICID PubidLiteral deriving Eq
+newtype EncodingDecl = EncodingDecl String deriving Eq
+
+type Name     = String           -- non-empty string
+type Names    = [Name]           -- non-empty list
+type NmToken  = String           -- non-empty string
+type NmTokens = [NmToken]        -- non-empty list
+
+data AttValue    = AttValue [Either String Reference] deriving Eq
+instance Show AttValue where
+  show (AttValue v) = concatMap decode v
+    where
+      decode (Left  w)               = w
+      decode (Right (RefEntity ent)) = "&"++ent++";"
+      decode (Right (RefChar cref))  = "&"++show cref++";"
+
+data EntityValue = EntityValue [EV] deriving (Eq,Show)
+data EV = EVString String
+ --  -- | EVPERef PEReference
+        | EVRef Reference  deriving (Eq,Show)
+newtype PubidLiteral  = PubidLiteral String deriving (Eq,Show)
+newtype SystemLiteral = SystemLiteral String deriving (Eq,Show)
+type CharData         = String
+type CDSect           = CharData
+
+instance Eq ElemTag where
+    (ElemTag n _) == (ElemTag m _)  = n==m
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Util.html b/docs/HaXml/src/Text/XML/HaXml/Util.html
--- a/docs/HaXml/src/Text/XML/HaXml/Util.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Util.html
@@ -1,45 +1,51 @@
 
 
-
{- |
- - Only a shmall module containing some helper functions to extract xml content
- - I would have added this to Types but I've put it into an additional module
- - to avoid circular references (Verbatim <-> Types)
--}
-
-module Text.XML.HaXml.Util
-  (
-  -- ** utility functions to access XML content
-    docContent
-  , contentElem
-  , attrs
-  , tagTextContent
-  ) where
-
-import Text.XML.HaXml.Posn
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.Verbatim
-
--- get the main element of the document so that you can apply CFilters directly
--- i is typically (posInNewCxt "filename" Nothing) 
-docContent :: i -> Document i -> Content i
-docContent i (Document _ _ e _) = CElem e i
-
--- if you know that your CFilter returns a tag your can use this function to get the tag Element 
-contentElem ::  Content i -> Element i
-contentElem (CElem e _) = e
-contentElem _ = error "content is not a CElem"
-attrs :: Element i -> [Attribute]
-attrs ( Elem _ attrs _ ) = attrs
-tagTextContent ((CElem (Elem _ _ cs) _)) = concatMap verbatim cs 
-
-{-
-  now you can extract an attribute quite easily:
-    let doc = "<xml><a><b a=\"x\">content</b></a></xml>"
-    let b = head $ xtract id "a/b" $ docContent (posInNewCxt filename Nothing) $ xmlParse filename doc
-    putStrLn $ "attr a of tag b" ++ (show $ lookup "a" $  attrs $ contentElem b)
-    putStrLn $ "text content of b :" ++ tagTextContent b
-  still (too) much code IMHO
--}
-
+
+
+src/Text/XML/HaXml/Util.hs
+
+
+
{- |
+ - Only a shmall module containing some helper functions to extract xml content
+ - I would have added this to Types but I've put it into an additional module
+ - to avoid circular references (Verbatim <-> Types)
+-}
+
+module Text.XML.HaXml.Util
+  (
+  -- ** utility functions to access XML content
+    docContent
+  , contentElem
+  , attrs
+  , tagTextContent
+  ) where
+
+import Text.XML.HaXml.Posn
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.Verbatim
+
+-- get the main element of the document so that you can apply CFilters directly
+-- i is typically (posInNewCxt "filename" Nothing) 
+docContent :: i -> Document i -> Content i
+docContent i (Document _ _ e _) = CElem e i
+
+-- if you know that your CFilter returns a tag your can use this function to get the tag Element 
+contentElem ::  Content i -> Element i
+contentElem (CElem e _) = e
+contentElem _ = error "content is not a CElem"
+attrs :: Element i -> [Attribute]
+attrs ( Elem _ attrs _ ) = attrs
+tagTextContent ((CElem (Elem _ _ cs) _)) = concatMap verbatim cs 
+
+{-
+  now you can extract an attribute quite easily:
+    let doc = "<xml><a><b a=\"x\">content</b></a></xml>"
+    let b = head $ xtract id "a/b" $ docContent (posInNewCxt filename Nothing) $ xmlParse filename doc
+    putStrLn $ "attr a of tag b" ++ (show $ lookup "a" $  attrs $ contentElem b)
+    putStrLn $ "text content of b :" ++ tagTextContent b
+  still (too) much code IMHO
+-}
+
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Validate.html b/docs/HaXml/src/Text/XML/HaXml/Validate.html
--- a/docs/HaXml/src/Text/XML/HaXml/Validate.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Validate.html
@@ -1,276 +1,282 @@
 
 
-
-- | Validate a document against a dtd.
-module Text.XML.HaXml.Validate
-  ( validate
-  , partialValidate
-  ) where
-
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.Combinators (multi,tag,iffind,literal,none,o)
-import Text.XML.HaXml.XmlContent (attr2str)
-import Maybe (fromMaybe,isNothing,fromJust)
-import List (intersperse,nub,(\\))
-import Char (isSpace)
-
-#if __GLASGOW_HASKELL__ >= 604 || __NHC__ >= 118 || defined(__HUGS__)
--- emulate older finite map interface using Data.Map, if it is available
-import qualified Data.Map as Map
-type FiniteMap a b = Map.Map a b
-listToFM :: Ord a => [(a,b)] -> FiniteMap a b
-listToFM = Map.fromList
-lookupFM :: Ord a => FiniteMap a b -> a -> Maybe b
-lookupFM = flip Map.lookup
-#elif __GLASGOW_HASKELL__ >= 504 || __NHC__ > 114
--- real finite map, if it is available
-import Data.FiniteMap
-#else
--- otherwise, a very simple and inefficient implementation of a finite map
-type FiniteMap a b = [(a,b)]
-listToFM :: Eq a => [(a,b)] -> FiniteMap a b
-listToFM = id
-lookupFM :: Eq a => FiniteMap a b -> a -> Maybe b
-lookupFM fm k = lookup k fm
-#endif
-
--- gather appropriate information out of the DTD
-data SimpleDTD = SimpleDTD
-    { elements   :: FiniteMap Name ContentSpec	-- content model of elem
-    , attributes :: FiniteMap (Name,Name) AttType -- type of (elem,attr)
-    , required   :: FiniteMap Name [Name]	-- required attributes of elem
-    , ids        :: [(Name,Name)]	-- all (element,attr) with ID type
-    , idrefs     :: [(Name,Name)]	-- all (element,attr) with IDREF type
-    }
-
-simplifyDTD :: DocTypeDecl -> SimpleDTD
-simplifyDTD (DTD _ _ decls) =
-    SimpleDTD
-      { elements   = listToFM [ (name,content)
-                              | Element (ElementDecl name content) <- decls ]
-      , attributes = listToFM [ ((elem,attr),typ)
-                              | AttList (AttListDecl elem attdefs) <- decls
-                              , AttDef attr typ _ <- attdefs ]
-      , required   = listToFM [ (elem, [ attr
-                                       | AttDef attr _ REQUIRED <- attdefs ])
-                              | AttList (AttListDecl elem attdefs) <- decls ]
-      , ids        = [ (elem,attr)
-                     | Element (ElementDecl elem _) <- decls
-                     , AttList (AttListDecl name attdefs) <- decls
-                     , elem == name
-                     , AttDef attr (TokenizedType ID) _ <- attdefs ]
-      , idrefs     = []	-- not implemented
-      }
-
--- simple auxiliary to avoid lots of if-then-else with empty else clauses.
-gives :: Bool -> a -> [a]
-True `gives` x = [x]
-False `gives` _ = []
-
--- | 'validate' takes a DTD and a tagged element, and returns a list of
---   errors in the document with respect to its DTD.
---
---   If you have several documents to validate against a single DTD,
---   then you will gain efficiency by freezing-in the DTD through partial
---   application, e.g. @checkMyDTD = validate myDTD@.
-validate :: DocTypeDecl -> Element i -> [String]
-validate dtd' elem = root dtd' elem ++ partialValidate dtd' elem
-  where
-    root (DTD name _ _) (Elem name' _ _) =
-        (name/=name') `gives` ("Document type should be <"++name
-                               ++"> but appears to be <"++name'++">.")
-
--- | 'partialValidate' is like validate, except that it does not check that
---   the element type matches that of the DTD's root element.
-partialValidate :: DocTypeDecl -> Element i -> [String]
-partialValidate dtd' elem = valid elem ++ checkIDs elem
-  where
-    dtd = simplifyDTD dtd'
-
-    valid (Elem name attrs contents) =
-        -- is the element defined in the DTD?
-        let spec = lookupFM (elements dtd) name in 
-        (isNothing spec) `gives` ("Element <"++name++"> not known.")
-        -- is each attribute mentioned only once?
-        ++ (let dups = duplicates (map fst attrs) in
-            not (null dups) `gives`
-               ("Element <"++name++"> has duplicate attributes: "
-                ++concat (intersperse "," dups)++"."))
-        -- does each attribute belong to this element?  value is in range?
-        ++ concatMap (checkAttr name) attrs
-        -- are all required attributes present?
-        ++ concatMap (checkRequired name attrs)
-                     (fromMaybe [] (lookupFM (required dtd) name))
-        -- are its children in a permissible sequence?
-        ++ checkContentSpec name (fromMaybe ANY spec) contents
-        -- now recursively check the element children
-        ++ concatMap valid [ elem | CElem elem _ <- contents ]
-
-    checkAttr elem (attr, val) =
-        let typ = lookupFM (attributes dtd) (elem,attr)
-            attval = attr2str val in
-        if isNothing typ then ["Attribute \""++attr
-                               ++"\" not known for element <"++elem++">."]
-        else
-          case fromJust typ of
-            EnumeratedType e ->
-              case e of
-                Enumeration es ->
-                    (not (attval `Prelude.elem` es)) `gives`
-                          ("Value \""++attval++"\" of attribute \""
-                           ++attr++"\" in element <"++elem
-                           ++"> is not in the required enumeration range: "
-                           ++unwords es)
-                _ -> []
-            _ -> []
-
-    checkRequired elem attrs req =
-        (not (req `Prelude.elem` map fst attrs)) `gives`
-            ("Element <"++elem++"> requires the attribute \""++req
-             ++"\" but it is missing.")
-
-    checkContentSpec elem ANY _ = []
-    checkContentSpec elem EMPTY [] = []
-    checkContentSpec elem EMPTY (_:_) =
-        ["Element <"++elem++"> is not empty but should be."]
-    checkContentSpec elem (Mixed PCDATA) cs = concatMap (checkMixed elem []) cs
-    checkContentSpec elem (Mixed (PCDATAplus names)) cs =
-        concatMap (checkMixed elem names) cs
-    checkContentSpec elem (ContentSpec cp) cs = excludeText elem cs ++
-        (let (errs,rest) = checkCP elem cp (flatten cs) in
-         case rest of [] -> errs
-                      _  -> errs++["Element <"++elem++"> contains extra "
-                                  ++"elements beyond its content spec."])
-
-    checkMixed elem permitted (CElem (Elem name _ _) _)
-        | not (name `Prelude.elem` permitted) =
-            ["Element <"++elem++"> contains an element <"++name
-             ++"> but should not."]
-    checkMixed elem permitted _ = []
-
-    flatten (CElem (Elem name _ _) _: cs) = name: flatten cs
-    flatten (_: cs)                       = flatten cs
-    flatten []                            = []
-
-    excludeText elem (CElem _ _: cs) = excludeText elem cs
-    excludeText elem (CMisc _ _: cs) = excludeText elem cs
-    excludeText elem (CString _ s _: cs) | all isSpace s = excludeText elem cs
-    excludeText elem (_:  cs) =
-        ["Element <"++elem++"> contains text/references but should not."]
-    excludeText elem [] = []
-
-    -- This is a little parser really.  Returns any errors, plus the remainder
-    -- of the input string.
-    checkCP :: Name -> CP -> [Name] -> ([String],[Name])
-    checkCP elem cp@(TagName n None) [] = (cpError elem cp, [])
-    checkCP elem cp@(TagName n None) (n':ns)
-        | n==n'     = ([], ns)
-        | otherwise = (cpError elem cp, n':ns)
-    checkCP elem cp@(TagName n Query) [] = ([],[])
-    checkCP elem cp@(TagName n Query) (n':ns)
-        | n==n'     = ([], ns)
-        | otherwise = ([], n':ns)
-    checkCP elem cp@(TagName n Star) [] = ([],[])
-    checkCP elem cp@(TagName n Star) (n':ns)
-        | n==n'     = checkCP elem (TagName n Star) ns
-        | otherwise = ([], n':ns)
-    checkCP elem cp@(TagName n Plus) [] = (cpError elem cp, [])
-    checkCP elem cp@(TagName n Plus) (n':ns)
-        | n==n'     = checkCP elem (TagName n Star) ns
-        | otherwise = (cpError elem cp, n':ns)
- -- omit this clause, to permit (a?|b?) as a valid but empty choice
- -- checkCP elem cp@(Choice cps None) [] = (cpError elem cp, [])
-    checkCP elem cp@(Choice cps None) ns =
-        let next = choice elem ns cps in
-        if null next then (cpError elem cp, ns)
-        else ([], head next)	-- choose the first alternative with no errors
-    checkCP elem cp@(Choice cps Query) [] = ([],[])
-    checkCP elem cp@(Choice cps Query) ns =
-        let next = choice elem ns cps in
-        if null next then ([],ns)
-        else ([], head next)
-    checkCP elem cp@(Choice cps Star) [] = ([],[])
-    checkCP elem cp@(Choice cps Star) ns =
-        let next = choice elem ns cps in
-        if null next then ([],ns)
-        else checkCP elem (Choice cps Star) (head next)
-    checkCP elem cp@(Choice cps Plus) [] = (cpError elem cp, [])
-    checkCP elem cp@(Choice cps Plus) ns =
-        let next = choice elem ns cps in
-        if null next then (cpError elem cp, ns)
-        else checkCP elem (Choice cps Star) (head next)
- -- omit this clause, to permit (a?,b?) as a valid but empty sequence
- -- checkCP elem cp@(Seq cps None) [] = (cpError elem cp, [])
-    checkCP elem cp@(Seq cps None) ns =
-        let (errs,next) = sequence elem ns cps in
-        if null errs then ([],next)
-        else (cpError elem cp++errs, ns)
-    checkCP elem cp@(Seq cps Query) [] = ([],[])
-    checkCP elem cp@(Seq cps Query) ns =
-        let (errs,next) = sequence elem ns cps in
-        if null errs then ([],next)
-        else ([], ns)
-    checkCP elem cp@(Seq cps Star) [] = ([],[])
-    checkCP elem cp@(Seq cps Star) ns =
-        let (errs,next) = sequence elem ns cps in
-        if null errs then checkCP elem (Seq cps Star) next
-        else ([], ns)
-    checkCP elem cp@(Seq cps Plus) [] = (cpError elem cp, [])
-    checkCP elem cp@(Seq cps Plus) ns =
-        let (errs,next) = sequence elem ns cps in
-        if null errs then checkCP elem (Seq cps Star) next
-        else (cpError elem cp++errs, ns)
-
-    choice elem ns cps =  -- return only those parses that don't give any errors
-        [ rem | ([],rem) <- map (\cp-> checkCP elem (definite cp) ns) cps ]
-        ++ [ ns | all possEmpty cps ]
-        where definite (TagName n Query)  = TagName n None
-              definite (Choice cps Query) = Choice cps None
-              definite (Seq cps Query)    = Seq cps None
-              definite (TagName n Star)   = TagName n Plus
-              definite (Choice cps Star)  = Choice cps Plus
-              definite (Seq cps Star)     = Seq cps Plus
-              definite x                  = x
-              possEmpty (TagName _ mod)   = mod `Prelude.elem` [Query,Star]
-              possEmpty (Choice cps None) = all possEmpty cps
-              possEmpty (Choice _ mod)    = mod `Prelude.elem` [Query,Star]
-              possEmpty (Seq cps None)    = all possEmpty cps
-              possEmpty (Seq _ mod)       = mod `Prelude.elem` [Query,Star]
-    sequence elem ns cps =  -- accumulate errors down the sequence
-        foldl (\(es,ns) cp-> let (es',ns') = checkCP elem cp ns
-                             in (es++es', ns'))
-              ([],ns) cps
-
-    checkIDs elem =
-        let celem = CElem elem undefined
-            showAttr a = iffind a literal none
-            idElems = concatMap (\(name,at)-> multi (showAttr at `o` tag name)
-                                                    celem)
-                                (ids dtd)
-            badIds  = duplicates (map (\(CString _ s _)->s) idElems)
-        in not (null badIds) `gives`
-               ("These attribute values of type ID are not unique: "
-                ++concat (intersperse "," badIds)++".")
-
-
-cpError :: Name -> CP -> [String]
-cpError elem cp =
-    ["Element <"++elem++"> should contain "++display cp++" but does not."]
-
-
-display :: CP -> String
-display (TagName name mod) = name ++ modifier mod
-display (Choice cps mod)   = "(" ++ concat (intersperse "|" (map display cps))
-                             ++ ")" ++ modifier mod
-display (Seq cps mod)      = "(" ++ concat (intersperse "," (map display cps))
-                             ++ ")" ++ modifier mod
-
-modifier :: Modifier -> String
-modifier None  = ""
-modifier Query = "?"
-modifier Star  = "*"
-modifier Plus  = "+"
-
-duplicates :: Eq a => [a] -> [a]
-duplicates xs = xs \\ (nub xs)
+
+
+src/Text/XML/HaXml/Validate.hs
+
+
+
-- | Validate a document against a dtd.
+module Text.XML.HaXml.Validate
+  ( validate
+  , partialValidate
+  ) where
+
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.Combinators (multi,tag,iffind,literal,none,o)
+import Text.XML.HaXml.XmlContent (attr2str)
+import Maybe (fromMaybe,isNothing,fromJust)
+import List (intersperse,nub,(\\))
+import Char (isSpace)
+
+#if __GLASGOW_HASKELL__ >= 604 || __NHC__ >= 118 || defined(__HUGS__)
+-- emulate older finite map interface using Data.Map, if it is available
+import qualified Data.Map as Map
+type FiniteMap a b = Map.Map a b
+listToFM :: Ord a => [(a,b)] -> FiniteMap a b
+listToFM = Map.fromList
+lookupFM :: Ord a => FiniteMap a b -> a -> Maybe b
+lookupFM = flip Map.lookup
+#elif __GLASGOW_HASKELL__ >= 504 || __NHC__ > 114
+-- real finite map, if it is available
+import Data.FiniteMap
+#else
+-- otherwise, a very simple and inefficient implementation of a finite map
+type FiniteMap a b = [(a,b)]
+listToFM :: Eq a => [(a,b)] -> FiniteMap a b
+listToFM = id
+lookupFM :: Eq a => FiniteMap a b -> a -> Maybe b
+lookupFM fm k = lookup k fm
+#endif
+
+-- gather appropriate information out of the DTD
+data SimpleDTD = SimpleDTD
+    { elements   :: FiniteMap Name ContentSpec	-- content model of elem
+    , attributes :: FiniteMap (Name,Name) AttType -- type of (elem,attr)
+    , required   :: FiniteMap Name [Name]	-- required attributes of elem
+    , ids        :: [(Name,Name)]	-- all (element,attr) with ID type
+    , idrefs     :: [(Name,Name)]	-- all (element,attr) with IDREF type
+    }
+
+simplifyDTD :: DocTypeDecl -> SimpleDTD
+simplifyDTD (DTD _ _ decls) =
+    SimpleDTD
+      { elements   = listToFM [ (name,content)
+                              | Element (ElementDecl name content) <- decls ]
+      , attributes = listToFM [ ((elem,attr),typ)
+                              | AttList (AttListDecl elem attdefs) <- decls
+                              , AttDef attr typ _ <- attdefs ]
+      , required   = listToFM [ (elem, [ attr
+                                       | AttDef attr _ REQUIRED <- attdefs ])
+                              | AttList (AttListDecl elem attdefs) <- decls ]
+      , ids        = [ (elem,attr)
+                     | Element (ElementDecl elem _) <- decls
+                     , AttList (AttListDecl name attdefs) <- decls
+                     , elem == name
+                     , AttDef attr (TokenizedType ID) _ <- attdefs ]
+      , idrefs     = []	-- not implemented
+      }
+
+-- simple auxiliary to avoid lots of if-then-else with empty else clauses.
+gives :: Bool -> a -> [a]
+True `gives` x = [x]
+False `gives` _ = []
+
+-- | 'validate' takes a DTD and a tagged element, and returns a list of
+--   errors in the document with respect to its DTD.
+--
+--   If you have several documents to validate against a single DTD,
+--   then you will gain efficiency by freezing-in the DTD through partial
+--   application, e.g. @checkMyDTD = validate myDTD@.
+validate :: DocTypeDecl -> Element i -> [String]
+validate dtd' elem = root dtd' elem ++ partialValidate dtd' elem
+  where
+    root (DTD name _ _) (Elem name' _ _) =
+        (name/=name') `gives` ("Document type should be <"++name
+                               ++"> but appears to be <"++name'++">.")
+
+-- | 'partialValidate' is like validate, except that it does not check that
+--   the element type matches that of the DTD's root element.
+partialValidate :: DocTypeDecl -> Element i -> [String]
+partialValidate dtd' elem = valid elem ++ checkIDs elem
+  where
+    dtd = simplifyDTD dtd'
+
+    valid (Elem name attrs contents) =
+        -- is the element defined in the DTD?
+        let spec = lookupFM (elements dtd) name in 
+        (isNothing spec) `gives` ("Element <"++name++"> not known.")
+        -- is each attribute mentioned only once?
+        ++ (let dups = duplicates (map fst attrs) in
+            not (null dups) `gives`
+               ("Element <"++name++"> has duplicate attributes: "
+                ++concat (intersperse "," dups)++"."))
+        -- does each attribute belong to this element?  value is in range?
+        ++ concatMap (checkAttr name) attrs
+        -- are all required attributes present?
+        ++ concatMap (checkRequired name attrs)
+                     (fromMaybe [] (lookupFM (required dtd) name))
+        -- are its children in a permissible sequence?
+        ++ checkContentSpec name (fromMaybe ANY spec) contents
+        -- now recursively check the element children
+        ++ concatMap valid [ elem | CElem elem _ <- contents ]
+
+    checkAttr elem (attr, val) =
+        let typ = lookupFM (attributes dtd) (elem,attr)
+            attval = attr2str val in
+        if isNothing typ then ["Attribute \""++attr
+                               ++"\" not known for element <"++elem++">."]
+        else
+          case fromJust typ of
+            EnumeratedType e ->
+              case e of
+                Enumeration es ->
+                    (not (attval `Prelude.elem` es)) `gives`
+                          ("Value \""++attval++"\" of attribute \""
+                           ++attr++"\" in element <"++elem
+                           ++"> is not in the required enumeration range: "
+                           ++unwords es)
+                _ -> []
+            _ -> []
+
+    checkRequired elem attrs req =
+        (not (req `Prelude.elem` map fst attrs)) `gives`
+            ("Element <"++elem++"> requires the attribute \""++req
+             ++"\" but it is missing.")
+
+    checkContentSpec elem ANY _ = []
+    checkContentSpec elem EMPTY [] = []
+    checkContentSpec elem EMPTY (_:_) =
+        ["Element <"++elem++"> is not empty but should be."]
+    checkContentSpec elem (Mixed PCDATA) cs = concatMap (checkMixed elem []) cs
+    checkContentSpec elem (Mixed (PCDATAplus names)) cs =
+        concatMap (checkMixed elem names) cs
+    checkContentSpec elem (ContentSpec cp) cs = excludeText elem cs ++
+        (let (errs,rest) = checkCP elem cp (flatten cs) in
+         case rest of [] -> errs
+                      _  -> errs++["Element <"++elem++"> contains extra "
+                                  ++"elements beyond its content spec."])
+
+    checkMixed elem permitted (CElem (Elem name _ _) _)
+        | not (name `Prelude.elem` permitted) =
+            ["Element <"++elem++"> contains an element <"++name
+             ++"> but should not."]
+    checkMixed elem permitted _ = []
+
+    flatten (CElem (Elem name _ _) _: cs) = name: flatten cs
+    flatten (_: cs)                       = flatten cs
+    flatten []                            = []
+
+    excludeText elem (CElem _ _: cs) = excludeText elem cs
+    excludeText elem (CMisc _ _: cs) = excludeText elem cs
+    excludeText elem (CString _ s _: cs) | all isSpace s = excludeText elem cs
+    excludeText elem (_:  cs) =
+        ["Element <"++elem++"> contains text/references but should not."]
+    excludeText elem [] = []
+
+    -- This is a little parser really.  Returns any errors, plus the remainder
+    -- of the input string.
+    checkCP :: Name -> CP -> [Name] -> ([String],[Name])
+    checkCP elem cp@(TagName n None) [] = (cpError elem cp, [])
+    checkCP elem cp@(TagName n None) (n':ns)
+        | n==n'     = ([], ns)
+        | otherwise = (cpError elem cp, n':ns)
+    checkCP elem cp@(TagName n Query) [] = ([],[])
+    checkCP elem cp@(TagName n Query) (n':ns)
+        | n==n'     = ([], ns)
+        | otherwise = ([], n':ns)
+    checkCP elem cp@(TagName n Star) [] = ([],[])
+    checkCP elem cp@(TagName n Star) (n':ns)
+        | n==n'     = checkCP elem (TagName n Star) ns
+        | otherwise = ([], n':ns)
+    checkCP elem cp@(TagName n Plus) [] = (cpError elem cp, [])
+    checkCP elem cp@(TagName n Plus) (n':ns)
+        | n==n'     = checkCP elem (TagName n Star) ns
+        | otherwise = (cpError elem cp, n':ns)
+ -- omit this clause, to permit (a?|b?) as a valid but empty choice
+ -- checkCP elem cp@(Choice cps None) [] = (cpError elem cp, [])
+    checkCP elem cp@(Choice cps None) ns =
+        let next = choice elem ns cps in
+        if null next then (cpError elem cp, ns)
+        else ([], head next)	-- choose the first alternative with no errors
+    checkCP elem cp@(Choice cps Query) [] = ([],[])
+    checkCP elem cp@(Choice cps Query) ns =
+        let next = choice elem ns cps in
+        if null next then ([],ns)
+        else ([], head next)
+    checkCP elem cp@(Choice cps Star) [] = ([],[])
+    checkCP elem cp@(Choice cps Star) ns =
+        let next = choice elem ns cps in
+        if null next then ([],ns)
+        else checkCP elem (Choice cps Star) (head next)
+    checkCP elem cp@(Choice cps Plus) [] = (cpError elem cp, [])
+    checkCP elem cp@(Choice cps Plus) ns =
+        let next = choice elem ns cps in
+        if null next then (cpError elem cp, ns)
+        else checkCP elem (Choice cps Star) (head next)
+ -- omit this clause, to permit (a?,b?) as a valid but empty sequence
+ -- checkCP elem cp@(Seq cps None) [] = (cpError elem cp, [])
+    checkCP elem cp@(Seq cps None) ns =
+        let (errs,next) = sequence elem ns cps in
+        if null errs then ([],next)
+        else (cpError elem cp++errs, ns)
+    checkCP elem cp@(Seq cps Query) [] = ([],[])
+    checkCP elem cp@(Seq cps Query) ns =
+        let (errs,next) = sequence elem ns cps in
+        if null errs then ([],next)
+        else ([], ns)
+    checkCP elem cp@(Seq cps Star) [] = ([],[])
+    checkCP elem cp@(Seq cps Star) ns =
+        let (errs,next) = sequence elem ns cps in
+        if null errs then checkCP elem (Seq cps Star) next
+        else ([], ns)
+    checkCP elem cp@(Seq cps Plus) [] = (cpError elem cp, [])
+    checkCP elem cp@(Seq cps Plus) ns =
+        let (errs,next) = sequence elem ns cps in
+        if null errs then checkCP elem (Seq cps Star) next
+        else (cpError elem cp++errs, ns)
+
+    choice elem ns cps =  -- return only those parses that don't give any errors
+        [ rem | ([],rem) <- map (\cp-> checkCP elem (definite cp) ns) cps ]
+        ++ [ ns | all possEmpty cps ]
+        where definite (TagName n Query)  = TagName n None
+              definite (Choice cps Query) = Choice cps None
+              definite (Seq cps Query)    = Seq cps None
+              definite (TagName n Star)   = TagName n Plus
+              definite (Choice cps Star)  = Choice cps Plus
+              definite (Seq cps Star)     = Seq cps Plus
+              definite x                  = x
+              possEmpty (TagName _ mod)   = mod `Prelude.elem` [Query,Star]
+              possEmpty (Choice cps None) = all possEmpty cps
+              possEmpty (Choice _ mod)    = mod `Prelude.elem` [Query,Star]
+              possEmpty (Seq cps None)    = all possEmpty cps
+              possEmpty (Seq _ mod)       = mod `Prelude.elem` [Query,Star]
+    sequence elem ns cps =  -- accumulate errors down the sequence
+        foldl (\(es,ns) cp-> let (es',ns') = checkCP elem cp ns
+                             in (es++es', ns'))
+              ([],ns) cps
+
+    checkIDs elem =
+        let celem = CElem elem undefined
+            showAttr a = iffind a literal none
+            idElems = concatMap (\(name,at)-> multi (showAttr at `o` tag name)
+                                                    celem)
+                                (ids dtd)
+            badIds  = duplicates (map (\(CString _ s _)->s) idElems)
+        in not (null badIds) `gives`
+               ("These attribute values of type ID are not unique: "
+                ++concat (intersperse "," badIds)++".")
+
+
+cpError :: Name -> CP -> [String]
+cpError elem cp =
+    ["Element <"++elem++"> should contain "++display cp++" but does not."]
+
+
+display :: CP -> String
+display (TagName name mod) = name ++ modifier mod
+display (Choice cps mod)   = "(" ++ concat (intersperse "|" (map display cps))
+                             ++ ")" ++ modifier mod
+display (Seq cps mod)      = "(" ++ concat (intersperse "," (map display cps))
+                             ++ ")" ++ modifier mod
+
+modifier :: Modifier -> String
+modifier None  = ""
+modifier Query = "?"
+modifier Star  = "*"
+modifier Plus  = "+"
+
+duplicates :: Eq a => [a] -> [a]
+duplicates xs = xs \\ (nub xs)
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Verbatim.html b/docs/HaXml/src/Text/XML/HaXml/Verbatim.html
--- a/docs/HaXml/src/Text/XML/HaXml/Verbatim.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Verbatim.html
@@ -1,95 +1,101 @@
 
 
-
{- |
-   Maintainer  :  simons@cryp.to
-   Stability   :  experimental
-   Portability :  portable
-
-   The preferred method for rendering a 'Document' or single 'Content'
-   is by using the pretty printing facility defined in "Pretty".
-   Pretty-printing does not work well for cases, however, where the
-   formatting in the XML document is significant. Examples of this
-   case are XHTML's @\<pre\>@ tag, Docbook's @\<literallayout\>@ tag,
-   and many more.
-
-   Theoretically, the document author could avoid this problem by
-   wrapping the contents of these tags in a \<![CDATA[...]]\> section,
-   but often this is not practical, for instance when the
-   literal-layout section contains other elements. Finally, program
-   writers could manually format these elements by transforming them
-   into a 'literal' string in their 'CFliter', etc., but this is
-   annoying to do and prone to omissions and formatting errors.
-
-   As an alternative, this module provides the function 'verbatim',
-   which will format XML 'Content' as a 'String' while retaining the
-   formatting of the input document unchanged.
-
-   /Know problems/:
-
-    * HaXml's parser eats line feeds between two tags.
-
-    * 'Attribute's should be formatted by making them an instance of
-      'Verbatim' as well, but since an 'Attribute' is just a tuple,
-      not a full data type, the helper function 'verbAttr' must be
-      used instead.
-
-    * 'CMisc' is not yet supported.
-
-    * 'Element's, which contain no content, are formatted as
-       @\<element-name\/\>@, even if they were not defined as being of
-       type @EMPTY@. In XML this perfectly alright, but in SGML it is
-       not. Those, who wish to use 'verbatim' to format parts of say
-       an HTML page will have to (a) replace problematic elements by
-       'literal's /before/ running 'verbatim' or (b) use a second
-       search-and-replace stage to fix this.
- -}
-
-module Text.XML.HaXml.Verbatim where
-
-import Text.XML.HaXml.Types
-
--- |This class promises that the function 'verbatim' knows how to
--- format this data type into a string without changing the
--- formatting.
-
-class Verbatim a where
-    verbatim :: a -> String
-
-instance (Verbatim a) => Verbatim [a] where
-    verbatim  = concat . (map verbatim)
-
-instance Verbatim Char where
-    verbatim c = [c]
-
-instance (Verbatim a, Verbatim b) => Verbatim (Either a b) where
-    verbatim (Left v)  = verbatim v
-    verbatim (Right v) = verbatim v
-
-instance Verbatim (Content i) where
-    verbatim (CElem c _)     = verbatim c
-    verbatim (CString _ c _) = c
-    verbatim (CRef c _)      = verbatim c
-    verbatim (CMisc _ _)     = error "NYI: verbatim not defined for CMisc"
-
-instance Verbatim (Element i) where
-    verbatim (Elem nam att [])   = "<" ++ nam ++ (concat . (map verbAttr)) att
-                                   ++ "/>"
-    verbatim (Elem nam att cont) = "<" ++ nam ++ (concat . (map verbAttr)) att
-                                   ++ ">" ++ verbatim cont ++ "</" ++ nam ++ ">"
-
-instance Verbatim Reference where
-    verbatim (RefEntity r) = "&" ++ verbatim r ++ ";"
-    verbatim (RefChar c)   = "&#" ++ show c ++ ";"
-
-
--- |This is a helper function is required because Haskell does not
--- allow to make an ordinary tuple (like 'Attribute') an instance of a
--- class. The resulting output will preface the actual attribute with
--- a single blank so that lists of 'Attribute's can be handled
--- implicitly by the definition for lists of 'Verbatim' data types.
-
-verbAttr :: Attribute -> String
-verbAttr (n, AttValue v) = " " ++ n ++ "=\"" ++ verbatim v ++ "\""
-
+
+
+src/Text/XML/HaXml/Verbatim.hs
+
+
+
{- |
+   Maintainer  :  simons@cryp.to
+   Stability   :  experimental
+   Portability :  portable
+
+   The preferred method for rendering a 'Document' or single 'Content'
+   is by using the pretty printing facility defined in "Pretty".
+   Pretty-printing does not work well for cases, however, where the
+   formatting in the XML document is significant. Examples of this
+   case are XHTML's @\<pre\>@ tag, Docbook's @\<literallayout\>@ tag,
+   and many more.
+
+   Theoretically, the document author could avoid this problem by
+   wrapping the contents of these tags in a \<![CDATA[...]]\> section,
+   but often this is not practical, for instance when the
+   literal-layout section contains other elements. Finally, program
+   writers could manually format these elements by transforming them
+   into a 'literal' string in their 'CFliter', etc., but this is
+   annoying to do and prone to omissions and formatting errors.
+
+   As an alternative, this module provides the function 'verbatim',
+   which will format XML 'Content' as a 'String' while retaining the
+   formatting of the input document unchanged.
+
+   /Know problems/:
+
+    * HaXml's parser eats line feeds between two tags.
+
+    * 'Attribute's should be formatted by making them an instance of
+      'Verbatim' as well, but since an 'Attribute' is just a tuple,
+      not a full data type, the helper function 'verbAttr' must be
+      used instead.
+
+    * 'CMisc' is not yet supported.
+
+    * 'Element's, which contain no content, are formatted as
+       @\<element-name\/\>@, even if they were not defined as being of
+       type @EMPTY@. In XML this perfectly alright, but in SGML it is
+       not. Those, who wish to use 'verbatim' to format parts of say
+       an HTML page will have to (a) replace problematic elements by
+       'literal's /before/ running 'verbatim' or (b) use a second
+       search-and-replace stage to fix this.
+ -}
+
+module Text.XML.HaXml.Verbatim where
+
+import Text.XML.HaXml.Types
+
+-- |This class promises that the function 'verbatim' knows how to
+-- format this data type into a string without changing the
+-- formatting.
+
+class Verbatim a where
+    verbatim :: a -> String
+
+instance (Verbatim a) => Verbatim [a] where
+    verbatim  = concat . (map verbatim)
+
+instance Verbatim Char where
+    verbatim c = [c]
+
+instance (Verbatim a, Verbatim b) => Verbatim (Either a b) where
+    verbatim (Left v)  = verbatim v
+    verbatim (Right v) = verbatim v
+
+instance Verbatim (Content i) where
+    verbatim (CElem c _)     = verbatim c
+    verbatim (CString _ c _) = c
+    verbatim (CRef c _)      = verbatim c
+    verbatim (CMisc _ _)     = error "NYI: verbatim not defined for CMisc"
+
+instance Verbatim (Element i) where
+    verbatim (Elem nam att [])   = "<" ++ nam ++ (concat . (map verbAttr)) att
+                                   ++ "/>"
+    verbatim (Elem nam att cont) = "<" ++ nam ++ (concat . (map verbAttr)) att
+                                   ++ ">" ++ verbatim cont ++ "</" ++ nam ++ ">"
+
+instance Verbatim Reference where
+    verbatim (RefEntity r) = "&" ++ verbatim r ++ ";"
+    verbatim (RefChar c)   = "&#" ++ show c ++ ";"
+
+
+-- |This is a helper function is required because Haskell does not
+-- allow to make an ordinary tuple (like 'Attribute') an instance of a
+-- class. The resulting output will preface the actual attribute with
+-- a single blank so that lists of 'Attribute's can be handled
+-- implicitly by the definition for lists of 'Verbatim' data types.
+
+verbAttr :: Attribute -> String
+verbAttr (n, AttValue v) = " " ++ n ++ "=\"" ++ verbatim v ++ "\""
+
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Wrappers.html b/docs/HaXml/src/Text/XML/HaXml/Wrappers.html
--- a/docs/HaXml/src/Text/XML/HaXml/Wrappers.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Wrappers.html
@@ -1,65 +1,81 @@
 
 
-
module Text.XML.HaXml.Wrappers
-  ( fix2Args
-  , processXmlWith
-  ) where
-
--- imports required for processXmlWith and fix2Args
-import System
-import IO
-import List (isSuffixOf)
-
-import Text.XML.HaXml.Types       (Document(..),Content(..))
-import Text.XML.HaXml.Combinators (CFilter)
-import Text.XML.HaXml.Posn        (Posn,posInNewCxt)
-import Text.XML.HaXml.Parse       (xmlParse)
-import Text.XML.HaXml.Html.Parse  (htmlParse)
-import Text.XML.HaXml.Pretty as PP(document)
-import Text.PrettyPrint.HughesPJ  (render)
-
-
--- | This useful auxiliary checks the commandline arguments for two
---   filenames, the input and output file respectively.  If either
---   is missing, it is replaced by '-', which can be interpreted by the
---   caller as stdin and\/or stdout.
-fix2Args :: IO (String,String)
-fix2Args = do
-  args <- getArgs
-  case length args of
-    0 -> return ("-",     "-")
-    1 -> return (args!!0, "-")
-    2 -> return (args!!0, args!!1)
-    _ -> do prog <- getProgName
-            putStrLn ("Usage: "++prog++" [infile] [outfile]")
-            exitFailure
-
-
--- | The wrapper @processXmlWith@ returns an IO () computation
---   that collects the filenames (or stdin\/stdout) to use when
---   reading\/writing XML documents.  Its CFilter argument
---   is applied to transform the XML document from the input and
---   write it to the output.  No DTD is attached to the output.
---
---   If the input filename ends with .html or .htm, it is parsed using
---   the error-correcting HTML parser rather than the strict XML parser.
-processXmlWith :: CFilter Posn -> IO ()
-processXmlWith f = do
-  (inf,outf) <- fix2Args
-  input      <- if inf=="-" then getContents else readFile inf
-  o          <- if outf=="-" then return stdout else openFile outf WriteMode
-  parse      <- if ".html" `isSuffixOf` inf || ".htm" `isSuffixOf` inf
-                then return (htmlParse inf)
-                else return (xmlParse inf)
-  ( hPutStrLn o . render . PP.document . onContent inf f . parse ) input
-  hFlush o
-
-  where
-    onContent :: FilePath -> (CFilter Posn) -> Document Posn -> Document Posn
-    onContent file filter (Document p s e m) =
-        case filter (CElem e (posInNewCxt file Nothing)) of
-            [CElem e' _] -> Document p s e' m
-            []           -> error "produced no output"
-            _            -> error "produced more than one output"
+
+
+src/Text/XML/HaXml/Wrappers.hs
+
+
+
module Text.XML.HaXml.Wrappers
+  ( fix2Args
+  , processXmlWith
+  , onContent
+  ) where
+
+-- imports required for processXmlWith and fix2Args
+import System
+import IO
+import List (isSuffixOf)
+
+import Text.XML.HaXml.Types       (Document(..),Content(..))
+import Text.XML.HaXml.Combinators (CFilter)
+import Text.XML.HaXml.Posn        (Posn,posInNewCxt)
+import Text.XML.HaXml.Parse       (xmlParse)
+import Text.XML.HaXml.Html.Parse  (htmlParse)
+import Text.XML.HaXml.Pretty as PP(document)
+import Text.PrettyPrint.HughesPJ  (render)
+
+
+-- | This useful auxiliary checks the commandline arguments for two
+--   filenames, the input and output file respectively.  If either
+--   is missing, it is replaced by '-', which can be interpreted by the
+--   caller as stdin and\/or stdout.
+fix2Args :: IO (String,String)
+fix2Args = do
+  args <- getArgs
+  case length args of
+    0 -> return ("-",     "-")
+    1 -> return (args!!0, "-")
+    2 -> return (args!!0, args!!1)
+    _ -> do prog <- getProgName
+            putStrLn ("Usage: "++prog++" [infile] [outfile]")
+            exitFailure
+
+
+-- | The wrapper @processXmlWith@ returns an IO () computation
+--   that collects the filenames (or stdin\/stdout) to use when
+--   reading\/writing XML documents.  Its CFilter argument
+--   is applied to transform the XML document from the input and
+--   write it to the output.  No DTD is attached to the output.
+--
+--   If the input filename ends with .html or .htm, it is parsed using
+--   the error-correcting HTML parser rather than the strict XML parser.
+processXmlWith :: CFilter Posn -> IO ()
+processXmlWith f = do
+  (inf,outf) <- fix2Args
+  input      <- if inf=="-" then getContents else readFile inf
+  o          <- if outf=="-" then return stdout else openFile outf WriteMode
+  parse      <- if ".html" `isSuffixOf` inf || ".htm" `isSuffixOf` inf
+                then return (htmlParse inf)
+                else return (xmlParse inf)
+  ( hPutStrLn o . render . PP.document . onContent inf f . parse ) input
+  hFlush o
+
+  where
+    onContent :: FilePath -> (CFilter Posn) -> Document Posn -> Document Posn
+    onContent file filter (Document p s e m) =
+        case filter (CElem e (posInNewCxt file Nothing)) of
+            [CElem e' _] -> Document p s e' m
+            []           -> error "produced no output"
+            _            -> error "produced more than one output"
+
+-- | The wrapper @onContent@ simply applies a given content filter to a
+--   document.  Ambiguous or empty results raise an error exception.
+onContent :: CFilter i -> Document i -> Document i
+onContent filter (Document p s e m) =
+    case filter (CElem e undefined) of
+      [CElem e' _] -> Document p s e' m
+      []           -> error "onContent: produced no output"
+      _            -> error "onContent: produced more than one output"
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/XmlContent.html b/docs/HaXml/src/Text/XML/HaXml/XmlContent.html
--- a/docs/HaXml/src/Text/XML/HaXml/XmlContent.html
+++ b/docs/HaXml/src/Text/XML/HaXml/XmlContent.html
@@ -1,683 +1,898 @@
 
 
-
{-# LANGUAGE ExistentialQuantification #-}
-
--- | The class 'XmlContent' is a kind of replacement for Read and Show:
---   it provides conversions between a generic XML tree representation
---   and your own more specialised typeful Haskell data trees.
---
---   If you are starting with a set of Haskell datatypes, use DrIFT to
---   derive instances of this class for you:
---       http:\/\/repetae.net\/john\/computer\/haskell\/DrIFT
---   If you are starting with an XML DTD, use HaXml's tool DtdToHaskell
---   to generate both the Haskell types and the corresponding instances.
---
---   This unified class interface replaces two previous (somewhat similar)
---   classes: Haskell2Xml and Xml2Haskell.  There was no real reason to have
---   separate classes depending on how you originally defined your datatypes.
-
---   The methods 'toContents' and 'parseContents' convert a value to and from
---   a generic internal representation of an XML document /without/ a DTD.
---   The functions 'toXml' and 'fromXml' convert a value to and from a generic
---   internal representation of an XML document /including/ a DTD.
---   The functions 'readXml' and 'showXml' convert to and from Strings.
---   The functions 'fReadXml' and 'fWriteXml' do the conversion to and from
---   the given filenames.
---   The functions 'hGetXml' and 'hPutXml' do the conversion to and from
---   the given file handles.
---   (See the type signatures.)
---
-
-module Text.XML.HaXml.XmlContent
-  ( -- * Re-export the relevant set of generic XML document type definitions
-    Document(..)
-  , Element(..)
-  , ElemTag(..)
-  , Content(..)
-  , Attribute()
-  , AttValue(..)
-  , Prolog(..)
-  , Reference(..)
-  -- * The enabling classes, that define parsing\/unparsing between Haskell
-  --   datatypes and a generic XML representation.
-  , XmlContent(..)
-  , XmlAttributes(..)
-  , XmlAttrType(..)
-  -- ** Auxiliaries for writing parsers in the XmlContent class
-  , module Text.ParserCombinators.Poly
-  , XMLParser
-  , content, posnElement, element, interior, inElement, text, attributes
-  , posnElementWith, elementWith, inElementWith
-  , choice, definite -- ???
-  -- ** Auxiliaries for generating in the XmlContent class
-  , mkElem, mkElemC, mkAttr
-  , toText, toCData
-  -- ** Auxiliaries for the attribute-related classes
-  , maybeToAttr, defaultToAttr
-  , definiteA, defaultA, possibleA, fromAttrToStr, toAttrFrStr
-  , Defaultable(..)
-  , str2attr, attr2str, attval
-  , catMaybes   -- re-exported from Maybe
-  -- * Whole-document conversion functions
-  , toXml, fromXml
-  , readXml, showXml, fpsShowXml
-  , fReadXml, fWriteXml, fpsWriteXml
-  , hGetXml,  hPutXml, fpsHPutXml
-  -- * Explicit representation of Haskell datatype information
-  --   (for conversion to a DTD)
-  , module Text.XML.HaXml.TypeMapping
-  -- * Types useful for some content models
-  , List1(..)
-  , ANYContent(..)
-  ) where
-
-import IO
-import Maybe (catMaybes)
-import Char  (chr, isSpace)
-import List  (isPrefixOf, isSuffixOf)
-
-import Text.PrettyPrint.HughesPJ (render)
-import qualified Text.XML.HaXml.Pretty as PP
-
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.TypeMapping
-import Text.XML.HaXml.Posn     (Posn, posInNewCxt)
-import Text.XML.HaXml.Pretty   (document)
-import Text.XML.HaXml.Parse    (xmlParse)
-import Text.XML.HaXml.Verbatim (Verbatim(verbatim))
-import qualified Text.XML.HaXml.ByteStringPP as FPS (document)
-import qualified Data.ByteString.Lazy.Char8 as FPS
-
-import Text.ParserCombinators.Poly
-
---  #define DEBUG
-
-#if defined(DEBUG)
-import Debug.Trace(trace)
-debug :: a -> String -> a
-v `debug` s = trace s v
-#else
-debug :: t -> t1 -> t
-v `debug` _ = v
-#endif
-
-
-------------------------------------------------------------------------
--- | Read a single attribute called "value".
-attval :: (Read a) => Element i -> a
-attval (Elem _ [("value",v@(AttValue _))] []) = read (show v)
-
--- | Generate a single attribute.
-mkAttr :: String -> String -> Attribute
-mkAttr n v = (n, AttValue [Left v])
-
--- | Generate an element with no attributes, named for its HType.
-mkElem :: XmlContent a => a -> [Content ()] -> Content ()
-mkElem x cs  = CElem (Elem (showHType (toHType x) "") [] cs) ()
-
--- | Generate an element with no attributes, named directly.
-mkElemC :: String -> [Content ()] -> Content ()
-mkElemC x cs = CElem (Elem x [] cs) ()
-
--- | Turn a simple string into XML text.
-toText :: String -> [Content ()]
-toText s = [CString False s ()]
-
--- | Turn a string into an XML CDATA section.
---   (i.e. special characters like '&' are preserved without interpretation.)
-toCData :: String -> [Content ()]
-toCData s = [CString True s ()]
-------------------------------------------------------------------------
-
-        -- probably want to write DTD separately from value, and have
-        -- easy ways to combine DTD + value into a document, or write
-        -- them to separate files.
-
--- | Read an XML document from a file and convert it to a fully-typed
---   Haskell value.
-fReadXml  :: XmlContent a => FilePath -> IO a
-fReadXml fp = do
-    f <- ( if fp=="-" then return stdin
-           else openFile fp ReadMode )
-    x <- hGetContents f
-    let (Document _ _ y _) = xmlParse fp x
-        y' = CElem y (posInNewCxt fp Nothing)
-    either fail return (fst (runParser parseContents [y']))
-
--- | Write a fully-typed Haskell value to the given file as an XML
---   document.
-fWriteXml :: XmlContent a => FilePath -> a -> IO ()
-fWriteXml fp x = do
-    f <- ( if fp=="-" then return stdout
-           else openFile fp WriteMode )
-    hPutXml f False x
-    hClose f
-
--- | Write any Haskell value to the given file as an XML document,
---   using the FastPackedString interface (output will not be prettified).
-fpsWriteXml :: XmlContent a => FilePath -> a -> IO ()
-fpsWriteXml fp x = do
-    f <- ( if fp=="-" then return stdout
-           else openFile fp WriteMode )
-    fpsHPutXml f False x
-    hClose f
-
--- | Read a fully-typed XML document from a string.
-readXml :: XmlContent a => String -> Either String a
-readXml s =
-    let (Document _ _ y _) = xmlParse "string input" s in
-    fst (runParser parseContents
-                   [CElem y (posInNewCxt "string input" Nothing)])
-
--- | Convert a fully-typed XML document to a string (without DTD).
-showXml :: XmlContent a => Bool -> a -> String
-showXml dtd x =
-    case toContents x of
-      [CElem _ _] -> (render . document . toXml dtd) x
-      _ -> ""
-
--- | Convert a fully-typed XML document to a ByteString (without DTD).
-fpsShowXml :: XmlContent a => Bool -> a -> FPS.ByteString
-fpsShowXml dtd x =
-    case toContents x of
-      [CElem _ _] -> (FPS.document . toXml dtd) x
-      _ -> FPS.empty
-
-
--- | Convert a fully-typed XML document to a string (with or without DTD).
-toXml :: XmlContent a => Bool -> a -> Document ()
-toXml dtd value =
-    let ht = toHType value in
-    Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing))
-                     [] (if dtd then Just (toDTD ht) else Nothing) [])
-             emptyST
-             ( case (ht, toContents value) of
-                 (Tuple _, cs)       -> Elem (showHType ht "") [] cs
-                 (Defined _ _ _, cs) -> Elem (showHType ht "-XML") [] cs
-                 (_, [CElem e ()])   -> e )
-             []
-
--- | Read a Haskell value from an XML document, ignoring the DTD and
---   using the Haskell result type to determine how to parse it.
-fromXml :: XmlContent a => Document Posn -> Either String a
-fromXml (Document _ _ e@(Elem n _ cs) _)
-  | "tuple" `isPrefixOf` n = fst (runParser parseContents cs)
-  | "-XML"  `isSuffixOf` n = fst (runParser parseContents cs)
-  | otherwise = fst (runParser parseContents
-                               [CElem e (posInNewCxt "document" Nothing)])
-
-
--- | Read a fully-typed XML document from a file handle.
-hGetXml :: XmlContent a => Handle -> IO a
-hGetXml h = do
-    x <- hGetContents h
-    let (Document _ _ y _) = xmlParse "file handle" x
-    either fail return
-           (fst (runParser parseContents
-                           [CElem y (posInNewCxt "file handle" Nothing)]))
-
--- | Write a fully-typed XML document to a file handle.
-hPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
-hPutXml h dtd x = do
-    (hPutStrLn h . render . document . toXml dtd) x
-
--- | Write a fully-typed XML document to a file handle, using the
---   FastPackedString interface (output will not be prettified).
-fpsHPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
-fpsHPutXml h dtd x = do
-    (FPS.hPut h . FPS.document . toXml dtd) x
-
-------------------------------------------------------------------------
-
--- | We need a parsing monad for reading generic XML Content into specific
---   datatypes.  This is a specialisation of the Text.ParserCombinators.Poly
---   ones, where the input token type is fixed as XML Content.
-type XMLParser a = Parser (Content Posn) a
-
-
-------------------------------------------------------------------------
--- Some useful parsing combinators
-------------------------------------------------------------------------
-
--- | The most primitive combinator for XMLParser - get one content item.
-content :: String -> XMLParser (Content Posn)
-content word = next `adjustErr` (++" when expecting "++word)
-
--- | Get the next content element, checking that it has one of the required
---   tags, using the given matching function.
---   (Skips over comments and whitespace, rejects text and refs.
---    Also returns position of element.)
-posnElementWith :: (String->String->Bool) -> [String]
-                   -> XMLParser (Posn, Element Posn)
-posnElementWith match tags = do
-    { c <- content (formatted tags)
-    ; case c of
-          CElem e@(Elem t _ _) pos
-              | any (match t) tags -> return (pos, e)
-              | otherwise          -> fail ("Found a <"++t++">, but expected "
-                                           ++formatted tags++"\nat "++show pos)
-          CString b s pos
-              | not b && all isSpace s -> posnElementWith match tags
-                                                        -- ignore blank space
-              | otherwise -> fail ("Found text content, but expected "
-                                  ++formatted tags++"\ntext is: "++s
-                                  ++"\nat "++show pos)
-          CRef r pos -> fail ("Found reference, but expected "
-                             ++formatted tags++"\nreference is: "++verbatim r
-                             ++"\nat "++show pos)
-          CMisc _ _ -> posnElementWith match tags  -- skip comments, PIs, etc.
-    }
-  where
-    formatted [t]  = "a <"++t++">"
-    formatted tgs = "one of"++ concatMap (\t->" <"++t++">") tgs
-
--- | A specialisation of @posnElementWith (==)@.
-posnElement :: [String] -> XMLParser (Posn, Element Posn)
-posnElement = posnElementWith (==)
-
--- | Get the next content element, checking that it has one of the required
---   tags.  (Skips over comments and whitespace, rejects text and refs.)
-element :: [String] -> XMLParser (Element Posn)
-element tags = fmap snd (posnElement tags)
-                                `debug` ("Element: "++unwords tags++"\n")
-
--- | Like element, only permits a more flexible match against the tagname.
-elementWith :: (String->String->Bool) -> [String] -> XMLParser (Element Posn)
-elementWith match tags = fmap snd (posnElementWith match tags)
-                                `debug` ("Element: "++unwords tags++"\n")
-
--- | Run an XMLParser on the contents of the given element (i.e. not on the
---   current monadic content sequence), checking that the contents are
---   exhausted, before returning the calculated value within the current
---   parser context.
-interior :: Element Posn -> XMLParser a -> XMLParser a
-interior (Elem e _ cs) p =
-    case runParser p cs of
-        (Left msg, _) -> fail msg
-        (Right x, []) -> return x
-        (Right x, ds@(d:_))
-            | all onlyMisc ds -> return x
-            | otherwise       -> fail ("Too many elements inside <"++e++"> at\n"
-                                      ++show (info d)++"\n"
-                                      ++"Found excess: "++verbatim d)
-  where onlyMisc (CMisc _ _) = True
-        onlyMisc (CString False s _) | all isSpace s = True
-        onlyMisc _ = False
-
--- | A combination of element + interior.
-inElement :: String -> XMLParser a -> XMLParser a
-inElement tag p = do { e <- element [tag]; commit (interior e p) }
-
--- | A combination of elementWith + interior.
-inElementWith :: (String->String->Bool) -> String -> XMLParser a -> XMLParser a
-inElementWith match tag p = do { e <- elementWith match [tag]
-                               ; commit (interior e p) }
-
--- | Do some parsing of the attributes of the given element
-attributes :: XmlAttributes a => Element Posn -> XMLParser a
-attributes (Elem _ as _) = return (fromAttrs as)
-
--- | 'text' is a counterpart to 'element', parsing text content if it
---   exists.  Adjacent text and references are coalesced.
-text :: XMLParser String
-text = text' []
-  where text' acc =
-          do { c <- content "plain text"
-             ; case c of
-                 CString _ s _        -> text' (s:acc)
-                 CRef (RefChar s) _   -> text' (("&#"++show s++";") :acc)
-                 CRef (RefEntity s) _ -> text' (('&':s++";"):acc)
-                 CMisc _ _            -> text' acc
-                 CElem _ _         -> do { reparse [c] -- put it back!
-                                         ; if null acc then fail "empty string"
-                                           else return (concat (reverse acc))
-                                         }
-             }
-          `onFail` ( if null acc then fail "empty string"
-                     else return (concat (reverse acc)) )
-
-
--- | 'choice f p' means if parseContents succeeds, apply f to the result,
---   otherwise use the continuation parser.
-choice :: XmlContent a => (a -> b) -> XMLParser b -> XMLParser b
-choice cons (P other) =
-    P (\cs-> case runParser parseContents cs of
-                 (Left _, _)  -> other cs
-                 (Right x, cs') -> (Right (cons x), cs'))
-
---choice cons other = fmap cons parseContents `onFail` other
-
--- | not sure this is needed now.   'definite p' previously ensured that
---   an element was definitely present.  Now I think the monad might take
---   care of that for us.
-definite :: XmlContent a => XMLParser a -> String -> String -> XMLParser a
-definite p inner tag = P (\cs-> case runParser p cs of
-                                   (Left _, cs') -> (Left (False,msg'), cs')
-                                   (Right x, cs')  -> (Right x,   cs'))
-  where msg' = "content error: expected "++inner++" inside <"++tag
-               ++"> element\n"
-
-------------------------------------------------------------------------
-
--- | The @XmlContent@ class promises that an XML Content element can be
---   converted to and from a Haskell value.
-class HTypeable a => XmlContent a where
-    -- | Convert from XML to Haskell
-    parseContents :: XMLParser a
-    -- | Convert from Haskell to XML
-    toContents    :: a -> [Content ()]
-
-    -- | Dummy functions (for most types): used /only/ in the Char instance
-    --   for coercing lists of Char into String.
-    xToChar       :: a -> Char
-    xFromChar     :: Char -> a
-    xToChar        = error "HaXml.XmlContent.xToChar used in error"
-    xFromChar      = error "HaXml.XmlContent.xFromChar used in error"
-
--- | The @XmlAttributes@ class promises that a list of XML tag attributes
---   can be converted to and from a Haskell value.
-class XmlAttributes a where
-    fromAttrs :: [Attribute] -> a
-    toAttrs   :: a -> [Attribute]
--- | The @XmlAttrType@ class promises that an attribute taking an XML
---   enumerated type can be converted to and from a Haskell value.
-class XmlAttrType a where
-    fromAttrToTyp :: String -> Attribute -> Maybe a
-    toAttrFrTyp   :: String -> a -> Maybe Attribute
-
-
-------------------------------------------------------------------------
--- Instances for all the standard basic datatypes.
--- These are for Haskell datatypes being derived to go to XML.
--- DtdToHaskell does not use these instances.
-------------------------------------------------------------------------
-
-instance XmlContent Bool where
-    toContents b   = [CElem (Elem "bool" [mkAttr "value" (show b)] []) ()]
-    parseContents = do { e <- element ["bool"] ; return (attval e) }
-
-instance XmlContent Int where
-    toContents i   = [CElem (Elem "int" [mkAttr "value" (show i)] []) ()]
-    parseContents = do { e <- element ["int"] ; return (attval e) }
-
-instance XmlContent Integer where
-    toContents i   = [CElem (Elem "integer" [mkAttr "value" (show i)] []) ()]
-    parseContents = do { e <- element ["integer"] ; return (attval e) }
-
-instance XmlContent Float where
-    toContents i   = [CElem (Elem "float" [mkAttr "value" (show i)] []) ()]
-    parseContents = do { e <- element ["float"] ; return (attval e) }
-
-instance XmlContent Double where
-    toContents i   = [CElem (Elem "double" [mkAttr "value" (show i)] []) ()]
-    parseContents = do { e <- element ["double"] ; return (attval e) }
-
-instance XmlContent Char where
-    -- NOT in a string
-    toContents c   = [CElem (Elem "char" [mkAttr "value" [c]] []) ()]
-    parseContents = do { (Elem _ [("value",(AttValue [Left [c]]))] [])
-                             <- element ["char"]
-                       ; return c
-                       }
-    -- Only defined for Char and no other types:
-    xToChar   = id
-    xFromChar = id
-
-instance XmlContent a => XmlContent [a] where
-    toContents xs  = case toHType x of
-                       (Prim "Char" _) ->
-                            [mkElem "string" [CString True (map xToChar xs) ()]]
-                       _ -> [mkElem xs (concatMap toContents xs)]
-                   where   (x:_) = xs
-    parseContents = P (\x ->
-        case x of
-            (CString _ s _:cs)
-                   -> (Right (map xFromChar s), cs)
-            (CElem (Elem "string" [] [CString _ s _]) _:cs)
-                   -> (Right (map xFromChar s), cs)
-            (CElem (Elem e [] xs) _:cs) | "list" `isPrefixOf` e
-                   -> scanElements xs
-                   where
-                  -- scanElements :: [Content] -> (Either String [a],[Content])
-                     scanElements [] = (Right [], cs)
-                     scanElements es =
-                        case runParser parseContents es of
-                            (Left msg, es') -> (Left (False,msg), es')
-                            (Right y, es') ->
-                                case scanElements es' of
-                                    (Left msg, ds) -> (Left msg, ds)
-                                    (Right ys, ds) -> (Right (y:ys), ds)
-            (CElem (Elem e _ _) pos: cs)
-                   -> (Left (False
-                            ,"Expected a <list-...>, but found a <"++e++"> at\n"
-                            ++ show pos), cs)
-            (CRef r pos: cs)
-                   -> (Left (False
-                            ,"Expected a <list-...>, but found a ref "
-                            ++verbatim r++" at\n"++ show pos), cs)
-            (_:cs) -> ((\ (P p)-> p) parseContents) cs  -- skip comments etc.
-            []     -> (Left (False
-                            ,"Ran out of input XML whilst secondary parsing")
-                      , [])
-        )
-
-instance XmlContent () where
-    toContents ()  = [CElem (Elem "unit" [] []) ()]
-    parseContents = do { element ["unit"]; return () }
-
-instance (XmlContent a, XmlContent b) => XmlContent (a,b) where
-    toContents (a,b) = toContents a ++ toContents b
-    parseContents    = do
-        { a <- parseContents
-        ; b <- parseContents
-        ; return (a,b)
-        }
-
-instance (XmlContent a, XmlContent b, XmlContent c) => XmlContent (a,b,c) where
-    toContents (x,y,z) = toContents x ++ toContents y ++ toContents z
-    parseContents = do
-        { a <- parseContents
-        ; b <- parseContents
-        ; c <- parseContents
-        ; return (a,b,c)
-        }
-
-instance (XmlContent a, XmlContent b, XmlContent c, XmlContent d) =>
-         XmlContent (a,b,c,d) where
-    toContents (x,y,z,t) = toContents x ++ toContents y ++ toContents z
-                           ++ toContents t
-    parseContents = do
-        { a <- parseContents
-        ; b <- parseContents
-        ; c <- parseContents
-        ; d <- parseContents
-        ; return (a,b,c,d)
-        }
-
-instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
-         , XmlContent e ) =>
-         XmlContent (a,b,c,d,e) where
-    toContents (x,y,z,t,u) = toContents x ++ toContents y ++ toContents z
-                             ++ toContents t ++ toContents u
-    parseContents = do
-        { a <- parseContents
-        ; b <- parseContents
-        ; c <- parseContents
-        ; d <- parseContents
-        ; e <- parseContents
-        ; return (a,b,c,d,e)
-        }
-
-instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
-         , XmlContent e, XmlContent f ) =>
-         XmlContent (a,b,c,d,e,f) where
-    toContents (x,y,z,t,u,v) = toContents x ++ toContents y ++ toContents z
-                               ++ toContents t ++ toContents u ++ toContents v
-    parseContents = do
-        { a <- parseContents
-        ; b <- parseContents
-        ; c <- parseContents
-        ; d <- parseContents
-        ; e <- parseContents
-        ; f <- parseContents
-        ; return (a,b,c,d,e,f)
-        }
-
-instance (XmlContent a) => XmlContent (Maybe a) where
-    toContents m   = [mkElem m (maybe [] toContents m)]
-    parseContents = do
-        { e <- elementWith (flip isPrefixOf) ["maybe"]
-        ; case e of (Elem _ [] []) -> return Nothing
-                    (Elem _ [] _)  -> fmap Just (interior e parseContents)
-        }
-
-instance (XmlContent a, XmlContent b) => XmlContent (Either a b) where
-    toContents v@(Left aa) =
-        [mkElemC (showConstr 0 (toHType v)) (toContents aa)]
-    toContents v@(Right ab) =
-        [mkElemC (showConstr 1 (toHType v)) (toContents ab)]
-    parseContents =
-        (inElementWith (flip isPrefixOf) "Left"  $ fmap Left  parseContents)
-          `onFail`
-        (inElementWith (flip isPrefixOf) "Right" $ fmap Right parseContents)
-
---    do{ e@(Elem t [] _) <- element ["Left","Right"]
---      ; case t of
---          _ | "Left"  `isPrefixOf` t -> fmap Left  (interior e parseContents)
---            | "Right" `isPrefixOf` t -> fmap Right (interior e parseContents)
---      }
-
-
-------------------------------------------------------------------------
--- Useful auxiliaries for "fromAttributes"
-------------------------------------------------------------------------
-
--- | If an attribute is defaultable, then it either takes the default
---   value (which is omitted from the output), or a non-default value
---   (which obviously must be printed).
-data Defaultable a  = Default a    | NonDefault a    deriving (Eq,Show)
-
-searchMaybe :: (a -> Maybe b) -> [a] -> Maybe b
-searchMaybe _ [] = Nothing
-searchMaybe f (x:xs) =
-    let fx = f x in
-    case fx of
-      Nothing  -> searchMaybe f xs
-      (Just _) -> fx
-
-maybeToAttr :: (String->a->Maybe Attribute) -> String -> Maybe a
-               -> Maybe Attribute
-maybeToAttr _ _ Nothing  = Nothing
-maybeToAttr to n (Just v) = to n v
-
-defaultToAttr :: (String->a->Maybe Attribute) -> String -> Defaultable a
-                 -> Maybe Attribute
-defaultToAttr _ _ (Default _)  = Nothing
-defaultToAttr to n (NonDefault v) = to n v
-
-definiteA :: (String->Attribute->Maybe a) -> String -> String
-             -> [Attribute] -> a
-definiteA from tag at as =
-    case searchMaybe (from at) as of
-      Nothing  -> error ("missing attribute "++at++" in tag <"++tag++">")
-      (Just a) -> a
-
-defaultA :: (String->Attribute->Maybe a) -> a -> String
-            -> [Attribute] -> Defaultable a
-defaultA from def at as =
-    case searchMaybe (from at) as of
-      Nothing  -> Default def
-      (Just a) -> NonDefault a
-
-possibleA :: (String->Attribute->Maybe a) -> String -> [Attribute] -> Maybe a
-possibleA from at as = searchMaybe (from at) as
-
-fromAttrToStr :: String -> Attribute -> Maybe String
-fromAttrToStr n (n0,v)
-        | n == n0   = Just (attr2str v)
-        | otherwise = Nothing
-
-toAttrFrStr   :: String -> String -> Maybe Attribute
-toAttrFrStr n v = Just (n, str2attr v)
-
-str2attr :: String -> AttValue
-str2attr s =
-    let f t =
-          let (l,r) = span (\c-> not (elem c "\"&<>'")) t
-          in if null r then [Left l]
-             else Left l: Right (g (head r)): f (tail r)
-        g '"'  = RefEntity "quot"
-        g '&'  = RefEntity "amp"
-        g '<'  = RefEntity "lt"
-        g '>'  = RefEntity "gt"
-        g '\'' = RefEntity "apos"
-    in AttValue (f s)
-
-attr2str :: AttValue -> String          -- really needs symbol table
-attr2str (AttValue xs) =
-    let f (Left s) = s
-        f (Right (RefChar i))        = [chr i]
-        f (Right (RefEntity "quot")) = "\""
-        f (Right (RefEntity "amp"))  = "&"
-        f (Right (RefEntity "lt"))   = "<"
-        f (Right (RefEntity "gt"))   = ">"
-        f (Right (RefEntity "apos")) = "'"
-        f (Right _)                  = "*"  -- Ooops, ST needed here.
-    in concatMap f xs
-
-------------------------------------------------------------------------
---  New content-model types
-------------------------------------------------------------------------
-
-{-
-data OneOf2 a b
-data OneOf3 a b c
-data OneOf4 a b c d
-    ... etc are now defined (with instances) in module OneOfN.
--}
-
--- | A type corresponding to XML's ANY contentspec.
---   It is either a list of unconverted xml 'Content'
---   or some 'XmlContent'-able value.
---
--- Parsing functions (e.g. 'parseContents') will always produce 'UnConverted'.
--- Note: The Show instance for 'UnConverted' uses 'verbatim'.
-data ANYContent = forall a . (XmlContent a, Show a) => ANYContent a
-                | UnConverted [Content Posn]
-
-instance Show ANYContent where
-    show (UnConverted c) = "UnConverted " ++ (show $ map verbatim c)
-    show (ANYContent a)  = "ANYContent " ++ (show a)
-
-instance Eq ANYContent where
-    a == b = show a == show b
-
--- | The List1 type represents lists with at least one element.
---   It is required for DTD content models that use + as a modifier.
-data List1 a = NonEmpty [a]  deriving (Eq, Show)
-
-
-------------------------------------------------------------------------
---  Instances for new content-model types
-------------------------------------------------------------------------
-instance (HTypeable a) => HTypeable (List1 a) where
-    toHType m  = Defined "List1" [hx]
-                         [Constr "NonEmpty" [hx] [List hx] {-Nothing-}]
-               where (NonEmpty x) = m
-                     hx = toHType x
-instance (XmlContent a) => XmlContent (List1 a) where
-    toContents (NonEmpty xs) = concatMap toContents xs
-    parseContents = fmap NonEmpty $ many1 parseContents
-
-instance HTypeable ANYContent where
-    toHType _      = Prim "ANYContent" "ANY"
-instance XmlContent ANYContent where
-    toContents (ANYContent a)  = toContents a
-    toContents (UnConverted s) = map (fmap (const ())) s
-    parseContents = P (\cs -> (Right (UnConverted cs), []))
-
-------------------------------------------------------------------------
---
-------------------------------------------------------------------------
-

+
+
+src/Text/XML/HaXml/XmlContent.hs
+
+
+
{-# LANGUAGE ExistentialQuantification #-}
+
+-- | The class 'XmlContent' is a kind of replacement for Read and Show:
+--   it provides conversions between a generic XML tree representation
+--   and your own more specialised typeful Haskell data trees.
+--
+--   If you are starting with a set of Haskell datatypes, use DrIFT to
+--   derive instances of this class for you:
+--       http:\/\/repetae.net\/john\/computer\/haskell\/DrIFT
+--   If you are starting with an XML DTD, use HaXml's tool DtdToHaskell
+--   to generate both the Haskell types and the corresponding instances.
+--
+--   This unified class interface replaces two previous (somewhat similar)
+--   classes: Haskell2Xml and Xml2Haskell.  There was no real reason to have
+--   separate classes depending on how you originally defined your datatypes.
+
+--   The methods 'toContents' and 'parseContents' convert a value to and from
+--   a generic internal representation of an XML document /without/ a DTD.
+--   The functions 'toXml' and 'fromXml' convert a value to and from a generic
+--   internal representation of an XML document /including/ a DTD.
+--   The functions 'readXml' and 'showXml' convert to and from Strings.
+--   The functions 'fReadXml' and 'fWriteXml' do the conversion to and from
+--   the given filenames.
+--   The functions 'hGetXml' and 'hPutXml' do the conversion to and from
+--   the given file handles.
+--   (See the type signatures.)
+--
+
+module Text.XML.HaXml.XmlContent
+  ( -- * Re-export the relevant set of generic XML document type definitions
+    Document(..)
+  , Element(..)
+  , ElemTag(..)
+  , Content(..)
+  , Attribute()
+  , AttValue(..)
+  , Prolog(..)
+  , Reference(..)
+  -- * The enabling classes, that define parsing\/unparsing between Haskell
+  --   datatypes and a generic XML representation.
+  , XmlContent(..)
+  , XmlAttributes(..)
+  , XmlAttrType(..)
+  -- ** Auxiliaries for writing parsers in the XmlContent class
+  , module Text.ParserCombinators.Poly
+  , XMLParser
+  , content, posnElement, element, interior, inElement, text, attributes
+  , posnElementWith, elementWith, inElementWith
+  , choice, definite -- ???
+  -- ** Auxiliaries for generating in the XmlContent class
+  , mkElem, mkElemC, mkAttr
+  , toText, toCData
+  -- ** Auxiliaries for the attribute-related classes
+  , maybeToAttr, defaultToAttr
+  , definiteA, defaultA, possibleA, fromAttrToStr, toAttrFrStr
+  , Defaultable(..)
+  , str2attr, attr2str, attval
+  , catMaybes   -- re-exported from Maybe
+  -- * Whole-document conversion functions
+  , toXml, fromXml
+  , readXml, showXml, fpsShowXml
+  , fReadXml, fWriteXml, fpsWriteXml
+  , hGetXml,  hPutXml, fpsHPutXml
+  -- * Explicit representation of Haskell datatype information
+  --   (for conversion to a DTD)
+  , module Text.XML.HaXml.TypeMapping
+  -- * Types useful for some content models
+  , List1(..)
+  , ANYContent(..)
+  ) where
+
+import IO
+import Maybe (catMaybes)
+import Char  (chr, isSpace)
+import List  (isPrefixOf, isSuffixOf)
+
+import Text.PrettyPrint.HughesPJ (render)
+import qualified Text.XML.HaXml.Pretty as PP
+
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.TypeMapping
+import Text.XML.HaXml.Posn     (Posn, posInNewCxt)
+import Text.XML.HaXml.Pretty   (document)
+import Text.XML.HaXml.Parse    (xmlParse)
+import Text.XML.HaXml.Verbatim (Verbatim(verbatim))
+import qualified Text.XML.HaXml.ByteStringPP as FPS (document)
+import qualified Data.ByteString.Lazy.Char8 as FPS
+
+import Text.ParserCombinators.Poly
+
+--  #define DEBUG
+
+#if defined(DEBUG)
+import Debug.Trace(trace)
+debug :: a -> String -> a
+v `debug` s = trace s v
+#else
+debug :: t -> t1 -> t
+v `debug` _ = v
+#endif
+
+
+------------------------------------------------------------------------
+-- | Read a single attribute called "value".
+attval :: (Read a) => Element i -> a
+attval (Elem _ [("value",v@(AttValue _))] []) = read (show v)
+
+-- | Generate a single attribute.
+mkAttr :: String -> String -> Attribute
+mkAttr n v = (n, AttValue [Left v])
+
+-- | Generate an element with no attributes, named for its HType.
+mkElem :: XmlContent a => a -> [Content ()] -> Content ()
+mkElem x cs  = CElem (Elem (showHType (toHType x) "") [] cs) ()
+
+-- | Generate an element with no attributes, named directly.
+mkElemC :: String -> [Content ()] -> Content ()
+mkElemC x cs = CElem (Elem x [] cs) ()
+
+-- | Turn a simple string into XML text.
+toText :: String -> [Content ()]
+toText s = [CString False s ()]
+
+-- | Turn a string into an XML CDATA section.
+--   (i.e. special characters like '&' are preserved without interpretation.)
+toCData :: String -> [Content ()]
+toCData s = [CString True s ()]
+------------------------------------------------------------------------
+
+        -- probably want to write DTD separately from value, and have
+        -- easy ways to combine DTD + value into a document, or write
+        -- them to separate files.
+
+-- | Read an XML document from a file and convert it to a fully-typed
+--   Haskell value.
+fReadXml  :: XmlContent a => FilePath -> IO a
+fReadXml fp = do
+    f <- ( if fp=="-" then return stdin
+           else openFile fp ReadMode )
+    x <- hGetContents f
+    let (Document _ _ y _) = xmlParse fp x
+        y' = CElem y (posInNewCxt fp Nothing)
+    either fail return (fst (runParser parseContents [y']))
+
+-- | Write a fully-typed Haskell value to the given file as an XML
+--   document.
+fWriteXml :: XmlContent a => FilePath -> a -> IO ()
+fWriteXml fp x = do
+    f <- ( if fp=="-" then return stdout
+           else openFile fp WriteMode )
+    hPutXml f False x
+    hClose f
+
+-- | Write any Haskell value to the given file as an XML document,
+--   using the FastPackedString interface (output will not be prettified).
+fpsWriteXml :: XmlContent a => FilePath -> a -> IO ()
+fpsWriteXml fp x = do
+    f <- ( if fp=="-" then return stdout
+           else openFile fp WriteMode )
+    fpsHPutXml f False x
+    hClose f
+
+-- | Read a fully-typed XML document from a string.
+readXml :: XmlContent a => String -> Either String a
+readXml s =
+    let (Document _ _ y _) = xmlParse "string input" s in
+    fst (runParser parseContents
+                   [CElem y (posInNewCxt "string input" Nothing)])
+
+-- | Convert a fully-typed XML document to a string (without DTD).
+showXml :: XmlContent a => Bool -> a -> String
+showXml dtd x =
+    case toContents x of
+      [CElem _ _] -> (render . document . toXml dtd) x
+      _ -> ""
+
+-- | Convert a fully-typed XML document to a ByteString (without DTD).
+fpsShowXml :: XmlContent a => Bool -> a -> FPS.ByteString
+fpsShowXml dtd x =
+    case toContents x of
+      [CElem _ _] -> (FPS.document . toXml dtd) x
+      _ -> FPS.empty
+
+
+-- | Convert a fully-typed XML document to a string (with or without DTD).
+toXml :: XmlContent a => Bool -> a -> Document ()
+toXml dtd value =
+    let ht = toHType value in
+    Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing))
+                     [] (if dtd then Just (toDTD ht) else Nothing) [])
+             emptyST
+             ( case (ht, toContents value) of
+                 (Tuple _, cs)       -> Elem (showHType ht "") [] cs
+                 (Defined _ _ _, cs) -> Elem (showHType ht "-XML") [] cs
+                 (_, [CElem e ()])   -> e )
+             []
+
+-- | Read a Haskell value from an XML document, ignoring the DTD and
+--   using the Haskell result type to determine how to parse it.
+fromXml :: XmlContent a => Document Posn -> Either String a
+fromXml (Document _ _ e@(Elem n _ cs) _)
+  | "tuple" `isPrefixOf` n = fst (runParser parseContents cs)
+  | "-XML"  `isSuffixOf` n = fst (runParser parseContents cs)
+  | otherwise = fst (runParser parseContents
+                               [CElem e (posInNewCxt "document" Nothing)])
+
+
+-- | Read a fully-typed XML document from a file handle.
+hGetXml :: XmlContent a => Handle -> IO a
+hGetXml h = do
+    x <- hGetContents h
+    let (Document _ _ y _) = xmlParse "file handle" x
+    either fail return
+           (fst (runParser parseContents
+                           [CElem y (posInNewCxt "file handle" Nothing)]))
+
+-- | Write a fully-typed XML document to a file handle.
+hPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
+hPutXml h dtd x = do
+    (hPutStrLn h . render . document . toXml dtd) x
+
+-- | Write a fully-typed XML document to a file handle, using the
+--   FastPackedString interface (output will not be prettified).
+fpsHPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
+fpsHPutXml h dtd x = do
+    (FPS.hPut h . FPS.document . toXml dtd) x
+
+------------------------------------------------------------------------
+
+-- | We need a parsing monad for reading generic XML Content into specific
+--   datatypes.  This is a specialisation of the Text.ParserCombinators.Poly
+--   ones, where the input token type is fixed as XML Content.
+type XMLParser a = Parser (Content Posn) a
+
+
+------------------------------------------------------------------------
+-- Some useful parsing combinators
+------------------------------------------------------------------------
+
+-- | The most primitive combinator for XMLParser - get one content item.
+content :: String -> XMLParser (Content Posn)
+content word = next `adjustErr` (++" when expecting "++word)
+
+-- | Get the next content element, checking that it has one of the required
+--   tags, using the given matching function.
+--   (Skips over comments and whitespace, rejects text and refs.
+--    Also returns position of element.)
+posnElementWith :: (String->String->Bool) -> [String]
+                   -> XMLParser (Posn, Element Posn)
+posnElementWith match tags = do
+    { c <- content (formatted tags)
+    ; case c of
+          CElem e@(Elem t _ _) pos
+              | any (match t) tags -> return (pos, e)
+              | otherwise          -> fail ("Found a <"++t++">, but expected "
+                                           ++formatted tags++"\nat "++show pos)
+          CString b s pos
+              | not b && all isSpace s -> posnElementWith match tags
+                                                        -- ignore blank space
+              | otherwise -> fail ("Found text content, but expected "
+                                  ++formatted tags++"\ntext is: "++s
+                                  ++"\nat "++show pos)
+          CRef r pos -> fail ("Found reference, but expected "
+                             ++formatted tags++"\nreference is: "++verbatim r
+                             ++"\nat "++show pos)
+          CMisc _ _ -> posnElementWith match tags  -- skip comments, PIs, etc.
+    }
+  where
+    formatted [t]  = "a <"++t++">"
+    formatted tgs = "one of"++ concatMap (\t->" <"++t++">") tgs
+
+-- | A specialisation of @posnElementWith (==)@.
+posnElement :: [String] -> XMLParser (Posn, Element Posn)
+posnElement = posnElementWith (==)
+
+-- | Get the next content element, checking that it has one of the required
+--   tags.  (Skips over comments and whitespace, rejects text and refs.)
+element :: [String] -> XMLParser (Element Posn)
+element tags = fmap snd (posnElement tags)
+                                `debug` ("Element: "++unwords tags++"\n")
+
+-- | Like element, only permits a more flexible match against the tagname.
+elementWith :: (String->String->Bool) -> [String] -> XMLParser (Element Posn)
+elementWith match tags = fmap snd (posnElementWith match tags)
+                                `debug` ("Element: "++unwords tags++"\n")
+
+-- | Run an XMLParser on the contents of the given element (i.e. not on the
+--   current monadic content sequence), checking that the contents are
+--   exhausted, before returning the calculated value within the current
+--   parser context.
+interior :: Element Posn -> XMLParser a -> XMLParser a
+interior (Elem e _ cs) p =
+    case runParser p cs of
+        (Left msg, _) -> fail msg
+        (Right x, []) -> return x
+        (Right x, ds@(d:_))
+            | all onlyMisc ds -> return x
+            | otherwise       -> fail ("Too many elements inside <"++e++"> at\n"
+                                      ++show (info d)++"\n"
+                                      ++"Found excess: "++verbatim d)
+  where onlyMisc (CMisc _ _) = True
+        onlyMisc (CString False s _) | all isSpace s = True
+        onlyMisc _ = False
+
+-- | A combination of element + interior.
+inElement :: String -> XMLParser a -> XMLParser a
+inElement tag p = do { e <- element [tag]; commit (interior e p) }
+
+-- | A combination of elementWith + interior.
+inElementWith :: (String->String->Bool) -> String -> XMLParser a -> XMLParser a
+inElementWith match tag p = do { e <- elementWith match [tag]
+                               ; commit (interior e p) }
+
+-- | Do some parsing of the attributes of the given element
+attributes :: XmlAttributes a => Element Posn -> XMLParser a
+attributes (Elem _ as _) = return (fromAttrs as)
+
+-- | 'text' is a counterpart to 'element', parsing text content if it
+--   exists.  Adjacent text and references are coalesced.
+text :: XMLParser String
+text = text' []
+  where text' acc =
+          do { c <- content "plain text"
+             ; case c of
+                 CString _ s _        -> text' (s:acc)
+                 CRef (RefChar s) _   -> text' (("&#"++show s++";") :acc)
+                 CRef (RefEntity s) _ -> text' (('&':s++";"):acc)
+                 CMisc _ _            -> text' acc
+                 CElem _ _         -> do { reparse [c] -- put it back!
+                                         ; if null acc then fail "empty string"
+                                           else return (concat (reverse acc))
+                                         }
+             }
+          `onFail` ( if null acc then fail "empty string"
+                     else return (concat (reverse acc)) )
+
+
+-- | 'choice f p' means if parseContents succeeds, apply f to the result,
+--   otherwise use the continuation parser.
+choice :: XmlContent a => (a -> b) -> XMLParser b -> XMLParser b
+choice cons (P other) =
+    P (\cs-> case runParser parseContents cs of
+                 (Left _, _)  -> other cs
+                 (Right x, cs') -> (Right (cons x), cs'))
+
+--choice cons other = fmap cons parseContents `onFail` other
+
+-- | not sure this is needed now.   'definite p' previously ensured that
+--   an element was definitely present.  Now I think the monad might take
+--   care of that for us.
+definite :: XmlContent a => XMLParser a -> String -> String -> XMLParser a
+definite p inner tag = P (\cs-> case runParser p cs of
+                                   (Left _, cs') -> (Left (False,msg'), cs')
+                                   (Right x, cs')  -> (Right x,   cs'))
+  where msg' = "content error: expected "++inner++" inside <"++tag
+               ++"> element\n"
+
+------------------------------------------------------------------------
+
+-- | The @XmlContent@ class promises that an XML Content element can be
+--   converted to and from a Haskell value.
+class HTypeable a => XmlContent a where
+    -- | Convert from XML to Haskell
+    parseContents :: XMLParser a
+    -- | Convert from Haskell to XML
+    toContents    :: a -> [Content ()]
+
+    -- | Dummy functions (for most types): used /only/ in the Char instance
+    --   for coercing lists of Char into String.
+    xToChar       :: a -> Char
+    xFromChar     :: Char -> a
+    xToChar        = error "HaXml.XmlContent.xToChar used in error"
+    xFromChar      = error "HaXml.XmlContent.xFromChar used in error"
+
+-- | The @XmlAttributes@ class promises that a list of XML tag attributes
+--   can be converted to and from a Haskell value.
+class XmlAttributes a where
+    fromAttrs :: [Attribute] -> a
+    toAttrs   :: a -> [Attribute]
+-- | The @XmlAttrType@ class promises that an attribute taking an XML
+--   enumerated type can be converted to and from a Haskell value.
+class XmlAttrType a where
+    fromAttrToTyp :: String -> Attribute -> Maybe a
+    toAttrFrTyp   :: String -> a -> Maybe Attribute
+
+
+------------------------------------------------------------------------
+-- Instances for all the standard basic datatypes.
+-- These are for Haskell datatypes being derived to go to XML.
+-- DtdToHaskell does not use these instances.
+------------------------------------------------------------------------
+
+instance XmlContent Bool where
+    toContents b   = [CElem (Elem "bool" [mkAttr "value" (show b)] []) ()]
+    parseContents = do { e <- element ["bool"] ; return (attval e) }
+
+instance XmlContent Int where
+    toContents i   = [CElem (Elem "int" [mkAttr "value" (show i)] []) ()]
+    parseContents = do { e <- element ["int"] ; return (attval e) }
+
+instance XmlContent Integer where
+    toContents i   = [CElem (Elem "integer" [mkAttr "value" (show i)] []) ()]
+    parseContents = do { e <- element ["integer"] ; return (attval e) }
+
+instance XmlContent Float where
+    toContents i   = [CElem (Elem "float" [mkAttr "value" (show i)] []) ()]
+    parseContents = do { e <- element ["float"] ; return (attval e) }
+
+instance XmlContent Double where
+    toContents i   = [CElem (Elem "double" [mkAttr "value" (show i)] []) ()]
+    parseContents = do { e <- element ["double"] ; return (attval e) }
+
+instance XmlContent Char where
+    -- NOT in a string
+    toContents c   = [CElem (Elem "char" [mkAttr "value" [c]] []) ()]
+    parseContents = do { (Elem _ [("value",(AttValue [Left [c]]))] [])
+                             <- element ["char"]
+                       ; return c
+                       }
+    -- Only defined for Char and no other types:
+    xToChar   = id
+    xFromChar = id
+
+instance XmlContent a => XmlContent [a] where
+    toContents xs  = case toHType x of
+                       (Prim "Char" _) ->
+                            [mkElem "string" [CString True (map xToChar xs) ()]]
+                       _ -> [mkElem xs (concatMap toContents xs)]
+                   where   (x:_) = xs
+    parseContents = P (\x ->
+        case x of
+            (CString _ s _:cs)
+                   -> (Right (map xFromChar s), cs)
+            (CElem (Elem "string" [] [CString _ s _]) _:cs)
+                   -> (Right (map xFromChar s), cs)
+            (CElem (Elem e [] xs) _:cs) | "list" `isPrefixOf` e
+                   -> scanElements xs
+                   where
+                  -- scanElements :: [Content] -> (Either String [a],[Content])
+                     scanElements [] = (Right [], cs)
+                     scanElements es =
+                        case runParser parseContents es of
+                            (Left msg, es') -> (Left (False,msg), es')
+                            (Right y, es') ->
+                                case scanElements es' of
+                                    (Left msg, ds) -> (Left msg, ds)
+                                    (Right ys, ds) -> (Right (y:ys), ds)
+            (CElem (Elem e _ _) pos: cs)
+                   -> (Left (False
+                            ,"Expected a <list-...>, but found a <"++e++"> at\n"
+                            ++ show pos), cs)
+            (CRef r pos: cs)
+                   -> (Left (False
+                            ,"Expected a <list-...>, but found a ref "
+                            ++verbatim r++" at\n"++ show pos), cs)
+            (_:cs) -> ((\ (P p)-> p) parseContents) cs  -- skip comments etc.
+            []     -> (Left (False
+                            ,"Ran out of input XML whilst secondary parsing")
+                      , [])
+        )
+
+instance XmlContent () where
+    toContents ()  = [CElem (Elem "unit" [] []) ()]
+    parseContents = do { element ["unit"]; return () }
+
+instance (XmlContent a, XmlContent b) => XmlContent (a,b) where
+    toContents (a,b) = toContents a ++ toContents b
+    parseContents    = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; return (a,b)
+        }
+
+instance (XmlContent a, XmlContent b, XmlContent c) => XmlContent (a,b,c) where
+    toContents (a,b,c) = toContents a ++ toContents b ++ toContents c
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; return (a,b,c)
+        }
+
+instance (XmlContent a, XmlContent b, XmlContent c, XmlContent d) =>
+         XmlContent (a,b,c,d) where
+    toContents (a,b,c,d) = toContents a ++ toContents b ++ toContents c
+                           ++ toContents d
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; return (a,b,c,d)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e ) =>
+         XmlContent (a,b,c,d,e) where
+    toContents (a,b,c,d,e) = toContents a ++ toContents b ++ toContents c
+                             ++ toContents d ++ toContents e
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; return (a,b,c,d,e)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f ) =>
+         XmlContent (a,b,c,d,e,f) where
+    toContents (a,b,c,d,e,f) = toContents a ++ toContents b ++ toContents c
+                               ++ toContents d ++ toContents e ++ toContents f
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; return (a,b,c,d,e,f)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g ) =>
+         XmlContent (a,b,c,d,e,f,g) where
+    toContents (a,b,c,d,e,f,g)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; return (a,b,c,d,e,f,g)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h ) =>
+         XmlContent (a,b,c,d,e,f,g,h) where
+    toContents (a,b,c,d,e,f,g,h)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; return (a,b,c,d,e,f,g,h)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i) where
+    toContents (a,b,c,d,e,f,g,h,i)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i, XmlContent j ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i,j) where
+    toContents (a,b,c,d,e,f,g,h,i,j)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i ++ toContents j
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; j <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i,j)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i, XmlContent j, XmlContent k ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i,j,k) where
+    toContents (a,b,c,d,e,f,g,h,i,j,k)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i ++ toContents j ++ toContents k
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; j <- parseContents
+        ; k <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i,j,k)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i, XmlContent j, XmlContent k, XmlContent l ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i,j,k,l) where
+    toContents (a,b,c,d,e,f,g,h,i,j,k,l)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i ++ toContents j ++ toContents k ++ toContents l
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; j <- parseContents
+        ; k <- parseContents
+        ; l <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i,j,k,l)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i, XmlContent j, XmlContent k, XmlContent l
+         , XmlContent m ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i,j,k,l,m) where
+    toContents (a,b,c,d,e,f,g,h,i,j,k,l,m)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i ++ toContents j ++ toContents k ++ toContents l
+          ++ toContents m
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; j <- parseContents
+        ; k <- parseContents
+        ; l <- parseContents
+        ; m <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i,j,k,l,m)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i, XmlContent j, XmlContent k, XmlContent l
+         , XmlContent m, XmlContent n ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
+    toContents (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i ++ toContents j ++ toContents k ++ toContents l
+          ++ toContents m ++ toContents n
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; j <- parseContents
+        ; k <- parseContents
+        ; l <- parseContents
+        ; m <- parseContents
+        ; n <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i, XmlContent j, XmlContent k, XmlContent l
+         , XmlContent m, XmlContent n, XmlContent o ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
+    toContents (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i ++ toContents j ++ toContents k ++ toContents l
+          ++ toContents m ++ toContents n ++ toContents o
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; j <- parseContents
+        ; k <- parseContents
+        ; l <- parseContents
+        ; m <- parseContents
+        ; n <- parseContents
+        ; o <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)
+        }
+
+instance (XmlContent a) => XmlContent (Maybe a) where
+    toContents m   = [mkElem m (maybe [] toContents m)]
+    parseContents = do
+        { e <- elementWith (flip isPrefixOf) ["maybe"]
+        ; case e of (Elem _ [] []) -> return Nothing
+                    (Elem _ [] _)  -> fmap Just (interior e parseContents)
+        }
+
+instance (XmlContent a, XmlContent b) => XmlContent (Either a b) where
+    toContents v@(Left aa) =
+        [mkElemC (showConstr 0 (toHType v)) (toContents aa)]
+    toContents v@(Right ab) =
+        [mkElemC (showConstr 1 (toHType v)) (toContents ab)]
+    parseContents =
+        (inElementWith (flip isPrefixOf) "Left"  $ fmap Left  parseContents)
+          `onFail`
+        (inElementWith (flip isPrefixOf) "Right" $ fmap Right parseContents)
+
+--    do{ e@(Elem t [] _) <- element ["Left","Right"]
+--      ; case t of
+--          _ | "Left"  `isPrefixOf` t -> fmap Left  (interior e parseContents)
+--            | "Right" `isPrefixOf` t -> fmap Right (interior e parseContents)
+--      }
+
+
+------------------------------------------------------------------------
+-- Useful auxiliaries for "fromAttributes"
+------------------------------------------------------------------------
+
+-- | If an attribute is defaultable, then it either takes the default
+--   value (which is omitted from the output), or a non-default value
+--   (which obviously must be printed).
+data Defaultable a  = Default a    | NonDefault a    deriving (Eq,Show)
+
+searchMaybe :: (a -> Maybe b) -> [a] -> Maybe b
+searchMaybe _ [] = Nothing
+searchMaybe f (x:xs) =
+    let fx = f x in
+    case fx of
+      Nothing  -> searchMaybe f xs
+      (Just _) -> fx
+
+maybeToAttr :: (String->a->Maybe Attribute) -> String -> Maybe a
+               -> Maybe Attribute
+maybeToAttr _ _ Nothing  = Nothing
+maybeToAttr to n (Just v) = to n v
+
+defaultToAttr :: (String->a->Maybe Attribute) -> String -> Defaultable a
+                 -> Maybe Attribute
+defaultToAttr _ _ (Default _)  = Nothing
+defaultToAttr to n (NonDefault v) = to n v
+
+definiteA :: (String->Attribute->Maybe a) -> String -> String
+             -> [Attribute] -> a
+definiteA from tag at as =
+    case searchMaybe (from at) as of
+      Nothing  -> error ("missing attribute "++at++" in tag <"++tag++">")
+      (Just a) -> a
+
+defaultA :: (String->Attribute->Maybe a) -> a -> String
+            -> [Attribute] -> Defaultable a
+defaultA from def at as =
+    case searchMaybe (from at) as of
+      Nothing  -> Default def
+      (Just a) -> NonDefault a
+
+possibleA :: (String->Attribute->Maybe a) -> String -> [Attribute] -> Maybe a
+possibleA from at as = searchMaybe (from at) as
+
+fromAttrToStr :: String -> Attribute -> Maybe String
+fromAttrToStr n (n0,v)
+        | n == n0   = Just (attr2str v)
+        | otherwise = Nothing
+
+toAttrFrStr   :: String -> String -> Maybe Attribute
+toAttrFrStr n v = Just (n, str2attr v)
+
+str2attr :: String -> AttValue
+str2attr s =
+    let f t =
+          let (l,r) = span (\c-> not (elem c "\"&<>'")) t
+          in if null r then [Left l]
+             else Left l: Right (g (head r)): f (tail r)
+        g '"'  = RefEntity "quot"
+        g '&'  = RefEntity "amp"
+        g '<'  = RefEntity "lt"
+        g '>'  = RefEntity "gt"
+        g '\'' = RefEntity "apos"
+    in AttValue (f s)
+
+attr2str :: AttValue -> String          -- really needs symbol table
+attr2str (AttValue xs) =
+    let f (Left s) = s
+        f (Right (RefChar i))        = [chr i]
+        f (Right (RefEntity "quot")) = "\""
+        f (Right (RefEntity "amp"))  = "&"
+        f (Right (RefEntity "lt"))   = "<"
+        f (Right (RefEntity "gt"))   = ">"
+        f (Right (RefEntity "apos")) = "'"
+        f (Right _)                  = "*"  -- Ooops, ST needed here.
+    in concatMap f xs
+
+------------------------------------------------------------------------
+--  New content-model types
+------------------------------------------------------------------------
+
+{-
+data OneOf2 a b
+data OneOf3 a b c
+data OneOf4 a b c d
+    ... etc are now defined (with instances) in module OneOfN.
+-}
+
+-- | A type corresponding to XML's ANY contentspec.
+--   It is either a list of unconverted xml 'Content'
+--   or some 'XmlContent'-able value.
+--
+-- Parsing functions (e.g. 'parseContents') will always produce 'UnConverted'.
+-- Note: The Show instance for 'UnConverted' uses 'verbatim'.
+data ANYContent = forall a . (XmlContent a, Show a) => ANYContent a
+                | UnConverted [Content Posn]
+
+instance Show ANYContent where
+    show (UnConverted c) = "UnConverted " ++ (show $ map verbatim c)
+    show (ANYContent a)  = "ANYContent " ++ (show a)
+
+instance Eq ANYContent where
+    a == b = show a == show b
+
+-- | The List1 type represents lists with at least one element.
+--   It is required for DTD content models that use + as a modifier.
+data List1 a = NonEmpty [a]  deriving (Eq, Show)
+
+
+------------------------------------------------------------------------
+--  Instances for new content-model types
+------------------------------------------------------------------------
+instance (HTypeable a) => HTypeable (List1 a) where
+    toHType m  = Defined "List1" [hx]
+                         [Constr "NonEmpty" [hx] [List hx] {-Nothing-}]
+               where (NonEmpty x) = m
+                     hx = toHType x
+instance (XmlContent a) => XmlContent (List1 a) where
+    toContents (NonEmpty xs) = concatMap toContents xs
+    parseContents = fmap NonEmpty $ many1 parseContents
+
+instance HTypeable ANYContent where
+    toHType _      = Prim "ANYContent" "ANY"
+instance XmlContent ANYContent where
+    toContents (ANYContent a)  = toContents a
+    toContents (UnConverted s) = map (fmap (const ())) s
+    parseContents = P (\cs -> (Right (UnConverted cs), []))
+
+------------------------------------------------------------------------
+--
+------------------------------------------------------------------------
+

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Xtract/Combinators.html b/docs/HaXml/src/Text/XML/HaXml/Xtract/Combinators.html
--- a/docs/HaXml/src/Text/XML/HaXml/Xtract/Combinators.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Xtract/Combinators.html
@@ -1,108 +1,114 @@
 
 
-
-- | This is a new set of XML combinators for Xtract, not standard,
---   but based on the standard set in "Text.Xml.Haxml.Combinators".
---   The main difference is that the Content Filter type becomes a
---   Double Filter.  A Double Filter always takes the whole document
---   as an extra argument, so you can start to traverse it again from
---   the root, when at any inner location within the document tree.
---
---   The new combinator definitions are derived from the old ones.
---   The same names have the equivalent meaning - use module qualification
---   on imports to distinguish between CFilter and DFilter variations.
-
-module Text.XML.HaXml.Xtract.Combinators where
-
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.Combinators (CFilter)
-import qualified Text.XML.HaXml.Combinators as C
-
-
--- | double content filter - takes document root + local subtree.
-type DFilter i = Content i -> Content i -> [Content i]
-
--- | lift an ordinary content filter to a double filter.
-local,global :: CFilter i -> DFilter i
-local  f = \xml sub-> f sub
-global f = \xml sub-> f xml
-
--- | drop a double filter to an ordinary content filter.
---   (permitting interior access to document root)
-dfilter :: DFilter i -> CFilter i
-dfilter f = \xml-> f xml xml
-
--- | drop a double filter to an ordinary content filter.
---   (Where interior access to the document root is not needed, the
---    retaining pointer to the outer element can be pruned away.
---   'cfilter' is more space-efficient than 'dfilter' in this situation.)
-cfilter :: DFilter i -> CFilter i
-cfilter f = \xml -> f undefined xml
---cfilter f = \xml-> flip f xml
---                          (case xml of
---                             CElem (Elem n as cs) i -> CElem (Elem n [] []) i
---                             _ -> xml)
-
--- | lift a CFilter combinator to a DFilter combinator
-liftLocal, liftGlobal :: (CFilter i->CFilter i) -> (DFilter i->DFilter i)
-liftLocal  ff = \df-> \xml sub-> (ff (df xml)) sub
-liftGlobal ff = \df-> \xml sub-> (ff (df xml)) xml
-
--- | lifted composition over double filters.
-o :: DFilter i -> DFilter i -> DFilter i
-g `o` f = \xml-> concatMap (g xml) . (f xml)
-
--- | lifted choice.
-(|>|) :: (a->b->[c]) -> (a->b->[c]) -> (a->b->[c])
-f |>| g = \xml sub-> let first = f xml sub in
-                     if null first then g xml sub else first
-
--- | lifted union.
-union :: (a->b->[c]) -> (a->b->[c]) -> (a->b->[c])
-union = lift (++)
-  where
-    lift f g h = \x y-> f (g x y) (h x y)
-
--- | lifted predicates.
-with, without :: DFilter i -> DFilter i -> DFilter i
-f `with` g    = \xml-> filter (not.null.g xml) . f xml
-f `without` g = \xml-> filter     (null.g xml) . f xml
-
--- | lifted unit and zero.
-keep, none :: DFilter i
-keep = \xml sub-> [sub]	-- local C.keep
-none = \xml sub-> []	-- local C.none
-
-children, elm, txt :: DFilter i
-children = local C.children
-elm      = local C.elm
-txt      = local C.txt
-
-applypred :: CFilter i -> DFilter i -> CFilter i
-applypred f p = \xml-> (const f `with` p) xml xml
-
-iffind :: String -> (String -> DFilter i) -> DFilter i -> DFilter i
-iffind key yes no xml c@(CElem (Elem _ as _) _) =
-  case (lookup key as) of
-    Nothing -> no xml c
-    (Just v@(AttValue _)) -> yes (show v) xml c
-iffind key yes no xml other = no xml other
-
-ifTxt :: (String->DFilter i) -> DFilter i -> DFilter i
-ifTxt yes no xml c@(CString _ s _) = yes s xml c
-ifTxt yes no xml c                 = no xml c
-
-cat :: [a->b->[c]] -> (a->b->[c])
-cat fs = \xml sub-> concat [ f xml sub | f <- fs ]
-
-(/>) :: DFilter i -> DFilter i -> DFilter i
-f /> g = g `o` children `o` f
-
-(</) :: DFilter i -> DFilter i -> DFilter i
-f </ g = f `with` (g `o` children)
-
-deep, deepest, multi :: DFilter i -> DFilter i
-deep f    = f |>| (deep f `o` children)
-deepest f = (deepest f `o` children) |>| f
-multi f   = f `union` (multi f `o` children)
+
+
+src/Text/XML/HaXml/Xtract/Combinators.hs
+
+
+
-- | This is a new set of XML combinators for Xtract, not standard,
+--   but based on the standard set in "Text.Xml.Haxml.Combinators".
+--   The main difference is that the Content Filter type becomes a
+--   Double Filter.  A Double Filter always takes the whole document
+--   as an extra argument, so you can start to traverse it again from
+--   the root, when at any inner location within the document tree.
+--
+--   The new combinator definitions are derived from the old ones.
+--   The same names have the equivalent meaning - use module qualification
+--   on imports to distinguish between CFilter and DFilter variations.
+
+module Text.XML.HaXml.Xtract.Combinators where
+
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.Combinators (CFilter)
+import qualified Text.XML.HaXml.Combinators as C
+
+
+-- | double content filter - takes document root + local subtree.
+type DFilter i = Content i -> Content i -> [Content i]
+
+-- | lift an ordinary content filter to a double filter.
+local,global :: CFilter i -> DFilter i
+local  f = \xml sub-> f sub
+global f = \xml sub-> f xml
+
+-- | drop a double filter to an ordinary content filter.
+--   (permitting interior access to document root)
+dfilter :: DFilter i -> CFilter i
+dfilter f = \xml-> f xml xml
+
+-- | drop a double filter to an ordinary content filter.
+--   (Where interior access to the document root is not needed, the
+--    retaining pointer to the outer element can be pruned away.
+--   'cfilter' is more space-efficient than 'dfilter' in this situation.)
+cfilter :: DFilter i -> CFilter i
+cfilter f = \xml -> f undefined xml
+--cfilter f = \xml-> flip f xml
+--                          (case xml of
+--                             CElem (Elem n as cs) i -> CElem (Elem n [] []) i
+--                             _ -> xml)
+
+-- | lift a CFilter combinator to a DFilter combinator
+liftLocal, liftGlobal :: (CFilter i->CFilter i) -> (DFilter i->DFilter i)
+liftLocal  ff = \df-> \xml sub-> (ff (df xml)) sub
+liftGlobal ff = \df-> \xml sub-> (ff (df xml)) xml
+
+-- | lifted composition over double filters.
+o :: DFilter i -> DFilter i -> DFilter i
+g `o` f = \xml-> concatMap (g xml) . (f xml)
+
+-- | lifted choice.
+(|>|) :: (a->b->[c]) -> (a->b->[c]) -> (a->b->[c])
+f |>| g = \xml sub-> let first = f xml sub in
+                     if null first then g xml sub else first
+
+-- | lifted union.
+union :: (a->b->[c]) -> (a->b->[c]) -> (a->b->[c])
+union = lift (++)
+  where
+    lift f g h = \x y-> f (g x y) (h x y)
+
+-- | lifted predicates.
+with, without :: DFilter i -> DFilter i -> DFilter i
+f `with` g    = \xml-> filter (not.null.g xml) . f xml
+f `without` g = \xml-> filter     (null.g xml) . f xml
+
+-- | lifted unit and zero.
+keep, none :: DFilter i
+keep = \xml sub-> [sub]	-- local C.keep
+none = \xml sub-> []	-- local C.none
+
+children, elm, txt :: DFilter i
+children = local C.children
+elm      = local C.elm
+txt      = local C.txt
+
+applypred :: CFilter i -> DFilter i -> CFilter i
+applypred f p = \xml-> (const f `with` p) xml xml
+
+iffind :: String -> (String -> DFilter i) -> DFilter i -> DFilter i
+iffind key yes no xml c@(CElem (Elem _ as _) _) =
+  case (lookup key as) of
+    Nothing -> no xml c
+    (Just v@(AttValue _)) -> yes (show v) xml c
+iffind key yes no xml other = no xml other
+
+ifTxt :: (String->DFilter i) -> DFilter i -> DFilter i
+ifTxt yes no xml c@(CString _ s _) = yes s xml c
+ifTxt yes no xml c                 = no xml c
+
+cat :: [a->b->[c]] -> (a->b->[c])
+cat fs = \xml sub-> concat [ f xml sub | f <- fs ]
+
+(/>) :: DFilter i -> DFilter i -> DFilter i
+f /> g = g `o` children `o` f
+
+(</) :: DFilter i -> DFilter i -> DFilter i
+f </ g = f `with` (g `o` children)
+
+deep, deepest, multi :: DFilter i -> DFilter i
+deep f    = f |>| (deep f `o` children)
+deepest f = (deepest f `o` children) |>| f
+multi f   = f `union` (multi f `o` children)
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Xtract/Lex.html b/docs/HaXml/src/Text/XML/HaXml/Xtract/Lex.html
--- a/docs/HaXml/src/Text/XML/HaXml/Xtract/Lex.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Xtract/Lex.html
@@ -1,132 +1,138 @@
 
 
-
-- | This is another hand-written lexer, this time for the Xtract
---   command-language.  The entry point is lexXtract.  You don't
---   normally need to use this module directly - the lexer is called
---   automatically by the parser.  (We only expose this interface
---   for debugging purposes.)
---
---   The Xtract command language is very like the XPath specification.
-
-module Text.XML.HaXml.Xtract.Lex
-  ( lexXtract
-  , Posn(..)
-  , TokenT(..)
-  , Token
-  ) where
-
-import Char
-import List(isPrefixOf)
-
-
-type Token = Either String (Posn, TokenT)
-
-data Posn = Pn Int		-- char index only
-        deriving Eq
-
-instance Show Posn where
-      showsPrec p (Pn c) = showString "char pos " . shows c
-
-data TokenT =
-      Symbol String
-    | TokString String		--     begins with letter
-    | TokNum Integer		--     begins with digit
-    deriving Eq
-
-instance Show TokenT where
-    showsPrec p (Symbol s) = showString s
-    showsPrec p (TokString s) = showString s
-    showsPrec p (TokNum n) = shows n
-
-emit :: TokenT -> Posn -> Token
-emit tok p = forcep p `seq` Right (p,tok)
-  where forcep (Pn n) = n
-
-lexerror :: String -> Posn -> [Token]
-lexerror s p = [Left ("Lexical error in selection pattern at "++show p++": "
-                       ++s++"\n")]
-
-addcol :: Int -> Posn -> Posn
-addcol n (Pn c) = Pn (c+n)
-
-newline, tab :: Posn -> Posn
-newline (Pn c) = Pn (c+1)
-tab     (Pn c) = Pn (((c`div`8)+1)*8)
-
-white :: Char -> Posn -> Posn
-white '\t' = tab
-white ' '  = addcol 1
-white '\n' = addcol 1
-white '\r' = addcol 1
-white '\xa0' = addcol 1
-
-blank :: (Posn->String->[Token]) -> Posn-> String-> [Token]
-blank k p []       = []
-blank k p (' ': s) = blank k (addcol 1 p) s
-blank k p ('\t':s) = blank k (tab p) s
-blank k p ('\n':s) = blank k (newline p) s
-blank k p ('\r':s) = blank k p s
-blank k p ('\xa0': s) = blank k (addcol 1 p) s
-blank k p    s     = k p s
-
-----
--- | First argument is a transformer for pattern strings, e.g. map toLower,
---   but only applying to parts of the pattern not in quotation marks.
---   (Needed to canonicalise HTML where tags are case-insensitive, but
---   attribute values are case sensitive.)
-lexXtract :: (String->String) -> String -> [Token]
-lexXtract f = selAny f (Pn 1)
-
-syms = "/[]()@,=*&|~$+-<>"
-
-selAny :: (String->String) -> Posn -> String -> [Token]
-selAny f p [] = []
-selAny f p ('/':'/':ss) = emit (Symbol "//") p:  selAny f (addcol 2 p) ss
-selAny f p ('!':'=':ss) = emit (Symbol "!=") p:  selAny f (addcol 2 p) ss
-selAny f p ('<':'=':ss) = emit (Symbol "<=") p:  selAny f (addcol 2 p) ss
-selAny f p ('>':'=':ss) = emit (Symbol ">=") p:  selAny f (addcol 2 p) ss
-selAny f p ('\'':ss)    = emit (Symbol "'") p:
-                          accumulateUntil '\'' (Symbol "'") [] p (addcol 1 p) ss
-                                          (selAny f)
-selAny f p ('"':ss)     = emit (Symbol "\"") p:
-                          accumulateUntil '"' (Symbol "\"") [] p (addcol 1 p) ss
-                                          (selAny f)
-selAny f p ('_':ss)     = gatherName f "_" p (addcol 1 p) ss (blank (selAny f))
-selAny f p (':':ss)     = gatherName f ":" p (addcol 1 p) ss (blank (selAny f))
-selAny f p ('.':'=':'.':ss) = emit (Symbol ".=.") p:  selAny f (addcol 3 p) ss
-selAny f p ('.':'!':'=':'.':ss)
-                            = emit (Symbol ".!=.") p: selAny f (addcol 4 p) ss
-selAny f p ('.':'<':'.':ss) = emit (Symbol ".<.") p:  selAny f (addcol 3 p) ss
-selAny f p ('.':'<':'=':'.':ss)
-                            = emit (Symbol ".<=.") p: selAny f (addcol 4 p) ss
-selAny f p ('.':'>':'.':ss) = emit (Symbol ".>.") p:  selAny f (addcol 3 p) ss
-selAny f p ('.':'>':'=':'.':ss)
-                            = emit (Symbol ".>=.") p: selAny f (addcol 4 p) ss
-selAny f p ('.':'/':ss)     = emit (Symbol "./") p:  selAny f (addcol 2 p) ss
-selAny f p (s:ss)
-    | s `elem` syms   = emit (Symbol [s]) p:     selAny f (addcol 1 p) ss
-    | isSpace s       = blank (selAny f) p (s:ss)
-    | isAlpha s       = gatherName f [s] p (addcol 1 p) ss (blank (selAny f))
-    | isDigit s       = gatherNum    [s] p (addcol 1 p) ss (blank (selAny f))
-    | otherwise       = lexerror "unrecognised pattern" p
-
-gatherName f acc pos p (s:ss) k
-  | isAlphaNum s || s `elem` "-_:" = gatherName f (s:acc) pos (addcol 1 p) ss k
-gatherName f acc pos p ss k =
-  emit (TokString (f (reverse acc))) pos: k p ss
-
-gatherNum acc pos p (s:ss) k
-  | isHexDigit s = gatherNum (s:acc) pos (addcol 1 p) ss k
-gatherNum acc pos p ss k =
-  emit (TokNum (read (reverse acc))) pos: k p ss
-
-accumulateUntil c tok acc pos  p  [] k =
-    lexerror ("found end of pattern while looking for "++c
-              :" to match opening quote at "++show pos) p
-accumulateUntil c tok acc pos  p (s:ss) k
-    | c==s       = emit (TokString (reverse acc)) pos:
-                                  emit tok p: k (addcol 1 p) ss
-    | isSpace s  = accumulateUntil c tok (s:acc) pos (white s p) ss k
-    | otherwise  = accumulateUntil c tok (s:acc) pos (addcol 1 p) ss k
+
+
+src/Text/XML/HaXml/Xtract/Lex.hs
+
+
+
-- | This is another hand-written lexer, this time for the Xtract
+--   command-language.  The entry point is lexXtract.  You don't
+--   normally need to use this module directly - the lexer is called
+--   automatically by the parser.  (We only expose this interface
+--   for debugging purposes.)
+--
+--   The Xtract command language is very like the XPath specification.
+
+module Text.XML.HaXml.Xtract.Lex
+  ( lexXtract
+  , Posn(..)
+  , TokenT(..)
+  , Token
+  ) where
+
+import Char
+import List(isPrefixOf)
+
+
+type Token = Either String (Posn, TokenT)
+
+data Posn = Pn Int		-- char index only
+        deriving Eq
+
+instance Show Posn where
+      showsPrec p (Pn c) = showString "char pos " . shows c
+
+data TokenT =
+      Symbol String
+    | TokString String		--     begins with letter
+    | TokNum Integer		--     begins with digit
+    deriving Eq
+
+instance Show TokenT where
+    showsPrec p (Symbol s) = showString s
+    showsPrec p (TokString s) = showString s
+    showsPrec p (TokNum n) = shows n
+
+emit :: TokenT -> Posn -> Token
+emit tok p = forcep p `seq` Right (p,tok)
+  where forcep (Pn n) = n
+
+lexerror :: String -> Posn -> [Token]
+lexerror s p = [Left ("Lexical error in selection pattern at "++show p++": "
+                       ++s++"\n")]
+
+addcol :: Int -> Posn -> Posn
+addcol n (Pn c) = Pn (c+n)
+
+newline, tab :: Posn -> Posn
+newline (Pn c) = Pn (c+1)
+tab     (Pn c) = Pn (((c`div`8)+1)*8)
+
+white :: Char -> Posn -> Posn
+white '\t' = tab
+white ' '  = addcol 1
+white '\n' = addcol 1
+white '\r' = addcol 1
+white '\xa0' = addcol 1
+
+blank :: (Posn->String->[Token]) -> Posn-> String-> [Token]
+blank k p []       = []
+blank k p (' ': s) = blank k (addcol 1 p) s
+blank k p ('\t':s) = blank k (tab p) s
+blank k p ('\n':s) = blank k (newline p) s
+blank k p ('\r':s) = blank k p s
+blank k p ('\xa0': s) = blank k (addcol 1 p) s
+blank k p    s     = k p s
+
+----
+-- | First argument is a transformer for pattern strings, e.g. map toLower,
+--   but only applying to parts of the pattern not in quotation marks.
+--   (Needed to canonicalise HTML where tags are case-insensitive, but
+--   attribute values are case sensitive.)
+lexXtract :: (String->String) -> String -> [Token]
+lexXtract f = selAny f (Pn 1)
+
+syms = "/[]()@,=*&|~$+-<>"
+
+selAny :: (String->String) -> Posn -> String -> [Token]
+selAny f p [] = []
+selAny f p ('/':'/':ss) = emit (Symbol "//") p:  selAny f (addcol 2 p) ss
+selAny f p ('!':'=':ss) = emit (Symbol "!=") p:  selAny f (addcol 2 p) ss
+selAny f p ('<':'=':ss) = emit (Symbol "<=") p:  selAny f (addcol 2 p) ss
+selAny f p ('>':'=':ss) = emit (Symbol ">=") p:  selAny f (addcol 2 p) ss
+selAny f p ('\'':ss)    = emit (Symbol "'") p:
+                          accumulateUntil '\'' (Symbol "'") [] p (addcol 1 p) ss
+                                          (selAny f)
+selAny f p ('"':ss)     = emit (Symbol "\"") p:
+                          accumulateUntil '"' (Symbol "\"") [] p (addcol 1 p) ss
+                                          (selAny f)
+selAny f p ('_':ss)     = gatherName f "_" p (addcol 1 p) ss (blank (selAny f))
+selAny f p (':':ss)     = gatherName f ":" p (addcol 1 p) ss (blank (selAny f))
+selAny f p ('.':'=':'.':ss) = emit (Symbol ".=.") p:  selAny f (addcol 3 p) ss
+selAny f p ('.':'!':'=':'.':ss)
+                            = emit (Symbol ".!=.") p: selAny f (addcol 4 p) ss
+selAny f p ('.':'<':'.':ss) = emit (Symbol ".<.") p:  selAny f (addcol 3 p) ss
+selAny f p ('.':'<':'=':'.':ss)
+                            = emit (Symbol ".<=.") p: selAny f (addcol 4 p) ss
+selAny f p ('.':'>':'.':ss) = emit (Symbol ".>.") p:  selAny f (addcol 3 p) ss
+selAny f p ('.':'>':'=':'.':ss)
+                            = emit (Symbol ".>=.") p: selAny f (addcol 4 p) ss
+selAny f p ('.':'/':ss)     = emit (Symbol "./") p:  selAny f (addcol 2 p) ss
+selAny f p (s:ss)
+    | s `elem` syms   = emit (Symbol [s]) p:     selAny f (addcol 1 p) ss
+    | isSpace s       = blank (selAny f) p (s:ss)
+    | isAlpha s       = gatherName f [s] p (addcol 1 p) ss (blank (selAny f))
+    | isDigit s       = gatherNum    [s] p (addcol 1 p) ss (blank (selAny f))
+    | otherwise       = lexerror "unrecognised pattern" p
+
+gatherName f acc pos p (s:ss) k
+  | isAlphaNum s || s `elem` "-_:" = gatherName f (s:acc) pos (addcol 1 p) ss k
+gatherName f acc pos p ss k =
+  emit (TokString (f (reverse acc))) pos: k p ss
+
+gatherNum acc pos p (s:ss) k
+  | isHexDigit s = gatherNum (s:acc) pos (addcol 1 p) ss k
+gatherNum acc pos p ss k =
+  emit (TokNum (read (reverse acc))) pos: k p ss
+
+accumulateUntil c tok acc pos  p  [] k =
+    lexerror ("found end of pattern while looking for "++c
+              :" to match opening quote at "++show pos) p
+accumulateUntil c tok acc pos  p (s:ss) k
+    | c==s       = emit (TokString (reverse acc)) pos:
+                                  emit tok p: k (addcol 1 p) ss
+    | isSpace s  = accumulateUntil c tok (s:acc) pos (white s p) ss k
+    | otherwise  = accumulateUntil c tok (s:acc) pos (addcol 1 p) ss k
 

+
 
diff --git a/docs/HaXml/src/Text/XML/HaXml/Xtract/Parse.html b/docs/HaXml/src/Text/XML/HaXml/Xtract/Parse.html
--- a/docs/HaXml/src/Text/XML/HaXml/Xtract/Parse.html
+++ b/docs/HaXml/src/Text/XML/HaXml/Xtract/Parse.html
@@ -1,421 +1,427 @@
 
 
-
-- | A parser for the Xtract command-language.  (The string input is
---   tokenised internally by the lexer 'lexXtract'.)
---   See <http://www.haskell.org/HaXml/Xtract.html> for the grammar that
---   is accepted.
-
---   Because the original Xtract grammar was left-recursive, we have
---   transformed it into a non-left-recursive form.
-module Text.XML.HaXml.Xtract.Parse (parseXtract,xtract) where
-
-import Text.ParserCombinators.Poly hiding (bracket)
-import Text.XML.HaXml.Xtract.Lex
-import Text.XML.HaXml.Xtract.Combinators as D
-import Text.XML.HaXml.Combinators as C
-import Text.XML.HaXml.Types (Content)
-import List(isPrefixOf)
-import Text.XML.HaXml.Escape (xmlUnEscapeContent,stdXmlEscaper)
-
--- output transformer - to ensure that text/references are glued together
-unescape = xmlUnEscapeContent stdXmlEscaper
-
-
--- | To convert an Xtract query into an ordinary HaXml combinator expression.
---   First arg is a tag-transformation function (e.g. map toLower) applied
----  before matching.  Second arg is the query string.
-xtract :: (String->String) -> String -> CFilter i
-xtract f query
-    | interiorRef lexedQ = dfilter (parseXtract lexedQ)
-    | otherwise          = cfilter (parseXtract lexedQ)
-  where
-    lexedQ = lexXtract f query
-    -- test whether query has interior reference to doc root
-    interiorRef (Right (_,Symbol s): Right (_,Symbol "//"): _)
-                                          | s `elem` predicateIntro = True
-    interiorRef (Right (_,Symbol s): Right (_,Symbol "/"): _)
-                                          | s `elem` predicateIntro = True
-    interiorRef (_ : rest) = interiorRef rest
-    interiorRef [] = False
-    predicateIntro = [ "[", "("
-                     ,  "&",   "|",  "~"
-                     ,  "=",  "!=",  "<",  "<=",  ">",  ">="
-                     , ".=.",".!=.",".<.",".<=.",".>.",".>=." ]
-
--- | The cool thing is that the Xtract command parser directly builds
---   a higher-order 'DFilter' (see "Text.XML.HaXml.Xtract.Combinators")
---   which can be applied to an XML document without further ado.
---   (@parseXtract@ halts the program if a parse error is found.)
-parseXtract :: [Token] -> DFilter i
-parseXtract = either error id . parseXtract'
-
--- | @parseXtract'@ returns error messages through the Either type.
-parseXtract' :: [Token] -> Either String (DFilter i)
-parseXtract' = fst . runParser (aquery liftLocal)
-
----- Auxiliary Parsing Functions ----
-type XParser a = Parser (Either String (Posn,TokenT)) a
-
-string :: XParser String
-string = P (\inp -> case inp of
-                (Left err: _) -> (Left (False,err), inp)
-                (Right (p,TokString n):ts) -> (Right n, ts)
-                ts -> (Left (False,"expected a string"), ts) )
-number :: XParser Integer
-number = P (\inp -> case inp of
-                (Left err: _) -> (Left (False,err), inp)
-                (Right (p,TokNum n):ts) -> (Right n, ts)
-                ts -> (Left (False,"expected a number"), ts) )
-symbol :: String -> XParser ()
-symbol s = P (\inp -> case inp of
-                (Left err: _) -> (Left (False,err), inp)
-                (Right (p, Symbol n):ts) | n==s -> (Right (), ts)
-                ts -> (Left (False,"expected symbol "++s), ts) )
-
-quote = oneOf [ symbol "'",  symbol "\"" ]
-
-pam fs x = [ f x | f <- fs ]
-
-
-{--- original Xtract grammar ----
-      query     = string			tagname
-                | string *			tagname prefix
-                | * string			tagname suffix
-                | *				any element
-                | -				chardata
-                | ( query )
-                | query / query			parent/child relationship
-                | query // query		deep inside
-                | query + query			union of queries
-                | query [predicate]
-                | query [positions]
-
-      predicate = quattr			has attribute
-                | quattr op ' string '		attribute has value
-                | quattr op " string "		attribute has value
-                | quattr op  quattr		attribute value comparison (lexical)
-                | quattr nop integer  		attribute has value (numerical)
-                | quattr nop quattr		attribute value comparison (numerical)
-                | ( predicate )			bracketting
-                | predicate & predicate		logical and
-                | predicate | predicate		logical or
-                | ~ predicate			logical not
-
-      attribute = @ string			has attribute
-                | query / @ string		child has attribute
-                | -				has textual content
-                | query / -			child has textual content
-
-      quattr    = query
-                | attribute
-
-      op        =  =				equal to
-                |  !=				not equal to
-                |  <				less than
-                |  <=				less than or equal to
-                |  >				greater than
-                |  >=				greater than or equal to
-
-      nop       =  .=.				equal to
-                |  .!=.				not equal to
-                |  .<.				less than
-                |  .<=.				less than or equal to
-                |  .>.				greater than
-                |  .>=.				greater than or equal to
-
-      positions = position {, positions}	multiple positions
-                | position - position		ranges
-
-      position  = integer			numbering is from 0 upwards
-                | $				last
-
-
----- transformed grammar (removing left recursion)
-      aquery = ./ tquery	-- current context
-             | tquery		-- also current context
-             | / tquery		-- root context
-             | // tquery	-- deep context from root
-
-      tquery = ( tquery ) xquery
-             | tag xquery
-             | -		-- fixes original grammar ("-/*" is incorrect)
-      
-      tag    = string *
-             | string
-             | * string
-             | *
-      
-      xquery = / tquery
-             | // tquery
-             | / @ string	-- new: print attribute value
-             | + tquery
-             | [ tpredicate ] xquery
-             | [ positions ] xquery
-             | lambda
-
-      tpredicate = vpredicate upredicate
-      upredicate = & tpredicate
-                 | | tpredicate
-                 | lambda
-      vpredicate = ( tpredicate )
-                 | ~ tpredicate
-                 | tattribute
-
-      tattribute = aquery uattribute
-                 | @ string vattribute
-      uattribute = / @ string vattribute
-                 | vattribute
-      vattribute = op wattribute
-                 | op ' string '
-                 | nop wattribute
-                 | nop integer
-                 | lambda
-      wattribute = @ string
-                 | aquery / @ string
-                 | aquery
-
-      positions  = simplepos commapos
-      simplepos  = integer range
-                 | $
-      range      = - integer
-                 | - $
-                 | lambda
-      commapos   = , simplepos commapos
-                 | lambda
-
-      op         =  =
-                 |  !=
-                 |  <
-                 |  <=
-                 |  >
-                 |  >=
-
-      nop        =  .=.
-                 |  .!=.
-                 |  .<.
-                 |  .<=.
-                 |  .>.
-                 |  .>=.
--}
-
-bracket :: XParser a -> XParser a
-bracket p =
-  do symbol "("
-     x <- p
-     symbol ")"
-     return x
-
-
----- Xtract parsers ----
-
--- aquery chooses to search from the root, or only in local context
-aquery ::  ((CFilter i->CFilter i) -> (DFilter i->DFilter i))
-           -> XParser (DFilter i)
-aquery lift = oneOf
-    [ do symbol "//"
-         tquery [lift C.multi]
-    , do symbol "/"
-         tquery [lift id]
-    , do symbol "./"
-         tquery [(local C.keep D./>)]
-    , do tquery [(local C.keep D./>)]
-    ]
-
-tquery :: [DFilter i->DFilter i] -> XParser (DFilter i)
-tquery [] = tquery [id]
-tquery (qf:cxt) = oneOf
-    [ do q <- bracket (tquery (qf:qf:cxt))
-         xquery cxt q
-    , do q <- xtag
-         xquery cxt (qf ((unescape .).q))	-- glue inners texts together
-    , do symbol "-"
-         return (qf (local C.txt))
-    ]
-
-xtag :: XParser (DFilter i)
-xtag = oneOf
-    [ do s <- string
-         symbol "*"
-         return (local (C.tagWith (s `isPrefixOf`)))
-    , do s <- string
-         return (local (C.tag s))
-    , do symbol "*"
-         s <- string
-         return (local (C.tagWith (((reverse s) `isPrefixOf`) . reverse)))
-    , do symbol "*"
-         return (local C.elm)
-    ]
-
-
-xquery :: [DFilter i->DFilter i] -> DFilter i -> XParser (DFilter i)
-xquery cxt q1 = oneOf
-    [ do symbol "/"
-         ( do symbol "@"
-              attr <- string
-              return (D.iffind attr (\s->local (C.literal s)) D.none `D.o` q1)
-           `onFail`
-           tquery ((q1 D./>):cxt) )
-    , do symbol "//"
-         tquery ((\q2-> (liftLocal C.multi) q2
-                            `D.o` local C.children `D.o` q1):cxt)
-    , do symbol "+"
-         q2 <- tquery cxt
-         return (D.cat [q1,q2])
-    , do symbol "["
-         is <- iindex	-- now extended to multiple indexes
-         symbol "]"
-         xquery cxt (\xml-> concat . pam is . q1 xml)
-    , do symbol "["
-         p <- tpredicate
-         symbol "]"
-         xquery cxt (q1 `D.with` p)
-    , return q1
-    ]
-
-tpredicate :: XParser (DFilter i)
-tpredicate =
-  do p <- vpredicate
-     f <- upredicate
-     return (f p)
-
-upredicate :: XParser (DFilter i->DFilter i)
-upredicate = oneOf
-    [ do symbol "&"
-         p2 <- tpredicate
-         return (`D.o` p2)
-    , do symbol "|"
-         p2 <- tpredicate
-         return (D.|>| p2)
-    , return id
-    ]
-
-vpredicate :: XParser (DFilter i)
-vpredicate = oneOf
-    [ do bracket tpredicate
-    , do symbol "~"
-         p <- tpredicate
-         return (local C.keep `D.without` p)
-    , do tattribute
-    ]
-
-tattribute :: XParser (DFilter i)
-tattribute = oneOf
-    [ do q <- aquery liftGlobal
-         uattribute q
-    , do symbol "@"
-         s <- string
-         vattribute (local C.keep, local (C.attr s), D.iffind s)
-    ]
-
-uattribute :: DFilter i -> XParser (DFilter i)
-uattribute q = oneOf
-    [ do symbol "/"
-         symbol "@"
-         s <- string
-         vattribute (q, local (C.attr s), D.iffind s)
-    , do vattribute (q, local C.keep,     D.ifTxt)
-    ]
-
-vattribute :: (DFilter i, DFilter i, (String->DFilter i)->DFilter i->DFilter i)
-              -> XParser (DFilter i)
-vattribute (q,a,iffn) = oneOf
-  [ do cmp <- op
-       quote
-       s2 <- string
-       quote
-       return ((iffn (\s1->if cmp s1 s2 then D.keep else D.none) D.none)
-               `D.o` q)
-  , do cmp <- op
-       (q2,iffn2) <- wattribute
-       return ((iffn (\s1-> iffn2 (\s2-> if cmp s1 s2 then D.keep else D.none)
-                                  D.none)
-                     D.none) `D.o` q)
-  , do cmp <- nop
-       n <- number
-       return ((iffn (\s->if cmp (read s) n then D.keep else D.none) D.none)
-               `D.o` q)
-  , do cmp <- nop
-       (q2,iffn2) <- wattribute
-       return ((iffn (\s1-> iffn2 (\s2-> if cmp (read s1) (read s2) then D.keep
-                                                                    else D.none)
-                                  D.none)
-                     D.none) `D.o` q)
-  , do return ((a `D.o` q))
-  ]
-
-wattribute :: XParser (DFilter i, (String->DFilter i)->DFilter i->DFilter i)
-wattribute = oneOf
-    [ do symbol "@"
-         s <- string
-         return (D.keep, D.iffind s)
-    , do q <- aquery liftGlobal
-         symbol "/"
-         symbol "@"
-         s <- string
-         return (q, D.iffind s)
-    , do q <- aquery liftGlobal
-         return (q, D.ifTxt)
-    ]
-
-
-iindex :: XParser [[a]->[a]]
-iindex =
-    do i <- simpleindex
-       is <- idxcomma
-       return (i:is)
-
-simpleindex :: XParser ([a]->[a])
-simpleindex = oneOf
-    [ do n <- number
-         r <- rrange n
-         return r
-    , do symbol "$"
-         return (C.keep . last)
-    ]
-
-rrange, numberdollar :: Integer -> XParser ([a]->[a])
-rrange n1 = oneOf
-    [ do symbol "-"
-         numberdollar n1
-    , return (C.keep.(!!(fromInteger n1)))
-    ]
-
-numberdollar n1 = oneOf
-    [ do n2 <- number
-         return (take (fromInteger (1+n2-n1)) . drop (fromInteger n1))
-    , do symbol "$"
-         return (drop (fromInteger n1))
-    ]
-
-idxcomma :: XParser [[a]->[a]]
-idxcomma = oneOf
-    [ do symbol ","
-         r <- simpleindex
-         rs <- idxcomma
-         return (r:rs)
-    , return []
-    ]
-
-
-op :: XParser (String->String->Bool)
-op = oneOf
-    [ do symbol "=";  return (==)
-    , do symbol "!="; return (/=)
-    , do symbol "<";  return (<)
-    , do symbol "<="; return (<=)
-    , do symbol ">";  return (>)
-    , do symbol ">="; return (>=)
-    ]
-
-nop :: XParser (Integer->Integer->Bool)
-nop = oneOf
-    [ do symbol ".=.";  return (==)
-    , do symbol ".!=."; return (/=)
-    , do symbol ".<.";  return (<)
-    , do symbol ".<=."; return (<=)
-    , do symbol ".>.";  return (>)
-    , do symbol ".>=."; return (>=)
-    ]
-
+
+
+src/Text/XML/HaXml/Xtract/Parse.hs
+
+
+
-- | A parser for the Xtract command-language.  (The string input is
+--   tokenised internally by the lexer 'lexXtract'.)
+--   See <http://www.haskell.org/HaXml/Xtract.html> for the grammar that
+--   is accepted.
+
+--   Because the original Xtract grammar was left-recursive, we have
+--   transformed it into a non-left-recursive form.
+module Text.XML.HaXml.Xtract.Parse (parseXtract,xtract) where
+
+import Text.ParserCombinators.Poly hiding (bracket)
+import Text.XML.HaXml.Xtract.Lex
+import Text.XML.HaXml.Xtract.Combinators as D
+import Text.XML.HaXml.Combinators as C
+import Text.XML.HaXml.Types (Content)
+import List(isPrefixOf)
+import Text.XML.HaXml.Escape (xmlUnEscapeContent,stdXmlEscaper)
+
+-- output transformer - to ensure that text/references are glued together
+unescape = xmlUnEscapeContent stdXmlEscaper
+
+
+-- | To convert an Xtract query into an ordinary HaXml combinator expression.
+--   First arg is a tag-transformation function (e.g. map toLower) applied
+---  before matching.  Second arg is the query string.
+xtract :: (String->String) -> String -> CFilter i
+xtract f query
+    | interiorRef lexedQ = dfilter (parseXtract lexedQ)
+    | otherwise          = cfilter (parseXtract lexedQ)
+  where
+    lexedQ = lexXtract f query
+    -- test whether query has interior reference to doc root
+    interiorRef (Right (_,Symbol s): Right (_,Symbol "//"): _)
+                                          | s `elem` predicateIntro = True
+    interiorRef (Right (_,Symbol s): Right (_,Symbol "/"): _)
+                                          | s `elem` predicateIntro = True
+    interiorRef (_ : rest) = interiorRef rest
+    interiorRef [] = False
+    predicateIntro = [ "[", "("
+                     ,  "&",   "|",  "~"
+                     ,  "=",  "!=",  "<",  "<=",  ">",  ">="
+                     , ".=.",".!=.",".<.",".<=.",".>.",".>=." ]
+
+-- | The cool thing is that the Xtract command parser directly builds
+--   a higher-order 'DFilter' (see "Text.XML.HaXml.Xtract.Combinators")
+--   which can be applied to an XML document without further ado.
+--   (@parseXtract@ halts the program if a parse error is found.)
+parseXtract :: [Token] -> DFilter i
+parseXtract = either error id . parseXtract'
+
+-- | @parseXtract'@ returns error messages through the Either type.
+parseXtract' :: [Token] -> Either String (DFilter i)
+parseXtract' = fst . runParser (aquery liftLocal)
+
+---- Auxiliary Parsing Functions ----
+type XParser a = Parser (Either String (Posn,TokenT)) a
+
+string :: XParser String
+string = P (\inp -> case inp of
+                (Left err: _) -> (Left (False,err), inp)
+                (Right (p,TokString n):ts) -> (Right n, ts)
+                ts -> (Left (False,"expected a string"), ts) )
+number :: XParser Integer
+number = P (\inp -> case inp of
+                (Left err: _) -> (Left (False,err), inp)
+                (Right (p,TokNum n):ts) -> (Right n, ts)
+                ts -> (Left (False,"expected a number"), ts) )
+symbol :: String -> XParser ()
+symbol s = P (\inp -> case inp of
+                (Left err: _) -> (Left (False,err), inp)
+                (Right (p, Symbol n):ts) | n==s -> (Right (), ts)
+                ts -> (Left (False,"expected symbol "++s), ts) )
+
+quote = oneOf [ symbol "'",  symbol "\"" ]
+
+pam fs x = [ f x | f <- fs ]
+
+
+{--- original Xtract grammar ----
+      query     = string			tagname
+                | string *			tagname prefix
+                | * string			tagname suffix
+                | *				any element
+                | -				chardata
+                | ( query )
+                | query / query			parent/child relationship
+                | query // query		deep inside
+                | query + query			union of queries
+                | query [predicate]
+                | query [positions]
+
+      predicate = quattr			has attribute
+                | quattr op ' string '		attribute has value
+                | quattr op " string "		attribute has value
+                | quattr op  quattr		attribute value comparison (lexical)
+                | quattr nop integer  		attribute has value (numerical)
+                | quattr nop quattr		attribute value comparison (numerical)
+                | ( predicate )			bracketting
+                | predicate & predicate		logical and
+                | predicate | predicate		logical or
+                | ~ predicate			logical not
+
+      attribute = @ string			has attribute
+                | query / @ string		child has attribute
+                | -				has textual content
+                | query / -			child has textual content
+
+      quattr    = query
+                | attribute
+
+      op        =  =				equal to
+                |  !=				not equal to
+                |  <				less than
+                |  <=				less than or equal to
+                |  >				greater than
+                |  >=				greater than or equal to
+
+      nop       =  .=.				equal to
+                |  .!=.				not equal to
+                |  .<.				less than
+                |  .<=.				less than or equal to
+                |  .>.				greater than
+                |  .>=.				greater than or equal to
+
+      positions = position {, positions}	multiple positions
+                | position - position		ranges
+
+      position  = integer			numbering is from 0 upwards
+                | $				last
+
+
+---- transformed grammar (removing left recursion)
+      aquery = ./ tquery	-- current context
+             | tquery		-- also current context
+             | / tquery		-- root context
+             | // tquery	-- deep context from root
+
+      tquery = ( tquery ) xquery
+             | tag xquery
+             | -		-- fixes original grammar ("-/*" is incorrect)
+      
+      tag    = string *
+             | string
+             | * string
+             | *
+      
+      xquery = / tquery
+             | // tquery
+             | / @ string	-- new: print attribute value
+             | + tquery
+             | [ tpredicate ] xquery
+             | [ positions ] xquery
+             | lambda
+
+      tpredicate = vpredicate upredicate
+      upredicate = & tpredicate
+                 | | tpredicate
+                 | lambda
+      vpredicate = ( tpredicate )
+                 | ~ tpredicate
+                 | tattribute
+
+      tattribute = aquery uattribute
+                 | @ string vattribute
+      uattribute = / @ string vattribute
+                 | vattribute
+      vattribute = op wattribute
+                 | op ' string '
+                 | nop wattribute
+                 | nop integer
+                 | lambda
+      wattribute = @ string
+                 | aquery / @ string
+                 | aquery
+
+      positions  = simplepos commapos
+      simplepos  = integer range
+                 | $
+      range      = - integer
+                 | - $
+                 | lambda
+      commapos   = , simplepos commapos
+                 | lambda
+
+      op         =  =
+                 |  !=
+                 |  <
+                 |  <=
+                 |  >
+                 |  >=
+
+      nop        =  .=.
+                 |  .!=.
+                 |  .<.
+                 |  .<=.
+                 |  .>.
+                 |  .>=.
+-}
+
+bracket :: XParser a -> XParser a
+bracket p =
+  do symbol "("
+     x <- p
+     symbol ")"
+     return x
+
+
+---- Xtract parsers ----
+
+-- aquery chooses to search from the root, or only in local context
+aquery ::  ((CFilter i->CFilter i) -> (DFilter i->DFilter i))
+           -> XParser (DFilter i)
+aquery lift = oneOf
+    [ do symbol "//"
+         tquery [lift C.multi]
+    , do symbol "/"
+         tquery [lift id]
+    , do symbol "./"
+         tquery [(local C.keep D./>)]
+    , do tquery [(local C.keep D./>)]
+    ]
+
+tquery :: [DFilter i->DFilter i] -> XParser (DFilter i)
+tquery [] = tquery [id]
+tquery (qf:cxt) = oneOf
+    [ do q <- bracket (tquery (qf:qf:cxt))
+         xquery cxt q
+    , do q <- xtag
+         xquery cxt (qf ((unescape .).q))	-- glue inners texts together
+    , do symbol "-"
+         return (qf (local C.txt))
+    ]
+
+xtag :: XParser (DFilter i)
+xtag = oneOf
+    [ do s <- string
+         symbol "*"
+         return (local (C.tagWith (s `isPrefixOf`)))
+    , do s <- string
+         return (local (C.tag s))
+    , do symbol "*"
+         s <- string
+         return (local (C.tagWith (((reverse s) `isPrefixOf`) . reverse)))
+    , do symbol "*"
+         return (local C.elm)
+    ]
+
+
+xquery :: [DFilter i->DFilter i] -> DFilter i -> XParser (DFilter i)
+xquery cxt q1 = oneOf
+    [ do symbol "/"
+         ( do symbol "@"
+              attr <- string
+              return (D.iffind attr (\s->local (C.literal s)) D.none `D.o` q1)
+           `onFail`
+           tquery ((q1 D./>):cxt) )
+    , do symbol "//"
+         tquery ((\q2-> (liftLocal C.multi) q2
+                            `D.o` local C.children `D.o` q1):cxt)
+    , do symbol "+"
+         q2 <- tquery cxt
+         return (D.cat [q1,q2])
+    , do symbol "["
+         is <- iindex	-- now extended to multiple indexes
+         symbol "]"
+         xquery cxt (\xml-> concat . pam is . q1 xml)
+    , do symbol "["
+         p <- tpredicate
+         symbol "]"
+         xquery cxt (q1 `D.with` p)
+    , return q1
+    ]
+
+tpredicate :: XParser (DFilter i)
+tpredicate =
+  do p <- vpredicate
+     f <- upredicate
+     return (f p)
+
+upredicate :: XParser (DFilter i->DFilter i)
+upredicate = oneOf
+    [ do symbol "&"
+         p2 <- tpredicate
+         return (`D.o` p2)
+    , do symbol "|"
+         p2 <- tpredicate
+         return (D.|>| p2)
+    , return id
+    ]
+
+vpredicate :: XParser (DFilter i)
+vpredicate = oneOf
+    [ do bracket tpredicate
+    , do symbol "~"
+         p <- tpredicate
+         return (local C.keep `D.without` p)
+    , do tattribute
+    ]
+
+tattribute :: XParser (DFilter i)
+tattribute = oneOf
+    [ do q <- aquery liftGlobal
+         uattribute q
+    , do symbol "@"
+         s <- string
+         vattribute (local C.keep, local (C.attr s), D.iffind s)
+    ]
+
+uattribute :: DFilter i -> XParser (DFilter i)
+uattribute q = oneOf
+    [ do symbol "/"
+         symbol "@"
+         s <- string
+         vattribute (q, local (C.attr s), D.iffind s)
+    , do vattribute (q, local C.keep,     D.ifTxt)
+    ]
+
+vattribute :: (DFilter i, DFilter i, (String->DFilter i)->DFilter i->DFilter i)
+              -> XParser (DFilter i)
+vattribute (q,a,iffn) = oneOf
+  [ do cmp <- op
+       quote
+       s2 <- string
+       quote
+       return ((iffn (\s1->if cmp s1 s2 then D.keep else D.none) D.none)
+               `D.o` q)
+  , do cmp <- op
+       (q2,iffn2) <- wattribute
+       return ((iffn (\s1-> iffn2 (\s2-> if cmp s1 s2 then D.keep else D.none)
+                                  D.none)
+                     D.none) `D.o` q)
+  , do cmp <- nop
+       n <- number
+       return ((iffn (\s->if cmp (read s) n then D.keep else D.none) D.none)
+               `D.o` q)
+  , do cmp <- nop
+       (q2,iffn2) <- wattribute
+       return ((iffn (\s1-> iffn2 (\s2-> if cmp (read s1) (read s2) then D.keep
+                                                                    else D.none)
+                                  D.none)
+                     D.none) `D.o` q)
+  , do return ((a `D.o` q))
+  ]
+
+wattribute :: XParser (DFilter i, (String->DFilter i)->DFilter i->DFilter i)
+wattribute = oneOf
+    [ do symbol "@"
+         s <- string
+         return (D.keep, D.iffind s)
+    , do q <- aquery liftGlobal
+         symbol "/"
+         symbol "@"
+         s <- string
+         return (q, D.iffind s)
+    , do q <- aquery liftGlobal
+         return (q, D.ifTxt)
+    ]
+
+
+iindex :: XParser [[a]->[a]]
+iindex =
+    do i <- simpleindex
+       is <- idxcomma
+       return (i:is)
+
+simpleindex :: XParser ([a]->[a])
+simpleindex = oneOf
+    [ do n <- number
+         r <- rrange n
+         return r
+    , do symbol "$"
+         return (C.keep . last)
+    ]
+
+rrange, numberdollar :: Integer -> XParser ([a]->[a])
+rrange n1 = oneOf
+    [ do symbol "-"
+         numberdollar n1
+    , return (C.keep.(!!(fromInteger n1)))
+    ]
+
+numberdollar n1 = oneOf
+    [ do n2 <- number
+         return (take (fromInteger (1+n2-n1)) . drop (fromInteger n1))
+    , do symbol "$"
+         return (drop (fromInteger n1))
+    ]
+
+idxcomma :: XParser [[a]->[a]]
+idxcomma = oneOf
+    [ do symbol ","
+         r <- simpleindex
+         rs <- idxcomma
+         return (r:rs)
+    , return []
+    ]
+
+
+op :: XParser (String->String->Bool)
+op = oneOf
+    [ do symbol "=";  return (==)
+    , do symbol "!="; return (/=)
+    , do symbol "<";  return (<)
+    , do symbol "<="; return (<=)
+    , do symbol ">";  return (>)
+    , do symbol ">="; return (>=)
+    ]
+
+nop :: XParser (Integer->Integer->Bool)
+nop = oneOf
+    [ do symbol ".=.";  return (==)
+    , do symbol ".!=."; return (/=)
+    , do symbol ".<.";  return (<)
+    , do symbol ".<=."; return (<=)
+    , do symbol ".>.";  return (>)
+    , do symbol ".>=."; return (>=)
+    ]
+
 

+
 
diff --git a/docs/changelog.html b/docs/changelog.html
--- a/docs/changelog.html
+++ b/docs/changelog.html
@@ -23,6 +23,10 @@
 
  •  Version 1.19.4 fixes an incompatibility with some versions of the
      Bytestring package.  Also has a bugfix in the DTD validator, and
      adds some new utility functions in Text.XML.HaXml.Util.
+
  •  Version 1.19.5 adds XmlContent instances for larger (up to 15-) tuples.
+     It also fixes a couple of bugs in DtdToHaskell, when dealing with
+     larger datatypes (more than 26 components) and duplicate ATTLIST
+     specifications.
 
 
 
    Changes in 1.18
    
diff --git a/docs/index.html b/docs/index.html
--- a/docs/index.html
+++ b/docs/index.html
@@ -132,11 +132,11 @@
 
    Downloads
    
 
    
 Development versions:
    
-HaXml-1.19.4, release date 2008.06.17
    
+HaXml-1.19.5, release date 2009.02.02
    
 From Hackage
    
 By HTTP:
-.tar.gz,
-.zip.
+.tar.gz,
+.zip.
 
    
 By FTP: 
 
@@ -203,6 +203,8 @@
 
    Recent news
    
 
 
    
+Version 1.19.5 has some bugfixes to DtdToHaskell, to cope with especially
+large datatypes.
    
 Version 1.19.4 has some minor bugfixes to increase compatibility with the
 ByteString package.
    
 Version 1.19.2 updates the Cabal file to enable HaXml to build with both
diff --git a/src/Makefile b/src/Makefile
--- a/src/Makefile
+++ b/src/Makefile
@@ -1,5 +1,5 @@
 SOFTWARE = HaXml
-VERSION = 1.19.4
+VERSION = 1.19.5
 
 LIBSRCS = \
 	Text/XML/HaXml.hs Text/XML/HaXml/Combinators.hs Text/XML/HaXml/Lex.hs \
diff --git a/src/Text/XML/HaXml/DtdToHaskell/Convert.hs b/src/Text/XML/HaXml/DtdToHaskell/Convert.hs
--- a/src/Text/XML/HaXml/DtdToHaskell/Convert.hs
+++ b/src/Text/XML/HaXml/DtdToHaskell/Convert.hs
@@ -5,7 +5,7 @@
   ( dtd2TypeDef
   ) where
 
-import List (intersperse)
+import List (intersperse,nub)
 
 import Text.XML.HaXml.Types hiding (Name)
 import Text.XML.HaXml.DtdToHaskell.TypeDef
@@ -34,7 +34,7 @@
         (AttList (AttListDecl n as)) ->
           case lookup n db of
             Nothing -> database ((n, R as EMPTY):db) ms
-            (Just (R a cs)) -> database (replace n (R (a++as) cs) db) ms
+            (Just (R a cs)) -> database (replace n (R (nub (a++as)) cs) db) ms
     --  (MarkupPE _ m') -> database db (m':ms)
         _ -> database db ms
 
diff --git a/src/Text/XML/HaXml/DtdToHaskell/Instance.hs b/src/Text/XML/HaXml/DtdToHaskell/Instance.hs
--- a/src/Text/XML/HaXml/DtdToHaskell/Instance.hs
+++ b/src/Text/XML/HaXml/DtdToHaskell/Instance.hs
@@ -272,7 +272,9 @@
 mkCpat n i vs = ppHName n <+> i <+> fsep vs
 
 nameSupply :: [b] -> [Doc]
-nameSupply  ss = take (length ss) (map char ['a'..])
+nameSupply  ss = take (length ss) (map char ['a'..'z']
+                                  ++ map text [ a:n:[] | n <- ['0'..'9']
+                                                       , a <- ['a'..'z'] ])
 -- nameSupply2 ss = take (length ss) [ text ('c':v:[]) | v <- ['a'..]]
 
 mkTranslate :: [Name] -> Doc
diff --git a/src/Text/XML/HaXml/Lex.hs b/src/Text/XML/HaXml/Lex.hs
--- a/src/Text/XML/HaXml/Lex.hs
+++ b/src/Text/XML/HaXml/Lex.hs
@@ -180,7 +180,7 @@
 --   especially in error messages), and the second is the string content of
 --   the XML file.
 xmlLex :: String -> String -> [Token]
-xmlLex filename = xmlAny [] (posInNewCxt ("file "++filename) Nothing)
+xmlLex filename = xmlAny [] (posInNewCxt filename Nothing)
 
 -- | 'xmlReLex' is used when the parser expands a macro (PE reference).
 --    The expansion of the macro must be re-lexed as if for the first time.
diff --git a/src/Text/XML/HaXml/Parse.hs b/src/Text/XML/HaXml/Parse.hs
--- a/src/Text/XML/HaXml/Parse.hs
+++ b/src/Text/XML/HaXml/Parse.hs
@@ -42,7 +42,9 @@
 import Text.XML.HaXml.Lex
 import Text.ParserCombinators.Poly.NoLeak.State
 
+import System.FilePath (combine, dropFileName)
 
+
 #if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
     ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
 import System.IO.Unsafe (unsafePerformIO)
@@ -151,6 +153,13 @@
 
 ---- Auxiliary Parsing Functions ----
 
+-- | Parse a bracketed item, discarding the brackets AND NOT using adjustErrBad
+myBracket :: PolyParse p => p bra -> p ket -> p a -> p a
+myBracket open close p = do
+    do { open    `adjustErr` ("Missing opening bracket:\n\t"++)
+       ; p `discard` (close `adjustErr` ("Missing closing bracket:\n\t"++))
+       }
+
 -- | XParser is just a specialisation of the PolyState parser.
 type XParser a = Parser SymTabs (Posn,TokenT) a
 
@@ -234,16 +243,18 @@
                                `debug` ("  defn:  "++flattenEV ev)
                          peRef p
            Just (PEDefExternalID (PUBLIC _ (SystemLiteral f))) ->
-                      do let val = unsafePerformIO (readFile f)
-                         reparse (xmlReLex (posInNewCxt ("file "++f)
+                      do let f' = combine (dropFileName $ posnFilename pn) f
+                             val = unsafePerformIO (readFile f')
+                         reparse (xmlReLex (posInNewCxt f'
                                                         (Just pn)) val)
-                               `debug` ("  reading from file "++f)
+                               `debug` ("  reading from file "++f')
                          peRef p
            Just (PEDefExternalID (SYSTEM (SystemLiteral f))) ->
-                      do let val = unsafePerformIO (readFile f)
-                         reparse (xmlReLex (posInNewCxt ("file "++f)
+                      do let f' = combine (dropFileName $ posnFilename pn) f
+                             val = unsafePerformIO (readFile f')
+                         reparse (xmlReLex (posInNewCxt f'
                                                         (Just pn)) val)
-                               `debug` ("  reading from file "++f)
+                               `debug` ("  reading from file "++f')
                          peRef p
            Nothing -> fail ("PEReference use before definition: "++"%"++n++";"
                            ++"\n    at "++show pn)
@@ -288,7 +299,7 @@
 -- | Return an XML comment.
 comment :: XParser Comment
 comment = do
-    bracket (tok TokCommentOpen) (tok TokCommentClose) freetext
+    myBracket (tok TokCommentOpen) (tok TokCommentClose) freetext
 --  tok TokCommentOpen
 --  commit $ do
 --    c <- freetext
@@ -509,19 +520,15 @@
 
 choice :: XParser [CP]
 choice = do
-    bracket (tok TokBraOpen `debug` "Trying choice")
-            (blank (tok TokBraClose `debug` "Succeeded with choice"))
-            (peRef cp `sepBy1` blank (tok TokPipe))
+    myBracket (tok TokBraOpen `debug` "Trying choice")
+              (blank (tok TokBraClose `debug` "Succeeded with choice"))
+              (peRef cp `sepBy1` blank (tok TokPipe))
 
 sequence :: XParser [CP]
-sequence = do	-- bracket is inappropriate because of inner failBad
- -- bracket (tok TokBraOpen `debug` "Trying sequence")
- --         (blank (tok TokBraClose `debug` "Succeeded with sequence"))
- --         (peRef cp `sepBy1` blank (tok TokComma))
-    tok TokBraOpen `debug` "Trying sequence"
-    cps <- peRef cp `sepBy1` blank (tok TokComma)
-    blank (tok TokBraClose `debug` "Succeeded with sequence")
-    return cps
+sequence = do
+ myBracket (tok TokBraOpen `debug` "Trying sequence")
+           (blank (tok TokBraClose `debug` "Succeeded with sequence"))
+           (peRef cp `sepBy1` blank (tok TokComma))
 
 cp :: XParser CP
 cp = oneOf [ ( do n <- name
@@ -701,7 +708,7 @@
 -- | Return either a general entity reference, or a character reference.
 reference :: XParser Reference
 reference = do
-    bracket (tok TokAmp) (tok TokSemi) (freetext >>= val)
+    myBracket (tok TokAmp) (tok TokSemi) (freetext >>= val)
   where
     val ('#':'x':i) | all isHexDigit i
                     = return . RefChar . fst . head . readHex $ i
@@ -729,11 +736,7 @@
 
 pereference :: XParser PEReference
 pereference = do
---  bracket (tok TokPercent) (tok TokSemi) nmtoken
-    tok TokPercent
-    p <- nmtoken
-    tok TokSemi
-    return p
+    myBracket (tok TokPercent) (tok TokSemi) nmtoken
 
 entitydecl :: XParser EntityDecl
 entitydecl =
diff --git a/src/Text/XML/HaXml/ParseLazy.hs b/src/Text/XML/HaXml/ParseLazy.hs
--- a/src/Text/XML/HaXml/ParseLazy.hs
+++ b/src/Text/XML/HaXml/ParseLazy.hs
@@ -42,7 +42,9 @@
 import Text.XML.HaXml.Lex
 import Text.ParserCombinators.Poly.NoLeak.StateLazy
 
+import System.FilePath (combine, dropFileName)
 
+
 #if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
     ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
 import System.IO.Unsafe (unsafePerformIO)
@@ -154,6 +156,14 @@
 
 ---- Auxiliary Parsing Functions ----
 
+-- | Parse a bracketed item, discarding the brackets AND NOT using adjustErrBad
+myBracket :: PolyParse p => p bra -> p ket -> p a -> p a
+myBracket open close p = do
+    do { open    `adjustErr` ("Missing opening bracket:\n\t"++)
+       ; p `discard` (close `adjustErr` ("Missing closing bracket:\n\t"++))
+       }
+
+
 -- | XParser is just a specialisation of the PolyStateLazy parser.
 type XParser a = Parser SymTabs (Posn,TokenT) a
 
@@ -237,16 +247,18 @@
                                `debug` ("  defn:  "++flattenEV ev)
                          peRef p
            Just (PEDefExternalID (PUBLIC _ (SystemLiteral f))) ->
-                      do let val = unsafePerformIO (readFile f)
-                         reparse (xmlReLex (posInNewCxt ("file "++f)
+                      do let f' = combine (dropFileName $ posnFilename pn) f
+                             val = unsafePerformIO (readFile f')
+                         reparse (xmlReLex (posInNewCxt f'
                                                         (Just pn)) val)
-                               `debug` ("  reading from file "++f)
+                               `debug` ("  reading from file "++f')
                          peRef p
            Just (PEDefExternalID (SYSTEM (SystemLiteral f))) ->
-                      do let val = unsafePerformIO (readFile f)
-                         reparse (xmlReLex (posInNewCxt ("file "++f)
+                      do let f' = combine (dropFileName $ posnFilename pn) f
+                             val = unsafePerformIO (readFile f')
+                         reparse (xmlReLex (posInNewCxt f'
                                                         (Just pn)) val)
-                               `debug` ("  reading from file "++f)
+                               `debug` ("  reading from file "++f')
                          peRef p
            Nothing -> fail ("PEReference use before definition: "++"%"++n++";"
                            ++"\n    at "++show pn)
@@ -296,7 +308,7 @@
 -- | Return an XML comment.
 comment :: XParser Comment
 comment = do
-    bracket (tok TokCommentOpen) (tok TokCommentClose) freetext
+    myBracket (tok TokCommentOpen) (tok TokCommentClose) freetext
 --  tok TokCommentOpen
 --  commit $ do
 --    c <- freetext
@@ -517,19 +529,15 @@
 
 choice :: XParser [CP]
 choice = do
-    bracket (tok TokBraOpen `debug` "Trying choice")
-            (blank (tok TokBraClose `debug` "Succeeded with choice"))
-            (peRef cp `sepBy1` blank (tok TokPipe))
+    myBracket (tok TokBraOpen `debug` "Trying choice")
+              (blank (tok TokBraClose `debug` "Succeeded with choice"))
+              (peRef cp `sepBy1` blank (tok TokPipe))
 
 sequence :: XParser [CP]
-sequence = do	-- bracket is inappropriate because of inner failBad
- -- bracket (tok TokBraOpen `debug` "Trying sequence")
- --         (blank (tok TokBraClose `debug` "Succeeded with sequence"))
- --         (peRef cp `sepBy1` blank (tok TokComma))
-    tok TokBraOpen `debug` "Trying sequence"
-    cps <- peRef cp `sepBy1` blank (tok TokComma)
-    blank (tok TokBraClose `debug` "Succeeded with sequence")
-    return cps
+sequence = do
+ myBracket (tok TokBraOpen `debug` "Trying sequence")
+           (blank (tok TokBraClose `debug` "Succeeded with sequence"))
+           (peRef cp `sepBy1` blank (tok TokComma))
 
 cp :: XParser CP
 cp = oneOf [ ( do n <- name
@@ -737,7 +745,7 @@
 
 pereference :: XParser PEReference
 pereference = do
-    bracket (tok TokPercent) (tok TokSemi) nmtoken
+    myBracket (tok TokPercent) (tok TokSemi) nmtoken
 
 entitydecl :: XParser EntityDecl
 entitydecl =
diff --git a/src/Text/XML/HaXml/Posn.hs b/src/Text/XML/HaXml/Posn.hs
--- a/src/Text/XML/HaXml/Posn.hs
+++ b/src/Text/XML/HaXml/Posn.hs
@@ -42,7 +42,8 @@
 posInNewCxt name pos = Pn name 1 1 pos
 
 instance Show Posn where
-      showsPrec _ (Pn f l c i) = showString f .
+      showsPrec _ (Pn f l c i) = showString "file " .
+                                 showString f .
                                  showString "  at line " . shows l .
                                  showString " col " . shows c .
                                  ( case i of
diff --git a/src/Text/XML/HaXml/TypeMapping.hs b/src/Text/XML/HaXml/TypeMapping.hs
--- a/src/Text/XML/HaXml/TypeMapping.hs
+++ b/src/Text/XML/HaXml/TypeMapping.hs
@@ -105,6 +105,76 @@
     toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
                            , toHType e, toHType f ]
                    where  (a,b,c,d,e,f) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g) =>
+         HTypeable (a,b,c,d,e,f,g) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g ]
+                   where  (a,b,c,d,e,f,g) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h) =>
+         HTypeable (a,b,c,d,e,f,g,h) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h ]
+                   where  (a,b,c,d,e,f,g,h) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i) =>
+         HTypeable (a,b,c,d,e,f,g,h,i) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i ]
+                   where  (a,b,c,d,e,f,g,h,i) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j) =>
+         HTypeable (a,b,c,d,e,f,g,h,i,j) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i, toHType j ]
+                   where  (a,b,c,d,e,f,g,h,i,j) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
+         , HTypeable k) =>
+         HTypeable (a,b,c,d,e,f,g,h,i,j,k) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i, toHType j, toHType k ]
+                   where  (a,b,c,d,e,f,g,h,i,j,k) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
+         , HTypeable k, HTypeable l) =>
+         HTypeable (a,b,c,d,e,f,g,h,i,j,k,l) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i, toHType j, toHType k, toHType l ]
+                   where  (a,b,c,d,e,f,g,h,i,j,k,l) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
+         , HTypeable k, HTypeable l, HTypeable m) =>
+         HTypeable (a,b,c,d,e,f,g,h,i,j,k,l,m) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i, toHType j, toHType k, toHType l
+                           , toHType m ]
+                   where  (a,b,c,d,e,f,g,h,i,j,k,l,m) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
+         , HTypeable k, HTypeable l, HTypeable m, HTypeable n) =>
+         HTypeable (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i, toHType j, toHType k, toHType l
+                           , toHType m, toHType n ]
+                   where  (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = p
+instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e
+         , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j
+         , HTypeable k, HTypeable l, HTypeable m, HTypeable n, HTypeable o) =>
+         HTypeable (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
+    toHType p      = Tuple [ toHType a, toHType b, toHType c, toHType d
+                           , toHType e, toHType f, toHType g, toHType h
+                           , toHType i, toHType j, toHType k, toHType l
+                           , toHType m, toHType n, toHType o ]
+                   where  (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = p
+
 instance (HTypeable a) => HTypeable (Maybe a) where
     toHType m      = Maybe (toHType x)   where   (Just x) = m
 instance (HTypeable a, HTypeable b) => HTypeable (Either a b) where
diff --git a/src/Text/XML/HaXml/Wrappers.hs b/src/Text/XML/HaXml/Wrappers.hs
--- a/src/Text/XML/HaXml/Wrappers.hs
+++ b/src/Text/XML/HaXml/Wrappers.hs
@@ -1,6 +1,7 @@
 module Text.XML.HaXml.Wrappers
   ( fix2Args
   , processXmlWith
+  , onContent
   ) where
 
 -- imports required for processXmlWith and fix2Args
@@ -59,3 +60,12 @@
             [CElem e' _] -> Document p s e' m
             []           -> error "produced no output"
             _            -> error "produced more than one output"
+
+-- | The wrapper @onContent@ simply applies a given content filter to a
+--   document.  Ambiguous or empty results raise an error exception.
+onContent :: CFilter i -> Document i -> Document i
+onContent filter (Document p s e m) =
+    case filter (CElem e undefined) of
+      [CElem e' _] -> Document p s e' m
+      []           -> error "onContent: produced no output"
+      _            -> error "onContent: produced more than one output"
diff --git a/src/Text/XML/HaXml/XmlContent.hs b/src/Text/XML/HaXml/XmlContent.hs
--- a/src/Text/XML/HaXml/XmlContent.hs
+++ b/src/Text/XML/HaXml/XmlContent.hs
@@ -472,7 +472,7 @@
         }
 
 instance (XmlContent a, XmlContent b, XmlContent c) => XmlContent (a,b,c) where
-    toContents (x,y,z) = toContents x ++ toContents y ++ toContents z
+    toContents (a,b,c) = toContents a ++ toContents b ++ toContents c
     parseContents = do
         { a <- parseContents
         ; b <- parseContents
@@ -482,8 +482,8 @@
 
 instance (XmlContent a, XmlContent b, XmlContent c, XmlContent d) =>
          XmlContent (a,b,c,d) where
-    toContents (x,y,z,t) = toContents x ++ toContents y ++ toContents z
-                           ++ toContents t
+    toContents (a,b,c,d) = toContents a ++ toContents b ++ toContents c
+                           ++ toContents d
     parseContents = do
         { a <- parseContents
         ; b <- parseContents
@@ -495,8 +495,8 @@
 instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
          , XmlContent e ) =>
          XmlContent (a,b,c,d,e) where
-    toContents (x,y,z,t,u) = toContents x ++ toContents y ++ toContents z
-                             ++ toContents t ++ toContents u
+    toContents (a,b,c,d,e) = toContents a ++ toContents b ++ toContents c
+                             ++ toContents d ++ toContents e
     parseContents = do
         { a <- parseContents
         ; b <- parseContents
@@ -509,8 +509,8 @@
 instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
          , XmlContent e, XmlContent f ) =>
          XmlContent (a,b,c,d,e,f) where
-    toContents (x,y,z,t,u,v) = toContents x ++ toContents y ++ toContents z
-                               ++ toContents t ++ toContents u ++ toContents v
+    toContents (a,b,c,d,e,f) = toContents a ++ toContents b ++ toContents c
+                               ++ toContents d ++ toContents e ++ toContents f
     parseContents = do
         { a <- parseContents
         ; b <- parseContents
@@ -519,6 +519,215 @@
         ; e <- parseContents
         ; f <- parseContents
         ; return (a,b,c,d,e,f)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g ) =>
+         XmlContent (a,b,c,d,e,f,g) where
+    toContents (a,b,c,d,e,f,g)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; return (a,b,c,d,e,f,g)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h ) =>
+         XmlContent (a,b,c,d,e,f,g,h) where
+    toContents (a,b,c,d,e,f,g,h)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; return (a,b,c,d,e,f,g,h)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i) where
+    toContents (a,b,c,d,e,f,g,h,i)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i, XmlContent j ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i,j) where
+    toContents (a,b,c,d,e,f,g,h,i,j)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i ++ toContents j
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; j <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i,j)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i, XmlContent j, XmlContent k ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i,j,k) where
+    toContents (a,b,c,d,e,f,g,h,i,j,k)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i ++ toContents j ++ toContents k
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; j <- parseContents
+        ; k <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i,j,k)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i, XmlContent j, XmlContent k, XmlContent l ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i,j,k,l) where
+    toContents (a,b,c,d,e,f,g,h,i,j,k,l)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i ++ toContents j ++ toContents k ++ toContents l
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; j <- parseContents
+        ; k <- parseContents
+        ; l <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i,j,k,l)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i, XmlContent j, XmlContent k, XmlContent l
+         , XmlContent m ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i,j,k,l,m) where
+    toContents (a,b,c,d,e,f,g,h,i,j,k,l,m)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i ++ toContents j ++ toContents k ++ toContents l
+          ++ toContents m
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; j <- parseContents
+        ; k <- parseContents
+        ; l <- parseContents
+        ; m <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i,j,k,l,m)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i, XmlContent j, XmlContent k, XmlContent l
+         , XmlContent m, XmlContent n ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
+    toContents (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i ++ toContents j ++ toContents k ++ toContents l
+          ++ toContents m ++ toContents n
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; j <- parseContents
+        ; k <- parseContents
+        ; l <- parseContents
+        ; m <- parseContents
+        ; n <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
+        }
+
+instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d
+         , XmlContent e, XmlContent f, XmlContent g, XmlContent h
+         , XmlContent i, XmlContent j, XmlContent k, XmlContent l
+         , XmlContent m, XmlContent n, XmlContent o ) =>
+         XmlContent (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
+    toContents (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)
+        = toContents a ++ toContents b ++ toContents c ++ toContents d
+          ++ toContents e ++ toContents f ++ toContents g ++ toContents h
+          ++ toContents i ++ toContents j ++ toContents k ++ toContents l
+          ++ toContents m ++ toContents n ++ toContents o
+    parseContents = do
+        { a <- parseContents
+        ; b <- parseContents
+        ; c <- parseContents
+        ; d <- parseContents
+        ; e <- parseContents
+        ; f <- parseContents
+        ; g <- parseContents
+        ; h <- parseContents
+        ; i <- parseContents
+        ; j <- parseContents
+        ; k <- parseContents
+        ; l <- parseContents
+        ; m <- parseContents
+        ; n <- parseContents
+        ; o <- parseContents
+        ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)
         }
 
 instance (XmlContent a) => XmlContent (Maybe a) where