diff --git a/HaXml.cabal b/HaXml.cabal --- a/HaXml.cabal +++ b/HaXml.cabal @@ -1,5 +1,5 @@ name: HaXml -version: 1.19.2 +version: 1.19.3 license: LGPL license-file: COPYRIGHT author: Malcolm Wallace @@ -14,7 +14,9 @@ cabal-version: >=1.2 flag splitBase + default: True flag bytestringInBase + default: False library exposed-modules: @@ -46,7 +48,7 @@ Text.XML.HaXml.Xtract.Combinators, Text.XML.HaXml.Xtract.Lex, Text.XML.HaXml.Xtract.Parse - hs-source-dir: src + hs-source-dirs: src build-depends: base, haskell98, polyparse if flag(splitBase) build-depends: base >= 3, pretty, random, containers @@ -56,8 +58,8 @@ build-depends: base >= 2 && < 3 else build-depends: base < 2 || >= 3, bytestring - extensions: CPP - cpp-options: -DVERSION=1.19.2 + extensions: CPP, ExistentialQuantification + cpp-options: -DVERSION=1.19.3 nhc98-options: -K10M Executable Canonicalise diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ SOFTWARE = HaXml -VERSION = 1.19.2 +VERSION = 1.19.3 #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.1" +VERSION="1.19.3" if [ -f obj/prefix ] then INSTALLDIR=`cat obj/prefix` diff --git a/docs/HaXml/Text-XML-HaXml-ShowXmlLazy.html b/docs/HaXml/Text-XML-HaXml-ShowXmlLazy.html --- a/docs/HaXml/Text-XML-HaXml-ShowXmlLazy.html +++ b/docs/HaXml/Text-XML-HaXml-ShowXmlLazy.html @@ -122,7 +122,7 @@ >Convert a fully-typed XML document to a string (without DTD). +>Convert a fully-typed XML document to a string (without DTD). (HTypeable a, HTypeable b, HTypeable c, HTypeable d) => HTypeable (a, b, c, d)(HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e) => HTypeable (a, b, c, d, e)(HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e, HTypeable f) => HTypeable (a, b, c, d, e, f)HTypeable a => info :: Content t -> tdata
info :: Content t -> tSource
Administrative parts of the document @@ -3565,7 +3601,7 @@ >PlusOne Or More +>One Or More (XmlContent a, XmlContent b, XmlContent c, XmlContent d) => XmlContent (a, b, c, d)(XmlContent a, XmlContent b, XmlContent c, XmlContent d, XmlContent e) => XmlContent (a, b, c, d, e)(XmlContent a, XmlContent b, XmlContent c, XmlContent d, XmlContent e, XmlContent f) => XmlContent (a, b, c, d, e, f)XmlContent a => Get the next content element, checking that it has one of the required - tags, using the given matching function. + tags, using the given matching function. (Skips over comments and whitespace, rejects text and refs. Also returns position of element.) Turn a simple string into XML text. +>Turn a simple string into XML text.

A type corresponding to XML's ANY contentspec. +>A type corresponding to XML's ANY contentspec. It is either a list of unconverted xml Content +> or some XmlContentText.XML.HaXml.Types, Text.XML.HaXml, Text.XML.HaXml import Prelude hiding (maybe,either,elem,concat) import Maybe hiding (maybe) -import Data.List (intersperse) +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, join +import Data.ByteString.Lazy.Char8 (ByteString(), concat, pack, singleton, intercalate , append, elem, empty) 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 - - --- 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.join (singleton ' ') -vcat = Data.ByteString.Lazy.Char8.join (singleton '\n') -cat = hcat -sep = hsep -text = pack -fcat = cat -fsep = sep -nest _ b = pack " " <> b -parens p = pack "(" <> p <> pack ")" - - ----- --- Now for the XML pretty-printing interface. --- (Basically copied direct from Text.XML.HaXml.Pretty). +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 ")" + -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 +---- +-- 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 ----- - -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 (ExtSubset t ds) = maybe textdecl t $$ - vcat (Prelude.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 (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 (CString _ _ _) = True -isText (CRef _ _) = True -isText _ = False +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 -carryelem (Elem n as []) c - = ( c <> - text "<" <> text n <+> fsep (Prelude.map attribute as) - , text "/>") -carryelem e@(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 (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 f [] 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 +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) + -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 "|") (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 None = empty -modifier Query = text "?" -modifier Star = text "*" -modifier Plus = text "+" -mixed PCDATA = text "(#PCDATA)" -mixed (PCDATAplus ns) = text "(#PCDATA |" <+> - hcat (intersperse (text "|") (Prelude.map text ns)) <> - text ")*" - -attlistdecl (AttListDecl n ds) = text "<!ATTLIST" <+> text n <+> - fsep (Prelude.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 "|") (Prelude.map text ns))) -enumeration ns = parens (hcat (intersperse (text "|") (Prelude.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 (Prelude.map extsubsetdecl i) <+> text "]]>" -conditionalsect (IgnoreSect i) = text "<![IGNORE [" <+> - fsep (Prelude.map ignoresectcontents i) <+> text "]]>" -ignore (Ignore) = empty -ignoresectcontents (IgnoreSectContents i is) - = ignore i <+> vcat (Prelude.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 (Prelude.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 (Prelude.map (either text reference) esr) <> - text "\"" -entityvalue (EntityValue evs) - | containsDoubleQuote evs = text "'" <> hcat (Prelude.map ev evs) <> text "'" - | otherwise = text "\"" <> hcat (Prelude.map ev evs) <> text "\"" -ev (EVString s) = text s ---ev (EVPERef p e) = peref p -ev (EVRef r) = reference r -pubidliteral (PubidLiteral s) - | toWord8 '"' `elem` (pack s) = text "'" <> text s <> text "'" - | otherwise = text "\"" <> text s <> text "\"" -systemliteral (SystemLiteral s) - | toWord8 '"' `elem` (pack s) = text "'" <> text s <> text "'" - | otherwise = text "\"" <> text s <> text "\"" -chardata s = {-if all isSpace s then empty else-} text s -cdsect c = text "<![CDATA[" <> chardata c <> text "]]>" - ---toWord8 :: Char -> Word8 -toWord8 = toEnum . fromEnum - ----- -containsDoubleQuote evs = any csq evs - where csq (EVString s) = toWord8 '"' `elem` (pack s) - csq _ = False +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/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 @@ -15,7 +15,7 @@ ---- Internal representation for database of DTD decls ---- data Record = R [AttDef] ContentSpec -type Db = [(String,Record)] +-- type Db = [(String,Record)] ---- Build a database of DTD decls then convert them to typedefs ---- @@ -23,7 +23,7 @@ ---- Apparently multiple ATTLIST decls for the same element are permitted, ---- although only one ELEMENT decl for it is allowed. dtd2TypeDef :: [MarkupDecl] -> [TypeDef] -dtd2TypeDef mds = +dtd2TypeDef mds = (concatMap convert . reverse . database []) mds where database db [] = db @@ -40,7 +40,7 @@ -- (MarkupPE _ m') -> database db (m':ms) _ -> database db ms - replace n v [] = error "dtd2TypeDef.replace: no element to replace" + 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 @@ -88,8 +88,8 @@ 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 n ts = (mkConsName n ts, ts) - mkConsName (Name x n) sts = Name x (n++concat (intersperse "_" (map flatten sts))) + 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 @@ -99,32 +99,33 @@ flatten (OneOf sts) = {-"OneOf" ++ show (length sts) ++ "_" ++ -} concat (intersperse "_" (map flatten sts)) flatten Any = "Any" - flatten (Defined (Name _ n)) = n + flatten (Defined (Name _ m)) = m -mkAttrDef e (AttDef n StringType def) = - [] -mkAttrDef e (AttDef n (TokenizedType t) def) = - [] -- mkData [[String]] [] False (name n) -mkAttrDef e (AttDef n (EnumeratedType (NotationType nt)) def) = - [EnumDef (name_a e n) (map (name_ac e n) nt)] -mkAttrDef e (AttDef n (EnumeratedType (Enumeration es)) def) = - [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 _) f) = Defaultable String (show v) - mkType (TokenizedType _) REQUIRED = String - mkType (TokenizedType _) IMPLIED = Maybe String - mkType (TokenizedType _) (DefaultTo v@(AttValue _) f) = - 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 _) f) = - Defaultable (Defined (name_a e n)) (hName (name_ac e n (show v))) - +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 @@ -14,8 +14,8 @@ mkInstance :: TypeDef -> Doc -- no constructors - represents an element with empty content but attributes. -mkInstance (DataDef aux n fs []) = - let (frpat, frattr, topat, toattr) = attrpats fs +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 @@ -83,9 +83,9 @@ -- multiple constructors (real) mkInstance (DataDef False n fs cs) = - let vs = nameSupply cs + let _ = nameSupply cs (frpat, frattr, topat, toattr) = attrpats fs - mixattrs = if null fs then False else True + _ = if null fs then False else True in text "instance HTypeable" <+> ppHName n <+> text "where" $$ nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" ) @@ -110,8 +110,8 @@ -- multiple constructors (auxiliary) mkInstance (DataDef True n fs cs) = - let vs = nameSupply cs - (frpat, frattr, topat, toattr) = attrpats fs + let _ = nameSupply cs + (_, frattr, _, _) = attrpats fs mixattrs = if null fs then False else True in text "instance HTypeable" <+> ppHName n <+> text "where" $$ @@ -145,7 +145,7 @@ data SameName = Same | Extended mkInstanceAttrs :: SameName -> Name -> AttrFields -> Doc -mkInstanceAttrs s n [] = empty +mkInstanceAttrs _ _ [] = empty mkInstanceAttrs s n fs = let ppName = case s of { Same-> ppHName; Extended-> ppAName; } in @@ -172,46 +172,46 @@ -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 n (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 s) -> text "fromElem" <+> cvo - (List String) -> text "many fromText" <+> cvo - (List s) -> 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 ss) -> 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 n <> text "\"" <+> cvo - (Defaultable _ _) -> text "nyi_fromElem_Defaultable" <+> cvo - ) +-- 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 = @@ -225,171 +225,173 @@ parens ( ) -} - -mkParseConstr frattr (c,sts) = +mkParseConstr :: Doc -> (Name, [StructType]) -> Doc +mkParseConstr frattr (c,sts) = fsep (text "return" <+> parens (ppHName c <+> frattr) : map mkParseContents sts) -mkParseContents st = - let ap = text "`apply`" in - case st of - (Maybe String) -> ap <+> text "optional text" - (Maybe s) -> ap <+> text "optional parseContents" - (List String) -> ap <+> text "many text" - (List s) -> ap <+> text "many parseContents" - (List1 s) -> ap <+> text "parseContents" - (Tuple ss) -> ap <+> text "parseContents" - (OneOf ss) -> ap <+> text "parseContents" - (String) -> ap <+> text "(text `onFail` return \"\")" - (Any) -> ap <+> text "parseContents" - (Defined m) -> 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 s) -> text "maybe [] toContents" <+> v - (List String) -> text "concatMap toText" <+> v - (List s) -> text "concatMap toContents" <+> v - (List1 s) -> text "toContents" <+> v - (Tuple ss) -> text "toContents" <+> v - (OneOf ss) -> text "toContents" <+> v - (String) -> text "toText" <+> v - (Any) -> text "toContents" <+> v - (Defined m) -> 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,nameSupply2 :: [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 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) inner = - 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 inner - ) - blah [st] [v] = - blahblahblah st (text "c0") - blah sts vs = - let ns = nameSupply2 vs - cvs = zip ns (text "c0": init ns) - blahblah (st,v,(cvi,cvo)) inner = - parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$ - nest 2 inner) $$ - 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 s) -> text "fromElem" <+> cvo - (List String) -> text "many fromText" <+> cvo - (List s) -> text "many fromElem" <+> cvo - (List1 s) -> text "fromElem" <+> cvo - (Tuple ss) -> text "fromElem" <+> cvo -- ?? - (OneOf ss) -> text "fromElem" <+> cvo - (String) -> text "fromText" <+> cvo - (Any) -> text "fromElem" <+> cvo - (Defined m) -> text "fromElem" <+> cvo - ) - failpat sts = - let fp st = - case st of - (Maybe s) -> text "Nothing" - (List s) -> text "[]" - (List1 s) -> text "_" - (Tuple ss) -> text "_" - (OneOf ss) -> text "_" - (String) -> text "_" - (Any) -> text "_" - (Defined m) -> text "_" - in parens (hcat (intersperse comma (map fp sts++[text "_"]))) - succpat sts vs = - let sp st v = - case st of - (Maybe s) -> v - (List s) -> v - (List1 s) -> text "Just" <+> v - (Tuple ss) -> text "Just" <+> v - (OneOf ss) -> text "Just" <+> v - (String) -> text "Just" <+> v - (Any) -> text "Just" <+> v - (Defined m) -> 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 ") ()]") - +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 ") ()]") + 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 @@ -28,25 +28,25 @@ ---- 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 +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. + 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. + | Defaultable StructType String -- ^ String holds default value. | List StructType - | List1 StructType -- ^ Non-empty lists. + | List1 StructType -- ^ Non-empty lists. | Tuple [StructType] | OneOf [StructType] - | Any -- ^ XML's contentspec allows ANY + | Any -- ^ XML's contentspec allows ANY | String | Defined Name deriving Eq @@ -54,50 +54,50 @@ -- 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 p (Defaultable s _) = shows s + showsPrec _ (Defaultable s _) = shows s showsPrec p (List s) = showsPrec (p+1) s . showChar '*' showsPrec p (List1 s) = showsPrec (p+1) s . showChar '+' - showsPrec p (Tuple ss) = showChar '(' + showsPrec _ (Tuple ss) = showChar '(' . foldr1 (.) (intersperse (showChar ',') (map shows ss)) . showChar ')' - showsPrec p (OneOf ss) = showChar '(' + showsPrec _ (OneOf ss) = showChar '(' . foldr1 (.) (intersperse (showChar '|') (map shows ss)) . showChar ')' - showsPrec p (Any) = showString "ANY" - showsPrec p (String) = showString "#PCDATA" - showsPrec p (Defined (Name n _)) = showString n + showsPrec _ (Any) = showString "ANY" + showsPrec _ (String) = showString "#PCDATA" + showsPrec _ (Defined (Name n _)) = showString n ---- Pretty-printing typedefs ---- ppTypeDef :: TypeDef -> Doc --- no attrs, no constructors +-- no attrs, no constructors ppTypeDef (DataDef _ n [] []) = - let name = ppHName n in - text "data" <+> name <+> text "=" <+> name <+> text "\t\t" <> derives + let nme = ppHName n in + text "data" <+> nme <+> text "=" <+> nme <+> text "\t\t" <> derives --- no attrs, single constructor +-- no attrs, single constructor ppTypeDef (DataDef _ n [] [c@(_,[_])]) = text "newtype" <+> ppHName n <+> text "=" <+> ppC c <+> text "\t\t" <> derives --- no attrs, multiple constrs +-- 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 +-- nonzero attrs, no constructors ppTypeDef (DataDef _ n fs []) = - let name = ppHName n in - text "data" <+> name <+> text "=" <+> name $$ + 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 +-- nonzero attrs, one or more constrs ppTypeDef (DataDef _ n fs cs) = let attr = ppAName n in text "data" <+> ppHName n <+> @@ -109,7 +109,7 @@ vcat (map (\f-> text "," <+> ppF f) (tail fs)) $$ text "}" <+> derives ) --- enumerations (of attribute values) +-- enumerations (of attribute values) ppTypeDef (EnumDef n es) = text "data" <+> ppHName n <+> ( text "=" <+> @@ -150,86 +150,86 @@ -- | Pretty print Haskell attributes name. ppAName :: Name -> Doc ppAName (Name _ s) = text s <> text "_Attrs" - -derives = text "deriving" <+> parens (commaList (map text ["Eq","Show"])) - + +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 "String" = "AString" -notPrelude "Maybe" = "AMaybe" -notPrelude "Either" = "AEither" + +---- 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 "String" = "AString" -notPrelude "Int" = "AInt" -notPrelude "Integer" = "AInteger" -notPrelude "Float" = "AFloat" -notPrelude "Double" = "ADouble" -notPrelude "List1" = "AList1" -- part of HaXml -notPrelude "IO" = "AIO" -notPrelude "IOError" = "AIOError" -notPrelude "FilePath"= "AFilePath" -notPrelude "Bool" = "ABool" -notPrelude "Ordering"= "AOrdering" -notPrelude "Eq" = "AEq" -notPrelude "Ord" = "AOrd" -notPrelude "Enum" = "AEnum" -notPrelude "Bounded" = "ABounded" -notPrelude "Functor" = "AFunctor" +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 "Rational"= "ARational" -notPrelude "Integral"= "AIntegral" -notPrelude "Num" = "ANum" -notPrelude "Real" = "AReal" -notPrelude "RealFrac"= "ARealFrac" -notPrelude "Floating"= "AFloating" -notPrelude "RealFloat" = "ARealFloat" -notPrelude "Fractional"= "AFractional" -notPrelude "Read" = "ARead" +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 "ReadS" = "AReadS" -notPrelude "ShowS" = "AShowS" +notPrelude "ShowS" = "AShowS" +notPrelude "String" = "AString" notPrelude n = n -- | Convert an XML name to a Haskell varid. @@ -246,6 +246,7 @@ decolonify '.' = '_' decolonify c = c -commaList = hcat . intersperse comma +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,7 +1,7 @@ 

{- This module contains code for escaping/unescaping text in attributes
-   and elements in the HaXml Element type, replacing characters by character 
+   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
@@ -23,7 +23,7 @@
       -- Something describing a particular set of escapes.
 
    stdXmlEscaper,
-      -- Standard boilerplate escaper, escaping everything that is 
+      -- Standard boilerplate escaper, escaping everything that is
       -- nonprintable, non-ASCII, or might conceivably cause problems by
       -- parsing XML, for example quotes, < signs, and ampersands.
 
@@ -58,7 +58,7 @@
    ) where
 
 import Char
-import Numeric
+-- import Numeric
 import Text.XML.HaXml.Types
 
 #if __GLASGOW_HASKELL__ >= 604 || __NHC__ >= 118 || defined(__HUGS__)
@@ -100,16 +100,16 @@
 
 
 xmlEscape :: XmlEscaper -> Element i -> Element i
-xmlEscape xmlEscaper element = 
+xmlEscape xmlEscaper element =
    compressElement (escapeElement xmlEscaper element)
 
 xmlEscapeContent :: XmlEscaper -> [Content i] -> [Content i]
-xmlEscapeContent xmlEscaper cs = 
+xmlEscapeContent xmlEscaper cs =
    compressContent (escapeContent xmlEscaper cs)
 
 escapeElement :: XmlEscaper -> Element i -> Element i
 escapeElement xmlEscaper (Elem name attributes content) =
-   Elem name (escapeAttributes xmlEscaper attributes) 
+   Elem name (escapeAttributes xmlEscaper attributes)
       (escapeContent xmlEscaper content)
 
 escapeAttributes :: XmlEscaper -> [Attribute] -> [Attribute]
@@ -117,23 +117,23 @@
    map
       (\ (name,av) -> (name,escapeAttValue xmlEscaper av))
       atts
-   
+
 escapeAttValue :: XmlEscaper -> AttValue -> AttValue
 escapeAttValue xmlEscaper (AttValue attValList) =
    AttValue (
-      concat ( 
+      concat (
          map
             (\ av -> case av of
-               Right ref -> [av]
+               Right _ -> [av]
                Left s ->
                   map
-                     (\ c -> if isEscape xmlEscaper c 
+                     (\ c -> if isEscape xmlEscaper c
                         then
                            Right (mkEscape xmlEscaper c)
                         else
                            Left [c]
                         )
-                     s 
+                     s
                )
             attValList
          )
@@ -153,20 +153,20 @@
                          CString b [c] i
                       )
                    str
-             (CElem elem i) -> [CElem (escapeElement xmlEscaper elem) i]
+             (CElem element i) -> [CElem (escapeElement xmlEscaper element) i]
              _ -> [content]
              )
           contents
           )
 
 mkEscape :: XmlEscaper -> Char -> Reference
-mkEscape (XmlEscaper {toEscape = toEscape}) ch =
-   case lookupFM toEscape ch of
+mkEscape (XmlEscaper {toEscape = toescape}) ch =
+   case lookupFM toescape ch of
       Nothing  -> RefChar (ord ch)
       Just str -> RefEntity str
-   where
-      showHex = showIntAtBase 16 intToDigit 
-      -- It should be, but in GHC it isn't.
+--    where
+--       _ = showIntAtBase 16 intToDigit
+--       -- It should be, but in GHC it isn't.
 
 -- ------------------------------------------------------------------------
 -- Unescaping
@@ -177,7 +177,7 @@
    compressElement (unEscapeElement xmlEscaper element)
 
 xmlUnEscapeContent :: XmlEscaper -> [Content i] -> [Content i]
-xmlUnEscapeContent xmlEscaper cs = 
+xmlUnEscapeContent xmlEscaper cs =
    compressContent (unEscapeContent xmlEscaper cs)
 
 unEscapeElement :: XmlEscaper -> Element i -> Element i
@@ -196,7 +196,7 @@
    AttValue (
       map
          (\ av -> case av of
-            Left s -> av
+            Left _ -> av
             Right ref -> case unEscapeChar xmlEscaper ref of
                Just c -> Left [c]
                Nothing -> av
@@ -207,12 +207,12 @@
 unEscapeContent :: XmlEscaper -> [Content i] -> [Content i]
 unEscapeContent xmlEscaper content =
    map
-      (\ content -> case content of
+      (\ cntnt -> case cntnt of
          CRef ref i -> case unEscapeChar xmlEscaper ref of
             Just c -> CString False [c] i
-            Nothing -> content
-         CElem elem i -> CElem (unEscapeElement xmlEscaper elem) i
-         _ -> content
+            Nothing -> cntnt
+         CElem element i -> CElem (unEscapeElement xmlEscaper element) i
+         _ -> cntnt
          )
       content
 
@@ -252,11 +252,11 @@
 compressContent [] = []
 compressContent ((csb @ (CString b1 s1 i1)) : cs) =
    case compressContent cs of
-      (CString b2 s2 i2) : cs2
+      (CString b2 s2 _) : cs2
           | b1 == b2
           -> CString b1 (s1 ++ s2) i1: cs2
       cs2 -> csb : cs2
-compressContent (CElem element i : cs) = 
+compressContent (CElem element i : cs) =
    CElem (compressElement element) i : compressContent cs
 compressContent (c : cs) = c : compressContent cs
 
@@ -268,7 +268,7 @@
 stdXmlEscaper :: XmlEscaper
 stdXmlEscaper = mkXmlEscaper
    [('\60',"lt"),('\62',"gt"),('\38',"amp"),('\39',"apos"),('\34',"quot")]
-   (\ ch -> 
+   (\ ch ->
       let
          i = ord ch
       in
@@ -281,14 +281,14 @@
                '>' -> True
                _ -> False
       )
-             
-            
+
+
 mkXmlEscaper :: [(Char,String)] -> (Char -> Bool) -> XmlEscaper
-mkXmlEscaper escapes isEscape =
+mkXmlEscaper escapes isescape =
    XmlEscaper {
       toEscape = listToFM escapes,
       fromEscape = listToFM (map (\ (c,str) -> (str,c)) escapes),
-      isEscape = isEscape
+      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 @@ -31,149 +31,149 @@ ) where import Char (isSpace) -import List (partition) - -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) ] + +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" [] +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":) +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++"'" +---- 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 _) = elem 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 m _) = Pretty.empty - - elem (Elem n as []) = Pretty.text "<" Pretty.<> - Pretty.text n Pretty.<> - attrs as Pretty.<> - Pretty.text " />" - elem (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 attr - attr (n,v@(AttValue _)) = - Pretty.text " " Pretty.<> - Pretty.text n Pretty.<> - Pretty.text "='" Pretty.<> - Pretty.text (show v) Pretty.<> - Pretty.text "'" - - fmt n [] = [] - 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 p (ls,[]) = (ls,[]) - select p (ls,(x:xs)) | p x = (ls,x:xs) - | otherwise = select p (x:ls,xs) +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/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 @@ -10,7 +10,7 @@ instance (HTypeable a,HTypeable b) => HTypeable (OneOf2 a b) - where toHType m = Defined "OneOf2" [] [] + where toHType _ = Defined "OneOf2" [] [] -- toHType m = Defined "OneOf2" [a,b] [] -- where a = toHType $ (\ (OneOf2 a)->a) $ m -- b = toHType $ (\ (TwoOf2 b)->b) $ m @@ -32,7 +32,7 @@ instance (HTypeable a,HTypeable b,HTypeable c) => HTypeable (OneOf3 a b c) - where toHType m = Defined "OneOf3" [] [] + where toHType _ = Defined "OneOf3" [] [] instance (XmlContent a,XmlContent b,XmlContent c) => XmlContent (OneOf3 a b c) @@ -51,7 +51,7 @@ instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d) => HTypeable (OneOf4 a b c d) - where toHType m = Defined "OneOf4" [] [] + where toHType _ = Defined "OneOf4" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d) => XmlContent (OneOf4 a b c d) @@ -71,7 +71,7 @@ instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e) => HTypeable (OneOf5 a b c d e) - where toHType m = Defined "OneOf5" [] [] + where toHType _ = Defined "OneOf5" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e) => XmlContent (OneOf5 a b c d e) @@ -94,7 +94,7 @@ instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f) => HTypeable (OneOf6 a b c d e f) - where toHType m = Defined "OneOf6" [] [] + where toHType _ = Defined "OneOf6" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f) @@ -120,7 +120,7 @@ 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 m = Defined "OneOf7" [] [] + where toHType _ = Defined "OneOf7" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g) @@ -147,7 +147,7 @@ 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 m = Defined "OneOf8" [] [] + where toHType _ = Defined "OneOf8" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h) @@ -175,7 +175,7 @@ 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 m = Defined "OneOf9" [] [] + where toHType _ = Defined "OneOf9" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h,XmlContent i) @@ -205,7 +205,7 @@ 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 m = Defined "OneOf10" [] [] + 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) @@ -238,7 +238,7 @@ ,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 m = Defined "OneOf11" [] [] + 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 @@ -274,7 +274,7 @@ ,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 m = Defined "OneOf12" [] [] + 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 @@ -311,7 +311,7 @@ ,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 m = Defined "OneOf13" [] [] + 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 @@ -349,7 +349,7 @@ ,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 m = Defined "OneOf14" [] [] + 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 @@ -390,7 +390,7 @@ ,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 m = Defined "OneOf15" [] [] + 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 @@ -433,7 +433,7 @@ ,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 m = Defined "OneOf16" [] [] + 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 @@ -478,7 +478,7 @@ ,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 m = Defined "OneOf17" [] [] + 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 @@ -525,7 +525,7 @@ ,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 m = Defined "OneOf18" [] [] + 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 @@ -574,7 +574,7 @@ ,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 m = Defined "OneOf19" [] [] + 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 @@ -624,7 +624,7 @@ ,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 m = Defined "OneOf20" [] [] + 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 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 @@ -44,7 +44,7 @@ posInNewCxt name pos = Pn name 1 1 pos instance Show Posn where - showsPrec p (Pn f l c i) = showString f . + showsPrec _ (Pn f l c i) = showString f . showString " at line " . shows l . showString " col " . shows c . ( case i of @@ -55,7 +55,7 @@ -- | Just used to strictify the internal values of a position, to avoid -- space leaks. forcep :: Posn -> Int -forcep (Pn f n m i) = m `seq` n +forcep (Pn _ n m _) = m `seq` n -- | Add n character positions to the given position. addcol :: Int -> Posn -> Posn @@ -63,7 +63,7 @@ -- | Add a newline or tab to the given position. newline, tab :: Posn -> Posn -newline (Pn f r c i) = Pn f (r+1) 1 i +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. 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 @@ -30,234 +30,273 @@ 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 ";" +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 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) -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 (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 f [] 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 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) = 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 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 "PUBLIC" <+> 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) - | containsDoubleQuote evs = text "'" <> hcat (map ev evs) <> text "'" - | otherwise = 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) - | '"' `elem` s = text "'" <> text s <> text "'" - | otherwise = text "\"" <> text s <> text "\"" -systemliteral (SystemLiteral s) - | '"' `elem` s = text "'" <> text s <> text "'" - | otherwise = text "\"" <> text s <> text "\"" -chardata s = {-if all isSpace s then empty else-} text s -cdsect c = text "<![CDATA[" <> chardata c <> text "]]>" - ----- -containsDoubleQuote evs = any csq evs - where csq (EVString s) = '"' `elem` s - csq _ = False +---- + +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 @@ -37,8 +37,8 @@ -> ([SaxElement],Maybe String) -- ^ A tuple of the parsed elements and @Nothing@, if no -- error occured, or @Just@ @String@ if an error occured. -saxParse file content = parseStream sax emptySTs - (xmlLex file content) +saxParse file cntnt = parseStream sax emptySTs + (xmlLex file cntnt) parseStream :: Parser s t a -> s -> [t] -> ([a], Maybe String) parseStream _ _ [] = ([],Nothing) @@ -80,13 +80,13 @@ saxcomment = comment >>= return . SaxComment saxchardata :: XParser SaxElement -saxchardata = +saxchardata = (cdsect >>= return . SaxCharData) `onFail` (chardata >>= return . SaxCharData) saxreference :: XParser SaxElement -saxreference = reference >>= return . SaxReference +saxreference = reference >>= return . SaxReference saxdoctypedecl :: XParser SaxElement saxdoctypedecl = doctypedecl >>= return . SaxDocTypeDecl 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,283 +1,331 @@ -

-module Text.XML.HaXml.ShowXmlLazy (showXmlLazy) where
-
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.TypeMapping
-
-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
-      _ -> ""
+
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 )
-             []
+-- | 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 = ""
-($$) a b = a ++ "\n" ++ b
-vcat a = foldr ($$) [] a
-hcat = concat
-(<>) = (++)
-(<+>) a b = a ++ " " ++ b
-fsep = vcat
-text string = string
-parens string = "("++string++")"
-nest _ string = string
-
-
-
-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 ";"
+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
+
 
-----
-
-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)
-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 (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 f []     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 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)
-  | containsDoubleQuote evs    = text "'"  <> hcat (map ev evs) <> text "'"
-  | otherwise                  = 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)
-    | '"' `elem` s             = text "'" <> text s <> text "'"
-    | otherwise                = text "\"" <> text s <> text "\""
-systemliteral (SystemLiteral s)
-    | '"' `elem` s             = text "'" <> text s <> text "'"
-    | otherwise                = text "\"" <> text s <> text "\""
-chardata s                     = {-if all isSpace s then empty else-} text s
-cdsect c                       = text "<![CDATA[" <> chardata c <> text "]]>"
-
-----
-containsDoubleQuote evs = any csq evs
-    where csq (EVString s) = '"' `elem` s
-          csq _            = False
-
+
+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
@@ -92,118 +92,133 @@
 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 (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))
+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
 
-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
+-- 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))
 
-constrHtExpr :: Constr -> CP
-constrHtExpr (Constr s fv [])  = TagName "EMPTY" None   --  ***HACK!!!***
-constrHtExpr (Constr s fv hts) = innerHtExpr (Tuple hts) None
-
-------------------------------------------------------------------------
+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 @@ -137,15 +137,15 @@ data XMLDecl = XMLDecl VersionInfo (Maybe EncodingDecl) (Maybe SDDecl) deriving Eq data Misc = Comment Comment - | PI ProcessingInstruction + | PI ProcessingInstruction deriving Eq - + type ProcessingInstruction = (PITarget,String) -type SDDecl = Bool -type VersionInfo = String -type Comment = String -type 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 @@ -161,134 +161,136 @@ deriving Eq data Element i = Elem Name [Attribute] [Content i] deriving Eq - -- intermediate for parsing + -- 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 + -- ^ bool is whether whitespace is significant | CRef Reference i | CMisc Misc i deriving Eq -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 v) = v - 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 + +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/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 @@ -222,49 +222,55 @@ choice elem ns cps = -- return only those parses that don't give any errors [ rem | ([],rem) <- map (\cp-> checkCP elem (definite cp) ns) 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 - 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."] - + ++ [ 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)++".") -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 = "+" + +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 -duplicates :: Eq a => [a] -> [a] -duplicates xs = xs \\ (nub xs) +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/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,640 +1,683 @@ -
{-# OPTIONS -fglasgow-exts #-}
--- | 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, ord, isSpace)
-import List  (intersperse, isPrefixOf, isSuffixOf, partition)
-
-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, fst3)
-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
-v `debug` s = 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 tags = "one of"++ concatMap (\t->" <"++t++">") tags
-
--- | 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, cs@(c:_))
-            | all onlyMisc cs -> return x
-            | otherwise       -> fail ("Too many elements inside <"++e++"> at\n"
-                                      ++show (info c)++"\n"
-                                      ++"Found excess: "++verbatim c)
-  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 msg, _)  -> 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 msg, 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 x, es') ->
-                                case scanElements es' of
-                                    (Left msg, cs) -> (Left msg, cs)
-                                    (Right xs, cs) -> (Right (x:xs), cs)
-            (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 (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 f [] = 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 to n Nothing  = Nothing
-maybeToAttr to n (Just v) = to n v
-
-defaultToAttr :: (String->a->Maybe Attribute) -> String -> Defaultable a
-                 -> Maybe Attribute
-defaultToAttr to n (Default v)  = 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 s =
-          let (l,r) = span (\c-> not (elem c "\"&<>'")) s
-          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), []))
-
-------------------------------------------------------------------------
---  
-------------------------------------------------------------------------
+
{-# 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), []))
+
+------------------------------------------------------------------------
+--
+------------------------------------------------------------------------
 

 
diff --git a/docs/changelog.html b/docs/changelog.html
--- a/docs/changelog.html
+++ b/docs/changelog.html
@@ -20,7 +20,9 @@
      in the XtractLazy tool.
 
  •  Version 1.19.2 updates the Cabal file to enable HaXml to build with both
      ghc-6.6.x and ghc-6.8.x.
-
+
  •  Version 1.19.3 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.
 
 
 
    Changes in 1.18
    
diff --git a/docs/index.html b/docs/index.html
--- a/docs/index.html
+++ b/docs/index.html
@@ -132,10 +132,11 @@
 
    Downloads
    
 
    
 Development versions:
    
-HaXml-1.19.2, release date 2008.01.14
    
+HaXml-1.19.3, release date 2008.06.17
    
+From Hackage
    
 By HTTP:
-.tar.gz,
-.zip.
+.tar.gz,
+.zip.
 
    
 By FTP: 
 
@@ -202,6 +203,8 @@
 
    Recent news
    
 
 
    
+Version 1.19.3 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
 ghc-6.6.x and ghc-6.8.x.
    
 Version 1.19.1 fixes a build error in 1.19.
    
diff --git a/src/Makefile b/src/Makefile
--- a/src/Makefile
+++ b/src/Makefile
@@ -1,5 +1,5 @@
 SOFTWARE = HaXml
-VERSION = 1.19.2
+VERSION = 1.19.3
 
 LIBSRCS = \
 	Text/XML/HaXml.hs Text/XML/HaXml/Combinators.hs Text/XML/HaXml/Lex.hs \
diff --git a/src/Text/XML/HaXml/ByteStringPP.hs b/src/Text/XML/HaXml/ByteStringPP.hs
--- a/src/Text/XML/HaXml/ByteStringPP.hs
+++ b/src/Text/XML/HaXml/ByteStringPP.hs
@@ -22,51 +22,55 @@
 
 import Prelude hiding (maybe,either,elem,concat)
 import Maybe hiding (maybe)
-import Data.List (intersperse) 
+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, join
+import Data.ByteString.Lazy.Char8 (ByteString(), concat, pack, singleton, intercalate
                                   , append, elem, empty)
 import Text.XML.HaXml.Types
 
-either f g (Left x)  = f x
-either f g (Right x) = g x
+either :: (t -> t1) -> (t2 -> t1) -> Either t t2 -> t1
+either f _ (Left x)  = f x
+either _ g (Right x) = g x
 
-maybe f Nothing  = empty
+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 6 <+>
-infixl 5 $$, $+$
+infixl 5 $$
 (<>)   :: ByteString   -> ByteString -> ByteString -- Beside
-hcat   :: [ByteString] -> ByteString		   -- List version of <>
+hcat   :: [ByteString] -> ByteString                 -- List version of <>
 (<+>)  :: ByteString   -> ByteString -> ByteString -- Beside, separated by space
-hsep   :: [ByteString] -> ByteString		   -- List version of <+>
+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
+-- cat    :: [ByteString] -> ByteString       -- Either hcat or vcat
 sep    :: [ByteString] -> ByteString       -- Either hsep or vcat
-fcat   :: [ByteString] -> ByteString       -- ``Paragraph fill'' version of cat
+-- 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.join (singleton ' ')
-vcat = Data.ByteString.Lazy.Char8.join (singleton '\n')
-cat  = hcat
+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
-fcat = cat
+-- _ = cat
 fsep = sep
 nest _ b = pack " " <> b
+parens :: ByteString -> ByteString
 parens p = pack "(" <> p <> pack ")"
 
 
@@ -82,8 +86,8 @@
 
 doctypedecl   :: DocTypeDecl   -> ByteString
 markupdecl    :: MarkupDecl    -> ByteString
-extsubset     :: ExtSubset     -> ByteString
-extsubsetdecl :: ExtSubsetDecl -> ByteString
+-- extsubset     :: ExtSubset     -> ByteString
+-- extsubsetdecl :: ExtSubsetDecl -> ByteString
 cp            :: CP            -> ByteString
 
 element   :: Element i -> ByteString
@@ -105,7 +109,7 @@
 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 
+doctypedecl (DTD n eid ds) = if Prelude.null ds then
                                   hd <> text ">"
                              else hd <+> text " [" $$
                                   vcat (Prelude.map markupdecl ds) $$ text "]>"
@@ -117,10 +121,10 @@
 markupdecl (Notation n)    = notationdecl n
 markupdecl (MarkupMisc m)  = misc m
 --markupdecl (MarkupPE p m)  = peref p
-extsubset (ExtSubset t ds) = maybe textdecl t $$
-                             vcat (Prelude.map extsubsetdecl ds)
-extsubsetdecl (ExtMarkupDecl m)      = markupdecl m
-extsubsetdecl (ExtConditionalSect c) = conditionalsect c
+-- _ (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 <+>
@@ -135,15 +139,17 @@
     | 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 e@(Elem n as cs) c
+carryelem (Elem n as cs) c
 --  | any isText cs    =  ( c <> element e, empty)
     | otherwise        =  let (cs0,d0) = carryscan carrycontent cs (text ">")
                           in
@@ -152,6 +158,7 @@
                             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)
@@ -159,7 +166,7 @@
 carrycontent (CMisc m _) c   = (c <> misc m, empty)
 
 carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c)
-carryscan f []     c = ([],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)
@@ -189,8 +196,10 @@
 content (CRef r _)          = reference r
 content (CMisc m _)         = misc m
 
+elementdecl :: ElementDecl -> ByteString
 elementdecl (ElementDecl n cs) = text " text n <+>
                                  contentspec cs <> text ">"
+contentspec :: ContentSpec -> ByteString
 contentspec EMPTY              = text "EMPTY"
 contentspec ANY                = text "ANY"
 contentspec (Mixed m)          = mixed m
@@ -202,21 +211,27 @@
 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 " 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"
@@ -224,75 +239,102 @@
 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
-conditionalsect (IncludeSect i)= text "
-                                 vcat (Prelude.map extsubsetdecl i) <+> text "]]>"
-conditionalsect (IgnoreSect i) = text "
-                                 fsep (Prelude.map ignoresectcontents i) <+> text "]]>"
-ignore (Ignore)                = empty
-ignoresectcontents (IgnoreSectContents i is)
-                               = ignore i <+> vcat (Prelude.map internal is)
-                          where internal (ics,i) = text "
-                                                   ignoresectcontents ics <+>
-                                                   text "]]>" <+> ignore i
+--_ (IncludeSect i)= text "
+--                                 vcat (Prelude.map extsubsetdecl i) <+> text "]]>"
+-- conditionalsect (IgnoreSect i) = text "
+--                                  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 " text n <+> entitydef ed <>
                                  text ">"
+pedecl :: PEDecl -> ByteString
 pedecl (PEDecl n pd)           = text " text n <+> pedef pd <>
                                  text ">"
-entitydef (DefEntityValue ev)  = entityvalue ev
+entitydef :: EntityDef -> ByteString
+entitydef (DefEntityValue ew)  = entityvalue ew
 entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd
-pedef (PEDefEntityValue ev)    = entityvalue ev
+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 (TextDecl vi ed)      = text " maybe text vi <+>
-                                 encodingdecl ed <> text "?>"
-extparsedent (ExtParsedEnt t c)= maybe textdecl t <+> content c
-extpe (ExtPE t esd)            = maybe textdecl t <+>
-                                 vcat (Prelude.map extsubsetdecl esd)
+-- _ (TextDecl vi ed)      = text " 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 " 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 " chardata c <> text "]]>"
 
---toWord8 :: Char -> Word8
+-- 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/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
@@ -13,7 +13,7 @@
 
 ---- Internal representation for database of DTD decls ----
 data Record = R [AttDef] ContentSpec
-type Db = [(String,Record)]
+-- type Db = [(String,Record)]
 
 
 ---- Build a database of DTD decls then convert them to typedefs ----
@@ -21,7 +21,7 @@
 ---- Apparently multiple ATTLIST decls for the same element are permitted,
 ---- although only one ELEMENT decl for it is allowed.
 dtd2TypeDef :: [MarkupDecl] -> [TypeDef]
-dtd2TypeDef mds = 
+dtd2TypeDef mds =
   (concatMap convert . reverse . database []) mds
   where
   database db [] = db
@@ -38,7 +38,7 @@
     --  (MarkupPE _ m') -> database db (m':ms)
         _ -> database db ms
 
-  replace n v [] = error "dtd2TypeDef.replace: no element to replace"
+  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
@@ -86,8 +86,8 @@
 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 n ts = (mkConsName n ts, ts)
-    mkConsName (Name x n) sts = Name x (n++concat (intersperse "_" (map flatten sts)))
+    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
@@ -97,15 +97,16 @@
     flatten (OneOf sts)  = {-"OneOf" ++ show (length sts) ++ "_" ++ -}
                             concat (intersperse "_" (map flatten sts))
     flatten Any          = "Any"
-    flatten (Defined (Name _ n))  = n
+    flatten (Defined (Name _ m))  = m
 
-mkAttrDef e (AttDef n StringType def) =
+mkAttrDef :: String -> AttDef -> [TypeDef]
+mkAttrDef _ (AttDef _ StringType _) =
     []
-mkAttrDef e (AttDef n (TokenizedType t) def) =
+mkAttrDef _ (AttDef _ (TokenizedType _) _) =
     [] -- mkData [[String]] [] False (name n)
-mkAttrDef e (AttDef n (EnumeratedType (NotationType nt)) def) =
+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)) def) =
+mkAttrDef e (AttDef n (EnumeratedType (Enumeration es)) _) =
     [EnumDef (name_a e n) (map (name_ac e n) es)]
         -- Default attribute values not handled here
 
@@ -114,13 +115,13 @@
   where
     mkType StringType REQUIRED = String
     mkType StringType IMPLIED  = Maybe String
-    mkType StringType (DefaultTo v@(AttValue _) f) = Defaultable String (show v)
+    mkType StringType (DefaultTo v@(AttValue _) _) = Defaultable String (show v)
     mkType (TokenizedType _) REQUIRED  = String
     mkType (TokenizedType _) IMPLIED   = Maybe String
-    mkType (TokenizedType _) (DefaultTo v@(AttValue _) f) =
-							Defaultable String (show v)
+    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 _) f) =
-		Defaultable (Defined (name_a e n)) (hName (name_ac e n (show v)))
+    mkType (EnumeratedType _) (DefaultTo v@(AttValue _) _) =
+                Defaultable (Defined (name_a e n)) (hName (name_ac e n (show v)))
 
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
@@ -12,8 +12,8 @@
 mkInstance :: TypeDef -> Doc
 
 -- no constructors - represents an element with empty content but attributes.
-mkInstance (DataDef aux n fs []) =
-    let (frpat, frattr, topat, toattr) = attrpats fs
+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
@@ -81,9 +81,9 @@
 
 -- multiple constructors (real)
 mkInstance (DataDef False n fs cs) =
-    let vs = nameSupply cs
+    let _ = nameSupply cs
         (frpat, frattr, topat, toattr) = attrpats fs
-        mixattrs = if null fs then False else True
+        _ = if null fs then False else True
     in
     text "instance HTypeable" <+> ppHName n <+> text "where" $$
     nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" )
@@ -108,8 +108,8 @@
 
 -- multiple constructors (auxiliary)
 mkInstance (DataDef True n fs cs) =
-    let vs = nameSupply cs
-        (frpat, frattr, topat, toattr) = attrpats fs
+    let _ = nameSupply cs
+        (_, frattr, _, _) = attrpats fs
         mixattrs = if null fs then False else True
     in
     text "instance HTypeable" <+> ppHName n <+> text "where" $$
@@ -143,7 +143,7 @@
 data SameName = Same | Extended
 
 mkInstanceAttrs        :: SameName -> Name -> AttrFields -> Doc
-mkInstanceAttrs s n []  = empty
+mkInstanceAttrs _ _ []  = empty
 mkInstanceAttrs s n fs  =
     let ppName = case s of { Same-> ppHName;  Extended-> ppAName; }
     in
@@ -170,46 +170,46 @@
 
 
 
-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 n (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 s)       -> text "fromElem" <+> cvo
-            (List String)   -> text "many fromText" <+> cvo
-            (List s)        -> 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 ss)  -> 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 n <> text "\"" <+> cvo
-            (Defaultable _ _)  -> text "nyi_fromElem_Defaultable" <+> cvo
-          )
+-- 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 =
@@ -223,24 +223,25 @@
         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 s)       -> ap <+> text "optional parseContents"
+            (Maybe _)       -> ap <+> text "optional parseContents"
             (List String)   -> ap <+> text "many text"
-            (List s)        -> ap <+> text "many parseContents"
-            (List1 s)       -> ap <+> text "parseContents"
-            (Tuple ss)      -> ap <+> text "parseContents"
-            (OneOf ss)      -> ap <+> text "parseContents"
+            (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 m)     -> ap <+> text "parseContents"
+            (Defined _)     -> ap <+> text "parseContents"
             (Defaultable _ _)  -> ap <+> text "nyi_fromElem_Defaultable"
 
 --
@@ -252,27 +253,27 @@
     toElem st v =
       case st of
         (Maybe String)  -> text "maybe [] toText" <+> v
-        (Maybe s)       -> text "maybe [] toContents" <+> v
+        (Maybe _)       -> text "maybe [] toContents" <+> v
         (List String)   -> text "concatMap toText" <+> v
-        (List s)        -> text "concatMap toContents" <+> v
-        (List1 s)       -> text "toContents" <+> v
-        (Tuple ss)      -> text "toContents" <+> v
-        (OneOf ss)      -> text "toContents" <+> 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 m)     -> 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
+-- 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,nameSupply2 :: [b] -> [Doc]
+nameSupply :: [b] -> [Doc]
 nameSupply  ss = take (length ss) (map char ['a'..])
-nameSupply2 ss = take (length ss) [ text ('c':v:[]) | v <- ['a'..]]
+-- nameSupply2 ss = take (length ss) [ text ('c':v:[]) | v <- ['a'..]]
 
 mkTranslate :: [Name] -> Doc
 mkTranslate es =
@@ -282,6 +283,7 @@
     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 ")"
 
@@ -290,14 +292,14 @@
     ppHName n <+> text "=" <+>
     ( case st of
         (Defaultable String s) -> text "defaultA fromAttrToStr" <+>
-						 doubleQuotes (text s)
+                                                 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)
+                                                 doubleQuotes (ppXName tag)
         _                      -> text "definiteA fromAttrToTyp" <+>
-						 doubleQuotes (ppXName tag)
+                                                 doubleQuotes (ppXName tag)
     ) <+> doubleQuotes (ppXName n) <+> text "as"
 
 mkToFld :: (Name,StructType) -> Doc
@@ -311,67 +313,67 @@
         _                      -> 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) inner =
-        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 inner
-               )
-    blah [st] [v] =
-        blahblahblah st (text "c0")
-    blah sts vs =
-        let ns = nameSupply2 vs
-            cvs = zip ns (text "c0": init ns)
-            blahblah (st,v,(cvi,cvo)) inner =
-                parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$
-                        nest 2 inner) $$
-                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 s)      -> text "fromElem" <+> cvo
-          (List String)  -> text "many fromText" <+> cvo
-          (List s)       -> text "many fromElem" <+> cvo
-          (List1 s)      -> text "fromElem" <+> cvo
-          (Tuple ss)     -> text "fromElem" <+> cvo	-- ??
-          (OneOf ss)     -> text "fromElem" <+> cvo
-          (String)       -> text "fromText" <+> cvo
-          (Any)          -> text "fromElem" <+> cvo
-          (Defined m)    -> text "fromElem" <+> cvo
-        )
-    failpat sts =
-        let fp st =
-                case st of
-                  (Maybe s)   -> text "Nothing"
-                  (List s)    -> text "[]"
-                  (List1 s)   -> text "_"
-                  (Tuple ss)  -> text "_"
-                  (OneOf ss)  -> text "_"
-                  (String)    -> text "_"
-                  (Any)       -> text "_"
-                  (Defined m) -> text "_"
-        in parens (hcat (intersperse comma (map fp sts++[text "_"])))
-    succpat sts vs =
-        let sp st v =
-                case st of
-                  (Maybe s)   -> v
-                  (List s)    -> v
-                  (List1 s)   -> text "Just" <+> v
-                  (Tuple ss)  -> text "Just" <+> v
-                  (OneOf ss)  -> text "Just" <+> v
-                  (String)    -> text "Just" <+> v
-                  (Any)       -> text "Just" <+> v
-                  (Defined m) -> text "Just" <+> v
-        in parens (hcat (intersperse comma (zipWith sp sts vs++[rest])))
+-- 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) =
diff --git a/src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs b/src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs
--- a/src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs
+++ b/src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs
@@ -26,25 +26,25 @@
 ---- 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
+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.
+      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.
+    | Defaultable StructType String     -- ^ String holds default value.
     | List StructType
-    | List1 StructType			-- ^ Non-empty lists.
+    | List1 StructType                  -- ^ Non-empty lists.
     | Tuple [StructType]
     | OneOf [StructType]
-    | Any				-- ^ XML's contentspec allows ANY
+    | Any                               -- ^ XML's contentspec allows ANY
     | String
     | Defined Name
     deriving Eq
@@ -52,50 +52,50 @@
 -- 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 p (Defaultable s _) = shows s
+    showsPrec _ (Defaultable s _) = shows s
     showsPrec p (List s)          = showsPrec (p+1) s . showChar '*'
     showsPrec p (List1 s)         = showsPrec (p+1) s . showChar '+'
-    showsPrec p (Tuple ss)        = showChar '('
+    showsPrec _ (Tuple ss)        = showChar '('
                                     . foldr1 (.) (intersperse (showChar ',')
                                                               (map shows ss))
                                     . showChar ')'
-    showsPrec p (OneOf ss)        = showChar '('
+    showsPrec _ (OneOf ss)        = showChar '('
                                     . foldr1 (.) (intersperse (showChar '|')
                                                               (map shows ss))
                                     . showChar ')'
-    showsPrec p (Any)             = showString "ANY"
-    showsPrec p (String)          = showString "#PCDATA"
-    showsPrec p (Defined (Name n _)) = showString n
+    showsPrec _ (Any)             = showString "ANY"
+    showsPrec _ (String)          = showString "#PCDATA"
+    showsPrec _ (Defined (Name n _)) = showString n
 
 
 ---- Pretty-printing typedefs ----
 ppTypeDef :: TypeDef -> Doc
 
---	no attrs, no constructors
+--      no attrs, no constructors
 ppTypeDef (DataDef _ n [] []) =
-    let name = ppHName n in
-    text "data" <+> name <+> text "=" <+> name <+> text "\t\t" <> derives
+    let nme = ppHName n in
+    text "data" <+> nme <+> text "=" <+> nme <+> text "\t\t" <> derives
 
---	no attrs, single constructor
+--      no attrs, single constructor
 ppTypeDef (DataDef _ n [] [c@(_,[_])]) =
     text "newtype" <+> ppHName n <+> text "=" <+> ppC c <+> text "\t\t" <> derives
 
---	no attrs, multiple constrs
+--      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
+--      nonzero attrs, no constructors
 ppTypeDef (DataDef _ n fs []) =
-    let name = ppHName n in
-    text "data" <+> name <+> text "=" <+> name $$
+    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
+--      nonzero attrs, one or more constrs
 ppTypeDef (DataDef _ n fs cs) =
     let attr = ppAName n in
     text "data" <+> ppHName n <+>
@@ -107,7 +107,7 @@
              vcat (map (\f-> text "," <+> ppF f) (tail fs)) $$
              text "}" <+> derives )
 
---	enumerations (of attribute values)
+--      enumerations (of attribute values)
 ppTypeDef (EnumDef n es) =
     text "data" <+> ppHName n <+>
     ( text "=" <+>
@@ -148,7 +148,8 @@
 -- | 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"]))
 
 
@@ -195,39 +196,38 @@
 
 -- | Ensure a generated name does not conflict with a standard haskell one.
 notPrelude :: String -> String
-notPrelude "String"  = "AString"
-notPrelude "Maybe"   = "AMaybe"
-notPrelude "Either"  = "AEither"
+notPrelude "Bool"    = "ABool"
+notPrelude "Bounded" = "ABounded"
 notPrelude "Char"    = "AChar"
-notPrelude "String"  = "AString"
-notPrelude "Int"     = "AInt"
-notPrelude "Integer" = "AInteger"
-notPrelude "Float"   = "AFloat"
 notPrelude "Double"  = "ADouble"
-notPrelude "List1"   = "AList1"	-- part of HaXml
-notPrelude "IO"      = "AIO"
-notPrelude "IOError" = "AIOError"
-notPrelude "FilePath"= "AFilePath"
-notPrelude "Bool"    = "ABool"
-notPrelude "Ordering"= "AOrdering"
-notPrelude "Eq"      = "AEq"
-notPrelude "Ord"     = "AOrd"
+notPrelude "Either"  = "AEither"
 notPrelude "Enum"    = "AEnum"
-notPrelude "Bounded" = "ABounded"
+notPrelude "Eq"      = "AEq"
+notPrelude "FilePath"= "AFilePath"
+notPrelude "Float"   = "AFloat"
+notPrelude "Floating"= "AFloating"
+notPrelude "Fractional"= "AFractional"
 notPrelude "Functor" = "AFunctor"
-notPrelude "Monad"   = "AMonad"
-notPrelude "Rational"= "ARational"
+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 "RealFrac"= "ARealFrac"
-notPrelude "Floating"= "AFloating"
 notPrelude "RealFloat" = "ARealFloat"
-notPrelude "Fractional"= "AFractional"
-notPrelude "Read"    = "ARead"
+notPrelude "RealFrac"= "ARealFrac"
 notPrelude "Show"    = "AShow"
-notPrelude "ReadS"   = "AReadS"
 notPrelude "ShowS"   = "AShowS"
+notPrelude "String"  = "AString"
 notPrelude n         = n
 
 -- | Convert an XML name to a Haskell varid.
@@ -244,4 +244,5 @@
 decolonify '.' = '_'
 decolonify  c  = c
 
+commaList :: [Doc] -> Doc
 commaList = hcat . intersperse comma
diff --git a/src/Text/XML/HaXml/Escape.hs b/src/Text/XML/HaXml/Escape.hs
--- a/src/Text/XML/HaXml/Escape.hs
+++ b/src/Text/XML/HaXml/Escape.hs
@@ -1,5 +1,5 @@
 {- This module contains code for escaping/unescaping text in attributes
-   and elements in the HaXml Element type, replacing characters by character 
+   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
@@ -21,7 +21,7 @@
       -- Something describing a particular set of escapes.
 
    stdXmlEscaper,
-      -- Standard boilerplate escaper, escaping everything that is 
+      -- Standard boilerplate escaper, escaping everything that is
       -- nonprintable, non-ASCII, or might conceivably cause problems by
       -- parsing XML, for example quotes, < signs, and ampersands.
 
@@ -56,7 +56,7 @@
    ) where
 
 import Char
-import Numeric
+-- import Numeric
 import Text.XML.HaXml.Types
 
 #if __GLASGOW_HASKELL__ >= 604 || __NHC__ >= 118 || defined(__HUGS__)
@@ -98,16 +98,16 @@
 
 
 xmlEscape :: XmlEscaper -> Element i -> Element i
-xmlEscape xmlEscaper element = 
+xmlEscape xmlEscaper element =
    compressElement (escapeElement xmlEscaper element)
 
 xmlEscapeContent :: XmlEscaper -> [Content i] -> [Content i]
-xmlEscapeContent xmlEscaper cs = 
+xmlEscapeContent xmlEscaper cs =
    compressContent (escapeContent xmlEscaper cs)
 
 escapeElement :: XmlEscaper -> Element i -> Element i
 escapeElement xmlEscaper (Elem name attributes content) =
-   Elem name (escapeAttributes xmlEscaper attributes) 
+   Elem name (escapeAttributes xmlEscaper attributes)
       (escapeContent xmlEscaper content)
 
 escapeAttributes :: XmlEscaper -> [Attribute] -> [Attribute]
@@ -115,23 +115,23 @@
    map
       (\ (name,av) -> (name,escapeAttValue xmlEscaper av))
       atts
-   
+
 escapeAttValue :: XmlEscaper -> AttValue -> AttValue
 escapeAttValue xmlEscaper (AttValue attValList) =
    AttValue (
-      concat ( 
+      concat (
          map
             (\ av -> case av of
-               Right ref -> [av]
+               Right _ -> [av]
                Left s ->
                   map
-                     (\ c -> if isEscape xmlEscaper c 
+                     (\ c -> if isEscape xmlEscaper c
                         then
                            Right (mkEscape xmlEscaper c)
                         else
                            Left [c]
                         )
-                     s 
+                     s
                )
             attValList
          )
@@ -151,20 +151,20 @@
                          CString b [c] i
                       )
                    str
-             (CElem elem i) -> [CElem (escapeElement xmlEscaper elem) i]
+             (CElem element i) -> [CElem (escapeElement xmlEscaper element) i]
              _ -> [content]
              )
           contents
           )
 
 mkEscape :: XmlEscaper -> Char -> Reference
-mkEscape (XmlEscaper {toEscape = toEscape}) ch =
-   case lookupFM toEscape ch of
+mkEscape (XmlEscaper {toEscape = toescape}) ch =
+   case lookupFM toescape ch of
       Nothing  -> RefChar (ord ch)
       Just str -> RefEntity str
-   where
-      showHex = showIntAtBase 16 intToDigit 
-      -- It should be, but in GHC it isn't.
+--    where
+--       _ = showIntAtBase 16 intToDigit
+--       -- It should be, but in GHC it isn't.
 
 -- ------------------------------------------------------------------------
 -- Unescaping
@@ -175,7 +175,7 @@
    compressElement (unEscapeElement xmlEscaper element)
 
 xmlUnEscapeContent :: XmlEscaper -> [Content i] -> [Content i]
-xmlUnEscapeContent xmlEscaper cs = 
+xmlUnEscapeContent xmlEscaper cs =
    compressContent (unEscapeContent xmlEscaper cs)
 
 unEscapeElement :: XmlEscaper -> Element i -> Element i
@@ -194,7 +194,7 @@
    AttValue (
       map
          (\ av -> case av of
-            Left s -> av
+            Left _ -> av
             Right ref -> case unEscapeChar xmlEscaper ref of
                Just c -> Left [c]
                Nothing -> av
@@ -205,12 +205,12 @@
 unEscapeContent :: XmlEscaper -> [Content i] -> [Content i]
 unEscapeContent xmlEscaper content =
    map
-      (\ content -> case content of
+      (\ cntnt -> case cntnt of
          CRef ref i -> case unEscapeChar xmlEscaper ref of
             Just c -> CString False [c] i
-            Nothing -> content
-         CElem elem i -> CElem (unEscapeElement xmlEscaper elem) i
-         _ -> content
+            Nothing -> cntnt
+         CElem element i -> CElem (unEscapeElement xmlEscaper element) i
+         _ -> cntnt
          )
       content
 
@@ -250,11 +250,11 @@
 compressContent [] = []
 compressContent ((csb @ (CString b1 s1 i1)) : cs) =
    case compressContent cs of
-      (CString b2 s2 i2) : cs2
+      (CString b2 s2 _) : cs2
           | b1 == b2
           -> CString b1 (s1 ++ s2) i1: cs2
       cs2 -> csb : cs2
-compressContent (CElem element i : cs) = 
+compressContent (CElem element i : cs) =
    CElem (compressElement element) i : compressContent cs
 compressContent (c : cs) = c : compressContent cs
 
@@ -266,7 +266,7 @@
 stdXmlEscaper :: XmlEscaper
 stdXmlEscaper = mkXmlEscaper
    [('\60',"lt"),('\62',"gt"),('\38',"amp"),('\39',"apos"),('\34',"quot")]
-   (\ ch -> 
+   (\ ch ->
       let
          i = ord ch
       in
@@ -279,13 +279,13 @@
                '>' -> True
                _ -> False
       )
-             
-            
+
+
 mkXmlEscaper :: [(Char,String)] -> (Char -> Bool) -> XmlEscaper
-mkXmlEscaper escapes isEscape =
+mkXmlEscaper escapes isescape =
    XmlEscaper {
       toEscape = listToFM escapes,
       fromEscape = listToFM (map (\ (c,str) -> (str,c)) escapes),
-      isEscape = isEscape
+      isEscape = isescape
       }
 
diff --git a/src/Text/XML/HaXml/Html/Generate.hs b/src/Text/XML/HaXml/Html/Generate.hs
--- a/src/Text/XML/HaXml/Html/Generate.hs
+++ b/src/Text/XML/HaXml/Html/Generate.hs
@@ -29,7 +29,6 @@
   ) where
 
 import Char (isSpace)
-import List (partition)
 
 import Text.XML.HaXml.Types
 import Text.XML.HaXml.Combinators
@@ -94,41 +93,41 @@
 -- htmlprint :: [Content] -> String
 -- htmlprint = concatMap cprint
 --   where
---   cprint (CElem e _) = elem e 
+--   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"
--- 
+--
 --   attrs = concatMap attr
 --   attr (n,v) = " "++n++"='"++v++"'"
 
 
 htmlprint :: [Content i] -> Pretty.Doc
-htmlprint = Pretty.cat . map cprint . foldrefs 
+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 (RefEntity (EntityRef n)) = n     -- Actually, should look-up symtable.
 --ref (RefChar (CharRef s)) = s
-  ref (RefEntity n) = n	-- Actually, should look-up symtable.
+  ref (RefEntity n) = n -- Actually, should look-up symtable.
   ref (RefChar s) = show s
 
-  cprint (CElem e _)      = elem e
+  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 m _)      = Pretty.empty
- 
-  elem (Elem n as []) = Pretty.text "<"   Pretty.<>
+  cprint (CMisc _ _)      = Pretty.empty
+
+  element (Elem n as []) = Pretty.text "<"   Pretty.<>
                         Pretty.text n     Pretty.<>
                         attrs as          Pretty.<>
                         Pretty.text " />"
-  elem (Elem n as cs) =
+  element (Elem n as cs) =
                     --  ( Pretty.text "<"   Pretty.<>
                     --    Pretty.text n     Pretty.<>
                     --    attrs as          Pretty.<>
@@ -147,15 +146,15 @@
                                         Pretty.text ">" )
                                     ]
 
-  attrs = Pretty.cat . map attr
-  attr (n,v@(AttValue _)) =
+  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 n [] = []
+  fmt _ [] = []
   fmt n s  = let (top,bot) = splitAt n s
                  (word,left) = keepUntil isSpace (reverse top)
              in if length top < n then [s]
@@ -170,6 +169,7 @@
                  | otherwise = c : deSpace cs
 
   keepUntil p xs = select p ([],xs)
-      where select p (ls,[])     = (ls,[])
-            select p (ls,(x:xs)) | p x       = (ls,x:xs)
-                                 | otherwise = select p (x:ls,xs)
+      where select _ (ls,[])     = (ls,[])
+            select q (ls,(y:ys)) | q y       = (ls,y:ys)
+                                 | otherwise = select q (y:ls,ys)
+
diff --git a/src/Text/XML/HaXml/OneOfN.hs b/src/Text/XML/HaXml/OneOfN.hs
--- a/src/Text/XML/HaXml/OneOfN.hs
+++ b/src/Text/XML/HaXml/OneOfN.hs
@@ -8,7 +8,7 @@
 
 instance (HTypeable a,HTypeable b)
     => HTypeable (OneOf2 a b)
-  where      toHType m = Defined "OneOf2" [] []
+  where      toHType _ = Defined "OneOf2" [] []
   --         toHType m = Defined "OneOf2" [a,b] []
   --            where a = toHType $ (\ (OneOf2 a)->a) $ m
   --                  b = toHType $ (\ (TwoOf2 b)->b) $ m
@@ -30,7 +30,7 @@
 
 instance (HTypeable a,HTypeable b,HTypeable c)
     => HTypeable (OneOf3 a b c)
-  where      toHType m = Defined "OneOf3" [] []
+  where      toHType _ = Defined "OneOf3" [] []
 
 instance (XmlContent a,XmlContent b,XmlContent c)
     => XmlContent (OneOf3 a b c)
@@ -49,7 +49,7 @@
 
 instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d)
     => HTypeable (OneOf4 a b c d)
-  where      toHType m = Defined "OneOf4" [] []
+  where      toHType _ = Defined "OneOf4" [] []
 
 instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d)
     => XmlContent (OneOf4 a b c d)
@@ -69,7 +69,7 @@
 
 instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e)
     => HTypeable (OneOf5 a b c d e)
-  where      toHType m = Defined "OneOf5" [] []
+  where      toHType _ = Defined "OneOf5" [] []
 
 instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e)
     => XmlContent (OneOf5 a b c d e)
@@ -92,7 +92,7 @@
 instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e
           ,HTypeable f)
     => HTypeable (OneOf6 a b c d e f)
-  where      toHType m = Defined "OneOf6" [] []
+  where      toHType _ = Defined "OneOf6" [] []
 
 instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
           ,XmlContent f)
@@ -118,7 +118,7 @@
 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 m = Defined "OneOf7" [] []
+  where      toHType _ = Defined "OneOf7" [] []
 
 instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
           ,XmlContent f,XmlContent g)
@@ -145,7 +145,7 @@
 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 m = Defined "OneOf8" [] []
+  where      toHType _ = Defined "OneOf8" [] []
 
 instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
           ,XmlContent f,XmlContent g,XmlContent h)
@@ -173,7 +173,7 @@
 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 m = Defined "OneOf9" [] []
+  where      toHType _ = Defined "OneOf9" [] []
 
 instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e
           ,XmlContent f,XmlContent g,XmlContent h,XmlContent i)
@@ -203,7 +203,7 @@
 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 m = Defined "OneOf10" [] []
+  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)
@@ -236,7 +236,7 @@
           ,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 m = Defined "OneOf11" [] []
+  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
@@ -272,7 +272,7 @@
           ,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 m = Defined "OneOf12" [] []
+  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
@@ -309,7 +309,7 @@
           ,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 m = Defined "OneOf13" [] []
+  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
@@ -347,7 +347,7 @@
           ,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 m = Defined "OneOf14" [] []
+  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
@@ -388,7 +388,7 @@
           ,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 m = Defined "OneOf15" [] []
+  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
@@ -431,7 +431,7 @@
           ,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 m = Defined "OneOf16" [] []
+  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
@@ -476,7 +476,7 @@
           ,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 m = Defined "OneOf17" [] []
+  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
@@ -523,7 +523,7 @@
           ,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 m = Defined "OneOf18" [] []
+  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
@@ -572,7 +572,7 @@
           ,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 m = Defined "OneOf19" [] []
+  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
@@ -622,7 +622,7 @@
           ,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 m = Defined "OneOf20" [] []
+  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
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,7 @@
 posInNewCxt name pos = Pn name 1 1 pos
 
 instance Show Posn where
-      showsPrec p (Pn f l c i) = showString f .
+      showsPrec _ (Pn f l c i) = showString f .
                                  showString "  at line " . shows l .
                                  showString " col " . shows c .
                                  ( case i of
@@ -53,7 +53,7 @@
 -- | Just used to strictify the internal values of a position, to avoid
 --   space leaks.
 forcep :: Posn -> Int
-forcep (Pn f n m i) = m `seq` n
+forcep (Pn _ n m _) = m `seq` n
 
 -- | Add n character positions to the given position.
 addcol :: Int -> Posn -> Posn
@@ -61,7 +61,7 @@
 
 -- | Add a newline or tab to the given position.
 newline, tab :: Posn -> Posn
-newline (Pn f r c i) = Pn f (r+1) 1 i
+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.
diff --git a/src/Text/XML/HaXml/Pretty.hs b/src/Text/XML/HaXml/Pretty.hs
--- a/src/Text/XML/HaXml/Pretty.hs
+++ b/src/Text/XML/HaXml/Pretty.hs
@@ -28,10 +28,12 @@
 import Text.PrettyPrint.HughesPJ
 import Text.XML.HaXml.Types
 
-either f g (Left x)  = f x
-either f g (Right x) = g x
+either :: (t -> t1) -> (t2 -> t1) -> Either t t2 -> t1
+either f _ (Left x)  = f x
+either _ g (Right x) = g x
 
-maybe f Nothing  = empty
+maybe :: (t -> Doc) -> Maybe t -> Doc
+maybe _ Nothing  = empty
 maybe f (Just x) = f x
 
 --peref p   = text "%" <> text p <> text ";"
@@ -69,7 +71,7 @@
 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 
+doctypedecl (DTD n eid ds) = if null ds then
                                   hd <> text ">"
                              else hd <+> text " [" $$
                                   vcat (map markupdecl ds) $$ text "]>"
@@ -80,12 +82,12 @@
 markupdecl (Entity e)      = entitydecl e
 markupdecl (Notation n)    = notationdecl n
 markupdecl (MarkupMisc m)  = misc m
---markupdecl (MarkupPE p m)  = peref p
+-- markupdecl (MarkupPE p m)  = peref p
 extsubset (ExtSubset t ds) = maybe textdecl t $$
                              vcat (map extsubsetdecl ds)
-extsubsetdecl (ExtMarkupDecl m)      = markupdecl m
+extmarkupdecl (ExtMarkupDecl m)      = markupdecl m
 extsubsetdecl (ExtConditionalSect c) = conditionalsect c
---extsubsetdecl (ExtPEReference p e)   = peref p
+-- extsubsetdecl (ExtPEReference p e)   = peref p
 
 element (Elem n as []) = text "<" <> text n <+>
                          fsep (map attribute as) <> text "/>"
@@ -99,15 +101,18 @@
     | 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 e@(Elem n as cs) c
+carryelem (Elem n as cs) c
 --  | any isText cs    =  ( c <> element e, empty)
     | otherwise        =  let (cs0,d0) = carryscan carrycontent cs (text ">")
                           in
@@ -123,7 +128,7 @@
 carrycontent (CMisc m _) c   = (c <> misc m, empty)
 
 carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c)
-carryscan f []     c = ([],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)
@@ -153,8 +158,10 @@
 content (CRef r _)          = reference r
 content (CMisc m _)         = misc m
 
+elementdecl :: ElementDecl -> Doc
 elementdecl (ElementDecl n cs) = text " text n <+>
                                  contentspec cs <> text ">"
+contentspec :: ContentSpec -> Doc
 contentspec EMPTY              = text "EMPTY"
 contentspec ANY                = text "ANY"
 contentspec (Mixed m)          = mixed m
@@ -166,21 +173,27 @@
 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 " 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"
@@ -188,11 +201,15 @@
 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
@@ -206,54 +223,76 @@
                           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 " text n <+> entitydef ed <>
                                  text ">"
+pedecl :: PEDecl -> Doc
 pedecl (PEDecl n pd)           = text " text n <+> pedef pd <>
                                  text ">"
-entitydef (DefEntityValue ev)  = entityvalue ev
+entitydef :: EntityDef -> Doc
+entitydef (DefEntityValue ew)  = entityvalue ew
 entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd
-pedef (PEDefEntityValue ev)    = entityvalue ev
+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 " 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 " 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 " chardata c <> text "]]>"
 
 ----
+containsDoubleQuote :: [EV] -> Bool
 containsDoubleQuote evs = any csq evs
     where csq (EVString s) = '"' `elem` s
           csq _            = False
diff --git a/src/Text/XML/HaXml/SAX.hs b/src/Text/XML/HaXml/SAX.hs
--- a/src/Text/XML/HaXml/SAX.hs
+++ b/src/Text/XML/HaXml/SAX.hs
@@ -35,8 +35,8 @@
 	 -> ([SaxElement],Maybe String)
 		-- ^ A tuple of the parsed elements and @Nothing@, if no
 		--   error occured, or @Just@ @String@ if an error occured.
-saxParse file content = parseStream sax emptySTs
-                                    (xmlLex file content)
+saxParse file cntnt = parseStream sax emptySTs
+                                    (xmlLex file cntnt)
 
 parseStream :: Parser s t a -> s -> [t] -> ([a], Maybe String)
 parseStream _ _ [] = ([],Nothing)
@@ -78,13 +78,13 @@
 saxcomment = comment >>= return . SaxComment
 
 saxchardata :: XParser SaxElement
-saxchardata = 
+saxchardata =
   (cdsect >>= return . SaxCharData)
   `onFail`
   (chardata >>= return . SaxCharData)
 
 saxreference :: XParser SaxElement
-saxreference = reference >>= return . SaxReference	
+saxreference = reference >>= return . SaxReference
 
 saxdoctypedecl :: XParser SaxElement
 saxdoctypedecl = doctypedecl >>= return . SaxDocTypeDecl
diff --git a/src/Text/XML/HaXml/ShowXmlLazy.hs b/src/Text/XML/HaXml/ShowXmlLazy.hs
--- a/src/Text/XML/HaXml/ShowXmlLazy.hs
+++ b/src/Text/XML/HaXml/ShowXmlLazy.hs
@@ -1,15 +1,14 @@
-
 module Text.XML.HaXml.ShowXmlLazy (showXmlLazy) where
 
 import Text.XML.HaXml.Types
-import Text.XML.HaXml.TypeMapping
+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).                                         
+-- | 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
@@ -17,7 +16,7 @@
       _ -> ""
 
 
--- | Convert a fully-typed XML document to a string (with or without DTD).                                 
+-- | 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
@@ -34,23 +33,35 @@
 
 
 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 f g (Left x)  = f x
-either f g (Right x) = g x
+either :: (t -> t1) -> (t2 -> t1) -> Either t t2 -> t1
+either f _ (Left x)  = f x
+either _ g (Right x) = g x
 
-maybe f Nothing  = empty
+maybe :: (t -> [Char]) -> Maybe t -> [Char]
+maybe _ Nothing  = empty
 maybe f (Just x) = f x
 
 --peref p   = text "%" <> text p <> text ";"
@@ -65,8 +76,8 @@
 
 doctypedecl :: DocTypeDecl -> Doc
 markupdecl  :: MarkupDecl -> Doc
-extsubset   :: ExtSubset -> Doc
-extsubsetdecl :: ExtSubsetDecl -> Doc
+-- extsubset   :: ExtSubset -> Doc
+-- extsubsetdecl :: ExtSubsetDecl -> Doc
 cp          :: CP -> Doc
 
 element   :: Element i -> Doc
@@ -88,7 +99,7 @@
 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 
+doctypedecl (DTD n eid ds) = if null ds then
                                   hd <> text ">"
                              else hd <+> text " [" $$
                                   vcat (map markupdecl ds) $$ text "]>"
@@ -100,10 +111,10 @@
 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
+-- _ (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 <+>
@@ -118,6 +129,7 @@
     | otherwise        = let (d,c) = carryelem e empty
                          in d <> c
 
+isText :: Content t -> Bool
 isText (CString _ _ _) = True
 isText (CRef _ _)      = True
 isText _               = False
@@ -126,15 +138,17 @@
                        = ( c <>
                            text "<" <> text n <+> fsep (map attribute as)
                          , text "/>")
-carryelem e@(Elem n as cs) c
+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) <> --- $$
+                            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)
@@ -142,7 +156,7 @@
 carrycontent (CMisc m _) c   = (c <> misc m, empty)
 
 carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c)
-carryscan f []     c = ([],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)
@@ -172,8 +186,10 @@
 content (CRef r _)          = reference r
 content (CMisc m _)         = misc m
 
+elementdecl :: ElementDecl -> [Char]
 elementdecl (ElementDecl n cs) = text " text n <+>
                                  contentspec cs <> text ">"
+contentspec :: ContentSpec -> [Char]
 contentspec EMPTY              = text "EMPTY"
 contentspec ANY                = text "ANY"
 contentspec (Mixed m)          = mixed m
@@ -185,21 +201,27 @@
 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 " 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"
@@ -207,72 +229,98 @@
 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
-conditionalsect (IncludeSect i)= text "
-                                 vcat (map extsubsetdecl i) <+> text "]]>"
-conditionalsect (IgnoreSect i) = text "
-                                 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
+-- _ (IncludeSect i)= text "
+--                                  vcat (map extsubsetdecl i) <+> text "]]>"
+-- conditionalsect (IgnoreSect i) = text "
+--                                  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 " text n <+> entitydef ed <>
                                  text ">"
+pedecl :: PEDecl -> [Char]
 pedecl (PEDecl n pd)           = text " text n <+> pedef pd <>
                                  text ">"
-entitydef (DefEntityValue ev)  = entityvalue ev
+entitydef :: EntityDef -> [Char]
+entitydef (DefEntityValue ew)  = entityvalue ew
 entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd
-pedef (PEDefEntityValue ev)    = entityvalue ev
+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 (TextDecl vi ed)      = text " 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)
+-- _ (TextDecl vi ed)      = text " 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 " 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 " chardata c <> text "]]>"
 
 ----
+containsDoubleQuote :: [EV] -> Bool
 containsDoubleQuote evs = any csq evs
     where csq (EVString s) = '"' `elem` s
           csq _            = False
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
@@ -90,6 +90,21 @@
 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
diff --git a/src/Text/XML/HaXml/Types.hs b/src/Text/XML/HaXml/Types.hs
--- a/src/Text/XML/HaXml/Types.hs
+++ b/src/Text/XML/HaXml/Types.hs
@@ -135,15 +135,15 @@
 data XMLDecl    = XMLDecl VersionInfo (Maybe EncodingDecl) (Maybe SDDecl)
                   deriving Eq
 data Misc       = Comment Comment
-                | PI ProcessingInstruction 
+                | PI ProcessingInstruction
                 deriving Eq
-              
+
 type ProcessingInstruction = (PITarget,String)
 
-type SDDecl      = Bool 
-type VersionInfo = String 
-type Comment     = String 
-type 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
@@ -159,15 +159,17 @@
                    deriving Eq
 
 data Element i = Elem Name [Attribute] [Content i] deriving Eq
-                                       	--  intermediate for parsing
+                                        --  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
+                        -- ^ 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
@@ -192,21 +194,21 @@
 -- FIXME: What is TagName here? Seems to be in disagreement with XML spec.
 data CP = TagName Name Modifier
         | Choice [CP] Modifier
-        | Seq [CP] Modifier 
+        | Seq [CP] Modifier
         deriving Eq
 data Modifier = None  -- ^ Just One
               | Query -- ^ Zero Or One
               | Star  -- ^ Zero Or More
-              | Plus  -- ^ One Or More 
+              | Plus  -- ^ One Or More
               deriving Eq
 data Mixed = PCDATA
-           | PCDATAplus [Name] 
+           | 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 
+                 | EnumeratedType EnumeratedType
                  deriving Eq
 data TokenizedType = ID
                    | IDREF
@@ -214,21 +216,21 @@
                    | ENTITY
                    | ENTITIES
                    | NMTOKEN
-                   | NMTOKENS 
+                   | NMTOKENS
                    deriving Eq
 data EnumeratedType = NotationType NotationType
-                    | Enumeration Enumeration 
+                    | Enumeration Enumeration
                     deriving Eq
-type NotationType   = [Name]	-- nonempty list
-type Enumeration    = [NmToken]	-- nonempty list
+type NotationType   = [Name]    -- nonempty list
+type Enumeration    = [NmToken] -- nonempty list
 data DefaultDecl    = REQUIRED
                     | IMPLIED
-                    | DefaultTo AttValue (Maybe FIXED) 
+                    | DefaultTo AttValue (Maybe FIXED)
                     deriving Eq
 data FIXED          = FIXED deriving Eq
 
 data ConditionalSect = IncludeSect IncludeSect
-                     | IgnoreSect IgnoreSect 
+                     | IgnoreSect IgnoreSect
                      deriving Eq
 type IncludeSect = [ExtSubsetDecl]
 type IgnoreSect  = [IgnoreSectContents]
@@ -236,19 +238,19 @@
 data IgnoreSectContents = IgnoreSectContents Ignore [(IgnoreSectContents,Ignore)]  deriving Eq
 
 data Reference    = RefEntity EntityRef
-                  | RefChar CharRef 
+                  | RefChar CharRef
                   deriving (Eq,Show)
-type EntityRef    = Name 
+type EntityRef    = Name
 type CharRef      = Int
-type PEReference  = Name 
+type PEReference  = Name
 
 data EntityDecl   = EntityGEDecl GEDecl
-                  | EntityPEDecl PEDecl 
+                  | 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) 
+data EntityDef    = DefEntityValue EntityValue
+                  | DefExternalID ExternalID (Maybe NDataDecl)
                   deriving Eq
 data PEDef        = PEDefEntityValue EntityValue
                   | PEDefExternalID ExternalID deriving (Eq,Show)
@@ -264,16 +266,16 @@
 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
+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  v)               = v
+      decode (Left  w)               = w
       decode (Right (RefEntity ent)) = "&"++ent++";"
       decode (Right (RefChar cref))  = "&"++show cref++";"
 
@@ -283,7 +285,7 @@
         | EVRef Reference  deriving (Eq,Show)
 newtype PubidLiteral  = PubidLiteral String deriving (Eq,Show)
 newtype SystemLiteral = SystemLiteral String deriving (Eq,Show)
-type CharData         = String 
+type CharData         = String
 type CDSect           = CharData
 
 instance Eq ElemTag where
diff --git a/src/Text/XML/HaXml/Validate.hs b/src/Text/XML/HaXml/Validate.hs
--- a/src/Text/XML/HaXml/Validate.hs
+++ b/src/Text/XML/HaXml/Validate.hs
@@ -220,6 +220,7 @@
 
     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
@@ -227,6 +228,11 @@
               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'))
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
@@ -1,4 +1,5 @@
-{-# OPTIONS -fglasgow-exts #-}
+{-# 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.
@@ -23,7 +24,7 @@
 --   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
@@ -31,7 +32,7 @@
   , Element(..)
   , ElemTag(..)
   , Content(..)
-  , Attribute(..)
+  , Attribute()
   , AttValue(..)
   , Prolog(..)
   , Reference(..)
@@ -54,7 +55,7 @@
   , definiteA, defaultA, possibleA, fromAttrToStr, toAttrFrStr
   , Defaultable(..)
   , str2attr, attr2str, attval
-  , catMaybes	-- re-exported from Maybe
+  , catMaybes   -- re-exported from Maybe
   -- * Whole-document conversion functions
   , toXml, fromXml
   , readXml, showXml, fpsShowXml
@@ -70,8 +71,8 @@
 
 import IO
 import Maybe (catMaybes)
-import Char  (chr, ord, isSpace)
-import List  (intersperse, isPrefixOf, isSuffixOf, partition)
+import Char  (chr, isSpace)
+import List  (isPrefixOf, isSuffixOf)
 
 import Text.PrettyPrint.HughesPJ (render)
 import qualified Text.XML.HaXml.Pretty as PP
@@ -80,7 +81,7 @@
 import Text.XML.HaXml.TypeMapping
 import Text.XML.HaXml.Posn     (Posn, posInNewCxt)
 import Text.XML.HaXml.Pretty   (document)
-import Text.XML.HaXml.Parse    (xmlParse, fst3)
+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
@@ -94,7 +95,8 @@
 debug :: a -> String -> a
 v `debug` s = trace s v
 #else
-v `debug` s = v
+debug :: t -> t1 -> t
+v `debug` _ = v
 #endif
 
 
@@ -115,7 +117,7 @@
 mkElemC :: String -> [Content ()] -> Content ()
 mkElemC x cs = CElem (Elem x [] cs) ()
 
--- | Turn a simple string into XML text. 
+-- | Turn a simple string into XML text.
 toText :: String -> [Content ()]
 toText s = [CString False s ()]
 
@@ -125,9 +127,9 @@
 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.
+        -- 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.
@@ -135,7 +137,7 @@
 fReadXml fp = do
     f <- ( if fp=="-" then return stdin
            else openFile fp ReadMode )
-    x <- hGetContents f 
+    x <- hGetContents f
     let (Document _ _ y _) = xmlParse fp x
         y' = CElem y (posInNewCxt fp Nothing)
     either fail return (fst (runParser parseContents [y']))
@@ -206,7 +208,7 @@
 -- | Read a fully-typed XML document from a file handle.
 hGetXml :: XmlContent a => Handle -> IO a
 hGetXml h = do
-    x <- hGetContents h 
+    x <- hGetContents h
     let (Document _ _ y _) = xmlParse "file handle" x
     either fail return
            (fst (runParser parseContents
@@ -240,7 +242,7 @@
 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. 
+--   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]
@@ -254,7 +256,7 @@
                                            ++formatted tags++"\nat "++show pos)
           CString b s pos
               | not b && all isSpace s -> posnElementWith match tags
-							-- ignore blank space
+                                                        -- ignore blank space
               | otherwise -> fail ("Found text content, but expected "
                                   ++formatted tags++"\ntext is: "++s
                                   ++"\nat "++show pos)
@@ -265,7 +267,7 @@
     }
   where
     formatted [t]  = "a <"++t++">"
-    formatted tags = "one of"++ concatMap (\t->" <"++t++">") tags
+    formatted tgs = "one of"++ concatMap (\t->" <"++t++">") tgs
 
 -- | A specialisation of @posnElementWith (==)@.
 posnElement :: [String] -> XMLParser (Posn, Element Posn)
@@ -275,12 +277,12 @@
 --   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")
+                                `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")
+                                `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
@@ -291,11 +293,11 @@
     case runParser p cs of
         (Left msg, _) -> fail msg
         (Right x, []) -> return x
-        (Right x, cs@(c:_))
-            | all onlyMisc cs -> return x
+        (Right x, ds@(d:_))
+            | all onlyMisc ds -> return x
             | otherwise       -> fail ("Too many elements inside <"++e++"> at\n"
-                                      ++show (info c)++"\n"
-                                      ++"Found excess: "++verbatim c)
+                                      ++show (info d)++"\n"
+                                      ++"Found excess: "++verbatim d)
   where onlyMisc (CMisc _ _) = True
         onlyMisc (CString False s _) | all isSpace s = True
         onlyMisc _ = False
@@ -338,7 +340,7 @@
 choice :: XmlContent a => (a -> b) -> XMLParser b -> XMLParser b
 choice cons (P other) =
     P (\cs-> case runParser parseContents cs of
-                 (Left msg, _)  -> other cs
+                 (Left _, _)  -> other cs
                  (Right x, cs') -> (Right (cons x), cs'))
 
 --choice cons other = fmap cons parseContents `onFail` other
@@ -348,7 +350,7 @@
 --   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 msg, cs') -> (Left (False,msg'), cs')
+                                   (Left _, cs') -> (Left (False,msg'), cs')
                                    (Right x, cs')  -> (Right x,   cs'))
   where msg' = "content error: expected "++inner++" inside <"++tag
                ++"> element\n"
@@ -391,7 +393,7 @@
 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) }
@@ -399,7 +401,7 @@
 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) }
@@ -439,10 +441,10 @@
                      scanElements es =
                         case runParser parseContents es of
                             (Left msg, es') -> (Left (False,msg), es')
-                            (Right x, es') ->
+                            (Right y, es') ->
                                 case scanElements es' of
-                                    (Left msg, cs) -> (Left msg, cs)
-                                    (Right xs, cs) -> (Right (x:xs), cs)
+                                    (Left msg, ds) -> (Left msg, ds)
+                                    (Right ys, ds) -> (Right (y:ys), ds)
             (CElem (Elem e _ _) pos: cs)
                    -> (Left (False
                             ,"Expected a , but found a <"++e++"> at\n"
@@ -478,6 +480,47 @@
         ; 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
@@ -504,7 +547,7 @@
 
 
 ------------------------------------------------------------------------
--- Useful auxiliaries for "fromAttributes" 
+-- Useful auxiliaries for "fromAttributes"
 ------------------------------------------------------------------------
 
 -- | If an attribute is defaultable, then it either takes the default
@@ -513,7 +556,7 @@
 data Defaultable a  = Default a    | NonDefault a    deriving (Eq,Show)
 
 searchMaybe :: (a -> Maybe b) -> [a] -> Maybe b
-searchMaybe f [] = Nothing
+searchMaybe _ [] = Nothing
 searchMaybe f (x:xs) =
     let fx = f x in
     case fx of
@@ -522,12 +565,12 @@
 
 maybeToAttr :: (String->a->Maybe Attribute) -> String -> Maybe a
                -> Maybe Attribute
-maybeToAttr to n Nothing  = Nothing
+maybeToAttr _ _ Nothing  = Nothing
 maybeToAttr to n (Just v) = to n v
 
 defaultToAttr :: (String->a->Maybe Attribute) -> String -> Defaultable a
                  -> Maybe Attribute
-defaultToAttr to n (Default v)  = Nothing
+defaultToAttr _ _ (Default _)  = Nothing
 defaultToAttr to n (NonDefault v) = to n v
 
 definiteA :: (String->Attribute->Maybe a) -> String -> String
@@ -557,8 +600,8 @@
 
 str2attr :: String -> AttValue
 str2attr s =
-    let f s =
-          let (l,r) = span (\c-> not (elem c "\"&<>'")) 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"
@@ -591,8 +634,8 @@
     ... 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' 
+-- | 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'.
@@ -632,5 +675,5 @@
     parseContents = P (\cs -> (Right (UnConverted cs), []))
 
 ------------------------------------------------------------------------
---  
+--
 ------------------------------------------------------------------------
diff --git a/src/tools/Xtract.hs b/src/tools/Xtract.hs
--- a/src/tools/Xtract.hs
+++ b/src/tools/Xtract.hs
@@ -16,6 +16,7 @@
 import Text.XML.HaXml.Pretty        (content)
 import Text.XML.HaXml.Html.Generate (htmlprint)
 import Text.XML.HaXml.Escape        (xmlEscapeContent,stdXmlEscaper)
+import Text.XML.HaXml.Util          (docContent)
 
 escape = xmlEscapeContent stdXmlEscaper
 
@@ -38,19 +39,18 @@
     in
 --  findcontents >>= \cs->
 --  ( hPutStrLn stdout . render . vcat
---  . map (vcat . map content . selection . getElem)) cs
+--  . map (vcat . map content . selection . docContent)) cs
     mapM_ (\x-> do c <- (if x=="-" then getContents else readFile x)
                    ( if isHTML x then
                           hPutStrLn stdout . render . htmlprint
                           . xtract (map toLower) pattern
-                          . getElem x . htmlParse x
+                          . docContent (posInNewCxt x Nothing) . htmlParse x
                      else hPutStrLn stdout . render . vcat . map (format . esc)
                           . xtract id pattern
-                          . getElem x . xmlParse x) c
+                          . docContent (posInNewCxt x Nothing) . xmlParse x) c
                    hFlush stdout)
           files
 
-getElem x (Document _ _ e _) = CElem e (posInNewCxt x Nothing)
 isHTML x = ".html" `isSuffixOf` x  ||  ".htm"  `isSuffixOf` x
 
 format [] = empty