packages feed

hxt 8.5.4 → 9.3.1.22

raw patch · 139 files changed

Files

examples/arrows/AGentleIntroductionToHXT/PicklerExample/Baseball.hs view
@@ -11,7 +11,7 @@  import           Data.Map (Map, fromList, toList) -import Text.XML.HXT.Arrow+import Text.XML.HXT.Core  -- Example data taken from: -- http://www.ibiblio.org/xml/books/bible/examples/05/5-1.xml@@ -23,7 +23,7 @@     { sYear    :: Int     , sLeagues :: Leagues     }-	      deriving (Show, Eq)+              deriving (Show, Eq)  type Leagues   = Map String Divisions @@ -34,8 +34,8 @@     , city     :: String     , players  :: [Player]     }-	    deriving (Show, Eq)-	     +            deriving (Show, Eq)+              data Player = Player     { firstName :: String     , lastName  :: String@@ -44,7 +44,7 @@     , hits      :: Maybe Int     , era       :: Maybe Float     }-	      deriving (Show, Eq)+              deriving (Show, Eq)  -- ------------------------------------------------------------ -- the pickler instance declarations@@ -64,73 +64,81 @@  -- the XML root element -xpSeason	:: PU Season+xpSeason        :: PU Season xpSeason     = xpElem "SEASON" $       xpWrap ( uncurry Season-	     , \ s -> (sYear s, sLeagues s)) $+             , \ s -> (sYear s, sLeagues s)) $       xpPair (xpAttr "YEAR" xpickle) xpLeagues -xpLeagues	:: PU Leagues+xpLeagues       :: PU Leagues xpLeagues     = xpWrap ( fromList-	     , toList ) $+             , toList ) $       xpList $       xpElem "LEAGUE" $       xpPair (xpAttr "NAME" xpText) xpDivisions -xpDivisions	:: PU Divisions+xpDivisions     :: PU Divisions xpDivisions     = xpWrap ( fromList-	     , toList-	     ) $+             , toList+             ) $       xpList $       xpElem "DIVISION" $-      xpPair (xpAttr "NAME" xpText) xpickle+      xpPair (xpAttr "NAME" xpText)+             xpickle -xpTeam	:: PU Team+xpTeam  :: PU Team xpTeam     = xpElem "TEAM" $       xpWrap ( uncurry3 Team-	     , \ t -> (teamName t, city t, players t)) $-      xpTriple (xpAttr "NAME" xpText) (xpAttr "CITY" xpText) (xpList xpickle)+             , \ t -> (teamName t, city t, players t)+             ) $+      xpTriple (xpAttr "NAME" xpText)+               (xpAttr "CITY" xpText)+               (xpList xpickle) -xpPlayer	:: PU Player+xpPlayer        :: PU Player xpPlayer     = xpElem "PLAYER" $-      xpWrap ( \ ((f,l,p),(a,h,e)) -> Player f l p a h e-	     , \ t -> ((firstName t, lastName t, position t),(atBats t, hits t, era t))) $-      xpPair (xpTriple (xpAttr "GIVEN_NAME" xpText)-	               (xpAttr "SURNAME"    xpText)-	               (xpAttr "POSITION"   xpText))-             (xpTriple (xpOption (xpAttr "AT_BATS" xpickle))-	               (xpOption (xpAttr "HITS"    xpickle))-	               (xpOption (xpAttr "ERA"     xpPrim )))+      xpWrap ( \ ((f,l,p,a,h,e)) -> Player f l p a h e+             , \ t -> (firstName t, lastName t+                      , position t, atBats t+                      , hits t, era t+                      )+             ) $+      xp6Tuple (xpAttr "GIVEN_NAME" xpText)+               (xpAttr "SURNAME"    xpText)+               (xpAttr "POSITION"   xpText)+               (xpOption (xpAttr "AT_BATS" xpickle))+               (xpOption (xpAttr "HITS"    xpickle))+               (xpOption (xpAttr "ERA"     xpPrim ))   -- ------------------------------------------------------------  -- a simple pickle/unpickle application -main	:: IO ()+main    :: IO () main     = do-      runX ( xunpickleDocument xpSeason [ (a_validate,v_0)-					, (a_trace, v_1)-					, (a_remove_whitespace,v_1)-					, (a_preserve_comment, v_0)-					] "simple2.xml"-	     >>>-	     processSeason-	     >>>-	     xpickleDocument xpSeason [ (a_indent, v_1)-				      ] "new-simple2.xml"-	   )+      runX ( xunpickleDocument xpSeason [ withValidate no+                                        , withTrace 1+                                        , withRemoveWS yes+                                        , withPreserveComment no+                                        ] "simple2.xml"+             >>>+             processSeason+             >>>+             xpickleDocument xpSeason [ withIndent yes+                                      ] "new-simple2.xml"+           )       return ()  -- the dummy for processing the unpickled data -processSeason	:: IOSArrow Season Season+processSeason   :: IOSArrow Season Season processSeason     = arrIO ( \ x -> do {print x ; return x}) @@ -138,175 +146,175 @@  -- the internal data of "simple2.xml" -season1998	:: Season+season1998      :: Season season1998     = Season       { sYear = 1998       , sLeagues = fromList-	[ ( "American League"-	  , fromList-	    [ ( "Central"-	      , [ Team { teamName = "White Sox"-		       , city = "Chicago"-		       , players = []}-		, Team { teamName = "Royals"-		       , city = "Kansas City"-		       , players = []}-		, Team { teamName = "Tigers"-		       , city = "Detroit"-		       , players = []}-		, Team { teamName = "Indians"-		       , city = "Cleveland"-		       , players = []}-		, Team { teamName = "Twins"-		       , city = "Minnesota"-		       , players = []}-		])-	    , ( "East"-	      , [ Team { teamName = "Orioles"-		       , city = "Baltimore"-		       , players = []}-		, Team { teamName = "Red Sox"-		       , city = "Boston"-		       , players = []}-		, Team { teamName = "Yankees"-		       , city = "New York"-		       , players = []}-		, Team { teamName = "Devil Rays"-		       , city = "Tampa Bay"-		       , players = []}-		, Team { teamName = "Blue Jays"-		       , city = "Toronto"-		       , players = []}-		])-	    , ( "West"-	      , [ Team { teamName = "Angels"-		       , city = "Anaheim"-		       , players = []}-		, Team { teamName = "Athletics"-		       , city = "Oakland"-		       , players = []}-		, Team { teamName = "Mariners"-		       , city = "Seattle"-		       , players = []}-		, Team { teamName = "Rangers"-		       , city = "Texas"-		       , players = []}-		])-	    ])-	, ( "National League"-	  , fromList-	    [ ( "Central"-	      , [ Team { teamName = "Cubs"-		       , city = "Chicago"-		       , players = []}-		, Team { teamName = "Reds"-		       , city = "Cincinnati"-		       , players = []}-		, Team { teamName = "Astros"-		       , city = "Houston"-		       , players = []}-		, Team { teamName = "Brewers"-		       , city = "Milwaukee"-		       , players = []}-		, Team { teamName = "Pirates"-		       , city = "Pittsburgh"-		       , players = []}-		, Team { teamName = "Cardinals"-		       , city = "St. Louis"-		       , players = []}-		])-	    , ( "East"-	      , [ Team { teamName = "Braves"-		       , city = "Atlanta"-		       , players =-			 [ Player { firstName = "Marty"-				  , lastName = "Malloy"-				  , position = "Second Base"-				  , atBats = Just 28-				  , hits = Just 5-				  , era = Nothing}-			 , Player { firstName = "Ozzie"-				  , lastName = "Guillen"-				  , position = "Shortstop"-				  , atBats = Just 264-				  , hits = Just 73-				  , era = Nothing}-			 , Player { firstName = "Danny"-				  , lastName = "Bautista"-				  , position = "Outfield"-				  , atBats = Just 144-				  , hits = Just 36-				  , era = Nothing}-			 , Player { firstName = "Gerald"-				  , lastName = "Williams"-				  , position = "Outfield"-				  , atBats = Just 266-				  , hits = Just 81-				  , era = Nothing}-			 , Player { firstName = "Tom"-				  , lastName = "Glavine"-				  , position = "Starting Pitcher"-				  , atBats = Nothing-				  , hits = Nothing-				  , era = Just 2.47}-			 , Player { firstName = "Javier"-				  , lastName = "Lopez"-				  , position = "Catcher"-				  , atBats = Just 489-				  , hits = Just 139-				  , era = Nothing}-			 , Player { firstName = "Ryan"-				  , lastName = "Klesko"-				  , position = "Outfield"-				  , atBats = Just 427-				  , hits = Just 117-				  , era = Nothing}-			 , Player { firstName = "Andres"-				  , lastName = "Galarraga"-				  , position = "First Base"-				  , atBats = Just 555-				  , hits = Just 169-				  , era = Nothing}-			 , Player { firstName = "Wes"-				  , lastName = "Helms"-				  , position = "Third Base"-				  , atBats = Just 13-				  , hits = Just 4-				  , era = Nothing}-			 ]}-		, Team { teamName = "Marlins"-		       , city = "Florida"-		       , players = []}-		, Team { teamName = "Expos"-		       , city = "Montreal"-		       , players = []}-		, Team { teamName = "Mets"-		       , city = "New York"-		       , players = []}-		, Team { teamName = "Phillies"-		       , city = "Philadelphia"-		       , players = []}-		])-	    , ( "West"-	      , [ Team { teamName = "Diamondbacks"-		       , city = "Arizona"-		       , players = []}-		, Team { teamName = "Rockies"-		       , city = "Colorado"-		       , players = []}-		, Team { teamName = "Dodgers"-		       , city = "Los Angeles"-		       , players = []}-		, Team { teamName = "Padres"-		       , city = "San Diego"-		       , players = []}-		, Team { teamName = "Giants"-		       , city = "San Francisco"-		       , players = []}-		])-	    ])-	]+        [ ( "American League"+          , fromList+            [ ( "Central"+              , [ Team { teamName = "White Sox"+                       , city = "Chicago"+                       , players = []}+                , Team { teamName = "Royals"+                       , city = "Kansas City"+                       , players = []}+                , Team { teamName = "Tigers"+                       , city = "Detroit"+                       , players = []}+                , Team { teamName = "Indians"+                       , city = "Cleveland"+                       , players = []}+                , Team { teamName = "Twins"+                       , city = "Minnesota"+                       , players = []}+                ])+            , ( "East"+              , [ Team { teamName = "Orioles"+                       , city = "Baltimore"+                       , players = []}+                , Team { teamName = "Red Sox"+                       , city = "Boston"+                       , players = []}+                , Team { teamName = "Yankees"+                       , city = "New York"+                       , players = []}+                , Team { teamName = "Devil Rays"+                       , city = "Tampa Bay"+                       , players = []}+                , Team { teamName = "Blue Jays"+                       , city = "Toronto"+                       , players = []}+                ])+            , ( "West"+              , [ Team { teamName = "Angels"+                       , city = "Anaheim"+                       , players = []}+                , Team { teamName = "Athletics"+                       , city = "Oakland"+                       , players = []}+                , Team { teamName = "Mariners"+                       , city = "Seattle"+                       , players = []}+                , Team { teamName = "Rangers"+                       , city = "Texas"+                       , players = []}+                ])+            ])+        , ( "National League"+          , fromList+            [ ( "Central"+              , [ Team { teamName = "Cubs"+                       , city = "Chicago"+                       , players = []}+                , Team { teamName = "Reds"+                       , city = "Cincinnati"+                       , players = []}+                , Team { teamName = "Astros"+                       , city = "Houston"+                       , players = []}+                , Team { teamName = "Brewers"+                       , city = "Milwaukee"+                       , players = []}+                , Team { teamName = "Pirates"+                       , city = "Pittsburgh"+                       , players = []}+                , Team { teamName = "Cardinals"+                       , city = "St. Louis"+                       , players = []}+                ])+            , ( "East"+              , [ Team { teamName = "Braves"+                       , city = "Atlanta"+                       , players =+                         [ Player { firstName = "Marty"+                                  , lastName = "Malloy"+                                  , position = "Second Base"+                                  , atBats = Just 28+                                  , hits = Just 5+                                  , era = Nothing}+                         , Player { firstName = "Ozzie"+                                  , lastName = "Guillen"+                                  , position = "Shortstop"+                                  , atBats = Just 264+                                  , hits = Just 73+                                  , era = Nothing}+                         , Player { firstName = "Danny"+                                  , lastName = "Bautista"+                                  , position = "Outfield"+                                  , atBats = Just 144+                                  , hits = Just 36+                                  , era = Nothing}+                         , Player { firstName = "Gerald"+                                  , lastName = "Williams"+                                  , position = "Outfield"+                                  , atBats = Just 266+                                  , hits = Just 81+                                  , era = Nothing}+                         , Player { firstName = "Tom"+                                  , lastName = "Glavine"+                                  , position = "Starting Pitcher"+                                  , atBats = Nothing+                                  , hits = Nothing+                                  , era = Just 2.47}+                         , Player { firstName = "Javier"+                                  , lastName = "Lopez"+                                  , position = "Catcher"+                                  , atBats = Just 489+                                  , hits = Just 139+                                  , era = Nothing}+                         , Player { firstName = "Ryan"+                                  , lastName = "Klesko"+                                  , position = "Outfield"+                                  , atBats = Just 427+                                  , hits = Just 117+                                  , era = Nothing}+                         , Player { firstName = "Andres"+                                  , lastName = "Galarraga"+                                  , position = "First Base"+                                  , atBats = Just 555+                                  , hits = Just 169+                                  , era = Nothing}+                         , Player { firstName = "Wes"+                                  , lastName = "Helms"+                                  , position = "Third Base"+                                  , atBats = Just 13+                                  , hits = Just 4+                                  , era = Nothing}+                         ]}+                , Team { teamName = "Marlins"+                       , city = "Florida"+                       , players = []}+                , Team { teamName = "Expos"+                       , city = "Montreal"+                       , players = []}+                , Team { teamName = "Mets"+                       , city = "New York"+                       , players = []}+                , Team { teamName = "Phillies"+                       , city = "Philadelphia"+                       , players = []}+                ])+            , ( "West"+              , [ Team { teamName = "Diamondbacks"+                       , city = "Arizona"+                       , players = []}+                , Team { teamName = "Rockies"+                       , city = "Colorado"+                       , players = []}+                , Team { teamName = "Dodgers"+                       , city = "Los Angeles"+                       , players = []}+                , Team { teamName = "Padres"+                       , city = "San Diego"+                       , players = []}+                , Team { teamName = "Giants"+                       , city = "San Francisco"+                       , players = []}+                ])+            ])+        ]       }  -- ------------------------------------------------------------
examples/arrows/AGentleIntroductionToHXT/SimpleExamples.hs view
@@ -1,14 +1,13 @@ {- |-   $Id: SimpleExamples.hs,v 1.3 2006/11/17 17:16:24 hxml Exp $-  -  The examples from the HXT tutorial at haskell.org "http://www.haskell.org/haskellwiki/HXT"+   The examples from the HXT tutorial at haskell.org "http://www.haskell.org/haskellwiki/HXT" -}  module Main where -import Text.XML.HXT.Arrow		-- import HXT stuff-import Text.XML.HXT.XPath+import Text.XML.HXT.Core		-- basic HXT stuff+import Text.XML.HXT.XPath               -- additional XPath functions+import Text.XML.HXT.Curl                -- Curl HTTP handler  import Data.List			-- auxiliary functions import Data.Maybe@@ -32,48 +31,57 @@       (al, fct, src, dst) <- cmdlineOpts argv       [rc]  <- runX (application al fct src dst)       if rc >= c_err-	 then exitWith (ExitFailure (-1))+	 then exitWith (ExitFailure 1) 	 else exitWith ExitSuccess -application	:: Attributes -> String -> String -> String -> IOSArrow b Int-application al fct src dst-    = readDocument al src+application	:: SysConfigList -> String -> String -> String -> IOSArrow b Int+application config fct src dst+    = configSysVars config                            -- set all global config options       >>>+      readDocument [] src+      >>>       processChildren (processRootElement fct `when` isElem)       >>>-      writeDocument ( (a_indent, v_1)-		      : (a_output_encoding, isoLatin1)-		      : al-		    ) dst+      writeDocument [ withIndent yes,+		      withOutputEncoding isoLatin1+		    ]+		    dst       >>>       getErrStatus  -- | the dummy for the boring stuff of option evaluation, -- usually done with 'System.Console.GetOpt' -cmdlineOpts 	:: [String] -> IO (Attributes, String, String, String)+cmdlineOpts 	:: [String] -> IO (SysConfigList, String, String, String) cmdlineOpts argv-    = return ([(a_validate, v_0),(a_parse_html, v_1)], argv!!0, argv!!1, argv!!2)+    = return ( [ withValidate no+	       , withParseHTML yes+	       , withCurl []+	       ]+	     , argv!!0+	     , argv!!1+	     , argv!!2+	     )   -- | the processing examples  examples	:: [ (String, IOSArrow XmlTree XmlTree) ] examples-    = [ ( "selectAllText",	selectAllText	)-      , ( "selectAllTextAndAltValues",	selectAllTextAndAltValues	)+    = [ ( "selectAllText",			selectAllText	)+      , ( "selectAllTextAndAltValues",		selectAllTextAndAltValues	)       , ( "selectAllTextAndRealAltValues",	selectAllTextAndRealAltValues	)-      , ( "addRefIcon",		addRefIcon	)-      , ( "helloWorld",		helloWorld	)-      , ( "helloWorld2",	helloWorld2	)-      , ( "imageTable",		imageTable	)-      , ( "imageTable0",	imageTable0	)-      , ( "imageTable1",	imageTable1	)-      , ( "imageTable2",	imageTable2	)-      , ( "imageTable3",	imageTable3	)-      , ( "toAbsHRefs",		toAbsHRefs	)-      , ( "toAbsRefs",		toAbsRefs	)-      , ( "toAbsRefs1",		toAbsRefs1	)+      , ( "addRefIcon",				addRefIcon	)+      , ( "helloWorld",				helloWorld	)+      , ( "helloWorld2",			helloWorld2	)+      , ( "imageTable",				imageTable	)+      , ( "imageTable0",			imageTable0	)+      , ( "imageTable1",			imageTable1	)+      , ( "imageTable2",			imageTable2	)+      , ( "imageTable3",			imageTable3	)+      , ( "toAbsHRefs",				toAbsHRefs	)+      , ( "toAbsRefs",				toAbsRefs	)+      , ( "toAbsRefs1",				toAbsRefs1	)       ]  processRootElement	:: String -> IOSArrow XmlTree XmlTree
examples/arrows/HelloWorld/HelloWorld.hs view
@@ -1,17 +1,17 @@ module Main where -import Text.XML.HXT.Arrow+import Text.XML.HXT.Core import System.Exit  main	:: IO() main     = do-      [rc] <- runX ( readDocument [ (a_trace, "1")-				  , (a_validate, v_0)+      [rc] <- runX ( readDocument [ withTrace 1+				  , withValidate no 				  ] "hello.xml" 		     >>>-		     writeDocument [ (a_output_encoding, isoLatin1)+		     writeDocument [ withOutputEncoding utf8 				   ] "-" 		     >>> 		     getErrStatus
examples/arrows/HelloWorld/Mini.hs view
@@ -1,13 +1,15 @@ module Main where -import Text.XML.HXT.Arrow+import Text.XML.HXT.Core  main	:: IO() main-    = runX ( readDocument [ (a_validate, v_0) ] "hello.xml"+    = runX ( configSysVars [ withTrace 1 ] 	     >>>-	     writeDocument [ ] "bye.xml"+	     readDocument    [ withValidate no ] "hello.xml"+	     >>>+	     writeDocument   [ ] "bye.xml" 	   )       >> return ()
− examples/arrows/RegexXMLSchema/Makefile 
@@ -1,128 +0,0 @@-# $Id: Makefile,v 1.9 2006/11/11 15:36:03 hxml Exp $--HXT_HOME	= ../../..-PKGFLAGS	= -GHCFLAGS	= -Wall -O2-GHC		= ghc $(GHCFLAGS) $(PKGFLAGS)--DIST		= $(HXT_HOME)/dist/examples/arrows-DIST_DIR	= $(DIST)/RegexXMLSchema--CNT		= 3--ropts		= +RTS -s -RTS --prog		= ./REtest-prog2		= ./Lines-prog3		= ./RElines-prog4		= ./Words-prog5		= ./REwords-prog0		= ./Copy--progs		= $(prog) $(prog0) $(prog2) $(prog3) $(prog4) $(prog5)--all		: $(progs)--$(prog)		: $(prog).hs-		$(GHC) --make -o $@ $<--local		:-		$(GHC) --make -o $(prog) -fglasgow-exts -ignore-package hxt -i../../../src $(prog).hs--$(prog2)	: $(prog)-		ln -f $(prog) $(prog2)--$(prog3)	: $(prog)-		ln -f $(prog) $(prog3)--$(prog4)	: $(prog)-		ln -f $(prog) $(prog4)--$(prog5)	: $(prog)-		ln -f $(prog) $(prog5)--$(prog0)	: $(prog)-		ln -f $(prog) $(prog0)--# generate and read documents containing a binary tree-# with 2^i leaf nodes containing the numbers 1 to 2^i-# for i up to at least 22 (8M XML elements) output works fine-# for i up to 19 (1M XML elements) input works without swapping-# with i=20 swapping starts, but the program it still terminates-# the size of the XML file for i=20 is about 36Mb-# these tests have run on a box with 1Gb memory--tests		= 18--test		: $(prog)-		$(MAKE) genfiles   tests="$(tests)"-		$(MAKE) copy       tests="$(tests)"-		$(MAKE) lines      tests="$(tests)"-		$(MAKE) relines    tests="$(tests)"-		$(MAKE) words      tests="$(tests)"-		$(MAKE) rewords    tests="$(tests)"--perftest	: $(prog)-		$(MAKE) test tests="2 3 10 11 12 13 14 15 16 17 18 19 20"--genfiles	:-		@for i in $(tests) ; \-		do \-		echo time $(prog) $(ropts) $$i ; \-		time $(prog) $(ropts) $$i ; \-		ls -l tree-*$$i.xml ; \-		echo ; \-		done--copy	:-		@for i in $(tests) ; \-		do \-		echo time $(prog0) $(ropts) $$i ; \-		time $(prog0) $(ropts) $$i ; \-		ls -l tree-*$$i.xml.copy ; \-		echo ; \-		done--lines	:-		@for i in $(tests) ; \-		do \-		echo time $(prog2) $(ropts) $$i ; \-		time $(prog2) $(ropts) $$i ; \-		ls -l tree-*$$i.xml.lines ; \-		echo ; \-		done--relines	:-		@for i in $(tests) ; \-		do \-		echo time $(prog3) $(ropts) $$i ; \-		time $(prog3) $(ropts) $$i ; \-		ls -l tree-*$$i.xml.relines ; \-		echo ; \-		done--words	:-		@for i in $(tests) ; \-		do \-		echo time $(prog4) $(ropts) $$i ; \-		time $(prog4) $(ropts) $$i ; \-		ls -l tree-*$$i.xml.words ; \-		echo ; \-		done--rewords	:-		@for i in $(tests) ; \-		do \-		echo time $(prog5) $$i ; \-		time $(prog5) $(ropts) $$i ; \-		ls -l tree-*$$i.xml.rewords ; \-		echo ; \-		done--dist		:-		[ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)-		cp Makefile REtest.hs $(DIST_DIR)--clean		:-		rm -f $(progs) *.o *.hi *.xml *.xml.*-
− examples/arrows/RegexXMLSchema/REtest.hs 
@@ -1,170 +0,0 @@-{-# LANGUAGE BangPatterns#-}---- ------------------------------------------module Main(main)-where--import Text.XML.HXT.Arrow-import Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch--import Text.XML.HXT.DOM.Unicode-    ( unicodeToXmlEntity-    )--import Control.Monad.State.Strict hiding (when)--import Data.Maybe--import System.IO			-- import the IO and commandline option stuff-import System.Environment---- ------------------------------------------main	:: IO ()-main-    = do-      p  <- getProgName-      al <- getArgs-      let i = if null al-	      then 4-	      else (read . head $ al)::Int-      main' p i-    where-    main' p' = fromMaybe main1 . lookup (pn p') $ mpt-    mpt = [ ("REtest",	   main1)-	  , ("Copy",       main2 "copy"    (:[]))-	  , ("Lines",      main2 "lines"   lines)-	  , ("RElines",    main2 "relines" relines)-	  , ("Words",      main2 "words"   words)-	  , ("REwords",    main2 "rewords" rewords)-	  ]---- -------------------------------------------- generate a document containing a binary tree of 2^i leafs (= 2^(i-1) XML elements)--main1	:: Int -> IO ()-main1 i-    = runX (genDoc i (fn i))-      >> return ()---- -------------------------------------------- read a document containing a binary tree of 2^i leafs--main2	:: String -> (String -> [String]) -> Int -> IO ()-main2 ext lines' i-    = do-      hPutStrLn stderr "start processing"-      h  <- openBinaryFile (fn i) ReadMode-      c  <- hGetContents h-      let ls = lines' c-      o  <- openBinaryFile (fn i ++ "." ++ ext) WriteMode-      mapM_ (hPutStrLn o) ls-      hClose o-      hClose h-      hPutStrLn stderr "end  processing"--relines		:: String -> [String]-relines		= tokenize "[^\n\r]*"--rewords		:: String -> [String]-rewords		= tokenize "[^ \t\n\r]+"---- ------------------------------------------pn	:: String -> String-pn	= reverse . takeWhile (/= '/') . reverse--fn	:: Int -> String-fn	= ("tree-" ++) . (++ ".xml") . reverse . take 4 . reverse . ((replicate 4 '0') ++ ) . show---- ------------------------------------------genDoc		:: Int -> String -> IOSArrow b XmlTree-genDoc d out    = constA (mkBTree d)-		  >>>-		  xpickleVal xpickle-		  >>>-		  indentDoc-		  >>>-		  putDoc out---- ------------------------------------------type Counter a	= State Int a--incr	:: Counter Int-incr	= do-	  modify (+1)-	  get---- ------------------------------------------data BTree	= Leaf Int-		| Fork BTree BTree-		  deriving (Show)--instance XmlPickler BTree where-    xpickle = xpAlt tag ps-	where-	tag (Leaf _	) = 0-	tag (Fork _ _	) = 1-	ps = [ xpWrap ( Leaf, \ (Leaf i) -> i)-	       ( xpElem "leaf" $ xpAttr "value" $ xpickle )--	     , xpWrap ( uncurry Fork, \ (Fork l r) -> (l, r))-	       ( xpElem "fork" $ xpPair xpickle xpickle )-	       ]---- ------------------------------------------mkBTree		:: Int -> BTree-mkBTree	depth	= evalState (mkT depth) 0--mkT	:: Int -> Counter BTree-mkT 0	= do-	  i <- incr-	  return (Leaf i)-mkT n	= do-	  l <- mkT (n-1)-	  r <- mkT (n-1)-	  return (Fork l r)---- -------------------------------------------- output is done with low level ops to write the--- document i a lazy manner--- adding an xml pi and encoding is done "by hand"--- latin1 decoding is the identity, so please generate the--- docs with latin1 encoding. Here ist done even with ASCCI--- every none ASCII char is represented by a char ref (&nnn;)--putDoc	:: String -> IOStateArrow s XmlTree XmlTree-putDoc dst-    = addXmlPi-      >>>-      addXmlPiEncoding isoLatin1-      >>>-      xshow getChildren-      >>>-      arr unicodeToXmlEntity-      >>>-      arrIO (\ s -> hPutDocument (\h -> hPutStrLn h s))-      >>>-      none-      where-      isStdout	= null dst || dst == "-"--      hPutDocument	:: (Handle -> IO()) -> IO()-      hPutDocument action-	  | isStdout-	      = action stdout-	  | otherwise-	      = do-		handle <- openBinaryFile dst WriteMode-		action handle-		hClose handle---- ----------------------------------------
examples/arrows/absurls/AbsURIs.hs view
@@ -9,9 +9,8 @@    Maintainer : uwe@fh-wedel.de    Stability  : experimental    Portability: portable-   Version    : $Id: AbsURIs.hs,v 1.1 2005/05/12 16:41:38 hxml Exp $ -AbsURIs - Conversion references into absolute URIs in HTML pages+   AbsURIs - Conversion references into absolute URIs in HTML pages  The commandline interface -}@@ -21,9 +20,9 @@ module Main where -import Text.XML.HXT.Arrow		-- import all stuff for parsing, validating, and transforming XML+import Text.XML.HXT.Core                -- import all stuff for parsing, validating, and transforming XML -import System.IO			-- import the IO and commandline option stuff+import System.IO                        -- import the IO and commandline option stuff import System.Environment import System.Console.GetOpt import System.Exit@@ -38,16 +37,16 @@ main :: IO () main     = do-      argv <- getArgs					-- get the commandline arguments-      (al, src) <- cmdlineOpts argv			-- and evaluate them, return a key-value list-      [rc]  <- runX (parser al src)			-- run the parser arrow-      exitProg (rc >= c_err)				-- set return code and terminate+      argv <- getArgs                                   -- get the commandline arguments+      (al, src) <- cmdlineOpts argv                     -- and evaluate them, return a key-value list+      [rc]  <- runX (parser al src)                     -- run the parser arrow+      exitProg (rc >= c_err)                            -- set return code and terminate  -- ------------------------------------------------------------ -exitProg	:: Bool -> IO a-exitProg True	= exitWith (ExitFailure (-1))-exitProg False	= exitWith ExitSuccess+exitProg        :: Bool -> IO a+exitProg True   = exitWith (ExitFailure 1)+exitProg False  = exitWith ExitSuccess  -- ------------------------------------------------------------ @@ -57,10 +56,12 @@ -- get wellformed document, validates document, propagates and check namespaces -- and controls output -parser	:: Attributes -> String -> IOSArrow b Int-parser al src-    = readDocument ([(a_parse_html, v_1)] ++ al) src+parser  :: SysConfigList -> String -> IOSArrow b Int+parser config src+    = configSysVars config                            -- set all global config options       >>>+      readDocument [withParseHTML yes] src              -- use HTML parser+      >>>       traceMsg 1 "start processing"       >>>       processDocument@@ -71,7 +72,7 @@       >>>       traceTree       >>>-      writeDocument al "-" `whenNot` hasAttr "no-output"+      ( writeDocument [] $< getSysAttr "output-file" )       >>>       getErrStatus @@ -80,51 +81,55 @@ -- the options definition part -- see doc for System.Console.GetOpt -progName	:: String-progName	= "AbsURIs"+progName        :: String+progName        = "AbsURIs"     -options 	:: [OptDescr (String, String)]+options         :: [OptDescr SysConfig] options     = generalOptions       ++-      selectOptions [a_trace, a_proxy, a_use_curl, a_issue_warnings, a_do_not_issue_warnings, a_do_not_use_curl, a_options_curl, a_encoding] inputOptions+      inputOptions       +++      [ Option "f" ["output-file"] (ReqArg  (withSysAttr "output-file") "FILE")+               "output file for resulting document (default: stdout)"+      ]+      ++       outputOptions       ++       showOptions -usage		:: [String] -> IO a+usage           :: [String] -> IO a usage errl     | null errl-	= do-	  hPutStrLn stdout use-	  exitProg False+        = do+          hPutStrLn stdout use+          exitProg False     | otherwise-	= do-	  hPutStrLn stderr (concat errl ++ "\n" ++ use)-	  exitProg True+        = do+          hPutStrLn stderr (concat errl ++ "\n" ++ use)+          exitProg True     where     header = progName ++ " - Convert all references in an HTML document into absolute URIs\n\n" ++              "Usage: " ++ progName ++ " [OPTION...] [URI or FILE]"     use    = usageInfo header options -cmdlineOpts 	:: [String] -> IO (Attributes, String)+cmdlineOpts     :: [String] -> IO (SysConfigList, String) cmdlineOpts argv     = case (getOpt Permute options argv) of-      (ol,n,[])-	  -> do-	     sa <- src n-	     help (lookup a_help ol) sa-	     return (ol, sa)+      (scfg,n,[])+          -> do+             sa <- src n+             help (getConfigAttr a_help scfg) sa+             return (scfg, sa)       (_,_,errs)-	  -> usage errs+          -> usage errs     where-    src []	= return []-    src [uri]	= return uri-    src _	= usage ["only one input uri or file allowed\n"]+    src []      = return []+    src [uri]   = return uri+    src _       = usage ["only one input uri or file allowed\n"] -    help (Just _) _	= usage []-    help Nothing []	= usage ["no input uri or file given\n"]-    help Nothing _	= return ()+    help "1" _  = usage []+    help _ []   = usage ["no input uri or file given\n"]+    help _ _    = return ()  -- ------------------------------------------------------------
examples/arrows/absurls/ProcessDocument.hs view
@@ -9,11 +9,10 @@    Maintainer : uwe@fh-wedel.de    Stability  : experimental    Portability: portable-   Version    : $Id: ProcessDocument.hs,v 1.2 2005/05/15 17:01:04 hxml Exp $ -AbsURIs - Conversion references into absolute URIs in HTML pages+   AbsURIs - Conversion references into absolute URIs in HTML pages -The REAL processing functions+   The REAL processing functions -}  -- ------------------------------------------------------------@@ -22,7 +21,7 @@     ( processDocument ) where -import Text.XML.HXT.Arrow		-- import all stuff for parsing, validating, and transforming XML+import Text.XML.HXT.Core		-- import all stuff for parsing, validating, and transforming XML  import Data.Maybe
examples/arrows/dtd2hxt/DTDtoHXT.hs view
@@ -4,22 +4,20 @@ -- -- Author : Uwe Schmidt ----- Version : $Id: DTDtoHXT.hs,v 1.3 2005/04/14 12:52:50 hxml Exp $--- -- this program may be used as example main program for the -- Haskell XML Toolbox  module Main where -import Text.XML.HXT.Arrow		-- import all stuff for parsing, validating, and transforming XML+import Text.XML.HXT.Core                -- import all stuff for parsing, validating, and transforming XML+import Text.XML.HXT.Curl -import System.IO			-- import the IO and commandline option stuff+import System.IO                        -- import the IO and commandline option stuff import System.Environment import System.Console.GetOpt import System.Exit -import Data.Maybe import Data.Char import Data.List @@ -31,43 +29,43 @@ main :: IO () main     = do-      argv <- getArgs					-- get the commandline arguments-      (al, src) <- cmdlineOpts argv				-- and evaluate them, return a key-value list+      argv <- getArgs                                   -- get the commandline arguments+      (al, src) <- cmdlineOpts argv                             -- and evaluate them, return a key-value list       [rc] <- runX (dtd2hxt al src)       exitProg (rc >= c_err)  -- ------------------------------------------------------------ -exitProg	:: Bool -> IO a-exitProg True	= exitWith (ExitFailure (-1))-exitProg False	= exitWith ExitSuccess+exitProg        :: Bool -> IO a+exitProg True   = exitWith (ExitFailure 1)+exitProg False  = exitWith ExitSuccess  -- ------------------------------------------------------------ -- -- options -uppercaseInitials, namespaceAware, prefixUnderline	:: String+uppercaseInitials, namespaceAware, prefixUnderline      :: String -uppercaseInitials	= "uppercase-initials"-namespaceAware		= "namespace-aware"-prefixUnderline		= "prefix-underline"+uppercaseInitials       = "uppercase-initials"+namespaceAware          = "namespace-aware"+prefixUnderline         = "prefix-underline"  -- name prefixes  tagPrefix, attPrefix, nsPrefix, isPrefix, mkPrefix, hasPrefix, getPrefix  , mkAttPrefix, mkSAttPrefix- , nsDefault	:: String+ , nsDefault    :: String -tagPrefix	= "tag"-attPrefix	= "attr"-nsPrefix	= "ns"-isPrefix	= "is"-mkPrefix	= "e"-hasPrefix	= "has"-getPrefix	= "get"-mkAttPrefix	= "a"-mkSAttPrefix	= "sa"-nsDefault	= "default"+tagPrefix       = "tag"+attPrefix       = "attr"+nsPrefix        = "ns"+isPrefix        = "is"+mkPrefix        = "e"+hasPrefix       = "has"+getPrefix       = "get"+mkAttPrefix     = "a"+mkSAttPrefix    = "sa"+nsDefault       = "default"  -- ------------------------------------------------------------ @@ -78,10 +76,14 @@ -- (this would remove the DTD), -- and controls output -dtd2hxt	:: Attributes -> String -> IOSArrow b Int-dtd2hxt al src-    = readDocument ((a_canonicalize, v_0) : al) src+dtd2hxt :: SysConfigList -> String -> IOSArrow b Int+dtd2hxt config src+    = configSysVars config                            -- set all global config options       >>>+      readDocument [withCanonicalize no+                   ,withCurl []+                   ] src+      >>>       traceMsg 1 "start processing DTD"       >>>       processChildren (isDTD `guards` genHXT)@@ -92,195 +94,195 @@       >>>       traceTree       >>>-      writeDocument ((a_output_xml, v_0) : al) (fromMaybe "" (lookup a_output_file al))+      ( writeDocument [withOutputPLAIN] $< getSysAttr "output-file" )       >>>       getErrStatus     where     genHXT-	= catA $ map (>>> mkText) $-	  [ getModuleName				-- the module header-	    >>>-	    arr genModHead+        = catA $ map (>>> mkText) $+          [ getModuleName                               -- the module header+            >>>+            arr genModHead -	  , constA $ comm "namespace declarations"+          , constA $ comm "namespace declarations" -	  , getNSAttr					-- namespace constants-	    >>>						-- declared as "xmlns" or "xmlns:<ns>" attribute with #FIXED values-	    arr2 genNSCode+          , getNSAttr                                   -- namespace constants+            >>>                                         -- declared as "xmlns" or "xmlns:<ns>" attribute with #FIXED values+            arr2 genNSCode -	  , constA $ comm "element arrows"+          , constA $ comm "element arrows" -	  , getElems >>. sort				-- element processing-	    >>>-	    arr genElemCode+          , getElems >>. sort                           -- element processing+            >>>+            arr genElemCode -          , getAttrs >>. ( sort . nub )			-- attribute processing+          , getAttrs >>. ( sort . nub )                 -- attribute processing             >>>-	    arr genAttrCode+            arr genAttrCode -          , getModuleName				-- module footer+          , getModuleName                               -- module footer             >>> arr genModFoot-	  ]+          ]      -- auxiliary arrows -------------------------------------------------- -    getModuleName	:: (ArrowXml a, ArrowDTD a) => a XmlTree String+    getModuleName       :: (ArrowXml a, ArrowDTD a) => a XmlTree String     getModuleName-	= isDTDDoctype-	  >>>-	  getDTDAttrValue a_name-	  >>>-	  arr moduleName+        = isDTDDoctype+          >>>+          getDTDAttrValue a_name+          >>>+          arr moduleName      -- filter namespace attributes ---------------------------------------- -    getNSAttr	::  (ArrowXml a, ArrowDTD a) => a XmlTree (String, String)+    getNSAttr   ::  (ArrowXml a, ArrowDTD a) => a XmlTree (String, String)     getNSAttr-	= deep isDTDAttlist-	  >>>-	  ( ( getDTDAttrValue a_value >>> isA (\ s -> s == "xmlns" || "xmlns:" `isPrefixOf` s)-	    )-	    `guards`-	    ( ( getDTDAttrValue a_kind >>> isA (== k_fixed)-	      )-	      `guards`-	      ( ( getDTDAttrValue a_value >>> arr (drop 6) )				-- remove "xmlns:" prefix-		&&&-		getDTDAttrValue a_default-	      )-	    )-	  )+        = deep isDTDAttlist+          >>>+          ( ( getDTDAttrValue a_value >>> isA (\ s -> s == "xmlns" || "xmlns:" `isPrefixOf` s)+            )+            `guards`+            ( ( getDTDAttrValue a_kind >>> isA (== k_fixed)+              )+              `guards`+              ( ( getDTDAttrValue a_value >>> arr (drop 6) )                            -- remove "xmlns:" prefix+                &&&+                getDTDAttrValue a_default+              )+            )+          ) -    getElems	::  (ArrowXml a, ArrowDTD a) => a XmlTree String+    getElems    ::  (ArrowXml a, ArrowDTD a) => a XmlTree String     getElems-	= deep isDTDElement-	  >>>-	  getDTDAttrValue a_name+        = deep isDTDElement+          >>>+          getDTDAttrValue a_name -    getAttrs	::  (ArrowXml a, ArrowDTD a) => a XmlTree String+    getAttrs    ::  (ArrowXml a, ArrowDTD a) => a XmlTree String     getAttrs-	= deep isDTDAttlist-	  >>>-	  getDTDAttrValue a_value+        = deep isDTDAttlist+          >>>+          getDTDAttrValue a_value      -- code generation ------------------------------------------------------------ -    genModHead	:: String -> String+    genModHead  :: String -> String     genModHead rootElem-	= code [ sepl-	       , "--"-	       , "-- don't edit this module"-	       , "-- generated with " ++ progName-	       , "-- simple access function for Haskell XML Toolbox"-	       , "-- generated from DTD of document: " ++ show src-	       , ""-	       , "module " ++ rootElem ++ " ( module " ++ rootElem ++ " )"-	       , "where"-	       , ""-	       , "import           Text.XML.HXT.Arrow (XmlTree, ArrowXml, (>>>))"-	       , "import qualified Text.XML.HXT.Arrow as X (attr, eelem, getAttrValue, hasAttr, hasName, isElem, sattr)"-	       ]+        = code [ sepl+               , "--"+               , "-- don't edit this module"+               , "-- generated with " ++ progName+               , "-- simple access function for Haskell XML Toolbox"+               , "-- generated from DTD of document: " ++ show src+               , ""+               , "module " ++ rootElem ++ " ( module " ++ rootElem ++ " )"+               , "where"+               , ""+               , "import           Text.XML.HXT.Core      (XmlTree, ArrowXml, (>>>))"+               , "import qualified Text.XML.HXT.Core as X (attr, eelem, getAttrValue, hasAttr, hasName, isElem, sattr)"+               ] -    genNSCode	:: String -> String -> String+    genNSCode   :: String -> String -> String     genNSCode prefix ns-	= code [ ns' ++ "\t:: String"-	       , ns' ++ "\t=  " ++ show ns-	       ]-	where-	ns' = nsPrefix ++ nn (if null prefix then nsDefault else prefix)+        = code [ ns' ++ "\t:: String"+               , ns' ++ "\t=  " ++ show ns+               ]+        where+        ns' = nsPrefix ++ nn (if null prefix then nsDefault else prefix) -    genElemCode	:: String -> String-    genElemCode	n-	= code [ comm ("arrows for element " ++ show n)-	       , tagN ++ "\t:: String"-	       , tagN ++ "\t=  " ++ show n-	       , ""-	       , isN  ++ "\t:: ArrowXml a => a XmlTree XmlTree"-	       , isN  ++ "\t=  X.isElem >>> X.hasName " ++ tagN-	       , ""-	       , mkN  ++ "\t:: ArrowXml a => a n XmlTree"-	       , mkN  ++ "\t=  X.eelem " ++ tagN-	       ]-	where-	tagN	= tagPrefix ++ nn n-	isN	= isPrefix  ++ nn n-	mkN	= mkPrefix  ++ nn n+    genElemCode :: String -> String+    genElemCode n+        = code [ comm ("arrows for element " ++ show n)+               , tagN ++ "\t:: String"+               , tagN ++ "\t=  " ++ show n+               , ""+               , isN  ++ "\t:: ArrowXml a => a XmlTree XmlTree"+               , isN  ++ "\t=  X.isElem >>> X.hasName " ++ tagN+               , ""+               , mkN  ++ "\t:: ArrowXml a => a n XmlTree"+               , mkN  ++ "\t=  X.eelem " ++ tagN+               ]+        where+        tagN    = tagPrefix ++ nn n+        isN     = isPrefix  ++ nn n+        mkN     = mkPrefix  ++ nn n -    genAttrCode	:: String -> String-    genAttrCode	n-	= code [ comm ("arrows for attribute " ++ show n)-	       , attN ++ "\t:: String"-	       , attN ++ "\t=  " ++ show n-	       , ""-	       , hasN ++ "\t:: ArrowXml a => a XmlTree XmlTree"-	       , hasN ++ "\t=  X.hasAttr " ++ attN-	       , ""-	       , getN ++ "\t:: ArrowXml a => a XmlTree String"-	       , getN ++ "\t=  X.getAttrValue " ++ attN-	       , ""-	       , mkN  ++ "\t:: ArrowXml a => a n XmlTree -> a n XmlTree"-	       , mkN  ++ "\t=  X.attr " ++ attN-	       , ""-	       , mksN ++ "\t:: ArrowXml a => String -> a n XmlTree"-	       , mksN ++ "\t=  X.sattr " ++ attN-	       ]-	where-	attN	= attPrefix ++ nn n-	hasN	= hasPrefix  ++ nn n-	getN	= getPrefix  ++ nn n ++ nn "value"-	mkN	= mkAttPrefix ++ nn n-	mksN	= mkSAttPrefix ++ nn n+    genAttrCode :: String -> String+    genAttrCode n+        = code [ comm ("arrows for attribute " ++ show n)+               , attN ++ "\t:: String"+               , attN ++ "\t=  " ++ show n+               , ""+               , hasN ++ "\t:: ArrowXml a => a XmlTree XmlTree"+               , hasN ++ "\t=  X.hasAttr " ++ attN+               , ""+               , getN ++ "\t:: ArrowXml a => a XmlTree String"+               , getN ++ "\t=  X.getAttrValue " ++ attN+               , ""+               , mkN  ++ "\t:: ArrowXml a => a n XmlTree -> a n XmlTree"+               , mkN  ++ "\t=  X.attr " ++ attN+               , ""+               , mksN ++ "\t:: ArrowXml a => String -> a n XmlTree"+               , mksN ++ "\t=  X.sattr " ++ attN+               ]+        where+        attN    = attPrefix ++ nn n+        hasN    = hasPrefix  ++ nn n+        getN    = getPrefix  ++ nn n ++ nn "value"+        mkN     = mkAttPrefix ++ nn n+        mksN    = mkSAttPrefix ++ nn n -    genModFoot	:: String -> String+    genModFoot  :: String -> String     genModFoot rootElem-	= comm ( "end of module " ++ rootElem)+        = comm ( "end of module " ++ rootElem)      -- string manipulation -------------------------------------------------- -    code	:: [String] -> String-    code	= concatMap (++ "\n")+    code        :: [String] -> String+    code        = concatMap (++ "\n") -    comm	:: String -> String-    comm cm	=  code [ "", sepl, "--", "-- " ++ cm, ""]+    comm        :: String -> String+    comm cm     =  code [ "", sepl, "--", "-- " ++ cm, ""] -    sepl	:: String-    sepl	= "-- ----------------------------------------"+    sepl        :: String+    sepl        = "-- ----------------------------------------" -    moduleName	:: String -> String+    moduleName  :: String -> String     moduleName rootElem-	= modname . fromMaybe rootElem . lookup a_output_file $ al+        = modname . (\ x -> if null x then rootElem else x) . getConfigAttr "output_file" $ config      modname-	= (\ x -> toUpper (head x) : tail x)-	  . reverse-	  . (\ n -> if '.' `elem` n				-- remove extension-		    then drop 1 . dropWhile (/= '.') $ n-		    else n-	    )-	  . takeWhile (/= '/')					-- remove dir path-	  . reverse+        = (\ x -> toUpper (head x) : tail x)+          . reverse+          . (\ n -> if '.' `elem` n                             -- remove extension+                    then drop 1 . dropWhile (/= '.') $ n+                    else n+            )+          . takeWhile (/= '/')                                  -- remove dir path+          . reverse -    nn		:: String -> String+    nn          :: String -> String     nn-	= trInitial . concatMap nc				-- normalize names+        = trInitial . concatMap nc                              -- normalize names -    nc		:: Char -> String+    nc          :: Char -> String     nc c-	| c `elem` ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"	= [c]-	| c == ':' || c == '-'					= "_" -	| otherwise							= ("_" ++) . show . fromEnum $ c+        | c `elem` ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"        = [c]+        | c == ':' || c == '-'                                  = "_" +        | otherwise                                                     = ("_" ++) . show . fromEnum $ c -    trInitial	:: String -> String+    trInitial   :: String -> String     trInitial str-	| null str	= str-	| underLn	= '_' : str-	| upperCs	= toUpper (head str) : tail str-	| otherwise	= str+        | null str      = str+        | underLn       = '_' : str+        | upperCs       = toUpper (head str) : tail str+        | otherwise     = str -    upperCs, underLn {-, nsAware -}	:: Bool-    upperCs	= isJust . lookup uppercaseInitials	$ al-    underLn	= isJust . lookup prefixUnderline	$ al-    {- nsAware 	= isJust . lookup namespaceAware	$ al -}+    upperCs, underLn {-, nsAware -}     :: Bool+    upperCs     = (== "1") . getConfigAttr uppercaseInitials    $ config+    underLn     = (== "1") . getConfigAttr prefixUnderline      $ config+    _nsAware    = (== "1") . getConfigAttr namespaceAware       $ config  -- ------------------------------------------------------------ --@@ -288,64 +290,62 @@ -- -- see doc for System.Console.GetOpt -progName	:: String-progName	= "DTDtoHXT"+progName        :: String+progName        = "DTDtoHXT"     -options 	:: [OptDescr (String, String)]+options         :: [OptDescr SysConfig] options     = selectOptions [ a_help-		    ] generalOptions+                    ] generalOptions       ++       selectOptions [ a_trace-		    , a_proxy-		    , a_use_curl-		    , a_options_curl-		    , a_encoding-		    , a_validate-		    , a_check_namespaces-		    ] inputOptions+                    , a_proxy+                    , a_encoding+                    , a_validate+                    , a_check_namespaces+                    ] inputOptions       ++-      selectOptions [ a_output_file-		    ] outputOptions+      selectOptions [ "output-file"+                    ] outputOptions       ++-      [ Option "u"	[prefixUnderline]	(NoArg	(prefixUnderline,   v_1))	"separate tag and attribute names with a '_'"-      , Option "U"	[uppercaseInitials]	(NoArg	(uppercaseInitials, v_1))	"transform the first char of tag and attribute names to uppercase"-      -- , Option "N"	[namespaceAware]	(NoArg	(namespaceAware,    v_1))	"filter are namespace aware, if namespace attributes occur in the DTD"+      [ Option "u"      [prefixUnderline]       (NoArg $ withSysAttr prefixUnderline "1")       "separate tag and attribute names with a '_'"+      , Option "U"      [uppercaseInitials]     (NoArg $ withSysAttr uppercaseInitials "1")     "transform the first char of tag and attribute names to uppercase"+      , Option "N"      [namespaceAware]        (NoArg $ withSysAttr namespaceAware "1")        "filter are namespace aware, if namespace attributes occur in the DTD"       ]       ++       showOptions -usage		:: [String] -> IO a+usage           :: [String] -> IO a usage errl     | null errl-	= do-	  hPutStrLn stdout use-	  exitProg False+        = do+          hPutStrLn stdout use+          exitProg False     | otherwise-	= do-	  hPutStrLn stderr (concat errl ++ "\n" ++ use)-	  exitProg True+        = do+          hPutStrLn stderr (concat errl ++ "\n" ++ use)+          exitProg True     where     header = "DTDtoHXml - Generation of access function for the Haskell XML Toolbox from a DTD\n" ++              "Usage: " ++ progName ++ " [OPTION...] [URI or FILE]"     use    = usageInfo header options -cmdlineOpts 	:: [String] -> IO (Attributes, String)+cmdlineOpts     :: [String] -> IO (SysConfigList, String) cmdlineOpts argv     = case (getOpt Permute options argv) of       (ol,n,[]  )-	  -> do-	     sa <- src n-	     help (lookup a_help ol)-	     return (ol, sa)+          -> do+             sa <- src n+             help (getConfigAttr a_help ol)+             return (ol, sa)       (_,_,errs)-	  -> usage errs+          -> usage errs     where-    src [uri]	= return uri-    src []	= usage ["input file/uri missing"]-    src _	= usage ["only one input url or file allowed\n"]+    src [uri]   = return uri+    src []      = usage ["input file/uri missing"]+    src _       = usage ["only one input url or file allowed\n"] -    help Nothing	= return ()-    help (Just _)	= usage []+    help "1"    = usage []+    help _      = return ()  -- ------------------------------------------------------------
examples/arrows/hparser/HXmlParser.hs view
@@ -10,7 +10,7 @@    Stability  : experimental    Portability: portable -   HXmlParser - Validating XML Parser of the Haskell XML Toolbox+   HXmlParser - Minimal Validating XML Parser of the Haskell XML Toolbox, no HTTP supported     XML well-formed checker and validator. @@ -28,15 +28,13 @@ module Main where -import Text.XML.HXT.Arrow		-- import all stuff for parsing, validating, and transforming XML+import Text.XML.HXT.Core                -- import all stuff for parsing, validating, and transforming XML -import System.IO			-- import the IO and commandline option stuff+import System.IO                        -- import the IO and commandline option stuff import System.Environment import System.Console.GetOpt import System.Exit -import Data.Maybe- -- ------------------------------------------------------------  -- |@@ -45,16 +43,16 @@ main :: IO () main     = do-      argv <- getArgs					-- get the commandline arguments-      (al, src) <- cmdlineOpts argv			-- and evaluate them, return a key-value list-      [rc]  <- runX (parser al src)			-- run the parser arrow-      exitProg (rc >= c_err)				-- set return code and terminate+      argv <- getArgs                                   -- get the commandline arguments+      (al, src) <- cmdlineOpts argv                     -- and evaluate them, return a key-value list+      [rc]  <- runX (parser al src)                     -- run the parser arrow+      exitProg (rc >= c_err)                            -- set return code and terminate  -- ------------------------------------------------------------ -exitProg	:: Bool -> IO a-exitProg True	= exitWith (ExitFailure (-1))-exitProg False	= exitWith ExitSuccess+exitProg        :: Bool -> IO a+exitProg True   = exitWith (ExitFailure 1)+exitProg False  = exitWith ExitSuccess  -- ------------------------------------------------------------ @@ -64,98 +62,108 @@ -- get wellformed document, validates document, propagates and check namespaces -- and controls output -parser	:: Attributes -> String -> IOSArrow b Int-parser al src-    = readDocument al src+parser  :: SysConfigList -> String -> IOSArrow b Int+parser config src+    = configSysVars config                            -- set all global config options, the output file and the+      >>>                                               -- other user options are stored as key-value pairs in the stystem state+      readDocument [] src                               -- no more special read options needed       >>>       ( ( traceMsg 1 "start processing document"-	  >>>-	  processDocument al-	  >>>-	  traceMsg 1 "document processing finished"-	)-	`when`-	documentStatusOk+          >>>+          ( processDocument $< getSysAttr "action" )    -- ask for the action stored in the key-value list of user defined values +          >>>+          traceMsg 1 "document processing finished"+        )+        `when`+        documentStatusOk       )       >>>       traceSource       >>>       traceTree       >>>-      writeDocument al (fromMaybe "-" . lookup a_output_file $ al) `whenNot` hasAttr "no-output"+      ( (writeDocument [] $< getSysAttr "output-file")  -- ask for the output file stored in the system configuration+        `whenNot`+        ( getSysAttr "no-output" >>> isA (== "1") )     -- ask for the no-output attr value in the system key-value list+      )       >>>       getErrStatus --- simple example of a processing arrow+-- simple example of a processing arrow, selected by a command line option -processDocument	:: Attributes -> IOSArrow XmlTree XmlTree-processDocument al-    | extractText-	= traceMsg 1 "selecting plain text"-	  >>>-	  processChildren (deep isText)-    | otherwise-	= this-    where-    extractText	= optionIsSet "show-text" $ al+processDocument :: String -> IOSArrow XmlTree XmlTree+processDocument "only-text"+    = traceMsg 1 "selecting plain text"+      >>>+      processChildren (deep isText) +processDocument "indent"+    = traceMsg 1 "indent document"+      >>>+      indentDoc++processDocument _action+    = traceMsg 1 "default action: do nothing"+      >>>+      this+ -- ------------------------------------------------------------ -- -- the options definition part -- see doc for System.Console.GetOpt -progName	:: String-progName	= "HXmlParser"+progName        :: String+progName        = "HXmlParser"     -options 	:: [OptDescr (String, String)]+options         :: [OptDescr SysConfig] options     = generalOptions       ++       inputOptions       ++-      relaxOptions-      ++       outputOptions       ++-      [ Option "q"	["no-output"]		(NoArg  ("no-output", "1"))		"no output of resulting document"-      , Option "x"	["show-text"]		(NoArg	("show-text", "1"))		"output only the raw text, remove all markup"-      ]-      ++       showOptions+      +++      [ Option "q"      ["no-output"]   (NoArg $  withSysAttr "no-output"      "1")   "no output of resulting document"+      , Option "x"      ["action"]      (ReqArg  (withSysAttr "action")   "ACTION")   "actions are: only-text, indent, no-op"+      ]+      -- the last 2 option values will be stored by withAttr in the system key-value list+      -- and can be read by getSysAttr key -usage		:: [String] -> IO a+usage           :: [String] -> IO a usage errl     | null errl-	= do-	  hPutStrLn stdout use-	  exitProg False+        = do+          hPutStrLn stdout use+          exitProg False     | otherwise-	= do-	  hPutStrLn stderr (concat errl ++ "\n" ++ use)-	  exitProg True+        = do+          hPutStrLn stderr (concat errl ++ "\n" ++ use)+          exitProg True     where     header = "HXmlParser - Validating XML Parser of the Haskell XML Toolbox with Arrow Interface\n" ++-             "XML well-formed checker, DTD validator, Relax NG validator.\n\n" +++             "XML well-formed checker, DTD validator, HTML parser.\n\n" ++              "Usage: " ++ progName ++ " [OPTION...] [URI or FILE]"     use    = usageInfo header options -cmdlineOpts 	:: [String] -> IO (Attributes, String)+cmdlineOpts     :: [String] -> IO (SysConfigList, String) cmdlineOpts argv     = case (getOpt Permute options argv) of-      (ol,n,[])-	  -> do-	     sa <- src n-	     help (lookup a_help ol) sa-	     return (ol, sa)+      (scfg,n,[])+          -> do+             sa <- src n+             help (getConfigAttr a_help scfg) sa+             return (scfg, sa)       (_,_,errs)-	  -> usage errs+          -> usage errs     where-    src []	= return []-    src [uri]	= return uri-    src _	= usage ["only one input uri or file allowed\n"]+    src []      = return []+    src [uri]   = return uri+    src _       = usage ["only one input uri or file allowed\n"] -    help (Just _) _	= usage []-    help Nothing []	= usage ["no input uri or file given\n"]-    help Nothing _	= return ()+    help "1" _  = usage []+    help _ []   = usage ["no input uri or file given\n"]+    help _ _    = return ()  -- ------------------------------------------------------------
examples/arrows/hparser/Makefile view
@@ -29,9 +29,10 @@ 		@echo "===> first see all command line options" 		$(prog) --help 		@echo-		$(MAKE) test0 test1 test2 test3 test4 test5+		$(MAKE) test0 test1 test2 test3 test4  EX1		= ./example1.xml+EX1a		= ./example1CRLF.xml EXi		= ./invalid.xml EX2		= ../../xhtml/xhtml.xml EX3		= ./namespace0.xml@@ -74,8 +75,11 @@ 		$(prog) --show-tree --output-encoding=ISO-8859-1 $(EX1) 		@echo 		@sleep 2 ; echo ; echo "===> once again, but without any markup" ; echo ; sleep 2-		$(prog) --show-text --output-encoding=ISO-8859-1 $(EX1)+		$(prog) --action=only-text --output-encoding=ISO-8859-1 $(EX1) 		@echo+		@sleep 2 ; echo ; echo "===> same source, but with CRLF, parser will emit UTF-8" ; echo ; sleep 2+		$(prog) --output-encoding=UTF-8 $(EX1a)+		@echo  test2		: 		@echo "===> the source of a xhtml document" ; echo ; sleep 2@@ -84,14 +88,14 @@ 		@sleep 2 ; echo ; echo "===> parser will validate this document and try to indent the output" ; echo ; sleep 2 		$(prog) --indent $(EX2) 		@sleep 2 ; echo ; echo "===> once again, but remove all markup" ; echo ; sleep 2-		$(prog) --show-text --remove-whitespace $(EX2)+		$(prog) --action=only-text --remove-whitespace $(EX2) 		@sleep 2 ; echo ; echo "===> once again with hdom tree output" ; echo ; sleep 2 		$(prog) --show-tree --remove-whitespace $(EX2)  test3		: 		@echo "===> namespace processing examples" ; echo ; sleep 2 		@echo "===> namespace propagation test" ; echo ; sleep 2-		$(prog) --verbose --check-namespaces  --indent --output-encoding=ISO-8859-1 $(EX3)+		$(prog) --verbose --check-namespaces  --indent --output-encoding=UTF-8 $(EX3) 		@echo 		@echo ; sleep 2 ; echo "===> namespace propagation test: tree output with attached namespaces" ; echo ; sleep 2 		$(prog) --verbose --check-namespaces  --remove-whitespace --show-tree --output-encoding=ISO-8859-1 $(EX3)@@ -107,49 +111,10 @@ 		cat $(EX4) 		@sleep 2 ; echo ; echo "===> parser accepts this document and tries to build a document tree" ; echo ; sleep 2 		$(prog) --indent --preserve-comment --parse-html $(EX4)-		@sleep 2 ; echo ; echo "===> same with lazy parser with tagsoup" ; echo ; sleep 2-		$(prog) -H -T -r --indent $(EX4)-		@echo 		@echo "===> the source of another lousy html document containing empty elements" ; echo ; sleep 2 		cat $(EX4a) 		@sleep 2 ; echo ; echo "===> parser accepts this document and tries to format this as a HTML document without any dangarous empty elements" ; echo ; sleep 2-		$(prog) --indent --preserve-comment --parse-html --output-html --no-empty-elements $(EX4a)-		@echo---test5		:-		@echo "===> Validate a valid xml file with respect to a valid Relax NG schema" ; echo ; sleep 1-		@echo "the XML document ./valid1.xml"-		@cat ./valid1.xml-		@echo "the Relax NG schema ./valid1.rng"-		@cat  ./valid1.rng-		@echo-		$(prog) --relax-schema ./valid1.rng ./valid1.xml-		@echo-		@echo "===> Validate an  invalid xml file with respect to a valid Relax NG schema" ; echo ; sleep 1-		@echo "the invalid XML document ./invalid1.xml"-		@cat ./valid1.xml-		$(prog) --relax-schema ./valid1.rng ./invalid1.xml || true-		@echo-		@echo "===> Incorrect Relax NG schema" ; echo ; sleep 1-		$(prog) --relax-schema ./invalid2.rng ./valid1.xml || true-		@echo-		@echo "===> Incorrect Relax NG schema with two errors" ; echo ; sleep 1-		$(prog) --relax-schema ./invalid3.rng ./valid1.xml || true-		@echo--test6		:-		@echo "===> tagsoup parsing examples" ; echo ; sleep 2-		@echo "===> lousy HTML document" ; echo ; sleep 2-		$(prog) --tagsoup --parse-html lousy.html-		@echo "===> www.w3c.org homepage (valid XHTML)" ; echo ; sleep 2-		$(prog) --tagsoup http://www.w3c.org/-		@echo "===> same again with removed whitespace and tree output" ; echo ; sleep 2-		$(prog) --tagsoup --remove-whitespace --show-tree http://www.w3c.org/-		@echo "===> same procedure with www.haskell.org homepage (rather valid HTML)" ; echo ; sleep 2-		$(prog) --tagsoup --parse-html http://www.haskell.org/-		@echo "===> same again with removed whitespace and tree output" ; echo ; sleep 2-		$(prog) --tagsoup --parse-html --remove-whitespace --show-tree http://www.haskell.org/+		$(prog) --indent --preserve-comment --parse-html --output-xhtml $(EX4a) 		@echo  dist		:@@ -159,4 +124,4 @@ clean		: 		rm -f $(prog) *.o *.hi -.PHONY		: all test test0 test1 test2 test3 test4 test5 test6 dist clean prof local force+.PHONY		: all test test0 test1 test2 test3 test4 dist clean prof local force
+ examples/arrows/hparser/example1CRLF.xml view
@@ -0,0 +1,22 @@+<?xml version="1.0" encoding="ISO-8859-1" ?>
+
+<!DOCTYPE a [
+<!ATTLIST a  att1  NMTOKENS  #IMPLIED
+             att2  ID        #REQUIRED>
+<!ATTLIST b  btt2  ID        #REQUIRED
+             btt3  IDREF     #REQUIRED>
+<!ELEMENT a  (b, cü?)>
+<!ELEMENT b  EMPTY>
+<!ELEMENT cü (#PCDATA)>
+]>
+
+<?pi a processing instruction?>
+
+<a att1=" test
+          äöüß
+          test "
+   att2="root"
+>
+    <b btt2="b1" btt3="root"/>
+    <cü>hello world äöüß test</cü>
+</a>
examples/arrows/hparser/lousy.html view
@@ -21,6 +21,7 @@     </table>      <xxx>xxx</xxx>+    <? abc + xyz ?>     <yyy a=b/>       <![CDATA[a CDATA       section with some unescaped chars@@ -30,8 +31,8 @@       &Auml; &Ouml; &Uuml; &#65;     <address><a href="mailto:uwe@muehle.welt.all">Uwe 		Schmidt</a></address>-<!-- Created: Tue Apr 29 16:07:57 CEST 2003 -->+<!-- Created: -- Tue Apr 29 16:07:57 CEST 2003 --> <!-- hhmts start -->-Last modified: Tue Aug 17 15:56:59 CEST 2010-<!-- hhmts end -->+Last modified: Thu Feb  3 13:27:19 CET 2011+<!-- hhmts end -> </html>
− examples/arrows/hrelaxng/.ghci 
@@ -1,3 +0,0 @@-:set -i../../../src-:set -Wall -fglasgow-exts-:load HRelaxNG
− examples/arrows/hrelaxng/HRelaxNG.hs 
@@ -1,170 +0,0 @@--- |--- HRelaxNG - Relax NG Validator of the Haskell XML Toolbox.--- RELAX NG is a simpler schema language for XML.------ Author : Torben Kuseler------ Version : $Id: HRelaxNG.hs,v 1.2 2005/09/30 14:41:44 hxml Exp $------ This program may be used as example main program for the--- Relax NG Validator.-----module Main-where--import System.IO-import System.Environment-import System.Console.GetOpt-import System.Exit--import Text.XML.HXT.Arrow -import Text.XML.HXT.RelaxNG---- ---------------------------------------------------------------main :: IO ()-main-  = do-    argv <- getArgs                       -- get the commandline arguments-    (al, xml, schema) <- cmdlineOpts argv -- and evaluate them, return a key-value list-    [rc]  <- runX (relax al xml schema)   -- run the Relax NG validator -    exitProg (rc >= c_err)                -- set return code and terminate--{--relax :: Attributes -> String -> String -> IOSArrow b Int-relax al xml schema-    = readDocument al schema-      >>>-      createSimpleForm-      >>>-      ( getErrors		-- compute errors in schema-        `orElse`-        validateXMLDoc [] xml	-- compute errors in document-        `orElse`-        root [] [txt "valid"]	-- or document is valid-      )-      >>>-      writeDocument [(a_show_tree, "1")] "-"-      >>>-      getErrStatus--}--relax :: Attributes -> String -> String -> IOSArrow b Int-relax al xml schema-    = readDocument ( [ (a_check_namespaces, v_1)-		     , (a_validate, v_0)-		     ] ++ al-		   ) xml-      >>>-      traceState-      >>>-      validateDocumentWithRelaxSchema al schema-      >>>-      traceState-      >>>-      writeDocument al "-"-      >>>-      getErrStatus---exitProg        :: Bool -> IO a-exitProg True   = exitWith (ExitFailure (-1))-exitProg False  = exitWith ExitSuccess------ ------------------------------------------------------------------ the options definition part--- see doc for System.Console.GetOpt--progName    :: String-progName    = "HRelaxNGValidator"--options     :: [OptDescr (String, String)]-options-    = generalOptions-      ++-      inputOptions-      ++-      outputOptions-      ++-      relaxOptions--usage :: [String] -> IO a-usage errl-    | null errl-        = do-          hPutStrLn stdout use-          exitProg False-    | otherwise-        = do-          hPutStrLn stderr (concat errl ++ "\n" ++ use)-          exitProg True-    where-    header = "HRelaxNGValidator - Relax NG schema validator of the " ++-             "Haskell XML Toolbox with Arrow Interface\n\n" ++-             "Usage: " ++ progName ++ " [OPTION...] (XML file URI/FILE) (Relax NG Schema URI/FILE)"-    use    = usageInfo header options--cmdlineOpts :: [String] -> IO (Attributes, String, String)-cmdlineOpts argv-    = case (getOpt Permute options argv) of-      (ol,n,[])-        -> do-           (xml, schema) <- src n-           help (lookup a_help ol)-           return (ol, xml, schema)-      (_,_,errs)-        -> usage errs-    where-    src [xml, schema] = return (xml, schema)-    src []  = usage ["XML file and Relax NG schema input file/url missing"]-    src [_] = usage ["Relax NG schema input file/url missing"]-    src _   = usage ["too many arguments"]--    help (Just _) = usage []-    help Nothing = return ()----- --------------------------------------------------------------- test environment----{--xmlFile :: String-xmlFile = "testCases/213/1.v.xml"--schema :: [String]-schema = ["testCases/213/c.rng"]--testValidator :: Attributes -> String -> String -> IOSArrow b Int-testValidator al src xmlFile-    = readDocument al src-      >>> propagateNamespaces-      >>> simplificationStep1-      >>> simplificationStep2 [] []-      >>> simplificationStep3-      >>> simplificationStep4-      >>> simplificationStep5-      >>> simplificationStep6-      >>> simplificationStep7-      >>> simplificationStep8-      >>> cleanUp-      >>> resetStates---       >>> perform (getErrors >>> writeDocument [(a_show_tree, "1")] "-")---       >>> perform (fromLA xmlTreeToPatternString >>> arrIO (\s -> hPutStrLn stdout (s ++ "\n\n")))---       >>> perform (fromLA xmlTreeToPatternFormatedString >>> arrIO (\s -> hPutStrLn stdout (s ++ "\n\n")))---       >>> perform (fromLA xmlTreeToPatternStringTree >>> arrIO (hPutStrLn stdout))-      >>>-      ( getErrors-        `orElse`-        (validateXMLDoc [] xmlFile)-        `orElse`-        (root [] [(constA $ mkXTextTree "valid")])-      )---       >>> writeDocument [(a_show_tree, "1")] "-"---       >>> writeDocument [(a_show_haskell, "1")] "-"      -      >>> getErrStatus--}
− examples/arrows/hrelaxng/Makefile 
@@ -1,77 +0,0 @@-# $Id: Makefile,v 1.2 2005/09/30 14:41:44 hxml Exp $--HXT_HOME	= ../../..-PKGFLAGS	= -GHCFLAGS	= -Wall -O2-GHC		= ghc $(GHCFLAGS) $(PKGFLAGS)--DIST		= $(HXT_HOME)/dist/examples/arrows-DIST_DIR	= $(DIST)/hrelaxng--prog		= ./HRelaxNG--all		: $(prog)--prof		:-		ghc --make -o $(prog) -Wall -prof -auto-all -O -fglasgow-exts -ignore-package hxt -ignore-package HTTP -i../../../src $(prog).hs--local		:-		ghc --make -o $(prog) $(GHCFLAGS) -fglasgow-exts -ignore-package hxt -i../../../src $(prog).hs--$(prog)		: $(prog).hs-		$(GHC) --make -o $@ $<--force		:-		$(GHC) --make -o $(prog) $(prog).hs--test		: $(prog)-		@echo "===> Relax NG examples" ; echo ; sleep 1-		@$(MAKE) example1 example1a example2 example3 example5--example1	:-		@echo "===> Validate a valid Relax NG schema with respect to a valid xml file" ; echo ; sleep 1-		$(prog) ./valid1.xml ./valid1.rng-		@echo--example1a	:-		@echo "a valid document"-		$(prog) ./valid2.xml ./valid2.rng || true-		@echo--example1b	:-		@echo "===> 1. invalid document\n"-		$(prog) ./inv2.xml ./valid2.rng || true-		@echo "\n===> 2. invalid document\n"-		$(prog) ./inv3.xml ./valid2.rng || true-		@echo--example2	:-		@echo "===> Validate a valid Relax NG schema with respect to a invalid xml file" ; echo ; sleep 1-		$(prog) ./invalid1.xml ./valid1.rng || true-		@echo--example3	:-		@echo "===> Incorrect Relax NG schema" ; echo ; sleep 1-		$(prog) ./valid1.xml ./invalid2.rng || true-		@echo--example4	:-		@echo "===> Same example with \"--output-pattern-transformations\" option " ; echo ; sleep 1-		$(prog) --output-pattern-transformations  ./valid1.xml ./invalid2.rng || true-		@echo--example5	:-		@echo "===> Incorrect Relax NG schema with two errors" ; echo ; sleep 1-		$(prog) ./valid1.xml ./invalid3.rng || true-		@echo--EX		= $(wildcard *valid*.xml *valid*.rng)--dist		:-		[ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)-		cp $(EX) Makefile $(prog).hs $(DIST_DIR)--clean		:-		rm -f $(prog) *.o *.hi--# eof ------------------------------------------------------------
− examples/arrows/hrelaxng/invalid1.xml 
@@ -1,1 +0,0 @@-<bar/>
− examples/arrows/hrelaxng/invalid2.rng 
@@ -1,13 +0,0 @@-<grammar xmlns:html="http://www.w3.org/TR/REC-html40" -         xmlns="http://relaxng.org/ns/structure/1.0" >-  <start>-    <element name="foo">-      <zeroOrMore>-        <group>-          <attribute name="bar"/>-          <attribute name="baz"/>-        </group>-      </zeroOrMore>-    </element>-  </start>-</grammar>
− examples/arrows/hrelaxng/invalid3.rng 
@@ -1,19 +0,0 @@-<grammar xmlns:html="http://www.w3.org/TR/REC-html40" -         xmlns="http://relaxng.org/ns/structure/1.0" >-  <start>-    <element name="foo">-      <zeroOrMore>-        <group>-          <attribute name="bar"/>-          <attribute name="baz"/>-        </group>-      </zeroOrMore>-    </element>-    <element name="bar">-      <group>-        <data type="token"/>-        <data type="token"/>-      </group>-    </element>-  </start>-</grammar>
− examples/arrows/hrelaxng/valid1.rng 
@@ -1,7 +0,0 @@-<grammar xmlns="http://relaxng.org/ns/structure/1.0">-  <start>-    <element name="foo">-      <empty/>-    </element>-  </start>-</grammar>
− examples/arrows/hrelaxng/valid1.xml 
@@ -1,1 +0,0 @@-<foo/>
− examples/arrows/hrelaxng/valid2.rng 
@@ -1,27 +0,0 @@-<grammar-  xmlns="http://relaxng.org/ns/structure/1.0"-  datatypeLibrary="http://www.w3.org/2001/XMLSchema-datatypes">-  <start>-    <ref name="foo"/>-  </start>-  -  <define name="foo">-    <element name="foo">--      <attribute name="string2-4">-	<data type="string">-	  <param name="minLength">2</param>-	  <param name="maxLength">4</param>-	</data>-      </attribute>--      <attribute name="id">-	<data type="ID">-	  <param name="length">4</param>-	</data>-      </attribute>-      -    </element>-  </define>--</grammar>
− examples/arrows/hrelaxng/valid2.xml 
@@ -1,1 +0,0 @@-<foo string2-4="xxx" id="iooo"/>
examples/arrows/performance/GenDoc.hs view
@@ -1,26 +1,41 @@ {-# LANGUAGE BangPatterns#-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}  -- ----------------------------------------  module Main where -import Text.XML.HXT.Arrow+import Text.XML.HXT.Core hiding (trace)+-- import Text.XML.HXT.TagSoup+-- import Text.XML.HXT.Expat -import Text.XML.HXT.DOM.Unicode+import Data.Char (isDigit)+import Data.List (foldl')++import Data.String.Unicode     ( unicodeToXmlEntity     )  import Control.Monad.State.Strict hiding (when) +import Control.DeepSeq+import Control.FlatSeq+ import Data.Maybe -import System.IO			-- import the IO and commandline option stuff+import System.IO  hiding (utf8)                      -- import the IO and commandline option stuff import System.Environment --- ----------------------------------------+import qualified Text.XML.HXT.DOM.XmlNode as XN+import qualified Data.Tree.Class as T+import Data.Tree.NTree.TypeDefs -- as T -main	:: IO ()+import           Debug.Trace++-- ------------------------------------------------------------++main    :: IO () main     = do       p <- getProgName@@ -29,18 +44,19 @@       main' p i     where     main' p' = fromMaybe main0 . lookup (pn p') $ mpt-    mpt = [ ("GenDoc",	   main1)-	  , ("ReadDoc",    main2)-	  , ("PruneRight", main3 False)-	  , ("PruneLeft",  main3 True)-	  , ("MemTest",    main4)-	 ]+    mpt = [ ("GenDoc",     main1)+          , ("ReadDoc",    main2)+          , ("PruneRight", main3 False)+          , ("PruneLeft",  main3 True)+          , ("MemTest",    main4 True)+          , ("MemTest1",   main4 False)+         ]  -- ----------------------------------------  -- generate a document containing a binary tree of 2^i leafs (= 2^(i-1) XML elements) -main1	:: Int -> IO ()+main1   :: Int -> IO () main1 i     = runX (genDoc i (fn i))       >> return ()@@ -49,62 +65,101 @@  -- read a document containing a binary tree of 2^i leafs -main2	:: Int -> IO ()+main2   :: Int -> IO () main2 i     = do-      [x] <- runX (readDoc (fn i)-		   >>>-		   traceMsg 1 "start unpickle"-		   >>>-		   unpickleTree-		   >>>-		   traceMsg 1 "start fold"-		   >>>-		   arr (foldT1 max)-		  )+      [x] <- runX (setTraceLevel 2+                   >>>+                   readDoc (fn i)+                   >>>+{-+                   traceMsg 1 "start rnfA"+                   >>>+                   rnfA this+                   >>>+-}+                   traceMsg 1 "start unpickle"+                   >>>+                   unpickleTree+                   >>>+                   traceMsg 1 "start fold"+                   >>>+                   arr (foldT1 max)+                  )       putStrLn ( "maximum value in tree is " ++ show x ++-		 ", expected value was " ++ show ((2::Int)^i)-	       )+                 ", expected value was " ++ show ((2::Int)^i)+               )  -- ----------------------------------------  -- test on lazyness, is the whole tree read or only the first child of every child node? -main3	:: Bool -> Int -> IO ()+main3   :: Bool -> Int -> IO () main3 l i     = do       [t] <- runX ( readDoc (fn i)-		    >>>-		    fromLA (xshow ( getChildren-				    >>>-				    if l then pruneForkLeft else pruneForkRight-				  )-			   )-		  )+                    >>>+                    fromLA (xshow ( getChildren+                                    >>>+                                    if l then pruneForkLeft else pruneForkRight+                                  )+                           )+                  )       putStrLn ("pruned binary tree is : " ++ show t)  -- ---------------------------------------- -main4	:: Int -> IO ()-main4 i+main4   :: Bool -> Int -> IO ()+main4 wnf i     = do       [x] <- runX ( setTraceLevel 1-		    >>>-		    traceMsg 1 ("generate tree of depth " ++ show i)-		    >>>-		    fromLA (genTree 0 i)-		    >>>-		    traceMsg 1 ("compute maximum and minimum")-		    >>>-		    fromLA ( foldBTree maximum &&& foldBTree minimum )	-- 2 traversals: complete tree in mem-		    >>>-		    arr2 (\ ma mi -> "maximum value = " ++ show ma ++ ", minimum = " ++ show mi )-		    >>>-		    traceValue 1 id-		  )+                    >>>+                    traceMsg 1 ("generate tree of depth " ++ show i)+                    >>>+                    ( if wnf+                      then fromLA (genTree'' 0 i)+                      else fromLA (rnfA $ genTree   0 i)+                    )+                    >>>+                    perform ( traceMsg 1 ("deep hasAttrValue")+                              >>>+                              deep (hasName "leaf" >>> hasAttrValue "value" (== "1"))+                              >>>+                              getAttrValue "value"+                              >>>+                              arrIO putStrLn+                            )+                    >>>+                    perform ( traceMsg 1 ("deep hasAttrValue")+                              >>>+                              deep (hasName "leaf" >>> hasAttrValue "value" (== "1"))+                              >>>+                              getAttrValue "value"+                              >>>+                              arrIO putStrLn+                            )+                    {-+                    perform (traceMsg 1 ("write doc")+                             >>>+                             putDoc "./tmp.xml"+                            )+                    >>>+                    traceMsg 1 ("compute maximum and minimum")+                    >>>+                    fromLA ( foldBTree maximum &&& foldBTree minimum )  -- 2 traversals: complete tree in mem+                    >>>+                    arr2 (\ ma mi -> "maximum value = " ++ show ma ++ ", minimum = " ++ show mi )+                    >>>+                    traceValue 1 id+                     -}+                    >>>+                    traceMsg 1 "done"+                    >>>+                    constA "0"+                  )       putStrLn x -foldBTree	:: ([Int] -> Int) -> LA XmlTree Int+foldBTree       :: ([Int] -> Int) -> LA XmlTree Int foldBTree f     = choiceA       [ hasName "leaf" :-> ( getAttrValue "value" >>^ read )@@ -116,7 +171,7 @@  -- just to check how much memory is used for the tree -main0	:: Int -> IO ()+main0   :: Int -> IO () main0 i     = do       let t = mkBTree i@@ -126,117 +181,225 @@  -- ---------------------------------------- -pn	:: String -> String-pn	= reverse . takeWhile (/= '/') . reverse+pn      :: String -> String+pn      = reverse . takeWhile (/= '/') . reverse -fn	:: Int -> String-fn	= ("tree-" ++) . (++ ".xml") . reverse . take 4 . reverse . ((replicate 4 '0') ++ ) . show+fn      :: Int -> String+fn      = ("tree-" ++) . (++ ".xml") . reverse . take 4 . reverse . ((replicate 4 '0') ++ ) . show  -- ---------------------------------------- -genTree	:: Int -> Int -> LA XmlTree XmlTree+genTree :: Int -> Int -> LA XmlTree XmlTree genTree !n !d-    | d == 0	= aelem "leaf" [sattr "value" (show (n + 1))]-    | otherwise	= selem "fork" [ genTree (2*n)   (d-1)-			       , genTree (2*n+1) (d-1)-			       ]+    | d == 0    = aelem "leaf" [sattr "value" (show (n + 1))]+    | otherwise = selem "fork" [ genTree (2*n)   (d-1)+                               , genTree (2*n+1) (d-1)+                               ]  -- ---------------------------------------- -genDoc		:: Int -> String -> IOSArrow b XmlTree-genDoc d out    = constA (mkBTree d)-		  >>>-		  xpickleVal xpickle-		  >>>-		  putDoc out+genTree'        :: Int -> Int -> LA XmlTree XmlTree+genTree' !n !d+    | d == 0    = aelem' "leaf" [sattr' "value" (show (n + 1))]+    | otherwise = selem' "fork" [ genTree' (2*n)   (d-1)+                                , genTree' (2*n+1) (d-1)+                                ]  -- ---------------------------------------- -readDoc	:: String -> IOSArrow b XmlTree+genTree''       :: Int -> Int -> LA XmlTree XmlTree+genTree'' !n !d+    | d == 0    = rwnfA $+                  -- trace ("+leaf " ++ show (n+1)) $+                  aelem "leaf" $+                  -- trace ("++leaf " ++ show (n+1)) $+                  [rwnf2A $+                   -- trace ("+valu " ++ show (n+1)) $+                   sattr "value" $+                   show $+                   -- trace ("++valu " ++ show (n+1)) $+                   (n + 1)+                  ]+    | otherwise = rwnfA $+                  -- trace ("+fork " ++ show (n+1)) $+                  selem "fork" $+                  -- trace ("++fork " ++ show (n+1)) $+                  [ genTree'' (2*n)   (d-1)+                  , genTree'' (2*n+1) (d-1)+                  ]++-- ----------------------------------------++-- (hopefully) strict constructors++mkText' s               = rwnf s `seq`+                          T.mkLeaf tn+    where+    tn = XN.mkText s++mkAttr' n al            = n        `seq`+                          rwnf al `seq`+                          T.mkTree an al+    where+    an = XN.mkAttrNode n++mkElem' n al cl         = n        `seq`+                          en       `seq`+                          rwnf al `seq`+                          rwnf cl `seq`+                          T.mkTree en cl+    where+    en = XN.mkElementNode n al++-- ----------------------------------------+-- strict arrows++mkElement'              :: String -> LA n XmlTree -> LA n XmlTree -> LA n XmlTree+mkElement' n af cf      = (listA af &&& listA cf)+                          >>>+                          arr2 (mkElem' (mkName n))++selem'                  :: String -> [LA n XmlTree] -> LA n XmlTree+selem' n cfs            = mkElement' n none (catA cfs)++aelem'                  :: String -> [LA n XmlTree] -> LA n XmlTree+aelem' n afs            = mkElement' n (catA afs) none++sattr'                  :: String -> String -> LA n XmlTree+sattr' an av            = constA (mkAttr' (mkName an) [mkText' av])++-- ----------------------------------------++genDoc          :: Int -> String -> IOSArrow b XmlTree+genDoc d out    = constA (let t = mkBTree d in rnf t `seq` t)+                  >>>+                  xpickleVal xpickle+                  >>>+{-+                  strictA+                  >>>+                  perform (writeBinaryValue (out ++ ".bin"))+                  >>>+                  readBinaryValue (out ++ ".bin")+                  >>>+                  strictA+                  >>>+-}+                  putDoc out++-- ----------------------------------------++readDoc :: String -> IOSArrow b XmlTree readDoc src-    = readDocument [ (a_tagsoup, v_1)-		   , (a_parse_xml, v_1)-		   , (a_remove_whitespace, v_1)-		   , (a_encoding, isoLatin1)-		   , (a_issue_warnings, v_0)-		   , (a_trace, v_1)-		   , (a_strict_input, v_0)-		   ] src+    = readDocument [ withParseHTML no+                   , withTrace 2+                   , withValidate no+                   , withInputEncoding isoLatin1+                   , withWarnings yes+                   , withStrictInput no+                   , withCanonicalize yes+                   , withRemoveWS no+                   -- , withExpat yes+                   -- , withTagSoup+                   ] src+{-       >>>-      processChildren (isElem `guards` this)-+      perform ( writeDocument [ withShowTree yes+                              , withOutputHTML+                              ] ""+              )+      >>>+      perform ( writeDocument [ withShowTree no+                              , withOutputHTML+                              ] ""+              )+-} -- ---------------------------------------- -unpickleTree	:: ArrowXml a => a XmlTree BTree-unpickleTree	= xunpickleVal xpickle+unpickleTree    :: ArrowXml a => a XmlTree BTree+unpickleTree    = xunpickleVal xpickle  -- ---------------------------------------- -pruneForkRight	:: LA XmlTree XmlTree+pruneForkRight  :: LA XmlTree XmlTree pruneForkRight     = ( replaceChildren-	( ( getChildren >>. take 1 )-	  >>>-	  pruneForkRight-	)+        ( ( getChildren >>. take 1 )+          >>>+          pruneForkRight+        )       ) `when` (hasName "fork")  -pruneForkLeft	:: LA XmlTree XmlTree+pruneForkLeft   :: LA XmlTree XmlTree pruneForkLeft     = ( replaceChildren-	( ( getChildren >>. drop 1 )-	  >>>-	  pruneForkLeft-	)+        ( ( getChildren >>. drop 1 )+          >>>+          pruneForkLeft+        )       ) `when` (hasName "fork")  -- ---------------------------------------- -type Counter a	= State Int a+type Counter a  = State Int a -incr	:: Counter Int-incr	= do-	  modify (+1)-	  get+incr    :: Counter Int+incr    = do+          modify (+1)+          get  -- ---------------------------------------- -data BTree	= Leaf Int-		| Fork BTree BTree-		  deriving (Show)+data BTree      = Leaf Int+                | Fork BTree BTree+                  deriving (Show) +instance NFData BTree where+    rnf (Leaf i)	= rnf i+    rnf (Fork t1 t2)	= rnf t1 `seq` rnf t2+ instance XmlPickler BTree where     xpickle = xpAlt tag ps-	where-	tag (Leaf _	) = 0-	tag (Fork _ _	) = 1-	ps = [ xpWrap ( Leaf, \ (Leaf i) -> i)-	       ( xpElem "leaf" $ xpAttr "value" $ xpickle )+        where+        tag (Leaf _     ) = 0+        tag (Fork _ _   ) = 1 -	     , xpWrap ( uncurry Fork, \ (Fork l r) -> (l, r))-	       ( xpElem "fork" $ xpPair xpickle xpickle )-	       ]+        ps = [ xpWrap ( Leaf, \ (Leaf i) -> i)+               ( xpElem "leaf" $ xpAttr "value" $ xpInt ) -- xpWrap (const 0, const ">&\"äöü") $ xpText )+             , xpWrap ( uncurry Fork, \ (Fork l r) -> (l, r))+               ( xpElem "fork" $ xpPair xpickle xpickle )+             ]  -- ---------------------------------------- -mkBTree		:: Int -> BTree-mkBTree	depth	= evalState (mkT depth) 0+mkBTree         :: Int -> BTree+mkBTree depth   = evalState (mkT depth) 0+    where+    mkT :: Int -> Counter BTree+    mkT 0 = do+            i <- incr+            return (Leaf i)+    mkT n = do+            l <- mkT (n-1)+            r <- mkT (n-1)+            return (Fork l r) -mkT	:: Int -> Counter BTree-mkT 0	= do-	  i <- incr-	  return (Leaf i)-mkT n	= do-	  l <- mkT (n-1)-	  r <- mkT (n-1)-	  return (Fork l r)+bTreeToNTree	:: BTree -> NTree Int+bTreeToNTree (Leaf i)	= NTree i []+bTreeToNTree (Fork l r) = NTree j [l',r']+    where+    l' = bTreeToNTree l+    r' = bTreeToNTree r+    j  = T.getNode l' + T.getNode r' +mkNTree = bTreeToNTree . mkBTree+ -- ---------------------------------------- -foldT1	:: (Int -> Int -> Int) -> BTree -> Int-foldT1 _  (Leaf v)	= v-foldT1 op (Fork l r)	= foldT1 op l `op` foldT1 op r+foldT1  :: (Int -> Int -> Int) -> BTree -> Int+foldT1 _  (Leaf v)      = v+foldT1 op (Fork l r)    = foldT1 op l `op` foldT1 op r  -- ---------------------------------------- @@ -247,8 +410,17 @@ -- docs with latin1 encoding. Here ist done even with ASCCI -- every none ASCII char is represented by a char ref (&nnn;) -putDoc	:: String -> IOStateArrow s XmlTree XmlTree+putDoc  :: String -> IOStateArrow s XmlTree XmlTree putDoc dst+    = writeDocument [ withOutputEncoding isoLatin1+                    , withOutputXML+                    ] dst++-- ----------------------------------------+{-++putDoc  :: String -> IOStateArrow s XmlTree XmlTree+putDoc dst     = addXmlPi       >>>       addXmlPiEncoding isoLatin1@@ -261,16 +433,16 @@       >>>       none       where-      isStdout	= null dst || dst == "-"+      isStdout  = null dst || dst == "-" -      hPutDocument	:: (Handle -> IO()) -> IO()+      hPutDocument      :: (Handle -> IO()) -> IO()       hPutDocument action-	  | isStdout-	      = action stdout-	  | otherwise-	      = do-		handle <- openBinaryFile dst WriteMode-		action handle-		hClose handle-+          | isStdout+              = action stdout+          | otherwise+              = do+                handle <- openBinaryFile dst WriteMode+                action handle+                hClose handle+-} -- ----------------------------------------
examples/arrows/performance/Makefile view
@@ -11,16 +11,21 @@ CNT		= 3  ropts		= +RTS -s -RTS +popts		= +RTS -P -hy -RTS  prog		= ./GenDoc prog2		= ./ReadDoc prog3		= ./PruneRight prog4		= ./PruneLeft prog5		= ./MemTest-progs		= $(prog) $(prog2) $(prog3) $(prog4) $(prog5)+prog6		= ./MemTest1+progs		= $(prog) $(prog2) $(prog3) $(prog4) $(prog5) $(prog6)  all		: $(progs) +prof		:+		$(MAKE) all PKGFLAGS="-prof -auto-all -caf-all"+ $(prog)		: $(prog).hs 		$(GHC) --make -o $@ $< @@ -39,6 +44,9 @@ $(prog5)	: $(prog) 		ln -f $(prog) $(prog5) +$(prog6)	: $(prog)+		ln -f $(prog) $(prog6)+ # generate and read documents containing a binary tree # with 2^i leaf nodes containing the numbers 1 to 2^i # for i up to at least 22 (8M XML elements) output works fine@@ -48,6 +56,7 @@ # these tests have run on a box with 1Gb memory  tests		= 2 3 10 11 12+ptests          = 16  test		: $(prog) 		$(MAKE) genfiles   tests="$(tests)"@@ -58,11 +67,20 @@ perftest	: $(prog) 		$(MAKE) test tests="2 3 10 11 12 13 14 15 16 17 18 19 20" +pgenfiles	:+		rm -f $(prog).aux $(prog).hp $(prog).ps $(prog).prof+		$(MAKE) genfiles ropts="$(popts)" tests=$(ptests)+		hp2ps -c $(prog).hp++preadfiles	:+		$(MAKE) readfiles ropts="$(popts)" tests=$(ptests)+		hp2ps -c $(prog2).hp+ genfiles	: 		@for i in $(tests) ; \ 		do \ 		echo time $(prog) $(ropts) $$i ; \-		time $(prog) $$i ; \+		time $(prog) $(ropts) $$i ; \ 		ls -l tree-*$$i.xml ; \ 		echo ; \ 		done@@ -71,7 +89,7 @@ 		@for i in $(tests) ; \ 		do \ 		echo time $(prog2) $(ropts) $$i ; \-		time $(prog2) $$i ; \+		time $(prog2) $(ropts) $$i ; \ 		echo ; \ 		done @@ -79,7 +97,7 @@ 		@for i in $(tests) ; \ 		do \ 		echo time $(prog3) $(ropts) $$i ; \-		time $(prog3) $$i ; \+		time $(prog3)  $(ropts) $$i ; \ 		echo ; \ 		done @@ -87,14 +105,14 @@ 		@for i in $(tests) ; \ 		do \ 		echo time $(prog4) $(ropts) $$i ; \-		time $(prog4) $$i ; \+		time $(prog4) $(ropts) $$i ; \ 		echo ; \ 		done  memtest	: 		@for i in $(tests) ; \ 		do \-		echo time $(prog5) $$i ; \+		echo time $(prog5) $(ropts) $$i ; \ 		time $(prog5) $(ropts) $$i ; \ 		echo ; \ 		done
examples/arrows/pickle/Makefile view
@@ -10,7 +10,7 @@ DIST		= $(HXT_HOME)/dist/examples/arrows DIST_DIR	= $(DIST)/pickle -PROG		= ./pickleTest+PROG		= ./pickleTest ./pickleTestWithNamespaces  all		: $(PROG) @@ -23,6 +23,11 @@ 		@echo "the program p2 as XML document" 		@sleep 3 		cat pickle.xml+		./pickleTestWithNamespaces+		@sleep 1+		@echo "the program p2 as XML document"+		@sleep 3+		cat pickle.xml  dist		: 		[ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)@@ -37,4 +42,7 @@ .PHONY		: all test dist clean distclean force  pickleTest	: PickleTest.hs+		$(GHC) --make -o $@ $<++pickleTestWithNamespaces	: PickleTestWithNamespaces.hs 		$(GHC) --make -o $@ $<
examples/arrows/pickle/PickleTest.hs view
@@ -5,7 +5,7 @@ import System.Exit import Test.HUnit -import Text.XML.HXT.Arrow+import Text.XML.HXT.Core  -- ------------------------------------------------------------ --@@ -71,29 +71,45 @@ 	tag (UnExpr _ _    ) = 3 	tag (BinExpr _ _ _ ) = 4 	ps = [ xpWrap ( IntConst-		      , \ (IntConst i ) -> i ) ( xpElem "int"  $-					         xpAttr "value" $-					         xpickle )+		      , \ (IntConst i ) -> i+                      ) $+               ( xpElem "int"   $+		 xpAttr "value" $+		 xpickle+               )  	     , xpWrap ( BoolConst-		      , \ (BoolConst b) -> b)  ( xpElem "bool" $-						 xpAttr "value" $-						 xpWrap (toEnum, fromEnum) xpickle )+		      , \ (BoolConst b) -> b+                      ) $+               ( xpElem "bool"  $+		 xpAttr "value" $+		 xpWrap (toEnum, fromEnum) xpickle+               )  	     , xpWrap ( Var-		      , \ (Var n)       -> n)  ( xpElem "var"  $-						 xpAttr "name"  $-						 xpText )+		      , \ (Var n)       -> n+                      ) $+               ( xpElem "var"   $+		 xpAttr "name"  $+		 xpText+               )  	     , xpWrap ( uncurry UnExpr-		      , \ (UnExpr op e) -> (op, e))-                                               ( xpElem "unex" $-						 xpPair (xpAttr "op" xpickle) xpickle )+		      , \ (UnExpr op e) -> (op, e)+                      ) $+               ( xpElem "unex" $+		 xpPair (xpAttr "op" xpickle)+                         xpickle+               )  	     , xpWrap ( uncurry3 $ BinExpr-		      , \ (BinExpr op e1 e2) -> (op, e1, e2))-                                               ( xpElem "binex" $-						 xpTriple (xpAttr "op" xpickle) xpickle xpickle )+		      , \ (BinExpr op e1 e2) -> (op, e1, e2)+                      ) $+               ( xpElem "binex" $+		 xpTriple (xpAttr "op" xpickle)+                           xpickle+                           xpickle+               ) 	     ]  instance XmlPickler Stmt where@@ -104,20 +120,33 @@ 	tag ( If _ _ _ )   = 2 	tag ( While _ _ )  = 3 	ps = [ xpWrap ( uncurry Assign-		      , \ (Assign n v) -> (n, v))-                                               ( xpElem "assign" $-						 xpPair (xpAttr "name" xpText) xpickle )+		      , \ (Assign n v) -> (n, v)+                      ) $+               ( xpElem "assign" $+		 xpPair (xpAttr "name" xpText)+                         xpickle+               ) 	     , xpWrap ( Stmts-		      , \ (Stmts sl) -> sl)    ( xpElem "block" $-						 xpList xpickle )+		      , \ (Stmts sl) -> sl+                      ) $+               ( xpElem "block" $+		 xpList xpickle+               ) 	     , xpWrap ( uncurry3 If-		      , \ (If c t e) -> (c, t, e))-                                               ( xpElem "if" $-						 xpTriple xpickle xpickle xpickle )+		      , \ (If c t e) -> (c, t, e)+                      ) $+               ( xpElem "if" $+		 xpTriple xpickle+                          xpickle+                          xpickle+               ) 	     , xpWrap ( uncurry While-		      , \ (While c b) -> (c, b))-                                               ( xpElem "while" $-						 xpPair xpickle xpickle )+		      , \ (While c b) -> (c, b)+                      ) $+               ( xpElem "while" $+		 xpPair xpickle+                        xpickle+               ) 	     ]  -- ------------------------------------------------------------@@ -232,7 +261,7 @@ 		 >>> 		 writeDocumentToString []			-- XmlTree => String 		 >>>-		 readFromString [(a_validate, v_0)]		-- String => XmlTree+		 readFromString [ withValidate no ]		-- String => XmlTree 		 >>> 		 arrL (maybeToList . unpickleDoc xpProgram)	-- XmlTree => Program 	       )@@ -245,11 +274,11 @@ 		 >>> 		 arr (pickleDoc xpProgram)			-- Program => XmlTree 		 >>>-		 writeDocument [ (a_indent, v_1)		-- XmlTree => formated external XML document+		 writeDocument [ withIndent yes			-- XmlTree => formated external XML document 			       ] "pickle.xml" 		 >>>-		 readDocument  [ (a_remove_whitespace, v_1)	-- formated external XML document => XmlTree-			       , (a_validate, v_0)+		 readDocument  [ withRemoveWS yes		-- formated external XML document => XmlTree+			       , withValidate no 			       ] "pickle.xml" 		 >>> 		 arrL (maybeToList . unpickleDoc xpProgram)	-- XmlTree => Program@@ -263,12 +292,12 @@ 	       ( constA p					-- take the Program value 		 >>> 		 xpickleDocument   xpProgram-                                 [ (a_indent, v_1)		-- Program => formated external XML document+                                 [ withIndent yes		-- Program => formated external XML document 				 ] "pickle.xml" 		 >>> 		 xunpickleDocument xpProgram-                                   [ (a_remove_whitespace, v_1)	-- formated external XML document => Program-				   , (a_validate, v_0)+                                   [ withRemoveWS yes		-- formated external XML document => Program+				   , withValidate no 				   ] "pickle.xml" 	       ) 	res7	:: IO [Program]					-- the most important case@@ -279,13 +308,13 @@ 	       ( constA p					-- take the Program value 		 >>> 		 xpickleDocument   xpProgram-                                 [ (a_indent, v_1)		-- Program => formated external XML document-				 , (a_addDTD, v_1)+                                 [ withIndent yes		-- Program => formated external XML document+				 , withSysAttr a_addDTD v_1	-- with inline DTD 				 ] "pickle.xml" 		 >>> 		 xunpickleDocument xpProgram-                                   [ (a_remove_whitespace, v_1)	-- formated external XML document => Program-				   , (a_validate, v_1)+                                   [ withRemoveWS yes		-- formated external XML document => Program+				   , withValidate yes 				   ] "pickle.xml" 	       )
+ examples/xhtml/tmp.xml view
@@ -0,0 +1,4 @@+<!DOCTYPE html SYSTEM "xhtml1-strict.dtd">+<html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">+<head><title>&Auml;</title></head><body/>+</html>
+ examples/xhtml/xhtml-lat1.ent view
@@ -0,0 +1,196 @@+<!-- Portions (C) International Organization for Standardization 1986+     Permission to copy in any form is granted for use with+     conforming SGML systems and applications as defined in+     ISO 8879, provided this notice is included in all copies.+-->+<!-- Character entity set. Typical invocation:+    <!ENTITY % HTMLlat1 PUBLIC+       "-//W3C//ENTITIES Latin 1 for XHTML//EN"+       "http://www.w3.org/TR/xhtml1/DTD/xhtml-lat1.ent">+    %HTMLlat1;+-->++<!ENTITY nbsp   "&#160;"> <!-- no-break space = non-breaking space,+                                  U+00A0 ISOnum -->+<!ENTITY iexcl  "&#161;"> <!-- inverted exclamation mark, U+00A1 ISOnum -->+<!ENTITY cent   "&#162;"> <!-- cent sign, U+00A2 ISOnum -->+<!ENTITY pound  "&#163;"> <!-- pound sign, U+00A3 ISOnum -->+<!ENTITY curren "&#164;"> <!-- currency sign, U+00A4 ISOnum -->+<!ENTITY yen    "&#165;"> <!-- yen sign = yuan sign, U+00A5 ISOnum -->+<!ENTITY brvbar "&#166;"> <!-- broken bar = broken vertical bar,+                                  U+00A6 ISOnum -->+<!ENTITY sect   "&#167;"> <!-- section sign, U+00A7 ISOnum -->+<!ENTITY uml    "&#168;"> <!-- diaeresis = spacing diaeresis,+                                  U+00A8 ISOdia -->+<!ENTITY copy   "&#169;"> <!-- copyright sign, U+00A9 ISOnum -->+<!ENTITY ordf   "&#170;"> <!-- feminine ordinal indicator, U+00AA ISOnum -->+<!ENTITY laquo  "&#171;"> <!-- left-pointing double angle quotation mark+                                  = left pointing guillemet, U+00AB ISOnum -->+<!ENTITY not    "&#172;"> <!-- not sign = discretionary hyphen,+                                  U+00AC ISOnum -->+<!ENTITY shy    "&#173;"> <!-- soft hyphen = discretionary hyphen,+                                  U+00AD ISOnum -->+<!ENTITY reg    "&#174;"> <!-- registered sign = registered trade mark sign,+                                  U+00AE ISOnum -->+<!ENTITY macr   "&#175;"> <!-- macron = spacing macron = overline+                                  = APL overbar, U+00AF ISOdia -->+<!ENTITY deg    "&#176;"> <!-- degree sign, U+00B0 ISOnum -->+<!ENTITY plusmn "&#177;"> <!-- plus-minus sign = plus-or-minus sign,+                                  U+00B1 ISOnum -->+<!ENTITY sup2   "&#178;"> <!-- superscript two = superscript digit two+                                  = squared, U+00B2 ISOnum -->+<!ENTITY sup3   "&#179;"> <!-- superscript three = superscript digit three+                                  = cubed, U+00B3 ISOnum -->+<!ENTITY acute  "&#180;"> <!-- acute accent = spacing acute,+                                  U+00B4 ISOdia -->+<!ENTITY micro  "&#181;"> <!-- micro sign, U+00B5 ISOnum -->+<!ENTITY para   "&#182;"> <!-- pilcrow sign = paragraph sign,+                                  U+00B6 ISOnum -->+<!ENTITY middot "&#183;"> <!-- middle dot = Georgian comma+                                  = Greek middle dot, U+00B7 ISOnum -->+<!ENTITY cedil  "&#184;"> <!-- cedilla = spacing cedilla, U+00B8 ISOdia -->+<!ENTITY sup1   "&#185;"> <!-- superscript one = superscript digit one,+                                  U+00B9 ISOnum -->+<!ENTITY ordm   "&#186;"> <!-- masculine ordinal indicator,+                                  U+00BA ISOnum -->+<!ENTITY raquo  "&#187;"> <!-- right-pointing double angle quotation mark+                                  = right pointing guillemet, U+00BB ISOnum -->+<!ENTITY frac14 "&#188;"> <!-- vulgar fraction one quarter+                                  = fraction one quarter, U+00BC ISOnum -->+<!ENTITY frac12 "&#189;"> <!-- vulgar fraction one half+                                  = fraction one half, U+00BD ISOnum -->+<!ENTITY frac34 "&#190;"> <!-- vulgar fraction three quarters+                                  = fraction three quarters, U+00BE ISOnum -->+<!ENTITY iquest "&#191;"> <!-- inverted question mark+                                  = turned question mark, U+00BF ISOnum -->+<!ENTITY Agrave "&#192;"> <!-- latin capital letter A with grave+                                  = latin capital letter A grave,+                                  U+00C0 ISOlat1 -->+<!ENTITY Aacute "&#193;"> <!-- latin capital letter A with acute,+                                  U+00C1 ISOlat1 -->+<!ENTITY Acirc  "&#194;"> <!-- latin capital letter A with circumflex,+                                  U+00C2 ISOlat1 -->+<!ENTITY Atilde "&#195;"> <!-- latin capital letter A with tilde,+                                  U+00C3 ISOlat1 -->+<!ENTITY Auml   "&#196;"> <!-- latin capital letter A with diaeresis,+                                  U+00C4 ISOlat1 -->+<!ENTITY Aring  "&#197;"> <!-- latin capital letter A with ring above+                                  = latin capital letter A ring,+                                  U+00C5 ISOlat1 -->+<!ENTITY AElig  "&#198;"> <!-- latin capital letter AE+                                  = latin capital ligature AE,+                                  U+00C6 ISOlat1 -->+<!ENTITY Ccedil "&#199;"> <!-- latin capital letter C with cedilla,+                                  U+00C7 ISOlat1 -->+<!ENTITY Egrave "&#200;"> <!-- latin capital letter E with grave,+                                  U+00C8 ISOlat1 -->+<!ENTITY Eacute "&#201;"> <!-- latin capital letter E with acute,+                                  U+00C9 ISOlat1 -->+<!ENTITY Ecirc  "&#202;"> <!-- latin capital letter E with circumflex,+                                  U+00CA ISOlat1 -->+<!ENTITY Euml   "&#203;"> <!-- latin capital letter E with diaeresis,+                                  U+00CB ISOlat1 -->+<!ENTITY Igrave "&#204;"> <!-- latin capital letter I with grave,+                                  U+00CC ISOlat1 -->+<!ENTITY Iacute "&#205;"> <!-- latin capital letter I with acute,+                                  U+00CD ISOlat1 -->+<!ENTITY Icirc  "&#206;"> <!-- latin capital letter I with circumflex,+                                  U+00CE ISOlat1 -->+<!ENTITY Iuml   "&#207;"> <!-- latin capital letter I with diaeresis,+                                  U+00CF ISOlat1 -->+<!ENTITY ETH    "&#208;"> <!-- latin capital letter ETH, U+00D0 ISOlat1 -->+<!ENTITY Ntilde "&#209;"> <!-- latin capital letter N with tilde,+                                  U+00D1 ISOlat1 -->+<!ENTITY Ograve "&#210;"> <!-- latin capital letter O with grave,+                                  U+00D2 ISOlat1 -->+<!ENTITY Oacute "&#211;"> <!-- latin capital letter O with acute,+                                  U+00D3 ISOlat1 -->+<!ENTITY Ocirc  "&#212;"> <!-- latin capital letter O with circumflex,+                                  U+00D4 ISOlat1 -->+<!ENTITY Otilde "&#213;"> <!-- latin capital letter O with tilde,+                                  U+00D5 ISOlat1 -->+<!ENTITY Ouml   "&#214;"> <!-- latin capital letter O with diaeresis,+                                  U+00D6 ISOlat1 -->+<!ENTITY times  "&#215;"> <!-- multiplication sign, U+00D7 ISOnum -->+<!ENTITY Oslash "&#216;"> <!-- latin capital letter O with stroke+                                  = latin capital letter O slash,+                                  U+00D8 ISOlat1 -->+<!ENTITY Ugrave "&#217;"> <!-- latin capital letter U with grave,+                                  U+00D9 ISOlat1 -->+<!ENTITY Uacute "&#218;"> <!-- latin capital letter U with acute,+                                  U+00DA ISOlat1 -->+<!ENTITY Ucirc  "&#219;"> <!-- latin capital letter U with circumflex,+                                  U+00DB ISOlat1 -->+<!ENTITY Uuml   "&#220;"> <!-- latin capital letter U with diaeresis,+                                  U+00DC ISOlat1 -->+<!ENTITY Yacute "&#221;"> <!-- latin capital letter Y with acute,+                                  U+00DD ISOlat1 -->+<!ENTITY THORN  "&#222;"> <!-- latin capital letter THORN,+                                  U+00DE ISOlat1 -->+<!ENTITY szlig  "&#223;"> <!-- latin small letter sharp s = ess-zed,+                                  U+00DF ISOlat1 -->+<!ENTITY agrave "&#224;"> <!-- latin small letter a with grave+                                  = latin small letter a grave,+                                  U+00E0 ISOlat1 -->+<!ENTITY aacute "&#225;"> <!-- latin small letter a with acute,+                                  U+00E1 ISOlat1 -->+<!ENTITY acirc  "&#226;"> <!-- latin small letter a with circumflex,+                                  U+00E2 ISOlat1 -->+<!ENTITY atilde "&#227;"> <!-- latin small letter a with tilde,+                                  U+00E3 ISOlat1 -->+<!ENTITY auml   "&#228;"> <!-- latin small letter a with diaeresis,+                                  U+00E4 ISOlat1 -->+<!ENTITY aring  "&#229;"> <!-- latin small letter a with ring above+                                  = latin small letter a ring,+                                  U+00E5 ISOlat1 -->+<!ENTITY aelig  "&#230;"> <!-- latin small letter ae+                                  = latin small ligature ae, U+00E6 ISOlat1 -->+<!ENTITY ccedil "&#231;"> <!-- latin small letter c with cedilla,+                                  U+00E7 ISOlat1 -->+<!ENTITY egrave "&#232;"> <!-- latin small letter e with grave,+                                  U+00E8 ISOlat1 -->+<!ENTITY eacute "&#233;"> <!-- latin small letter e with acute,+                                  U+00E9 ISOlat1 -->+<!ENTITY ecirc  "&#234;"> <!-- latin small letter e with circumflex,+                                  U+00EA ISOlat1 -->+<!ENTITY euml   "&#235;"> <!-- latin small letter e with diaeresis,+                                  U+00EB ISOlat1 -->+<!ENTITY igrave "&#236;"> <!-- latin small letter i with grave,+                                  U+00EC ISOlat1 -->+<!ENTITY iacute "&#237;"> <!-- latin small letter i with acute,+                                  U+00ED ISOlat1 -->+<!ENTITY icirc  "&#238;"> <!-- latin small letter i with circumflex,+                                  U+00EE ISOlat1 -->+<!ENTITY iuml   "&#239;"> <!-- latin small letter i with diaeresis,+                                  U+00EF ISOlat1 -->+<!ENTITY eth    "&#240;"> <!-- latin small letter eth, U+00F0 ISOlat1 -->+<!ENTITY ntilde "&#241;"> <!-- latin small letter n with tilde,+                                  U+00F1 ISOlat1 -->+<!ENTITY ograve "&#242;"> <!-- latin small letter o with grave,+                                  U+00F2 ISOlat1 -->+<!ENTITY oacute "&#243;"> <!-- latin small letter o with acute,+                                  U+00F3 ISOlat1 -->+<!ENTITY ocirc  "&#244;"> <!-- latin small letter o with circumflex,+                                  U+00F4 ISOlat1 -->+<!ENTITY otilde "&#245;"> <!-- latin small letter o with tilde,+                                  U+00F5 ISOlat1 -->+<!ENTITY ouml   "&#246;"> <!-- latin small letter o with diaeresis,+                                  U+00F6 ISOlat1 -->+<!ENTITY divide "&#247;"> <!-- division sign, U+00F7 ISOnum -->+<!ENTITY oslash "&#248;"> <!-- latin small letter o with stroke,+                                  = latin small letter o slash,+                                  U+00F8 ISOlat1 -->+<!ENTITY ugrave "&#249;"> <!-- latin small letter u with grave,+                                  U+00F9 ISOlat1 -->+<!ENTITY uacute "&#250;"> <!-- latin small letter u with acute,+                                  U+00FA ISOlat1 -->+<!ENTITY ucirc  "&#251;"> <!-- latin small letter u with circumflex,+                                  U+00FB ISOlat1 -->+<!ENTITY uuml   "&#252;"> <!-- latin small letter u with diaeresis,+                                  U+00FC ISOlat1 -->+<!ENTITY yacute "&#253;"> <!-- latin small letter y with acute,+                                  U+00FD ISOlat1 -->+<!ENTITY thorn  "&#254;"> <!-- latin small letter thorn with,+                                  U+00FE ISOlat1 -->+<!ENTITY yuml   "&#255;"> <!-- latin small letter y with diaeresis,+                                  U+00FF ISOlat1 -->
+ examples/xhtml/xhtml-special.ent view
@@ -0,0 +1,79 @@+<!-- Special characters for HTML -->++<!-- Character entity set. Typical invocation:+     <!ENTITY % HTMLspecial PUBLIC+        "-//W3C//ENTITIES Special for XHTML//EN"+        "http://www.w3.org/TR/xhtml1/DTD/xhtml-special.ent">+     %HTMLspecial;+-->++<!-- Portions (C) International Organization for Standardization 1986:+     Permission to copy in any form is granted for use with+     conforming SGML systems and applications as defined in+     ISO 8879, provided this notice is included in all copies.+-->++<!-- Relevant ISO entity set is given unless names are newly introduced.+     New names (i.e., not in ISO 8879 list) do not clash with any+     existing ISO 8879 entity names. ISO 10646 character numbers+     are given for each character, in hex. values are decimal+     conversions of the ISO 10646 values and refer to the document+     character set. Names are Unicode names. +-->++<!-- C0 Controls and Basic Latin -->+<!ENTITY quot    "&#34;"> <!--  quotation mark = APL quote,+                                    U+0022 ISOnum -->+<!ENTITY amp     "&#38;#38;"> <!--  ampersand, U+0026 ISOnum -->+<!ENTITY lt      "&#38;#60;"> <!--  less-than sign, U+003C ISOnum -->+<!ENTITY gt      "&#62;"> <!--  greater-than sign, U+003E ISOnum -->+<!ENTITY apos	 "&#39;"> <!--  apostrophe mark, U+0027 ISOnum -->++<!-- Latin Extended-A -->+<!ENTITY OElig   "&#338;"> <!--  latin capital ligature OE,+                                    U+0152 ISOlat2 -->+<!ENTITY oelig   "&#339;"> <!--  latin small ligature oe, U+0153 ISOlat2 -->+<!-- ligature is a misnomer, this is a separate character in some languages -->+<!ENTITY Scaron  "&#352;"> <!--  latin capital letter S with caron,+                                    U+0160 ISOlat2 -->+<!ENTITY scaron  "&#353;"> <!--  latin small letter s with caron,+                                    U+0161 ISOlat2 -->+<!ENTITY Yuml    "&#376;"> <!--  latin capital letter Y with diaeresis,+                                    U+0178 ISOlat2 -->++<!-- Spacing Modifier Letters -->+<!ENTITY circ    "&#710;"> <!--  modifier letter circumflex accent,+                                    U+02C6 ISOpub -->+<!ENTITY tilde   "&#732;"> <!--  small tilde, U+02DC ISOdia -->++<!-- General Punctuation -->+<!ENTITY ensp    "&#8194;"> <!-- en space, U+2002 ISOpub -->+<!ENTITY emsp    "&#8195;"> <!-- em space, U+2003 ISOpub -->+<!ENTITY thinsp  "&#8201;"> <!-- thin space, U+2009 ISOpub -->+<!ENTITY zwnj    "&#8204;"> <!-- zero width non-joiner,+                                    U+200C NEW RFC 2070 -->+<!ENTITY zwj     "&#8205;"> <!-- zero width joiner, U+200D NEW RFC 2070 -->+<!ENTITY lrm     "&#8206;"> <!-- left-to-right mark, U+200E NEW RFC 2070 -->+<!ENTITY rlm     "&#8207;"> <!-- right-to-left mark, U+200F NEW RFC 2070 -->+<!ENTITY ndash   "&#8211;"> <!-- en dash, U+2013 ISOpub -->+<!ENTITY mdash   "&#8212;"> <!-- em dash, U+2014 ISOpub -->+<!ENTITY lsquo   "&#8216;"> <!-- left single quotation mark,+                                    U+2018 ISOnum -->+<!ENTITY rsquo   "&#8217;"> <!-- right single quotation mark,+                                    U+2019 ISOnum -->+<!ENTITY sbquo   "&#8218;"> <!-- single low-9 quotation mark, U+201A NEW -->+<!ENTITY ldquo   "&#8220;"> <!-- left double quotation mark,+                                    U+201C ISOnum -->+<!ENTITY rdquo   "&#8221;"> <!-- right double quotation mark,+                                    U+201D ISOnum -->+<!ENTITY bdquo   "&#8222;"> <!-- double low-9 quotation mark, U+201E NEW -->+<!ENTITY dagger  "&#8224;"> <!-- dagger, U+2020 ISOpub -->+<!ENTITY Dagger  "&#8225;"> <!-- double dagger, U+2021 ISOpub -->+<!ENTITY permil  "&#8240;"> <!-- per mille sign, U+2030 ISOtech -->+<!ENTITY lsaquo  "&#8249;"> <!-- single left-pointing angle quotation mark,+                                    U+2039 ISO proposed -->+<!-- lsaquo is proposed but not yet ISO standardized -->+<!ENTITY rsaquo  "&#8250;"> <!-- single right-pointing angle quotation mark,+                                    U+203A ISO proposed -->+<!-- rsaquo is proposed but not yet ISO standardized -->+<!ENTITY euro   "&#8364;"> <!--  euro sign, U+20AC NEW -->
+ examples/xhtml/xhtml-symbol.ent view
@@ -0,0 +1,242 @@+<!-- Mathematical, Greek and Symbolic characters for HTML -->++<!-- Character entity set. Typical invocation:+     <!ENTITY % HTMLsymbol PUBLIC+        "-//W3C//ENTITIES Symbols for XHTML//EN"+        "http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent">+     %HTMLsymbol;+-->++<!-- Portions (C) International Organization for Standardization 1986:+     Permission to copy in any form is granted for use with+     conforming SGML systems and applications as defined in+     ISO 8879, provided this notice is included in all copies.+-->++<!-- Relevant ISO entity set is given unless names are newly introduced.+     New names (i.e., not in ISO 8879 list) do not clash with any+     existing ISO 8879 entity names. ISO 10646 character numbers+     are given for each character, in hex. values are decimal+     conversions of the ISO 10646 values and refer to the document+     character set. Names are Unicode names. +-->++<!-- Latin Extended-B -->+<!ENTITY fnof     "&#402;"> <!-- latin small f with hook = function+                                    = florin, U+0192 ISOtech -->++<!-- Greek -->+<!ENTITY Alpha    "&#913;"> <!-- greek capital letter alpha, U+0391 -->+<!ENTITY Beta     "&#914;"> <!-- greek capital letter beta, U+0392 -->+<!ENTITY Gamma    "&#915;"> <!-- greek capital letter gamma,+                                    U+0393 ISOgrk3 -->+<!ENTITY Delta    "&#916;"> <!-- greek capital letter delta,+                                    U+0394 ISOgrk3 -->+<!ENTITY Epsilon  "&#917;"> <!-- greek capital letter epsilon, U+0395 -->+<!ENTITY Zeta     "&#918;"> <!-- greek capital letter zeta, U+0396 -->+<!ENTITY Eta      "&#919;"> <!-- greek capital letter eta, U+0397 -->+<!ENTITY Theta    "&#920;"> <!-- greek capital letter theta,+                                    U+0398 ISOgrk3 -->+<!ENTITY Iota     "&#921;"> <!-- greek capital letter iota, U+0399 -->+<!ENTITY Kappa    "&#922;"> <!-- greek capital letter kappa, U+039A -->+<!ENTITY Lambda   "&#923;"> <!-- greek capital letter lambda,+                                    U+039B ISOgrk3 -->+<!ENTITY Mu       "&#924;"> <!-- greek capital letter mu, U+039C -->+<!ENTITY Nu       "&#925;"> <!-- greek capital letter nu, U+039D -->+<!ENTITY Xi       "&#926;"> <!-- greek capital letter xi, U+039E ISOgrk3 -->+<!ENTITY Omicron  "&#927;"> <!-- greek capital letter omicron, U+039F -->+<!ENTITY Pi       "&#928;"> <!-- greek capital letter pi, U+03A0 ISOgrk3 -->+<!ENTITY Rho      "&#929;"> <!-- greek capital letter rho, U+03A1 -->+<!-- there is no Sigmaf, and no U+03A2 character either -->+<!ENTITY Sigma    "&#931;"> <!-- greek capital letter sigma,+                                    U+03A3 ISOgrk3 -->+<!ENTITY Tau      "&#932;"> <!-- greek capital letter tau, U+03A4 -->+<!ENTITY Upsilon  "&#933;"> <!-- greek capital letter upsilon,+                                    U+03A5 ISOgrk3 -->+<!ENTITY Phi      "&#934;"> <!-- greek capital letter phi,+                                    U+03A6 ISOgrk3 -->+<!ENTITY Chi      "&#935;"> <!-- greek capital letter chi, U+03A7 -->+<!ENTITY Psi      "&#936;"> <!-- greek capital letter psi,+                                    U+03A8 ISOgrk3 -->+<!ENTITY Omega    "&#937;"> <!-- greek capital letter omega,+                                    U+03A9 ISOgrk3 -->++<!ENTITY alpha    "&#945;"> <!-- greek small letter alpha,+                                    U+03B1 ISOgrk3 -->+<!ENTITY beta     "&#946;"> <!-- greek small letter beta, U+03B2 ISOgrk3 -->+<!ENTITY gamma    "&#947;"> <!-- greek small letter gamma,+                                    U+03B3 ISOgrk3 -->+<!ENTITY delta    "&#948;"> <!-- greek small letter delta,+                                    U+03B4 ISOgrk3 -->+<!ENTITY epsilon  "&#949;"> <!-- greek small letter epsilon,+                                    U+03B5 ISOgrk3 -->+<!ENTITY zeta     "&#950;"> <!-- greek small letter zeta, U+03B6 ISOgrk3 -->+<!ENTITY eta      "&#951;"> <!-- greek small letter eta, U+03B7 ISOgrk3 -->+<!ENTITY theta    "&#952;"> <!-- greek small letter theta,+                                    U+03B8 ISOgrk3 -->+<!ENTITY iota     "&#953;"> <!-- greek small letter iota, U+03B9 ISOgrk3 -->+<!ENTITY kappa    "&#954;"> <!-- greek small letter kappa,+                                    U+03BA ISOgrk3 -->+<!ENTITY lambda   "&#955;"> <!-- greek small letter lambda,+                                    U+03BB ISOgrk3 -->+<!ENTITY mu       "&#956;"> <!-- greek small letter mu, U+03BC ISOgrk3 -->+<!ENTITY nu       "&#957;"> <!-- greek small letter nu, U+03BD ISOgrk3 -->+<!ENTITY xi       "&#958;"> <!-- greek small letter xi, U+03BE ISOgrk3 -->+<!ENTITY omicron  "&#959;"> <!-- greek small letter omicron, U+03BF NEW -->+<!ENTITY pi       "&#960;"> <!-- greek small letter pi, U+03C0 ISOgrk3 -->+<!ENTITY rho      "&#961;"> <!-- greek small letter rho, U+03C1 ISOgrk3 -->+<!ENTITY sigmaf   "&#962;"> <!-- greek small letter final sigma,+                                    U+03C2 ISOgrk3 -->+<!ENTITY sigma    "&#963;"> <!-- greek small letter sigma,+                                    U+03C3 ISOgrk3 -->+<!ENTITY tau      "&#964;"> <!-- greek small letter tau, U+03C4 ISOgrk3 -->+<!ENTITY upsilon  "&#965;"> <!-- greek small letter upsilon,+                                    U+03C5 ISOgrk3 -->+<!ENTITY phi      "&#966;"> <!-- greek small letter phi, U+03C6 ISOgrk3 -->+<!ENTITY chi      "&#967;"> <!-- greek small letter chi, U+03C7 ISOgrk3 -->+<!ENTITY psi      "&#968;"> <!-- greek small letter psi, U+03C8 ISOgrk3 -->+<!ENTITY omega    "&#969;"> <!-- greek small letter omega,+                                    U+03C9 ISOgrk3 -->+<!ENTITY thetasym "&#977;"> <!-- greek small letter theta symbol,+                                    U+03D1 NEW -->+<!ENTITY upsih    "&#978;"> <!-- greek upsilon with hook symbol,+                                    U+03D2 NEW -->+<!ENTITY piv      "&#982;"> <!-- greek pi symbol, U+03D6 ISOgrk3 -->++<!-- General Punctuation -->+<!ENTITY bull     "&#8226;"> <!-- bullet = black small circle,+                                     U+2022 ISOpub  -->+<!-- bullet is NOT the same as bullet operator, U+2219 -->+<!ENTITY hellip   "&#8230;"> <!-- horizontal ellipsis = three dot leader,+                                     U+2026 ISOpub  -->+<!ENTITY prime    "&#8242;"> <!-- prime = minutes = feet, U+2032 ISOtech -->+<!ENTITY Prime    "&#8243;"> <!-- double prime = seconds = inches,+                                     U+2033 ISOtech -->+<!ENTITY oline    "&#8254;"> <!-- overline = spacing overscore,+                                     U+203E NEW -->+<!ENTITY frasl    "&#8260;"> <!-- fraction slash, U+2044 NEW -->++<!-- Letterlike Symbols -->+<!ENTITY weierp   "&#8472;"> <!-- script capital P = power set+                                     = Weierstrass p, U+2118 ISOamso -->+<!ENTITY image    "&#8465;"> <!-- blackletter capital I = imaginary part,+                                     U+2111 ISOamso -->+<!ENTITY real     "&#8476;"> <!-- blackletter capital R = real part symbol,+                                     U+211C ISOamso -->+<!ENTITY trade    "&#8482;"> <!-- trade mark sign, U+2122 ISOnum -->+<!ENTITY alefsym  "&#8501;"> <!-- alef symbol = first transfinite cardinal,+                                     U+2135 NEW -->+<!-- alef symbol is NOT the same as hebrew letter alef,+     U+05D0 although the same glyph could be used to depict both characters -->++<!-- Arrows -->+<!ENTITY larr     "&#8592;"> <!-- leftwards arrow, U+2190 ISOnum -->+<!ENTITY uarr     "&#8593;"> <!-- upwards arrow, U+2191 ISOnum-->+<!ENTITY rarr     "&#8594;"> <!-- rightwards arrow, U+2192 ISOnum -->+<!ENTITY darr     "&#8595;"> <!-- downwards arrow, U+2193 ISOnum -->+<!ENTITY harr     "&#8596;"> <!-- left right arrow, U+2194 ISOamsa -->+<!ENTITY crarr    "&#8629;"> <!-- downwards arrow with corner leftwards+                                     = carriage return, U+21B5 NEW -->+<!ENTITY lArr     "&#8656;"> <!-- leftwards double arrow, U+21D0 ISOtech -->+<!-- Unicode does not say that lArr is the same as the 'is implied by' arrow+    but also does not have any other character for that function. So ? lArr can+    be used for 'is implied by' as ISOtech suggests -->+<!ENTITY uArr     "&#8657;"> <!-- upwards double arrow, U+21D1 ISOamsa -->+<!ENTITY rArr     "&#8658;"> <!-- rightwards double arrow,+                                     U+21D2 ISOtech -->+<!-- Unicode does not say this is the 'implies' character but does not have +     another character with this function so ?+     rArr can be used for 'implies' as ISOtech suggests -->+<!ENTITY dArr     "&#8659;"> <!-- downwards double arrow, U+21D3 ISOamsa -->+<!ENTITY hArr     "&#8660;"> <!-- left right double arrow,+                                     U+21D4 ISOamsa -->++<!-- Mathematical Operators -->+<!ENTITY forall   "&#8704;"> <!-- for all, U+2200 ISOtech -->+<!ENTITY part     "&#8706;"> <!-- partial differential, U+2202 ISOtech  -->+<!ENTITY exist    "&#8707;"> <!-- there exists, U+2203 ISOtech -->+<!ENTITY empty    "&#8709;"> <!-- empty set = null set = diameter,+                                     U+2205 ISOamso -->+<!ENTITY nabla    "&#8711;"> <!-- nabla = backward difference,+                                     U+2207 ISOtech -->+<!ENTITY isin     "&#8712;"> <!-- element of, U+2208 ISOtech -->+<!ENTITY notin    "&#8713;"> <!-- not an element of, U+2209 ISOtech -->+<!ENTITY ni       "&#8715;"> <!-- contains as member, U+220B ISOtech -->+<!-- should there be a more memorable name than 'ni'? -->+<!ENTITY prod     "&#8719;"> <!-- n-ary product = product sign,+                                     U+220F ISOamsb -->+<!-- prod is NOT the same character as U+03A0 'greek capital letter pi' though+     the same glyph might be used for both -->+<!ENTITY sum      "&#8721;"> <!-- n-ary sumation, U+2211 ISOamsb -->+<!-- sum is NOT the same character as U+03A3 'greek capital letter sigma'+     though the same glyph might be used for both -->+<!ENTITY minus    "&#8722;"> <!-- minus sign, U+2212 ISOtech -->+<!ENTITY lowast   "&#8727;"> <!-- asterisk operator, U+2217 ISOtech -->+<!ENTITY radic    "&#8730;"> <!-- square root = radical sign,+                                     U+221A ISOtech -->+<!ENTITY prop     "&#8733;"> <!-- proportional to, U+221D ISOtech -->+<!ENTITY infin    "&#8734;"> <!-- infinity, U+221E ISOtech -->+<!ENTITY ang      "&#8736;"> <!-- angle, U+2220 ISOamso -->+<!ENTITY and      "&#8743;"> <!-- logical and = wedge, U+2227 ISOtech -->+<!ENTITY or       "&#8744;"> <!-- logical or = vee, U+2228 ISOtech -->+<!ENTITY cap      "&#8745;"> <!-- intersection = cap, U+2229 ISOtech -->+<!ENTITY cup      "&#8746;"> <!-- union = cup, U+222A ISOtech -->+<!ENTITY int      "&#8747;"> <!-- integral, U+222B ISOtech -->+<!ENTITY there4   "&#8756;"> <!-- therefore, U+2234 ISOtech -->+<!ENTITY sim      "&#8764;"> <!-- tilde operator = varies with = similar to,+                                     U+223C ISOtech -->+<!-- tilde operator is NOT the same character as the tilde, U+007E,+     although the same glyph might be used to represent both  -->+<!ENTITY cong     "&#8773;"> <!-- approximately equal to, U+2245 ISOtech -->+<!ENTITY asymp    "&#8776;"> <!-- almost equal to = asymptotic to,+                                     U+2248 ISOamsr -->+<!ENTITY ne       "&#8800;"> <!-- not equal to, U+2260 ISOtech -->+<!ENTITY equiv    "&#8801;"> <!-- identical to, U+2261 ISOtech -->+<!ENTITY le       "&#8804;"> <!-- less-than or equal to, U+2264 ISOtech -->+<!ENTITY ge       "&#8805;"> <!-- greater-than or equal to,+                                     U+2265 ISOtech -->+<!ENTITY sub      "&#8834;"> <!-- subset of, U+2282 ISOtech -->+<!ENTITY sup      "&#8835;"> <!-- superset of, U+2283 ISOtech -->+<!-- note that nsup, 'not a superset of, U+2283' is not covered by the Symbol +     font encoding and is not included. Should it be, for symmetry?+     It is in ISOamsn  --> +<!ENTITY nsub     "&#8836;"> <!-- not a subset of, U+2284 ISOamsn -->+<!ENTITY sube     "&#8838;"> <!-- subset of or equal to, U+2286 ISOtech -->+<!ENTITY supe     "&#8839;"> <!-- superset of or equal to,+                                     U+2287 ISOtech -->+<!ENTITY oplus    "&#8853;"> <!-- circled plus = direct sum,+                                     U+2295 ISOamsb -->+<!ENTITY otimes   "&#8855;"> <!-- circled times = vector product,+                                     U+2297 ISOamsb -->+<!ENTITY perp     "&#8869;"> <!-- up tack = orthogonal to = perpendicular,+                                     U+22A5 ISOtech -->+<!ENTITY sdot     "&#8901;"> <!-- dot operator, U+22C5 ISOamsb -->+<!-- dot operator is NOT the same character as U+00B7 middle dot -->++<!-- Miscellaneous Technical -->+<!ENTITY lceil    "&#8968;"> <!-- left ceiling = apl upstile,+                                     U+2308 ISOamsc  -->+<!ENTITY rceil    "&#8969;"> <!-- right ceiling, U+2309 ISOamsc  -->+<!ENTITY lfloor   "&#8970;"> <!-- left floor = apl downstile,+                                     U+230A ISOamsc  -->+<!ENTITY rfloor   "&#8971;"> <!-- right floor, U+230B ISOamsc  -->+<!ENTITY lang     "&#9001;"> <!-- left-pointing angle bracket = bra,+                                     U+2329 ISOtech -->+<!-- lang is NOT the same character as U+003C 'less than' +     or U+2039 'single left-pointing angle quotation mark' -->+<!ENTITY rang     "&#9002;"> <!-- right-pointing angle bracket = ket,+                                     U+232A ISOtech -->+<!-- rang is NOT the same character as U+003E 'greater than' +     or U+203A 'single right-pointing angle quotation mark' -->++<!-- Geometric Shapes -->+<!ENTITY loz      "&#9674;"> <!-- lozenge, U+25CA ISOpub -->++<!-- Miscellaneous Symbols -->+<!ENTITY spades   "&#9824;"> <!-- black spade suit, U+2660 ISOpub -->+<!-- black here seems to mean filled as opposed to hollow -->+<!ENTITY clubs    "&#9827;"> <!-- black club suit = shamrock,+                                     U+2663 ISOpub -->+<!ENTITY hearts   "&#9829;"> <!-- black heart suit = valentine,+                                     U+2665 ISOpub -->+<!ENTITY diams    "&#9830;"> <!-- black diamond suit, U+2666 ISOpub -->
+ examples/xhtml/xhtml.xml view
@@ -0,0 +1,1484 @@+<!DOCTYPE html SYSTEM "xhtml1-strict.dtd">+<?xml-stylesheet href="http://www.w3.org/StyleSheets/TR/W3C-REC.css" type="text/css"?>+<html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">+<head>+<title>XHTML 1.0: The Extensible HyperText Markup+Language</title>+<link rel="stylesheet"+href="http://www.w3.org/StyleSheets/TR/W3C-REC.css" type="text/css" />+<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" />+<style type="text/css">+span.term { font-style: italic; color: rgb(0, 0, 192) }+code {+	color: green;+	font-family: monospace;+	font-weight: bold;+}++code.greenmono {+	color: green;+	font-family: monospace;+	font-weight: bold;+}+.good {+	border: solid green;+	border-width: 2px;+	color: green;+	font-weight: bold;+	margin-right: 5%;+	margin-left: 0;+}+.bad  {+	border: solid red;+	border-width: 2px;+	margin-left: 0;+	margin-right: 5%;+	color: rgb(192, 101, 101);+}++img {+	color: white;+	border: none;+}++div.navbar { text-align: center; }+div.contents {+	background-color: rgb(204,204,255);+	padding: 0.5em;+	border: none;+	margin-right: 5%;+}+.tocline { list-style: none; }+table.exceptions { background-color: rgb(255,255,153); }+</style>+</head>+<body>+<div class="navbar">+  <a href="#toc">table of contents</a>+  <hr />+</div>+<div class="head"><p><a href="http://www.w3.org/"><img class="head"+src="http://www.w3.org/Icons/WWW/w3c_home.gif" alt="W3C" /></a></p>++<h1 class="head"><a name="title" id="title">XHTML</a><sup>&#8482;</sup> 1.0:+The Extensible HyperText Markup Language</h1>++<h2>A Reformulation of HTML 4 in XML 1.0</h2>++<h3>W3C Recommendation 26 January 2000</h3>++<dl>+<dt>This version:</dt>++<dd><a href=+"http://www.w3.org/TR/2000/REC-xhtml1-20000126">+http://www.w3.org/TR/2000/REC-xhtml1-20000126</a> <br />+(<a href="xhtml1.ps">Postscript version</a>,+<a href="xhtml1.pdf">PDF version</a>,+<a href="xhtml1.zip">ZIP archive</a>, or+<a href="xhtml1.tgz">Gzip'd TAR archive</a>)+</dd>++<dt>Latest version:</dt>++<dd><a href="http://www.w3.org/TR/xhtml1">+http://www.w3.org/TR/xhtml1</a></dd>++<dt>Previous version:</dt>++<dd><a href=+"http://www.w3.org/TR/1999/PR-xhtml1-19991210">+http://www.w3.org/TR/1999/PR-xhtml1-19991210</a></dd>++<dt>Authors:</dt>++<dd>See <a href="#acks">acknowledgements</a>.</dd>+</dl>++<p class="copyright"><a+href="http://www.w3.org/Consortium/Legal/ipr-notice#Copyright"> Copyright</a>+&copy;2000 <a href="http://www.w3.org/"><abbr title="World Wide Web+Consortium">W3C</abbr></a><sup>&reg;</sup> (<a+href="http://www.lcs.mit.edu/"><abbr+title="Massachusetts Institute of Technology">MIT</abbr></a>, <a+href="http://www.inria.fr/"><abbr+lang="fr" title="Institut National de Recherche en Informatique et+Automatique">INRIA</abbr></a>, <a+href="http://www.keio.ac.jp/">Keio</a>), All Rights Reserved. W3C <a+href="http://www.w3.org/Consortium/Legal/ipr-notice#Legal_Disclaimer">liability</a>,+<a+href="http://www.w3.org/Consortium/Legal/ipr-notice#W3C_Trademarks">trademark</a>,+<a+href="http://www.w3.org/Consortium/Legal/copyright-documents-19990405">document+use</a> and <a+href="http://www.w3.org/Consortium/Legal/copyright-software-19980720">software+licensing</a> rules+apply.</p>+<hr />+</div>++<h2 class="notoc">Abstract</h2>++<p>This specification defines <abbr title="Extensible Hypertext Markup+Language">XHTML</abbr> 1.0, a reformulation of HTML&nbsp;4+as an XML 1.0 application, and three <abbr title="Document Type+Definition">DTDs</abbr> corresponding to+the ones defined by HTML&nbsp;4. The semantics of the elements and+their attributes are defined in the W3C Recommendation for HTML&nbsp;4.+These semantics provide the foundation for future+extensibility of XHTML. Compatibility with existing HTML user+agents is possible by following a small set of guidelines.</p>++<h2>Status of this document</h2>++<p><em>This section describes the status of this document at the time+of its publication. Other documents may supersede this document. The+latest status of this document series is maintained at the W3C.</em></p>++<p>+This document has been reviewed by W3C Members and other+interested parties and has been endorsed by the Director+as a W3C Recommendation. It is a stable document and may be+used as reference material or cited as a normative+reference from another document. W3C's role in making the+Recommendation is to draw attention to the specification and+to promote its widespread deployment. This enhances the+functionality and interoperability of the Web.+</p>+<p>This document has been produced as part of the <a href=+"http://www.w3.org/MarkUp/">W3C HTML Activity</a>. The goals of+the <a href="http://www.w3.org/MarkUp/Group/">HTML Working+Group</a> <i>(<a href="http://cgi.w3.org/MemberAccess/">members+only</a>)</i> are discussed in the <a href=+"http://www.w3.org/MarkUp/Group/HTMLcharter">HTML Working Group+charter</a> <i>(<a href="http://cgi.w3.org/MemberAccess/">members+only</a>)</i>.</p>++<p>A list of current W3C Recommendations and other technical documents+can be found at <a+href="http://www.w3.org/TR">http://www.w3.org/TR</a>.</p>++<p>Public discussion on <abbr title="HyperText Markup+Language">HTML</abbr> features takes place on the mailing list <a+href="mailto:www-html@w3.org"> www-html@w3.org</a> (<a href=+"http://lists.w3.org/Archives/Public/www-html/">archive</a>).</p>++<p>Please report errors in this document to <a+href="mailto:www-html-editor@w3.org">www-html-editor@w3.org</a>.</p>++<p>The list of known errors in this specification is available at <a+href="http://www.w3.org/2000/01/REC-xhtml1-20000126-errata">http://www.w3.org/2000/01/REC-xhtml1-20000126-errata</a>.</p>++<h2 class="notoc"><a id="toc" name="toc">Contents</a></h2>++<div class="contents">+<ul class="toc">+<li class="tocline">1. <a href="#xhtml">What is XHTML?</a>++<ul class="toc">+<li class="tocline">1.1 <a href="#html4">What is HTML 4?</a></li>++<li class="tocline">1.2 <a href="#xml">What is XML?</a></li>++<li class="tocline">1.3 <a href="#why">Why the need for XHTML?</a></li>+</ul>+</li>++<li class="tocline">2. <a href="#defs">Definitions</a>++<ul class="toc">+<li class="tocline">2.1 <a href="#terms">Terminology</a></li>++<li class="tocline">2.2 <a href="#general">General Terms</a></li>+</ul>+</li>++<li class="tocline">3. <a href="#normative">Normative Definition of XHTML 1.0</a>+++<ul class="toc">+<li class="tocline">3.1 <a href="#docconf">Document Conformance</a></li>++<li class="tocline">3.2 <a href="#uaconf">User Agent Conformance</a></li>+</ul>+</li>++<li class="tocline">4. <a href="#diffs">Differences with HTML 4</a>++</li>++<li class="tocline">5. <a href="#issues">Compatibility Issues</a>++<ul class="toc">+<li class="tocline">5.1 <a href="#media">Internet Media Types</a></li>+</ul>+</li>++<li class="tocline">6. <a href="#future">Future Directions</a>++<ul class="toc">+<li class="tocline">6.1 <a href="#mods">Modularizing HTML</a></li>++<li class="tocline">6.2 <a href="#extensions">Subsets and Extensibility</a></li>++<li class="tocline">6.3 <a href="#profiles">Document Profiles</a></li>+</ul>+</li>++<li class="tocline"><a href="#dtds">Appendix A. DTDs</a></li>++<li class="tocline"><a href="#prohibitions">Appendix B. Element+Prohibitions</a></li>++<li class="tocline"><a href="#guidelines">Appendix C. HTML Compatibility Guidelines</a></li>++<li class="tocline"><a href="#acks">Appendix D. Acknowledgements</a></li>++<li class="tocline"><a href="#refs">Appendix E. References</a></li>+</ul>+</div>++<!--OddPage-->+<h1><a name="xhtml" id="xhtml">1. What is XHTML?</a></h1>++<p>XHTML is a family of current and future document types and modules that+reproduce, subset, and extend HTML&nbsp;4 <a href="#ref-html4">[HTML]</a>. XHTML family document types are <abbr title="Extensible Markup Language">XML</abbr> based,+and ultimately are designed to work in conjunction with XML-based user agents.+The details of this family and its evolution are+discussed in more detail in the section on <a href="#future">Future+Directions</a>. </p>++<p>XHTML 1.0 (this specification) is the first document type in the XHTML+family. It is a reformulation of the three HTML&nbsp;4 document types as+applications of XML 1.0 <a href="#ref-xml"> [XML]</a>. It is intended+to be used as a language for content that is both XML-conforming and, if some+simple <a href="#guidelines">guidelines</a> are followed,+operates in HTML&nbsp;4 conforming user agents. Developers who migrate+their content to XHTML 1.0 will realize the following benefits:</p>++<ul>+<li>XHTML documents are XML conforming. As such, they are readily viewed,+edited, and validated with standard XML tools.</li>+<li>XHTML documents can be written to+to operate as well or better than they did before in existing+HTML&nbsp;4-conforming user agents as well as in new, XHTML 1.0 conforming user+agents.</li>+<li>XHTML documents can utilize applications (e.g. scripts and applets) that rely+upon either the HTML Document Object Model or the XML Document Object Model <a+href="#ref-dom">[DOM]</a>.</li>+<li>As the XHTML family evolves, documents conforming to XHTML 1.0 will be more+likely to interoperate within and among various XHTML environments.</li>+</ul>++<p>The XHTML family is the next step in the evolution of the Internet. By+migrating to XHTML today, content developers can enter the XML world with all+of its attendant benefits, while still remaining confident in their+content's backward and future compatibility.</p>++<h2><a name="html4" id="html4">1.1 What is HTML&nbsp;4?</a></h2>++<p>HTML 4 <a href="#ref-html4">[HTML]</a> is an <abbr title="Standard+Generalized Markup Language">SGML</abbr> (Standard+Generalized Markup Language) application conforming to+International Standard <abbr title="Organization for International+Standardization">ISO</abbr> 8879, and is widely regarded as the+standard publishing language of the World Wide Web.</p>++<p>SGML is a language for describing markup languages,+particularly those used in electronic document exchange, document+management, and document publishing. HTML is an example of a+language defined in SGML.</p>++<p>SGML has been around since the middle 1980's and has remained+quite stable. Much of this stability stems from the fact that the+language is both feature-rich and flexible. This flexibility,+however, comes at a price, and that price is a level of+complexity that has inhibited its adoption in a diversity of+environments, including the World Wide Web.</p>++<p>HTML, as originally conceived, was to be a language for the+exchange of scientific and other technical documents, suitable+for use by non-document specialists. HTML addressed the problem+of SGML complexity by specifying a small set of structural and+semantic tags suitable for authoring relatively simple documents.+In addition to simplifying the document structure, HTML added+support for hypertext. Multimedia capabilities were added+later.</p>++<p>In a remarkably short space of time, HTML became wildly+popular and rapidly outgrew its original purpose. Since HTML's+inception, there has been rapid invention of new elements for use+within HTML (as a standard) and for adapting HTML to vertical,+highly specialized, markets. This plethora of new elements has+led to compatibility problems for documents across different+platforms.</p>++<p>As the heterogeneity of both software and platforms rapidly+proliferate, it is clear that the suitability of 'classic' HTML&nbsp;4+for use on these platforms is somewhat limited.</p>++<h2><a name="xml" id="xml">1.2 What is XML?</a></h2>++<p>XML<sup>&#8482;</sup> is the shorthand for Extensible Markup+Language, and is an acronym of Extensible Markup Language <a+href="#ref-xml">[XML]</a>.</p>++<p>XML was conceived as a means of regaining the power and+flexibility of SGML without most of its complexity. Although a+restricted form of SGML, XML nonetheless preserves most of SGML's+power and richness, and yet still retains all of SGML's commonly+used features.</p>++<p>While retaining these beneficial features, XML removes many of+the more complex features of SGML that make the authoring and+design of suitable software both difficult and costly.</p>++<h2><a name="why" id="why">1.3 Why the need for XHTML?</a></h2>++<p>The benefits of migrating to XHTML 1.0 are described above. Some of the+benefits of migrating to XHTML in general are:</p>++<ul>+<li>Document developers and user agent designers are constantly+discovering new ways to express their ideas through new markup. In XML, it is+relatively easy to introduce new elements or additional element+attributes.  The XHTML family is designed to accommodate these extensions+through XHTML modules and techniques for developing new XHTML-conforming+modules (described in the forthcoming XHTML Modularization specification).+These modules will permit the combination of existing and+new feature sets when developing content and when designing new user+agents.</li>++<li>Alternate ways of accessing the Internet are constantly being+introduced.  Some estimates indicate that by the year 2002, 75% of+Internet document viewing will be carried out on these alternate+platforms.  The XHTML family is designed with general user agent+interoperability in mind. Through a new user agent and document profiling+mechanism, servers, proxies, and user agents will be able to perform+best effort content transformation. Ultimately, it will be possible to+develop XHTML-conforming content that is usable by any XHTML-conforming+user agent.</li>++</ul>+<!--OddPage-->+<h1><a name="defs" id="defs">2. Definitions</a></h1>++<h2><a name="terms" id="terms">2.1 Terminology</a></h2>++<p>The following terms are used in this specification. These+terms extend the definitions in <a href="#ref-rfc2119">+[RFC2119]</a> in ways based upon similar definitions in ISO/<abbr+title="International Electro-technical Commission">IEC</abbr>+9945-1:1990 <a href="#ref-posix">[POSIX.1]</a>:</p>++<dl>+<dt>Implementation-defined</dt>++<dd>A value or behavior is implementation-defined when it is left+to the implementation to define [and document] the corresponding+requirements for correct document construction.</dd>++<dt>May</dt>++<dd>With respect to implementations, the word "may" is to be+interpreted as an optional feature that is not required in this+specification but can be provided. With respect to <a href=+"#docconf">Document Conformance</a>, the word "may" means that+the optional feature must not be used. The term "optional" has+the same definition as "may".</dd>++<dt>Must</dt>++<dd>In this specification, the word "must" is to be interpreted+as a mandatory requirement on the implementation or on Strictly+Conforming XHTML Documents, depending upon the context. The term+"shall" has the same definition as "must".</dd>++<dt>Reserved</dt>++<dd>A value or behavior is unspecified, but it is not allowed to+be used by Conforming Documents nor to be supported by a+Conforming User Agents.</dd>++<dt>Should</dt>++<dd>With respect to implementations, the word "should" is to be+interpreted as an implementation recommendation, but not a+requirement. With respect to documents, the word "should" is to+be interpreted as recommended programming practice for documents+and a requirement for Strictly Conforming XHTML Documents.</dd>++<dt>Supported</dt>++<dd>Certain facilities in this specification are optional. If a+facility is supported, it behaves as specified by this+specification.</dd>++<dt>Unspecified</dt>++<dd>When a value or behavior is unspecified, the specification+defines no portability requirements for a facility on an+implementation even when faced with a document that uses the+facility. A document that requires specific behavior in such an+instance, rather than tolerating any behavior when using that+facility, is not a Strictly Conforming XHTML Document.</dd>+</dl>++<h2><a name="general" id="general">2.2 General Terms</a></h2>++<dl>+<dt>Attribute</dt>++<dd>An attribute is a parameter to an element declared in the+DTD. An attribute's type and value range, including a possible+default value, are defined in the DTD.</dd>++<dt>DTD</dt>++<dd>A DTD, or document type definition, is a collection of XML+declarations that, as a collection, defines the legal structure,+<span class="term">elements</span>, and <span class="term">+attributes</span> that are available for use in a document that+complies to the DTD.</dd>++<dt>Document</dt>++<dd>A document is a stream of data that, after being combined+with any other streams it references, is structured such that it+holds information contained within <span class="term">+elements</span> that are organized as defined in the associated+<span class="term">DTD</span>. See <a href="#docconf">Document+Conformance</a> for more information.</dd>++<dt>Element</dt>++<dd>An element is a document structuring unit declared in the+<span class="term">DTD</span>. The element's content model is+defined in the <span class="term">DTD</span>, and additional+semantics may be defined in the prose description of the+element.</dd>++<dt><a name="facilities" id="facilities">Facilities</a></dt>++<dd>Functionality includes <span class="term">elements</span>,+<span class="term">attributes</span>, and the semantics+associated with those <span class="term">elements</span> and+<span class="term">attributes</span>. An implementation+supporting that functionality is said to provide the necessary+facilities.</dd>++<dt>Implementation</dt>++<dd>An implementation is a system that provides collection of+<span class="term">facilities</span> and services that supports+this specification. See <a href="#uaconf">User Agent+Conformance</a> for more information.</dd>++<dt>Parsing</dt>++<dd>Parsing is the act whereby a <span class="term">+document</span> is scanned, and the information contained within+the <span class="term">document</span> is filtered into the+context of the <span class="term">elements</span> in which the+information is structured.</dd>++<dt>Rendering</dt>++<dd>Rendering is the act whereby the information in a <span+class="term">document</span> is presented. This presentation is+done in the form most appropriate to the environment (e.g.+aurally, visually, in print).</dd>++<dt>User Agent</dt>++<dd>A user agent is an <span class="term">implementation</span>+that retrieves and processes XHTML documents. See <a href=+"#uaconf">User Agent Conformance</a> for more information.</dd>++<dt>Validation</dt>++<dd>Validation is a process whereby <span class="term">+documents</span> are verified against the associated <span class=+"term">DTD</span>, ensuring that the structure, use of <span+class="term">elements</span>, and use of <span class="term">+attributes</span> are consistent with the definitions in the+<span class="term">DTD</span>.</dd>++<dt><a name="wellformed" id="wellformed">Well-formed</a></dt>++<dd>A <span class="term">document</span> is well-formed when it+is structured according to the rules defined in <a href=+"http://www.w3.org/TR/REC-xml#sec-well-formed">Section 2.1</a> of+the XML 1.0 Recommendation <a href="#ref-xml">[XML]</a>.+Basically, this definition states that elements, delimited by+their start and end tags, are nested properly within one+another.</dd>+</dl>++<!--OddPage-->+<h1><a name="normative" id="normative">3. Normative Definition of+XHTML 1.0</a></h1>++<h2><a name="docconf" id="docconf">3.1 Document+Conformance</a></h2>++<p>This version of XHTML provides a definition of strictly+conforming XHTML documents, which are restricted to tags and+attributes from the XHTML namespace. See <a href=+"#well-formed">Section 3.1.2</a> for information on using XHTML+with other namespaces, for instance, to include metadata+expressed in <abbr title="Resource Description Format">RDF</abbr> within XHTML documents.</p>++<h3><a name="strict" id="strict">3.1.1 Strictly Conforming+Documents</a></h3>++<p>A Strictly Conforming XHTML Document is a document that+requires only the facilities described as mandatory in this+specification. Such a document must meet all of the following+criteria:</p>++<ol>+<li>+<p>It must validate against one of the three DTDs found in <a+href="#dtds">Appendix&#160;A</a>.</p>+</li>++<li>+<p>The root element of the document must be <code>+&lt;html&gt;</code>.</p>+</li>++<li>+<p>The root element of the document must designate the XHTML+namespace using the <code>xmlns</code> attribute <a href=+"#ref-xmlns">[XMLNAMES]</a>. The namespace for XHTML is+defined to be+<code>http://www.w3.org/1999/xhtml</code>.</p>+</li>++<li>+<p>There must be a DOCTYPE declaration in the document prior to+the root element. The public identifier included in+the DOCTYPE declaration must reference one of the three DTDs+found in <a href="#dtds">Appendix&#160;A</a> using the respective+Formal Public Identifier. The system identifier may be changed to reflect+local system conventions.</p>++<pre>+&lt;!DOCTYPE html+     PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"+     "DTD/xhtml1-strict.dtd"&gt;++&lt;!DOCTYPE html+     PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"+     "DTD/xhtml1-transitional.dtd"&gt;++&lt;!DOCTYPE html+     PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"+     "DTD/xhtml1-frameset.dtd"&gt;+</pre>+</li>+</ol>++<p>Here is an example of a minimal XHTML document.</p>++<div class="good">+<pre>+&lt;?xml version="1.0" encoding="UTF-8"?&gt;+&lt;!DOCTYPE html+     PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"+    "DTD/xhtml1-strict.dtd"&gt;+&lt;html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"&gt;+  &lt;head&gt;+    &lt;title&gt;Virtual Library&lt;/title&gt;+  &lt;/head&gt;+  &lt;body&gt;+    &lt;p&gt;Moved to &lt;a href="http://vlib.org/"&gt;vlib.org&lt;/a&gt;.&lt;/p&gt;+  &lt;/body&gt;+&lt;/html&gt;</pre>+</div>++<p>Note that in this example, the XML declaration is included. An XML+declaration like the one above is+not required in all XML documents. XHTML document authors are strongly encouraged to use XML declarations in all their documents. Such a declaration is required+when the character encoding of the document is other than the default UTF-8 or+UTF-16.</p>++<h3><a name="well-formed" id="well-formed">3.1.2 Using XHTML with+other namespaces</a></h3>++<p>The XHTML namespace may be used with other XML namespaces+as per <a href="#ref-xmlns">[XMLNAMES]</a>, although such+documents are not strictly conforming XHTML 1.0 documents as+defined above. Future work by W3C will address ways to specify+conformance for documents involving multiple namespaces.</p>++<p>The following example shows the way in which XHTML 1.0 could+be used in conjunction with the MathML Recommendation:</p>++<div class="good">+<pre>+&lt;html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"&gt;+  &lt;head&gt;+    &lt;title&gt;A Math Example&lt;/title&gt;+  &lt;/head&gt;+  &lt;body&gt;+    &lt;p&gt;The following is MathML markup:&lt;/p&gt;+    &lt;math xmlns="http://www.w3.org/1998/Math/MathML"&gt;+      &lt;apply&gt; &lt;log/&gt;+        &lt;logbase&gt;+          &lt;cn&gt; 3 &lt;/cn&gt;+        &lt;/logbase&gt;+        &lt;ci&gt; x &lt;/ci&gt;+      &lt;/apply&gt;+    &lt;/math&gt;+  &lt;/body&gt;+&lt;/html&gt;+</pre>+</div>++<p>The following example shows the way in which XHTML 1.0 markup+could be incorporated into another XML namespace:</p>++<div class="good">+<pre>+&lt;?xml version="1.0" encoding="UTF-8"?&gt;+&lt;!-- initially, the default namespace is "books" --&gt;+&lt;book xmlns='urn:loc.gov:books'+    xmlns:isbn='urn:ISBN:0-395-36341-6' xml:lang="en" lang="en"&gt;+  &lt;title&gt;Cheaper by the Dozen&lt;/title&gt;+  &lt;isbn:number&gt;1568491379&lt;/isbn:number&gt;+  &lt;notes&gt;+    &lt;!-- make HTML the default namespace for a hypertext commentary --&gt;+    &lt;p xmlns='http://www.w3.org/1999/xhtml'&gt;+        This is also available &lt;a href="http://www.w3.org/"&gt;online&lt;/a&gt;.+    &lt;/p&gt;+  &lt;/notes&gt;+&lt;/book&gt;+</pre>+</div>++<h2><a name="uaconf" id="uaconf">3.2 User Agent+Conformance</a></h2>++<p>A conforming user agent must meet all of the following+criteria:</p>++<ol>+<li>In order to be consistent with the XML 1.0 Recommendation <a+href="#ref-xml">[XML]</a>, the user agent must parse and evaluate+an XHTML document for well-formedness. If the user agent claims+to be a validating user agent, it must also validate documents+against their referenced DTDs according to <a href="#ref-xml">+[XML]</a>.</li>++<li>When the user agent claims to support <a href="#facilities">+facilities</a> defined within this specification or required by+this specification through normative reference, it must do so in+ways consistent with the facilities' definition.</li>++<li>When a user agent processes an XHTML document as generic XML,+it shall only recognize attributes of type+<code>ID</code> (e.g. the <code>id</code> attribute on most XHTML elements)+as fragment identifiers.</li>++<li>If a user agent encounters an element it does not recognize,+it must render the element's content.</li>++<li>If a user agent encounters an attribute it does not+recognize, it must ignore the entire attribute specification+(i.e., the attribute and its value).</li>++<li>If a user agent encounters an attribute value it doesn't+recognize, it must use the default attribute value.</li>++<li>If it encounters an entity reference (other than one+of the predefined entities) for which the User Agent has+processed no declaration (which could happen if the declaration+is in the external subset which the User Agent hasn't read), the entity+reference should be rendered as the characters (starting+with the ampersand and ending with the semi-colon) that+make up the entity reference.</li>++<li>When rendering content, User Agents that encounter+characters or character entity references that are recognized but not renderable should display the document in such a way that it is obvious to the user that normal rendering has not taken place.</li>++<li>+The following characters are defined in [XML] as whitespace characters:++<ul>+<li>Space (&amp;#x0020;)</li>+<li>Tab (&amp;#x0009;)</li>+<li>Carriage return (&amp;#x000D;)</li>+<li>Line feed (&amp;#x000A;)</li>+</ul>++<p>+The XML processor normalizes different system's line end codes into one+single line-feed character, that is passed up to the application. The XHTML+user agent in addition, must treat the following characters as whitespace:+</p>++<ul>+<li>Form feed (&amp;#x000C;)</li>+<li>Zero-width space (&amp;#x200B;)</li>+</ul>++<p>+In elements where the 'xml:space' attribute is set to 'preserve', the user+agent must leave all whitespace characters intact (with the exception of+leading and trailing whitespace characters, which should be removed).+Otherwise, whitespace+is handled according to the following rules:+</p>++<ul>+<li>+All whitespace surrounding block elements should be removed.+</li>+<li>+Comments are removed entirely and do not affect whitespace handling. One+whitespace character on either side of a comment is treated as two white+space characters.+</li>+<li>+Leading and trailing whitespace inside a block element must be removed.+</li>+<li>Line feed characters within a block element must be converted into a+space (except when the 'xml:space' attribute is set to 'preserve').+</li>+<li>+A sequence of white space characters must be reduced to a single space+character (except when the 'xml:space' attribute is set to 'preserve').+</li>+<li>+With regard to rendition,+the User Agent should render the content in a+manner appropriate to the language in which the content is written.+In languages whose primary script is Latinate, the ASCII space+character is typically used to encode both grammatical word boundaries and+typographic whitespace; in languages whose script is related to Nagari+(e.g., Sanskrit, Thai, etc.), grammatical boundaries may be encoded using+the ZW 'space' character, but will not typically be represented by+typographic whitespace in rendered output; languages using Arabiform scripts+may encode typographic whitespace using a space character, but may also use+the ZW space character to delimit 'internal' grammatical boundaries (what+look like words in Arabic to an English eye frequently encode several words,+e.g. 'kitAbuhum' = 'kitAbu-hum' = 'book them' == their book); and languages+in the Chinese script tradition typically neither encode such delimiters nor+use typographic whitespace in this way.+</li>+</ul>++<p>Whitespace in attribute values is processed according to <a+href="#ref-xml">[XML]</a>.</p>+</li>+</ol>++<!--OddPage-->+<h1><a name="diffs" id="diffs">4. Differences with HTML&nbsp;4</a></h1>++<p>Due to the fact that XHTML is an XML application, certain+practices that were perfectly legal in SGML-based HTML&nbsp;4 <a+href="#ref-html4">[HTML]</a> must be changed.</p>++<h2><a name="h-4.1" id="h-4.1">4.1 Documents must be+well-formed</a></h2>++<p><a href="#wellformed">Well-formedness</a> is a new concept+introduced by <a href="#ref-xml">[XML]</a>. Essentially this+means that all elements must either have closing tags or be+written in a special form (as described below), and that all the+elements must nest.</p>++<p>Although overlapping is illegal in SGML, it was widely+tolerated in existing browsers.</p>++<div class="good">+<p><strong><em>CORRECT: nested elements.</em></strong></p>++<p>&lt;p&gt;here is an emphasized+&lt;em&gt;paragraph&lt;/em&gt;.&lt;/p&gt;</p>+</div>++<div class="bad">+<p><strong><em>INCORRECT: overlapping elements</em></strong></p>++<p>&lt;p&gt;here is an emphasized+&lt;em&gt;paragraph.&lt;/p&gt;&lt;/em&gt;</p>+</div>++<h2><a name="h-4.2" id="h-4.2">4.2 Element and attribute+names must be in lower case</a></h2>++<p>XHTML documents must use lower case for all HTML element and+attribute names. This difference is necessary because XML is+case-sensitive e.g. &lt;li&gt; and &lt;LI&gt; are different+tags.</p>++<h2><a name="h-4.3" id="h-4.3">4.3 For non-empty elements,+end tags are required</a></h2>++<p>In SGML-based HTML 4 certain elements were permitted to omit+the end tag; with the elements that followed implying closure.+This omission is not permitted in XML-based XHTML. All elements+other than those declared in the DTD as <code>EMPTY</code> must+have an end tag.</p>++<div class="good">+<p><strong><em>CORRECT: terminated elements</em></strong></p>++<p>&lt;p&gt;here is a paragraph.&lt;/p&gt;&lt;p&gt;here is+another paragraph.&lt;/p&gt;</p>+</div>++<div class="bad">+<p><strong><em>INCORRECT: unterminated elements</em></strong></p>++<p>&lt;p&gt;here is a paragraph.&lt;p&gt;here is another+paragraph.</p>+</div>++<h2><a name="h-4.4" id="h-4.4">4.4 Attribute values must+always be quoted</a></h2>++<p>All attribute values must be quoted, even those which appear+to be numeric.</p>++<div class="good">+<p><strong><em>CORRECT: quoted attribute values</em></strong></p>++<p>&lt;table rows="3"&gt;</p>+</div>++<div class="bad">+<p><strong><em>INCORRECT: unquoted attribute values</em></strong></p>++<p>&lt;table rows=3&gt;</p>+</div>++<h2><a name="h-4.5" id="h-4.5">4.5 Attribute+Minimization</a></h2>++<p>XML does not support attribute minimization. Attribute-value+pairs must be written in full. Attribute names such as <code>+compact</code> and <code>checked</code> cannot occur in elements+without their value being specified.</p>++<div class="good">+<p><strong><em>CORRECT: unminimized attributes</em></strong></p>++<p>&lt;dl compact="compact"&gt;</p>+</div>++<div class="bad">+<p><strong><em>INCORRECT: minimized attributes</em></strong></p>++<p>&lt;dl compact&gt;</p>+</div>++<h2><a name="h-4.6" id="h-4.6">4.6 Empty Elements</a></h2>++<p>Empty elements must either have an end tag or the start tag must end with <code>/&gt;</code>. For instance,+<code>&lt;br/&gt;</code> or <code>&lt;hr&gt;&lt;/hr&gt;</code>. See <a+href="#guidelines">HTML Compatibility Guidelines</a> for information on ways to+ensure this is backward compatible with HTML 4 user agents.</p>++<div class="good">+<p><strong><em>CORRECT: terminated empty tags</em></strong></p>++<p>&lt;br/&gt;&lt;hr/&gt;</p>+</div>++<div class="bad">+<p><strong><em>INCORRECT: unterminated empty tags</em></strong></p>++<p>&lt;br&gt;&lt;hr&gt;</p>+</div>++<h2><a name="h-4.7" id="h-4.7">4.7 Whitespace handling in+attribute values</a></h2>++<p>In attribute values, user agents will strip leading and+trailing whitespace from attribute values and map sequences+of one or more whitespace characters (including line breaks) to+a single inter-word space (an ASCII space character for western+scripts). See <a href="http://www.w3.org/TR/REC-xml#AVNormalize">+Section 3.3.3</a> of <a href="#ref-xml">[XML]</a>.</p>++<h2><a name="h-4.8" id="h-4.8">4.8 Script and Style+elements</a></h2>++<p>In XHTML, the script and style elements are declared as having+<code>#PCDATA</code> content. As a result, <code>&lt;</code> and+<code>&amp;</code> will be treated as the start of markup, and+entities such as <code>&amp;lt;</code> and <code>&amp;amp;</code>+will be recognized as entity references by the XML processor to+<code>&lt;</code> and <code>&amp;</code> respectively. Wrapping+the content of the script or style element within a <code>+CDATA</code> marked section avoids the expansion of these+entities.</p>++<div class="good">+<pre>+&lt;script&gt;+ &lt;![CDATA[+ ... unescaped script content ...+ ]]&gt;+ &lt;/script&gt;+</pre>+</div>++<p><code>CDATA</code> sections are recognized by the XML+processor and appear as nodes in the Document Object Model, see+<a href=+"http://www.w3.org/TR/REC-DOM-Level-1/level-one-core.html#ID-E067D597">+Section 1.3</a> of the DOM Level 1 Recommendation <a href=+"#ref-dom">[DOM]</a>.</p>++<p>An alternative is to use external script and style+documents.</p>++<h2><a name="h-4.9" id="h-4.9">4.9 SGML exclusions</a></h2>++<p>SGML gives the writer of a DTD the ability to exclude specific+elements from being contained within an element. Such+prohibitions (called "exclusions") are not possible in XML.</p>++<p>For example, the HTML 4 Strict DTD forbids the nesting of an+'<code>a</code>' element within another '<code>a</code>' element+to any descendant depth. It is not possible to spell out such+prohibitions in XML. Even though these prohibitions cannot be+defined in the DTD, certain elements should not be nested. A+summary of such elements and the elements that should not be+nested in them is found in the normative <a href="#prohibitions">+Appendix&#160;B</a>.</p>++<h2><a name="h-4.10" id="h-4.10">4.10 The elements with 'id' and 'name'+attributes</a></h2>++<p>HTML 4 defined the <code>name</code> attribute for the elements+<code>a</code>,+<code>applet</code>, <code>form</code>, <code>frame</code>,+<code>iframe</code>, <code>img</code>, and <code>map</code>.+HTML 4 also introduced+the <code>id</code> attribute. Both of these attributes are designed to be+used as fragment identifiers.</p>+<p>In XML, fragment identifiers are of type <code>ID</code>, and+there can only be a single attribute of type <code>ID</code> per element.+Therefore, in XHTML 1.0 the <code>id</code>+attribute is defined to be of type <code>ID</code>. In order to+ensure that XHTML 1.0 documents are well-structured XML documents, XHTML 1.0+documents MUST use the <code>id</code> attribute when defining fragment+identifiers, even on elements that historically have also had a+<code>name</code> attribute.+See the <a href="#guidelines">HTML Compatibility+Guidelines</a> for information on ensuring such anchors are backwards+compatible when serving XHTML documents as media type <code>text/html</code>.+</p>+<p>Note that in XHTML 1.0, the <code>name</code> attribute of these+elements is formally deprecated, and will be removed in a+subsequent version of XHTML.</p>++<!--OddPage-->+<h1><a name="issues" id="issues">5. Compatibility Issues</a></h1>++<p>Although there is no requirement for XHTML 1.0 documents to be+compatible with existing user agents, in practice this is easy to+accomplish. Guidelines for creating compatible documents can be+found in <a href="#guidelines">Appendix&#160;C</a>.</p>++<h2><a name="media" id="media">5.1 Internet Media Type</a></h2>+<p>As of the publication of this recommendation, the general+recommended MIME labeling for XML-based applications+has yet to be resolved.</p>++<p>However, XHTML Documents which follow the guidelines set forth+in <a href="#guidelines">Appendix C</a>, "HTML Compatibility Guidelines" may be+labeled with the Internet Media Type "text/html", as they+are compatible with most HTML browsers. This document+makes no recommendation about MIME labeling of other+XHTML documents.</p>++<!--OddPage-->+<h1><a name="future" id="future">6. Future Directions</a></h1>++<p>XHTML 1.0 provides the basis for a family of document types+that will extend and subset XHTML, in order to support a wide+range of new devices and applications, by defining modules and+specifying a mechanism for combining these modules. This+mechanism will enable the extension and sub-setting of XHTML 1.0+in a uniform way through the definition of new modules.</p>++<h2><a name="mods" id="mods">6.1 Modularizing HTML</a></h2>++<p>As the use of XHTML moves from the traditional desktop user+agents to other platforms, it is clear that not all of the XHTML+elements will be required on all platforms. For example a hand+held device or a cell-phone may only support a subset of XHTML+elements.</p>++<p>The process of modularization breaks XHTML up into a series of+smaller element sets. These elements can then be recombined to+meet the needs of different communities.</p>++<p>These modules will be defined in a later W3C document.</p>++<h2><a name="extensions" id="extensions">6.2 Subsets and+Extensibility</a></h2>++<p>Modularization brings with it several advantages:</p>++<ul>+<li>+<p>It provides a formal mechanism for sub-setting XHTML.</p>+</li>++<li>+<p>It provides a formal mechanism for extending XHTML.</p>+</li>++<li>+<p>It simplifies the transformation between document types.</p>+</li>++<li>+<p>It promotes the reuse of modules in new document types.</p>+</li>+</ul>++<h2><a name="profiles" id="profiles">6.3 Document+Profiles</a></h2>++<p>A document profile specifies the syntax and semantics of a set+of documents. Conformance to a document profile provides a basis+for interoperability guarantees. The document profile specifies+the facilities required to process documents of that type, e.g.+which image formats can be used, levels of scripting, style sheet+support, and so on.</p>++<p>For product designers this enables various groups to define+their own standard profile.</p>++<p>For authors this will obviate the need to write several+different versions of documents for different clients.</p>++<p>For special groups such as chemists, medical doctors, or+mathematicians this allows a special profile to be built using+standard HTML elements plus a group of elements geared to the+specialist's needs.</p>++<!--OddPage-->+<h1><a name="appendices" id="appendices"></a>+<a name="dtds" id="dtds">Appendix A. DTDs</a></h1>++<p><b>This appendix is normative.</b></p>++<p>These DTDs and entity sets form a normative part of this+specification. The complete set of DTD files together with an XML+declaration and SGML Open Catalog is included in the <a href=+"xhtml1.zip">zip file</a> for this specification.</p>++<h2><a name="h-A1" id="h-A1">A.1 Document Type+Definitions</a></h2>++<p>These DTDs approximate the HTML 4 DTDs. It is likely that+when the DTDs are modularized, a method of DTD construction will+be employed that corresponds more closely to HTML 4.</p>++<ul>+<li>+<p><a href="DTD/xhtml1-strict.dtd" type="text/plain">+XHTML-1.0-Strict</a></p>+</li>++<li>+<p><a href="DTD/xhtml1-transitional.dtd" type="text/plain">+XHTML-1.0-Transitional</a></p>+</li>++<li>+<p><a href="DTD/xhtml1-frameset.dtd" type="text/plain">+XHTML-1.0-Frameset</a></p>+</li>+</ul>++<h2><a name="h-A2" id="h-A2">A.2 Entity Sets</a></h2>++<p>The XHTML entity sets are the same as for HTML 4, but have+been modified to be valid XML 1.0 entity declarations. Note the+entity for the Euro currency sign (<code>&amp;euro;</code> or+<code>&amp;#8364;</code> or <code>&amp;#x20AC;</code>) is defined+as part of the special characters.</p>++<ul>+<li>+<p><a href="DTD/xhtml-lat1.ent">Latin-1 characters</a></p>+</li>++<li>+<p><a href="DTD/xhtml-special.ent">Special characters</a></p>+</li>++<li>+<p><a href="DTD/xhtml-symbol.ent">Symbols</a></p>+</li>+</ul>++<!--OddPage-->+<h1><a name="prohibitions" id="prohibitions">Appendix B. Element+Prohibitions</a></h1>++<p><b>This appendix is normative.</b></p>++<p>The following elements have prohibitions on which elements+they can contain (see <a href="#h-4.9">Section 4.9</a>). This+prohibition applies to all depths of nesting, i.e. it contains+all the descendant elements.</p>++<dl><dt><code class="tag">a</code></dt>+<dd>+cannot contain other <code>a</code> elements.</dd>+<dt><code class="tag">pre</code></dt>+<dd>cannot contain the <code>img</code>, <code>object</code>,+<code>big</code>, <code>small</code>, <code>sub</code>, or <code>+sup</code> elements.</dd>++<dt><code class="tag">button</code></dt>+<dd>cannot contain the <code>input</code>, <code>select</code>,+<code>textarea</code>, <code>label</code>, <code>button</code>,+<code>form</code>, <code>fieldset</code>, <code>iframe</code> or+<code>isindex</code> elements.</dd>+<dt><code class="tag">label</code></dt>+<dd>cannot contain other <code class="tag">label</code> elements.</dd>+<dt><code class="tag">form</code></dt>+<dd>cannot contain other <code>form</code> elements.</dd>+</dl>++<!--OddPage-->+<h1><a name="guidelines" id="guidelines">Appendix C.+HTML Compatibility Guidelines</a></h1>++<p><b>This appendix is informative.</b></p>++<p>This appendix summarizes design guidelines for authors who+wish their XHTML documents to render on existing HTML user+agents.</p>++<h2>C.1 Processing Instructions</h2>+<p>Be aware that processing instructions are rendered on some+user agents. However, also note that when the XML declaration is not included+in a document, the document can only use the default character encodings UTF-8+or UTF-16.</p>++<h2>C.2 Empty Elements</h2>+<p>Include a space before the trailing <code>/</code> and <code>+&gt;</code> of empty elements, e.g. <code class="greenmono">+&lt;br&#160;/&gt;</code>, <code class="greenmono">+&lt;hr&#160;/&gt;</code> and <code class="greenmono">&lt;img+src="karen.jpg" alt="Karen"&#160;/&gt;</code>. Also, use the+minimized tag syntax for empty elements, e.g. <code class=+"greenmono">&lt;br /&gt;</code>, as the alternative syntax <code+class="greenmono">&lt;br&gt;&lt;/br&gt;</code> allowed by XML+gives uncertain results in many existing user agents.</p>++<h2>C.3 Element Minimization and Empty Element Content</h2>+<p>Given an empty instance of an element whose content model is+not <code>EMPTY</code> (for example, an empty title or paragraph)+do not use the minimized form (e.g. use <code class="greenmono">+&lt;p&gt; &lt;/p&gt;</code> and not <code class="greenmono">+&lt;p&#160;/&gt;</code>).</p>++<h2>C.4 Embedded Style Sheets and Scripts</h2>+<p>Use external style sheets if your style sheet uses <code>+&lt;</code> or <code>&amp;</code> or <code>]]&gt;</code> or <code>--</code>. Use+external scripts if your script uses <code>&lt;</code> or <code>+&amp;</code> or <code>]]&gt;</code> or <code>--</code>. Note that XML parsers+are permitted to silently remove the contents of comments. Therefore, the historical+practice of "hiding" scripts and style sheets within comments to make the+documents backward compatible is likely to not work as expected in XML-based+implementations.</p>++<h2>C.5 Line Breaks within Attribute Values</h2>+<p>Avoid line breaks and multiple whitespace characters within+attribute values. These are handled inconsistently by user+agents.</p>++<h2>C.6 Isindex</h2>+<p>Don't include more than one <code>isindex</code> element in+the document <code>head</code>. The <code>isindex</code> element+is deprecated in favor of the <code>input</code> element.</p>++<h2>C.7 The <code>lang</code> and <code>xml:lang</code> Attributes</h2>+<p>Use both the <code>lang</code> and <code>xml:lang</code>+attributes when specifying the language of an element. The value+of the <code>xml:lang</code> attribute takes precedence.</p>++<h2>C.8 Fragment Identifiers</h2>+<p>In XML, <abbr title="Uniform Resource Identifiers">URIs</abbr> [<a href="#ref-rfc2396">RFC2396</a>] that end with fragment identifiers of the form+<code>"#foo"</code> do not refer to elements with an attribute+<code>name="foo"</code>; rather, they refer to elements with an+attribute defined to be of type <code>ID</code>, e.g., the <code>+id</code> attribute in HTML 4. Many existing HTML clients don't+support the use of <code>ID</code>-type attributes in this way,+so identical values may be supplied for both of these attributes to ensure+maximum forward and backward compatibility (e.g., <code class=+"greenmono">&lt;a id="foo" name="foo"&gt;...&lt;/a&gt;</code>).</p>++<p>Further, since the set of+legal values for attributes of type <code>ID</code> is much smaller than+for those of type <code>CDATA</code>, the type of the <code>name</code>+attribute has been changed to <code>NMTOKEN</code>. This attribute is+constrained such that it can only have the same values as type+<code>ID</code>, or as the <code>Name</code> production in XML 1.0 Section+2.5, production 5. Unfortunately, this constraint cannot be expressed in the+XHTML 1.0 DTDs.  Because of this change, care must be taken when+converting existing HTML documents. The values of these attributes+must be unique within the document, valid, and any references to these+fragment identifiers (both+internal and external) must be updated should the values be changed during+conversion.</p>+<p>Finally, note that XHTML 1.0 has deprecated the+<code>name</code> attribute of the <code>a</code>, <code>applet</code>, <code>form</code>, <code>frame</code>, <code>iframe</code>, <code>img</code>, and <code>map</code>+elements, and it will be+removed from XHTML in subsequent versions.</p>++<h2>C.9 Character Encoding</h2>+<p>To specify a character encoding in the document, use both the+encoding attribute specification on the xml declaration (e.g.+<code class="greenmono">&lt;?xml version="1.0"+encoding="EUC-JP"?&gt;</code>) and a meta http-equiv statement+(e.g. <code class="greenmono">&lt;meta http-equiv="Content-type"+content='text/html; charset="EUC-JP"'&#160;/&gt;</code>). The+value of the encoding attribute of the xml processing instruction+takes precedence.</p>++<h2>C.10 Boolean Attributes</h2>+<p>Some HTML user agents are unable to interpret boolean+attributes when these appear in their full (non-minimized) form,+as required by XML 1.0. Note this problem doesn't affect user+agents compliant with HTML 4. The following attributes are+involved: <code>compact</code>, <code>nowrap</code>, <code>+ismap</code>, <code>declare</code>, <code>noshade</code>, <code>+checked</code>, <code>disabled</code>, <code>readonly</code>,+<code>multiple</code>, <code>selected</code>, <code>+noresize</code>, <code>defer</code>.</p>++<h2>C.11 Document Object Model and XHTML</h2>+<p>+The Document Object Model level 1 Recommendation [<a href="#ref-dom">DOM</a>]+defines document object model interfaces for XML and HTML 4. The HTML 4+document object model specifies that HTML element and attribute names are+returned in upper-case. The XML document object model specifies that+element and attribute names are returned in the case they are specified. In+XHTML 1.0, elements and attributes are specified in lower-case. This apparent difference can be+addressed in two ways:+</p>+<ol>+<li>Applications that access XHTML documents served as Internet media type+<code>text/html</code>+via the <abbr title="Document Object Model">DOM</abbr> can use the HTML DOM,+and can rely upon element and attribute names being returned in+upper-case from those interfaces.</li>+<li>Applications that access XHTML documents served as Internet media types+<code>text/xml</code> or <code>application/xml</code>+can also use the XML DOM. Elements and attributes will be returned in lower-case.+Also, some XHTML elements may or may+not appear+in the object tree because they are optional in the content model+(e.g. the <code>tbody</code> element within+<code>table</code>).  This occurs because in HTML 4 some elements were+permitted to be minimized such that their start and end tags are both omitted+(an SGML feature).+This is not possible in XML. Rather than require document authors to insert+extraneous elements, XHTML has made the elements optional.+Applications need to adapt to this+accordingly.</li>+</ol>++<h2>C.12 Using Ampersands in Attribute Values</h2>+<p>+When an attribute value contains an ampersand, it must be expressed as a character+entity reference+(e.g. "<code>&amp;amp;</code>"). For example, when the+<code>href</code> attribute+of the <code>a</code> element refers to a+CGI script that takes parameters, it must be expressed as+<code>http://my.site.dom/cgi-bin/myscript.pl?class=guest&amp;amp;name=user</code>+rather than as+<code>http://my.site.dom/cgi-bin/myscript.pl?class=guest&amp;name=user</code>.+</p>++<h2>C.13 Cascading Style Sheets (CSS) and XHTML</h2>++<p>The Cascading Style Sheets level 2 Recommendation [<a href="#ref-css2">CSS2</a>] defines style+properties which are applied to the parse tree of the HTML or XML+document.  Differences in parsing will produce different visual or+aural results, depending on the selectors used. The following hints+will reduce this effect for documents which are served without+modification as both media types:</p>++<ol>+<li>+CSS style sheets for XHTML should use lower case element and+attribute names.</li>+++<li>In tables, the tbody element will be inferred by the parser of an+HTML user agent, but not by the parser of an XML user agent. Therefore+you should always explicitly add a tbody element if it is referred to+in a CSS selector.</li>++<li>Within the XHTML name space, user agents are expected to+recognize the "id" attribute as an attribute of type ID.+Therefore, style sheets should be able to continue using the+shorthand "#" selector syntax even if the user agent does not read+the DTD.</li>++<li>Within the XHTML name space, user agents are expected to+recognize the "class" attribute. Therefore, style sheets should be+able to continue using the shorthand "." selector syntax.</li>++<li>+CSS defines different conformance rules for HTML and XML documents;+be aware that the HTML rules apply to XHTML documents delivered as+HTML and the XML rules apply to XHTML documents delivered as XML.</li>+</ol>+<!--OddPage-->+<h1><a name="acks" id="acks">Appendix D.+Acknowledgements</a></h1>++<p><b>This appendix is informative.</b></p>++<p>This specification was written with the participation of the+members of the W3C HTML working group:</p>++<dl>+<dd>Steven Pemberton, CWI (HTML Working Group Chair)<br />+Murray Altheim, Sun Microsystems<br />+Daniel Austin, AskJeeves (CNET: The Computer Network through July 1999)<br />+Frank Boumphrey, HTML Writers Guild<br />+John Burger, Mitre<br />+Andrew W. Donoho, IBM<br />+Sam Dooley, IBM<br />+Klaus Hofrichter, GMD<br />+Philipp Hoschka, W3C<br />+Masayasu Ishikawa, W3C<br />+Warner ten Kate, Philips Electronics<br />+Peter King, Phone.com<br />+Paula Klante, JetForm<br />+Shin'ichi Matsui, Panasonic (W3C visiting engineer through September 1999)<br />+Shane McCarron, Applied Testing and Technology (The Open Group through August+1999)<br />+Ann Navarro, HTML Writers Guild<br />+Zach Nies, Quark<br />+Dave Raggett, W3C/HP (W3C lead for HTML)<br />+Patrick Schmitz, Microsoft<br />+Sebastian Schnitzenbaumer, Stack Overflow<br />+Peter Stark, Phone.com<br />+Chris Wilson, Microsoft<br />+Ted Wugofski, Gateway 2000<br />+Dan Zigmond, WebTV Networks</dd>+</dl>++<!--OddPage-->+<h1><a name="refs" id="refs">Appendix E. References</a></h1>++<p><b>This appendix is informative.</b></p>++<dl>++<dt><a name="ref-css2" id="ref-css2"><b>[CSS2]</b></a></dt>++<dd><a href="http://www.w3.org/TR/1998/REC-CSS2-19980512">"Cascading Style Sheets, level 2 (CSS2) Specification"</a>, B.+Bos, H. W. Lie, C. Lilley, I. Jacobs, 12 May 1998.<br />+Latest version available at: <a href="http://www.w3.org/TR/REC-CSS2">+http://www.w3.org/TR/REC-CSS2</a></dd>++<dt><a name="ref-dom" id="ref-dom"><b>[DOM]</b></a></dt>++<dd><a href="http://www.w3.org/TR/1998/REC-DOM-Level-1-19981001">"Document Object Model (DOM) Level 1 Specification"</a>, Lauren+Wood <i>et al.</i>, 1 October 1998.<br />+Latest version available at: <a href="http://www.w3.org/TR/REC-DOM-Level-1">+http://www.w3.org/TR/REC-DOM-Level-1</a></dd>++<dt><a name="ref-html4" id="ref-html4"><b>[HTML]</b></a></dt>++<dd><a href="http://www.w3.org/TR/1999/REC-html401-19991224">"HTML 4.01 Specification"</a>, D. Raggett, A. Le&#160;Hors, I.+Jacobs, 24 December 1999.<br />+Latest version available at: <a href="http://www.w3.org/TR/html401">+http://www.w3.org/TR/html401</a></dd>++<dt><a name="ref-posix" id="ref-posix"><b>[POSIX.1]</b></a></dt>++<dd>"ISO/IEC 9945-1:1990 Information Technology - Portable+Operating System Interface (POSIX) - Part 1: System Application+Program Interface (API) [C Language]", Institute of Electrical+and Electronics Engineers, Inc, 1990.</dd>++<dt><a name="ref-rfc2046" id="ref-rfc2046"><b>+[RFC2046]</b></a></dt>++<dd><a href="http://www.ietf.org/rfc/rfc2046.txt">"RFC2046: Multipurpose Internet Mail Extensions (MIME) Part+Two: Media Types"</a>, N. Freed and N. Borenstein, November+1996.<br />+Available at <a href="http://www.ietf.org/rfc/rfc2046.txt">+http://www.ietf.org/rfc/rfc2046.txt</a>. Note that this RFC+obsoletes RFC1521, RFC1522, and RFC1590.</dd>++<dt><a name="ref-rfc2119" id="ref-rfc2119"><b>+[RFC2119]</b></a></dt>++<dd><a href="http://www.ietf.org/rfc/rfc2119.txt">"RFC2119: Key words for use in RFCs to Indicate Requirement+Levels"</a>, S. Bradner, March 1997.<br />+Available at: <a href="http://www.ietf.org/rfc/rfc2119.txt">+http://www.ietf.org/rfc/rfc2119.txt</a></dd>++<dt><a name="ref-rfc2376" id="ref-rfc2376"><b>+[RFC2376]</b></a></dt>++<dd><a href="http://www.ietf.org/rfc/rfc2376.txt">"RFC2376: XML Media Types"</a>, E. Whitehead, M. Murata, July+1998.<br />+Available at: <a href="http://www.ietf.org/rfc/rfc2376.txt">+http://www.ietf.org/rfc/rfc2376.txt</a></dd>++<dt><a name="ref-rfc2396" id="ref-rfc2396"><b>+[RFC2396]</b></a></dt>++<dd><a href="http://www.ietf.org/rfc/rfc2396.txt">"RFC2396: Uniform Resource Identifiers (URI): Generic+Syntax"</a>, T. Berners-Lee, R. Fielding, L. Masinter, August+1998.<br />+This document updates RFC1738 and RFC1808.<br />+Available at: <a href="http://www.ietf.org/rfc/rfc2396.txt">+http://www.ietf.org/rfc/rfc2396.txt</a></dd>++<dt><a name="ref-xml" id="ref-xml"><b>[XML]</b></a></dt>++<dd><a href="http://www.w3.org/TR/1998/REC-xml-19980210">"Extensible Markup Language (XML) 1.0 Specification"</a>, T.+Bray, J. Paoli, C. M. Sperberg-McQueen, 10 February 1998.<br />+Latest version available at: <a href="http://www.w3.org/TR/REC-xml">+http://www.w3.org/TR/REC-xml</a></dd>++<dt><a name="ref-xmlns" id="ref-xmlns"><b>[XMLNAMES]</b></a></dt>++<dd><a href="http://www.w3.org/TR/1999/REC-xml-names-19990114">"Namespaces in XML"</a>, T. Bray, D. Hollander, A. Layman, 14+January 1999.<br />+XML namespaces provide a simple method for qualifying names used+in XML documents by associating them with namespaces identified+by URI.<br />+Latest version available at: <a href="http://www.w3.org/TR/REC-xml-names">+http://www.w3.org/TR/REC-xml-names</a></dd>++</dl>+<p><a href="http://www.w3.org/WAI/WCAG1AAA-Conformance"+title="Explanation of Level Triple-A Conformance">+<img height="32" width="88"+src="http://www.w3.org/WAI/wcag1AAA.gif"+alt="Level Triple-A conformance icon, W3C-WAI Web Content Accessibility Guidelines 1.0" /></a></p>+<div class="navbar">+  <hr />+  <a href="#toc">table of contents</a>+</div>+</body>+</html>+
+ examples/xhtml/xhtml1-frameset.dtd view
@@ -0,0 +1,1225 @@+<!--+   Extensible HTML version 1.0 Frameset DTD++   This is the same as HTML 4.0 Frameset except for+   changes due to the differences between XML and SGML.++   Namespace = http://www.w3.org/1999/xhtml++   For further information, see: http://www.w3.org/TR/xhtml1++   Copyright (c) 1998-2000 W3C (MIT, INRIA, Keio),+   All Rights Reserved. ++   This DTD module is identified by the PUBLIC and SYSTEM identifiers:++   PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"+   SYSTEM "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd"++   $Revision: 1.1 $+   $Date: 2002/10/01 13:47:08 $++-->++<!--================ Character mnemonic entities =========================-->++<!ENTITY % HTMLlat1 PUBLIC+   "-//W3C//ENTITIES Latin 1 for XHTML//EN"+   "xhtml-lat1.ent">+%HTMLlat1;++<!ENTITY % HTMLsymbol PUBLIC+   "-//W3C//ENTITIES Symbols for XHTML//EN"+   "xhtml-symbol.ent">+%HTMLsymbol;++<!ENTITY % HTMLspecial PUBLIC+   "-//W3C//ENTITIES Special for XHTML//EN"+   "xhtml-special.ent">+%HTMLspecial;++<!--================== Imported Names ====================================-->++<!ENTITY % ContentType "CDATA">+    <!-- media type, as per [RFC2045] -->++<!ENTITY % ContentTypes "CDATA">+    <!-- comma-separated list of media types, as per [RFC2045] -->++<!ENTITY % Charset "CDATA">+    <!-- a character encoding, as per [RFC2045] -->++<!ENTITY % Charsets "CDATA">+    <!-- a space separated list of character encodings, as per [RFC2045] -->++<!ENTITY % LanguageCode "NMTOKEN">+    <!-- a language code, as per [RFC1766] -->++<!ENTITY % Character "CDATA">+    <!-- a single character from [ISO10646] -->++<!ENTITY % Number "CDATA">+    <!-- one or more digits -->++<!ENTITY % LinkTypes "CDATA">+    <!-- space-separated list of link types -->++<!ENTITY % MediaDesc "CDATA">+    <!-- single or comma-separated list of media descriptors -->++<!ENTITY % URI "CDATA">+    <!-- a Uniform Resource Identifier, see [RFC2396] -->++<!ENTITY % UriList "CDATA">+    <!-- a space separated list of Uniform Resource Identifiers -->++<!ENTITY % Datetime "CDATA">+    <!-- date and time information. ISO date format -->++<!ENTITY % Script "CDATA">+    <!-- script expression -->++<!ENTITY % StyleSheet "CDATA">+    <!-- style sheet data -->++<!ENTITY % Text "CDATA">+    <!-- used for titles etc. -->++<!ENTITY % FrameTarget "NMTOKEN">+    <!-- render in this frame -->++<!ENTITY % Length "CDATA">+    <!-- nn for pixels or nn% for percentage length -->++<!ENTITY % MultiLength "CDATA">+    <!-- pixel, percentage, or relative -->++<!ENTITY % MultiLengths "CDATA">+    <!-- comma-separated list of MultiLength -->++<!ENTITY % Pixels "CDATA">+    <!-- integer representing length in pixels -->++<!-- these are used for image maps -->++<!ENTITY % Shape "(rect|circle|poly|default)">++<!ENTITY % Coords "CDATA">+    <!-- comma separated list of lengths -->++<!-- used for object, applet, img, input and iframe -->+<!ENTITY % ImgAlign "(top|middle|bottom|left|right)">++<!-- a color using sRGB: #RRGGBB as Hex values -->+<!ENTITY % Color "CDATA">++<!-- There are also 16 widely known color names with their sRGB values:++    Black  = #000000    Green  = #008000+    Silver = #C0C0C0    Lime   = #00FF00+    Gray   = #808080    Olive  = #808000+    White  = #FFFFFF    Yellow = #FFFF00+    Maroon = #800000    Navy   = #000080+    Red    = #FF0000    Blue   = #0000FF+    Purple = #800080    Teal   = #008080+    Fuchsia= #FF00FF    Aqua   = #00FFFF+-->++<!--=================== Generic Attributes ===============================-->++<!-- core attributes common to most elements+  id       document-wide unique id+  class    space separated list of classes+  style    associated style info+  title    advisory title/amplification+-->+<!ENTITY % coreattrs+ "id          ID             #IMPLIED+  class       CDATA          #IMPLIED+  style       %StyleSheet;   #IMPLIED+  title       %Text;         #IMPLIED"+  >++<!-- internationalization attributes+  lang        language code (backwards compatible)+  xml:lang    language code (as per XML 1.0 spec)+  dir         direction for weak/neutral text+-->+<!ENTITY % i18n+ "lang        %LanguageCode; #IMPLIED+  xml:lang    %LanguageCode; #IMPLIED+  dir         (ltr|rtl)      #IMPLIED"+  >++<!-- attributes for common UI events+  onclick     a pointer button was clicked+  ondblclick  a pointer button was double clicked+  onmousedown a pointer button was pressed down+  onmouseup   a pointer button was released+  onmousemove a pointer was moved onto the element+  onmouseout  a pointer was moved away from the element+  onkeypress  a key was pressed and released+  onkeydown   a key was pressed down+  onkeyup     a key was released+-->+<!ENTITY % events+ "onclick     %Script;       #IMPLIED+  ondblclick  %Script;       #IMPLIED+  onmousedown %Script;       #IMPLIED+  onmouseup   %Script;       #IMPLIED+  onmouseover %Script;       #IMPLIED+  onmousemove %Script;       #IMPLIED+  onmouseout  %Script;       #IMPLIED+  onkeypress  %Script;       #IMPLIED+  onkeydown   %Script;       #IMPLIED+  onkeyup     %Script;       #IMPLIED"+  >++<!-- attributes for elements that can get the focus+  accesskey   accessibility key character+  tabindex    position in tabbing order+  onfocus     the element got the focus+  onblur      the element lost the focus+-->+<!ENTITY % focus+ "accesskey   %Character;    #IMPLIED+  tabindex    %Number;       #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED"+  >++<!ENTITY % attrs "%coreattrs; %i18n; %events;">++<!-- text alignment for p, div, h1-h6. The default is+     align="left" for ltr headings, "right" for rtl -->++<!ENTITY % TextAlign "align (left|center|right) #IMPLIED">++<!--=================== Text Elements ====================================-->++<!ENTITY % special+   "br | span | bdo |object | applet | img | map | iframe">++<!ENTITY % fontstyle "tt | i | b | big | small | u+                      | s | strike |font | basefont">++<!ENTITY % phrase "em | strong | dfn | code | q | sub | sup |+                   samp | kbd | var | cite | abbr | acronym">++<!ENTITY % inline.forms "input | select | textarea | label | button">++<!-- these can occur at block or inline level -->+<!ENTITY % misc "ins | del | script | noscript">++<!ENTITY % inline "a | %special; | %fontstyle; | %phrase; | %inline.forms;">++<!-- %Inline; covers inline or "text-level" elements -->+<!ENTITY % Inline "(#PCDATA | %inline; | %misc;)*">++<!--================== Block level elements ==============================-->++<!ENTITY % heading "h1|h2|h3|h4|h5|h6">+<!ENTITY % lists "ul | ol | dl | menu | dir">+<!ENTITY % blocktext "pre | hr | blockquote | address | center">++<!ENTITY % block+    "p | %heading; | div | %lists; | %blocktext; | isindex | fieldset | table">++<!ENTITY % Block "(%block; | form | %misc;)*">++<!-- %Flow; mixes Block and Inline and is used for list items etc. -->+<!ENTITY % Flow "(#PCDATA | %block; | form | %inline; | %misc;)*">++<!--================== Content models for exclusions =====================-->++<!-- a elements use %Inline; excluding a -->++<!ENTITY % a.content+   "(#PCDATA | %special; | %fontstyle; | %phrase; | %inline.forms; | %misc;)*">++<!-- pre uses %Inline excluding img, object, applet, big, small,+     sub, sup, font, or basefont -->++<!ENTITY % pre.content+   "(#PCDATA | a | br | span | bdo | map | tt | i | b | u | s |+      %phrase; | %inline.forms;)*">++<!-- form uses %Flow; excluding form -->++<!ENTITY % form.content "(#PCDATA | %block; | %inline; | %misc;)*">++<!-- button uses %Flow; but excludes a, form, form controls, iframe -->++<!ENTITY % button.content+   "(#PCDATA | p | %heading; | div | %lists; | %blocktext; |+      table | br | span | bdo | object | applet | img | map |+      %fontstyle; | %phrase; | %misc;)*">++<!--================ Document Structure ==================================-->++<!-- the namespace URI designates the document profile -->++<!ELEMENT html (head, frameset)>+<!ATTLIST html+  %i18n;+  xmlns       %URI;          #FIXED 'http://www.w3.org/1999/xhtml'+  >++<!--================ Document Head =======================================-->++<!ENTITY % head.misc "(script|style|meta|link|object|isindex)*">++<!-- content model is %head.misc; combined with a single+     title and an optional base element in any order -->++<!ELEMENT head (%head.misc;,+     ((title, %head.misc;, (base, %head.misc;)?) |+      (base, %head.misc;, (title, %head.misc;))))>++<!ATTLIST head+  %i18n;+  profile     %URI;          #IMPLIED+  >++<!-- The title element is not considered part of the flow of text.+       It should be displayed, for example as the page header or+       window title. Exactly one title is required per document.+    -->+<!ELEMENT title (#PCDATA)>+<!ATTLIST title %i18n;>++<!-- document base URI -->++<!ELEMENT base EMPTY>+<!ATTLIST base+  href        %URI;          #IMPLIED+  target      %FrameTarget;  #IMPLIED+  >++<!-- generic metainformation -->+<!ELEMENT meta EMPTY>+<!ATTLIST meta+  %i18n;+  http-equiv  CDATA          #IMPLIED+  name        CDATA          #IMPLIED+  content     CDATA          #REQUIRED+  scheme      CDATA          #IMPLIED+  >++<!--+  Relationship values can be used in principle:++   a) for document specific toolbars/menus when used+      with the link element in document head e.g.+        start, contents, previous, next, index, end, help+   b) to link to a separate style sheet (rel="stylesheet")+   c) to make a link to a script (rel="script")+   d) by stylesheets to control how collections of+      html nodes are rendered into printed documents+   e) to make a link to a printable version of this document+      e.g. a PostScript or PDF version (rel="alternate" media="print")+-->++<!ELEMENT link EMPTY>+<!ATTLIST link+  %attrs;+  charset     %Charset;      #IMPLIED+  href        %URI;          #IMPLIED+  hreflang    %LanguageCode; #IMPLIED+  type        %ContentType;  #IMPLIED+  rel         %LinkTypes;    #IMPLIED+  rev         %LinkTypes;    #IMPLIED+  media       %MediaDesc;    #IMPLIED+  target      %FrameTarget;  #IMPLIED+  >++<!-- style info, which may include CDATA sections -->+<!ELEMENT style (#PCDATA)>+<!ATTLIST style+  %i18n;+  type        %ContentType;  #REQUIRED+  media       %MediaDesc;    #IMPLIED+  title       %Text;         #IMPLIED+  xml:space   (preserve)     #FIXED 'preserve'+  >++<!-- script statements, which may include CDATA sections -->+<!ELEMENT script (#PCDATA)>+<!ATTLIST script+  charset     %Charset;      #IMPLIED+  type        %ContentType;  #REQUIRED+  language    CDATA          #IMPLIED+  src         %URI;          #IMPLIED+  defer       (defer)        #IMPLIED+  xml:space   (preserve)     #FIXED 'preserve'+  >++<!-- alternate content container for non script-based rendering -->++<!ELEMENT noscript %Flow;>+<!ATTLIST noscript+  %attrs;+  >++<!--======================= Frames =======================================-->++<!-- only one noframes element permitted per document -->++<!ELEMENT frameset (frameset|frame|noframes)*>+<!ATTLIST frameset+  %coreattrs;+  rows        %MultiLengths; #IMPLIED+  cols        %MultiLengths; #IMPLIED+  onload      %Script;       #IMPLIED+  onunload    %Script;       #IMPLIED+  >++<!-- reserved frame names start with "_" otherwise starts with letter -->++<!-- tiled window within frameset -->++<!ELEMENT frame EMPTY>+<!ATTLIST frame+  %coreattrs;+  longdesc    %URI;          #IMPLIED+  name        NMTOKEN        #IMPLIED+  src         %URI;          #IMPLIED+  frameborder (1|0)          "1"+  marginwidth %Pixels;       #IMPLIED+  marginheight %Pixels;      #IMPLIED+  noresize    (noresize)     #IMPLIED+  scrolling   (yes|no|auto)  "auto"+  >++<!-- inline subwindow -->++<!ELEMENT iframe %Flow;>+<!ATTLIST iframe+  %coreattrs;+  longdesc    %URI;          #IMPLIED+  name        NMTOKEN        #IMPLIED+  src         %URI;          #IMPLIED+  frameborder (1|0)          "1"+  marginwidth %Pixels;       #IMPLIED+  marginheight %Pixels;      #IMPLIED+  scrolling   (yes|no|auto)  "auto"+  align       %ImgAlign;     #IMPLIED+  height      %Length;       #IMPLIED+  width       %Length;       #IMPLIED+  >++<!-- alternate content container for non frame-based rendering -->++<!ELEMENT noframes (body)>+<!ATTLIST noframes+  %attrs;+  >++<!--=================== Document Body ====================================-->++<!ELEMENT body %Flow;>+<!ATTLIST body+  %attrs;+  onload      %Script;       #IMPLIED+  onunload    %Script;       #IMPLIED+  background  %URI;          #IMPLIED+  bgcolor     %Color;        #IMPLIED+  text        %Color;        #IMPLIED+  link        %Color;        #IMPLIED+  vlink       %Color;        #IMPLIED+  alink       %Color;        #IMPLIED+  >++<!ELEMENT div %Flow;>  <!-- generic language/style container -->+<!ATTLIST div+  %attrs;+  %TextAlign;+  >++<!--=================== Paragraphs =======================================-->++<!ELEMENT p %Inline;>+<!ATTLIST p+  %attrs;+  %TextAlign;+  >++<!--=================== Headings =========================================-->++<!--+  There are six levels of headings from h1 (the most important)+  to h6 (the least important).+-->++<!ELEMENT h1  %Inline;>+<!ATTLIST h1+  %attrs;+  %TextAlign;+  >++<!ELEMENT h2 %Inline;>+<!ATTLIST h2+  %attrs;+  %TextAlign;+  >++<!ELEMENT h3 %Inline;>+<!ATTLIST h3+  %attrs;+  %TextAlign;+  >++<!ELEMENT h4 %Inline;>+<!ATTLIST h4+  %attrs;+  %TextAlign;+  >++<!ELEMENT h5 %Inline;>+<!ATTLIST h5+  %attrs;+  %TextAlign;+  >++<!ELEMENT h6 %Inline;>+<!ATTLIST h6+  %attrs;+  %TextAlign;+  >++<!--=================== Lists ============================================-->++<!-- Unordered list bullet styles -->++<!ENTITY % ULStyle "(disc|square|circle)">++<!-- Unordered list -->++<!ELEMENT ul (li)+>+<!ATTLIST ul+  %attrs;+  type        %ULStyle;     #IMPLIED+  compact     (compact)     #IMPLIED+  >++<!-- Ordered list numbering style++    1   arabic numbers      1, 2, 3, ...+    a   lower alpha         a, b, c, ...+    A   upper alpha         A, B, C, ...+    i   lower roman         i, ii, iii, ...+    I   upper roman         I, II, III, ...++    The style is applied to the sequence number which by default+    is reset to 1 for the first list item in an ordered list.+-->+<!ENTITY % OLStyle "CDATA">++<!-- Ordered (numbered) list -->++<!ELEMENT ol (li)+>+<!ATTLIST ol+  %attrs;+  type        %OLStyle;      #IMPLIED+  compact     (compact)      #IMPLIED+  start       %Number;       #IMPLIED+  >++<!-- single column list (DEPRECATED) --> +<!ELEMENT menu (li)+>+<!ATTLIST menu+  %attrs;+  compact     (compact)     #IMPLIED+  >++<!-- multiple column list (DEPRECATED) --> +<!ELEMENT dir (li)+>+<!ATTLIST dir+  %attrs;+  compact     (compact)     #IMPLIED+  >++<!-- LIStyle is constrained to: "(%ULStyle;|%OLStyle;)" -->+<!ENTITY % LIStyle "CDATA">++<!-- list item -->++<!ELEMENT li %Flow;>+<!ATTLIST li+  %attrs;+  type        %LIStyle;      #IMPLIED+  value       %Number;       #IMPLIED+  >++<!-- definition lists - dt for term, dd for its definition -->++<!ELEMENT dl (dt|dd)+>+<!ATTLIST dl+  %attrs;+  compact     (compact)      #IMPLIED+  >++<!ELEMENT dt %Inline;>+<!ATTLIST dt+  %attrs;+  >++<!ELEMENT dd %Flow;>+<!ATTLIST dd+  %attrs;+  >++<!--=================== Address ==========================================-->++<!-- information on author -->++<!ELEMENT address %Inline;>+<!ATTLIST address+  %attrs;+  >++<!--=================== Horizontal Rule ==================================-->++<!ELEMENT hr EMPTY>+<!ATTLIST hr+  %attrs;+  align       (left|center|right) #IMPLIED+  noshade     (noshade)      #IMPLIED+  size        %Pixels;       #IMPLIED+  width       %Length;       #IMPLIED+  >++<!--=================== Preformatted Text ================================-->++<!-- content is %Inline; excluding +        "img|object|applet|big|small|sub|sup|font|basefont" -->++<!ELEMENT pre %pre.content;>+<!ATTLIST pre+  %attrs;+  width       %Number;      #IMPLIED+  xml:space   (preserve)    #FIXED 'preserve'+  >++<!--=================== Block-like Quotes ================================-->++<!ELEMENT blockquote %Flow;>+<!ATTLIST blockquote+  %attrs;+  cite        %URI;          #IMPLIED+  >++<!--=================== Text alignment ===================================-->++<!-- center content -->+<!ELEMENT center %Flow;>+<!ATTLIST center+  %attrs;+  >++<!--=================== Inserted/Deleted Text ============================-->+++<!--+  ins/del are allowed in block and inline content, but its+  inappropriate to include block content within an ins element+  occurring in inline content.+-->+<!ELEMENT ins %Flow;>+<!ATTLIST ins+  %attrs;+  cite        %URI;          #IMPLIED+  datetime    %Datetime;     #IMPLIED+  >++<!ELEMENT del %Flow;>+<!ATTLIST del+  %attrs;+  cite        %URI;          #IMPLIED+  datetime    %Datetime;     #IMPLIED+  >++<!--================== The Anchor Element ================================-->++<!-- content is %Inline; except that anchors shouldn't be nested -->++<!ELEMENT a %a.content;>+<!ATTLIST a+  %attrs;+  charset     %Charset;      #IMPLIED+  type        %ContentType;  #IMPLIED+  name        NMTOKEN        #IMPLIED+  href        %URI;          #IMPLIED+  hreflang    %LanguageCode; #IMPLIED+  rel         %LinkTypes;    #IMPLIED+  rev         %LinkTypes;    #IMPLIED+  accesskey   %Character;    #IMPLIED+  shape       %Shape;        "rect"+  coords      %Coords;       #IMPLIED+  tabindex    %Number;       #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  target      %FrameTarget;  #IMPLIED+  >++<!--===================== Inline Elements ================================-->++<!ELEMENT span %Inline;> <!-- generic language/style container -->+<!ATTLIST span+  %attrs;+  >++<!ELEMENT bdo %Inline;>  <!-- I18N BiDi over-ride -->+<!ATTLIST bdo+  %coreattrs;+  %events;+  lang        %LanguageCode; #IMPLIED+  xml:lang    %LanguageCode; #IMPLIED+  dir         (ltr|rtl)      #REQUIRED+  >++<!ELEMENT br EMPTY>   <!-- forced line break -->+<!ATTLIST br+  %coreattrs;+  clear       (left|all|right|none) "none"+  >++<!ELEMENT em %Inline;>   <!-- emphasis -->+<!ATTLIST em %attrs;>++<!ELEMENT strong %Inline;>   <!-- strong emphasis -->+<!ATTLIST strong %attrs;>++<!ELEMENT dfn %Inline;>   <!-- definitional -->+<!ATTLIST dfn %attrs;>++<!ELEMENT code %Inline;>   <!-- program code -->+<!ATTLIST code %attrs;>++<!ELEMENT samp %Inline;>   <!-- sample -->+<!ATTLIST samp %attrs;>++<!ELEMENT kbd %Inline;>  <!-- something user would type -->+<!ATTLIST kbd %attrs;>++<!ELEMENT var %Inline;>   <!-- variable -->+<!ATTLIST var %attrs;>++<!ELEMENT cite %Inline;>   <!-- citation -->+<!ATTLIST cite %attrs;>++<!ELEMENT abbr %Inline;>   <!-- abbreviation -->+<!ATTLIST abbr %attrs;>++<!ELEMENT acronym %Inline;>   <!-- acronym -->+<!ATTLIST acronym %attrs;>++<!ELEMENT q %Inline;>   <!-- inlined quote -->+<!ATTLIST q+   %attrs;+  cite        %URI;          #IMPLIED+   >++<!ELEMENT sub %Inline;> <!-- subscript -->+<!ATTLIST sub %attrs;>++<!ELEMENT sup %Inline;> <!-- superscript -->+<!ATTLIST sup %attrs;>++<!ELEMENT tt %Inline;>   <!-- fixed pitch font -->+<!ATTLIST tt %attrs;>++<!ELEMENT i %Inline;>   <!-- italic font -->+<!ATTLIST i %attrs;>++<!ELEMENT b %Inline;>   <!-- bold font -->+<!ATTLIST b %attrs;>++<!ELEMENT big %Inline;>   <!-- bigger font -->+<!ATTLIST big %attrs;>++<!ELEMENT small %Inline;>   <!-- smaller font -->+<!ATTLIST small %attrs;>++<!ELEMENT u %Inline;>   <!-- underline -->+<!ATTLIST u %attrs;>++<!ELEMENT s %Inline;>   <!-- strike-through -->+<!ATTLIST s %attrs;>++<!ELEMENT strike %Inline;>   <!-- strike-through -->+<!ATTLIST strike %attrs;>++<!ELEMENT basefont EMPTY>  <!-- base font size -->+<!ATTLIST basefont+  id          ID             #IMPLIED+  size        CDATA          #REQUIRED+  color       %Color;        #IMPLIED+  face        CDATA          #IMPLIED+  >++<!ELEMENT font %Inline;> <!-- local change to font -->+<!ATTLIST font+  %coreattrs;+  %i18n;+  size        CDATA          #IMPLIED+  color       %Color;        #IMPLIED+  face        CDATA          #IMPLIED+  >++<!--==================== Object ======================================-->+<!--+  object is used to embed objects as part of HTML pages.+  param elements should precede other content. Parameters+  can also be expressed as attribute/value pairs on the+  object element itself when brevity is desired.+-->++<!ELEMENT object (#PCDATA | param | %block; | form |%inline; | %misc;)*>+<!ATTLIST object+  %attrs;+  declare     (declare)      #IMPLIED+  classid     %URI;          #IMPLIED+  codebase    %URI;          #IMPLIED+  data        %URI;          #IMPLIED+  type        %ContentType;  #IMPLIED+  codetype    %ContentType;  #IMPLIED+  archive     %UriList;      #IMPLIED+  standby     %Text;         #IMPLIED+  height      %Length;       #IMPLIED+  width       %Length;       #IMPLIED+  usemap      %URI;          #IMPLIED+  name        NMTOKEN        #IMPLIED+  tabindex    %Number;       #IMPLIED+  align       %ImgAlign;     #IMPLIED+  border      %Pixels;       #IMPLIED+  hspace      %Pixels;       #IMPLIED+  vspace      %Pixels;       #IMPLIED+  >++<!--+  param is used to supply a named property value.+  In XML it would seem natural to follow RDF and support an+  abbreviated syntax where the param elements are replaced+  by attribute value pairs on the object start tag.+-->+<!ELEMENT param EMPTY>+<!ATTLIST param+  id          ID             #IMPLIED+  name        CDATA          #REQUIRED+  value       CDATA          #IMPLIED+  valuetype   (data|ref|object) "data"+  type        %ContentType;  #IMPLIED+  >++<!--=================== Java applet ==================================-->+<!--+  One of code or object attributes must be present.+  Place param elements before other content.+-->+<!ELEMENT applet (#PCDATA | param | %block; | form | %inline; | %misc;)*>+<!ATTLIST applet+  %coreattrs;+  codebase    %URI;          #IMPLIED+  archive     CDATA          #IMPLIED+  code        CDATA          #IMPLIED+  object      CDATA          #IMPLIED+  alt         %Text;         #IMPLIED+  name        NMTOKEN        #IMPLIED+  width       %Length;       #REQUIRED+  height      %Length;       #REQUIRED+  align       %ImgAlign;     #IMPLIED+  hspace      %Pixels;       #IMPLIED+  vspace      %Pixels;       #IMPLIED+  >++<!--=================== Images ===========================================-->++<!--+   To avoid accessibility problems for people who aren't+   able to see the image, you should provide a text+   description using the alt and longdesc attributes.+   In addition, avoid the use of server-side image maps.+-->++<!ELEMENT img EMPTY>+<!ATTLIST img+  %attrs;+  src         %URI;          #REQUIRED+  alt         %Text;         #REQUIRED+  name        NMTOKEN        #IMPLIED+  longdesc    %URI;          #IMPLIED+  height      %Length;       #IMPLIED+  width       %Length;       #IMPLIED+  usemap      %URI;          #IMPLIED+  ismap       (ismap)        #IMPLIED+  align       %ImgAlign;     #IMPLIED+  border      %Pixels;       #IMPLIED+  hspace      %Pixels;       #IMPLIED+  vspace      %Pixels;       #IMPLIED+  >++<!-- usemap points to a map element which may be in this document+  or an external document, although the latter is not widely supported -->++<!--================== Client-side image maps ============================-->++<!-- These can be placed in the same document or grouped in a+     separate document although this isn't yet widely supported -->++<!ELEMENT map ((%block; | form | %misc;)+ | area+)>+<!ATTLIST map+  %i18n;+  %events;+  id          ID             #REQUIRED+  class       CDATA          #IMPLIED+  style       %StyleSheet;   #IMPLIED+  title       %Text;         #IMPLIED+  name        NMTOKEN        #IMPLIED+  >++<!ELEMENT area EMPTY>+<!ATTLIST area+  %attrs;+  shape       %Shape;        "rect"+  coords      %Coords;       #IMPLIED+  href        %URI;          #IMPLIED+  nohref      (nohref)       #IMPLIED+  alt         %Text;         #REQUIRED+  tabindex    %Number;       #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  target      %FrameTarget;  #IMPLIED+  >++<!--================ Forms ===============================================-->++<!ELEMENT form %form.content;>   <!-- forms shouldn't be nested -->++<!ATTLIST form+  %attrs;+  action      %URI;          #REQUIRED+  method      (get|post)     "get"+  name        NMTOKEN        #IMPLIED+  enctype     %ContentType;  "application/x-www-form-urlencoded"+  onsubmit    %Script;       #IMPLIED+  onreset     %Script;       #IMPLIED+  accept      %ContentTypes; #IMPLIED+  accept-charset %Charsets;  #IMPLIED+  target      %FrameTarget;  #IMPLIED+  >++<!--+  Each label must not contain more than ONE field+  Label elements shouldn't be nested.+-->+<!ELEMENT label %Inline;>+<!ATTLIST label+  %attrs;+  for         IDREF          #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  >++<!ENTITY % InputType+  "(text | password | checkbox |+    radio | submit | reset |+    file | hidden | image | button)"+   >++<!-- the name attribute is required for all but submit & reset -->++<!ELEMENT input EMPTY>     <!-- form control -->+<!ATTLIST input+  %attrs;+  type        %InputType;    "text"+  name        CDATA          #IMPLIED+  value       CDATA          #IMPLIED+  checked     (checked)      #IMPLIED+  disabled    (disabled)     #IMPLIED+  readonly    (readonly)     #IMPLIED+  size        CDATA          #IMPLIED+  maxlength   %Number;       #IMPLIED+  src         %URI;          #IMPLIED+  alt         CDATA          #IMPLIED+  usemap      %URI;          #IMPLIED+  tabindex    %Number;       #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  onselect    %Script;       #IMPLIED+  onchange    %Script;       #IMPLIED+  accept      %ContentTypes; #IMPLIED+  align       %ImgAlign;     #IMPLIED+  >++<!ELEMENT select (optgroup|option)+>  <!-- option selector -->+<!ATTLIST select+  %attrs;+  name        CDATA          #IMPLIED+  size        %Number;       #IMPLIED+  multiple    (multiple)     #IMPLIED+  disabled    (disabled)     #IMPLIED+  tabindex    %Number;       #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  onchange    %Script;       #IMPLIED+  >++<!ELEMENT optgroup (option)+>   <!-- option group -->+<!ATTLIST optgroup+  %attrs;+  disabled    (disabled)     #IMPLIED+  label       %Text;         #REQUIRED+  >++<!ELEMENT option (#PCDATA)>     <!-- selectable choice -->+<!ATTLIST option+  %attrs;+  selected    (selected)     #IMPLIED+  disabled    (disabled)     #IMPLIED+  label       %Text;         #IMPLIED+  value       CDATA          #IMPLIED+  >++<!ELEMENT textarea (#PCDATA)>     <!-- multi-line text field -->+<!ATTLIST textarea+  %attrs;+  name        CDATA          #IMPLIED+  rows        %Number;       #REQUIRED+  cols        %Number;       #REQUIRED+  disabled    (disabled)     #IMPLIED+  readonly    (readonly)     #IMPLIED+  tabindex    %Number;       #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  onselect    %Script;       #IMPLIED+  onchange    %Script;       #IMPLIED+  >++<!--+  The fieldset element is used to group form fields.+  Only one legend element should occur in the content+  and if present should only be preceded by whitespace.+-->+<!ELEMENT fieldset (#PCDATA | legend | %block; | form | %inline; | %misc;)*>+<!ATTLIST fieldset+  %attrs;+  >++<!ENTITY % LAlign "(top|bottom|left|right)">++<!ELEMENT legend %Inline;>     <!-- fieldset label -->+<!ATTLIST legend+  %attrs;+  accesskey   %Character;    #IMPLIED+  align       %LAlign;       #IMPLIED+  >++<!--+ Content is %Flow; excluding a, form, form controls, iframe+--> +<!ELEMENT button %button.content;>  <!-- push button -->+<!ATTLIST button+  %attrs;+  name        CDATA          #IMPLIED+  value       CDATA          #IMPLIED+  type        (button|submit|reset) "submit"+  disabled    (disabled)     #IMPLIED+  tabindex    %Number;       #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  >++<!-- single-line text input control (DEPRECATED) -->+<!ELEMENT isindex EMPTY>+<!ATTLIST isindex+  %coreattrs;+  %i18n;+  prompt      %Text;         #IMPLIED+  >++<!--======================= Tables =======================================-->++<!-- Derived from IETF HTML table standard, see [RFC1942] -->++<!--+ The border attribute sets the thickness of the frame around the+ table. The default units are screen pixels.++ The frame attribute specifies which parts of the frame around+ the table should be rendered. The values are not the same as+ CALS to avoid a name clash with the valign attribute.+-->+<!ENTITY % TFrame "(void|above|below|hsides|lhs|rhs|vsides|box|border)">++<!--+ The rules attribute defines which rules to draw between cells:++ If rules is absent then assume:+     "none" if border is absent or border="0" otherwise "all"+-->++<!ENTITY % TRules "(none | groups | rows | cols | all)">+  +<!-- horizontal placement of table relative to document -->+<!ENTITY % TAlign "(left|center|right)">++<!-- horizontal alignment attributes for cell contents++  char        alignment char, e.g. char=":"+  charoff     offset for alignment char+-->+<!ENTITY % cellhalign+  "align      (left|center|right|justify|char) #IMPLIED+   char       %Character;    #IMPLIED+   charoff    %Length;       #IMPLIED"+  >++<!-- vertical alignment attributes for cell contents -->+<!ENTITY % cellvalign+  "valign     (top|middle|bottom|baseline) #IMPLIED"+  >++<!ELEMENT table+     (caption?, (col*|colgroup*), thead?, tfoot?, (tbody+|tr+))>+<!ELEMENT caption  %Inline;>+<!ELEMENT thead    (tr)+>+<!ELEMENT tfoot    (tr)+>+<!ELEMENT tbody    (tr)+>+<!ELEMENT colgroup (col)*>+<!ELEMENT col      EMPTY>+<!ELEMENT tr       (th|td)+>+<!ELEMENT th       %Flow;>+<!ELEMENT td       %Flow;>++<!ATTLIST table+  %attrs;+  summary     %Text;         #IMPLIED+  width       %Length;       #IMPLIED+  border      %Pixels;       #IMPLIED+  frame       %TFrame;       #IMPLIED+  rules       %TRules;       #IMPLIED+  cellspacing %Length;       #IMPLIED+  cellpadding %Length;       #IMPLIED+  align       %TAlign;       #IMPLIED+  bgcolor     %Color;        #IMPLIED+  >++<!ENTITY % CAlign "(top|bottom|left|right)">++<!ATTLIST caption+  %attrs;+  align       %CAlign;       #IMPLIED+  >++<!--+colgroup groups a set of col elements. It allows you to group+several semantically related columns together.+-->+<!ATTLIST colgroup+  %attrs;+  span        %Number;       "1"+  width       %MultiLength;  #IMPLIED+  %cellhalign;+  %cellvalign;+  >++<!--+ col elements define the alignment properties for cells in+ one or more columns.++ The width attribute specifies the width of the columns, e.g.++     width=64        width in screen pixels+     width=0.5*      relative width of 0.5++ The span attribute causes the attributes of one+ col element to apply to more than one column.+-->+<!ATTLIST col+  %attrs;+  span        %Number;       "1"+  width       %MultiLength;  #IMPLIED+  %cellhalign;+  %cellvalign;+  >++<!--+    Use thead to duplicate headers when breaking table+    across page boundaries, or for static headers when+    tbody sections are rendered in scrolling panel.++    Use tfoot to duplicate footers when breaking table+    across page boundaries, or for static footers when+    tbody sections are rendered in scrolling panel.++    Use multiple tbody sections when rules are needed+    between groups of table rows.+-->+<!ATTLIST thead+  %attrs;+  %cellhalign;+  %cellvalign;+  >++<!ATTLIST tfoot+  %attrs;+  %cellhalign;+  %cellvalign;+  >++<!ATTLIST tbody+  %attrs;+  %cellhalign;+  %cellvalign;+  >++<!ATTLIST tr+  %attrs;+  %cellhalign;+  %cellvalign;+  bgcolor     %Color;        #IMPLIED+  >++<!-- Scope is simpler than headers attribute for common tables -->+<!ENTITY % Scope "(row|col|rowgroup|colgroup)">++<!-- th is for headers, td for data and for cells acting as both -->++<!ATTLIST th+  %attrs;+  abbr        %Text;         #IMPLIED+  axis        CDATA          #IMPLIED+  headers     IDREFS         #IMPLIED+  scope       %Scope;        #IMPLIED+  rowspan     %Number;       "1"+  colspan     %Number;       "1"+  %cellhalign;+  %cellvalign;+  nowrap      (nowrap)       #IMPLIED+  bgcolor     %Color;        #IMPLIED+  width       %Pixels;       #IMPLIED+  height      %Pixels;       #IMPLIED+  >++<!ATTLIST td+  %attrs;+  abbr        %Text;         #IMPLIED+  axis        CDATA          #IMPLIED+  headers     IDREFS         #IMPLIED+  scope       %Scope;        #IMPLIED+  rowspan     %Number;       "1"+  colspan     %Number;       "1"+  %cellhalign;+  %cellvalign;+  nowrap      (nowrap)       #IMPLIED+  bgcolor     %Color;        #IMPLIED+  width       %Pixels;       #IMPLIED+  height      %Pixels;       #IMPLIED+  >+
+ examples/xhtml/xhtml1-strict.dtd view
@@ -0,0 +1,988 @@+<!--+   Extensible HTML version 1.0 Strict DTD++   This is the same as HTML 4.0 Strict except for+   changes due to the differences between XML and SGML.++   Namespace = http://www.w3.org/1999/xhtml++   For further information, see: http://www.w3.org/TR/xhtml1++   Copyright (c) 1998-2000 W3C (MIT, INRIA, Keio),+   All Rights Reserved. ++   This DTD module is identified by the PUBLIC and SYSTEM identifiers:++   PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"+   SYSTEM "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"++   $Revision: 1.1 $+   $Date: 2002/10/01 13:47:08 $++-->++<!--================ Character mnemonic entities =========================-->++<!ENTITY % HTMLlat1 PUBLIC+   "-//W3C//ENTITIES Latin 1 for XHTML//EN"+   "xhtml-lat1.ent">+%HTMLlat1;++<!ENTITY % HTMLsymbol PUBLIC+   "-//W3C//ENTITIES Symbols for XHTML//EN"+   "xhtml-symbol.ent">+%HTMLsymbol;++<!ENTITY % HTMLspecial PUBLIC+   "-//W3C//ENTITIES Special for XHTML//EN"+   "xhtml-special.ent">+%HTMLspecial;++<!--================== Imported Names ====================================-->++<!ENTITY % ContentType "CDATA">+    <!-- media type, as per [RFC2045] -->++<!ENTITY % ContentTypes "CDATA">+    <!-- comma-separated list of media types, as per [RFC2045] -->++<!ENTITY % Charset "CDATA">+    <!-- a character encoding, as per [RFC2045] -->++<!ENTITY % Charsets "CDATA">+    <!-- a space separated list of character encodings, as per [RFC2045] -->++<!ENTITY % LanguageCode "NMTOKEN">+    <!-- a language code, as per [RFC1766] -->++<!ENTITY % Character "CDATA">+    <!-- a single character from [ISO10646] -->++<!ENTITY % Number "CDATA">+    <!-- one or more digits -->++<!ENTITY % LinkTypes "CDATA">+    <!-- space-separated list of link types -->++<!ENTITY % MediaDesc "CDATA">+    <!-- single or comma-separated list of media descriptors -->++<!ENTITY % URI "CDATA">+    <!-- a Uniform Resource Identifier, see [RFC2396] -->++<!ENTITY % UriList "CDATA">+    <!-- a space separated list of Uniform Resource Identifiers -->++<!ENTITY % Datetime "CDATA">+    <!-- date and time information. ISO date format -->++<!ENTITY % Script "CDATA">+    <!-- script expression -->++<!ENTITY % StyleSheet "CDATA">+    <!-- style sheet data -->++<!ENTITY % Text "CDATA">+    <!-- used for titles etc. -->++<!ENTITY % FrameTarget "NMTOKEN">+    <!-- render in this frame -->++<!ENTITY % Length "CDATA">+    <!-- nn for pixels or nn% for percentage length -->++<!ENTITY % MultiLength "CDATA">+    <!-- pixel, percentage, or relative -->++<!ENTITY % MultiLengths "CDATA">+    <!-- comma-separated list of MultiLength -->++<!ENTITY % Pixels "CDATA">+    <!-- integer representing length in pixels -->++<!-- these are used for image maps -->++<!ENTITY % Shape "(rect|circle|poly|default)">++<!ENTITY % Coords "CDATA">+    <!-- comma separated list of lengths -->++<!--=================== Generic Attributes ===============================-->++<!-- core attributes common to most elements+  id       document-wide unique id+  class    space separated list of classes+  style    associated style info+  title    advisory title/amplification+-->+<!ENTITY % coreattrs+ "id          ID             #IMPLIED+  class       CDATA          #IMPLIED+  style       %StyleSheet;   #IMPLIED+  title       %Text;         #IMPLIED"+  >++<!-- internationalization attributes+  lang        language code (backwards compatible)+  xml:lang    language code (as per XML 1.0 spec)+  dir         direction for weak/neutral text+-->+<!ENTITY % i18n+ "lang        %LanguageCode; #IMPLIED+  xml:lang    %LanguageCode; #IMPLIED+  dir         (ltr|rtl)      #IMPLIED"+  >++<!-- attributes for common UI events+  onclick     a pointer button was clicked+  ondblclick  a pointer button was double clicked+  onmousedown a pointer button was pressed down+  onmouseup   a pointer button was released+  onmousemove a pointer was moved onto the element+  onmouseout  a pointer was moved away from the element+  onkeypress  a key was pressed and released+  onkeydown   a key was pressed down+  onkeyup     a key was released+-->+<!ENTITY % events+ "onclick     %Script;       #IMPLIED+  ondblclick  %Script;       #IMPLIED+  onmousedown %Script;       #IMPLIED+  onmouseup   %Script;       #IMPLIED+  onmouseover %Script;       #IMPLIED+  onmousemove %Script;       #IMPLIED+  onmouseout  %Script;       #IMPLIED+  onkeypress  %Script;       #IMPLIED+  onkeydown   %Script;       #IMPLIED+  onkeyup     %Script;       #IMPLIED"+  >++<!-- attributes for elements that can get the focus+  accesskey   accessibility key character+  tabindex    position in tabbing order+  onfocus     the element got the focus+  onblur      the element lost the focus+-->+<!ENTITY % focus+ "accesskey   %Character;    #IMPLIED+  tabindex    %Number;       #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED"+  >++<!ENTITY % attrs "%coreattrs; %i18n; %events;">++<!--=================== Text Elements ====================================-->++<!ENTITY % special+   "br | span | bdo | object | img | map">++<!ENTITY % fontstyle "tt | i | b | big | small">++<!ENTITY % phrase "em | strong | dfn | code | q | sub | sup |+                   samp | kbd | var | cite | abbr | acronym">++<!ENTITY % inline.forms "input | select | textarea | label | button">++<!-- these can occur at block or inline level -->+<!ENTITY % misc "ins | del | script | noscript">++<!ENTITY % inline "a | %special; | %fontstyle; | %phrase; | %inline.forms;">++<!-- %Inline; covers inline or "text-level" elements -->+<!ENTITY % Inline "(#PCDATA | %inline; | %misc;)*">++<!--================== Block level elements ==============================-->++<!ENTITY % heading "h1|h2|h3|h4|h5|h6">+<!ENTITY % lists "ul | ol | dl">+<!ENTITY % blocktext "pre | hr | blockquote | address">++<!ENTITY % block+     "p | %heading; | div | %lists; | %blocktext; | fieldset | table">++<!ENTITY % Block "(%block; | form | %misc;)*">++<!-- %Flow; mixes Block and Inline and is used for list items etc. -->+<!ENTITY % Flow "(#PCDATA | %block; | form | %inline; | %misc;)*">++<!--================== Content models for exclusions =====================-->++<!-- a elements use %Inline; excluding a -->++<!ENTITY % a.content+   "(#PCDATA | %special; | %fontstyle; | %phrase; | %inline.forms; | %misc;)*">++<!-- pre uses %Inline excluding img, object, big, small, sup or sup -->++<!ENTITY % pre.content+   "(#PCDATA | a | br | span | bdo | map | tt | i | b |+      %phrase; | %inline.forms;)*">++<!-- form uses %Block; excluding form -->++<!ENTITY % form.content "(%block; | %misc;)*">++<!-- button uses %Flow; but excludes a, form and form controls -->++<!ENTITY % button.content+   "(#PCDATA | p | %heading; | div | %lists; | %blocktext; |+    table | %special; | %fontstyle; | %phrase; | %misc;)*">++<!--================ Document Structure ==================================-->++<!-- the namespace URI designates the document profile -->++<!ELEMENT html (head, body)>+<!ATTLIST html+  %i18n;+  xmlns       %URI;          #FIXED 'http://www.w3.org/1999/xhtml'+  >++<!--================ Document Head =======================================-->++<!ENTITY % head.misc "(script|style|meta|link|object)*">++<!-- content model is %head.misc; combined with a single+     title and an optional base element in any order -->++<!ELEMENT head (%head.misc;,+     ((title, %head.misc;, (base, %head.misc;)?) |+      (base, %head.misc;, (title, %head.misc;))))>++<!ATTLIST head+  %i18n;+  profile     %URI;          #IMPLIED+  >++<!-- The title element is not considered part of the flow of text.+       It should be displayed, for example as the page header or+       window title. Exactly one title is required per document.+    -->+<!ELEMENT title (#PCDATA)>+<!ATTLIST title %i18n;>++<!-- document base URI -->++<!ELEMENT base EMPTY>+<!ATTLIST base+  href        %URI;          #IMPLIED+  >++<!-- generic metainformation -->+<!ELEMENT meta EMPTY>+<!ATTLIST meta+  %i18n;+  http-equiv  CDATA          #IMPLIED+  name        CDATA          #IMPLIED+  content     CDATA          #REQUIRED+  scheme      CDATA          #IMPLIED+  >++<!--+  Relationship values can be used in principle:++   a) for document specific toolbars/menus when used+      with the link element in document head e.g.+        start, contents, previous, next, index, end, help+   b) to link to a separate style sheet (rel="stylesheet")+   c) to make a link to a script (rel="script")+   d) by stylesheets to control how collections of+      html nodes are rendered into printed documents+   e) to make a link to a printable version of this document+      e.g. a PostScript or PDF version (rel="alternate" media="print")+-->++<!ELEMENT link EMPTY>+<!ATTLIST link+  %attrs;+  charset     %Charset;      #IMPLIED+  href        %URI;          #IMPLIED+  hreflang    %LanguageCode; #IMPLIED+  type        %ContentType;  #IMPLIED+  rel         %LinkTypes;    #IMPLIED+  rev         %LinkTypes;    #IMPLIED+  media       %MediaDesc;    #IMPLIED+  >++<!-- style info, which may include CDATA sections -->+<!ELEMENT style (#PCDATA)>+<!ATTLIST style+  %i18n;+  type        %ContentType;  #REQUIRED+  media       %MediaDesc;    #IMPLIED+  title       %Text;         #IMPLIED+  xml:space   (preserve)     #FIXED 'preserve'+  >++<!-- script statements, which may include CDATA sections -->+<!ELEMENT script (#PCDATA)>+<!ATTLIST script+  charset     %Charset;      #IMPLIED+  type        %ContentType;  #REQUIRED+  src         %URI;          #IMPLIED+  defer       (defer)        #IMPLIED+  xml:space   (preserve)     #FIXED 'preserve'+  >++<!-- alternate content container for non script-based rendering -->++<!ELEMENT noscript %Block;>+<!ATTLIST noscript+  %attrs;+  >++<!--=================== Document Body ====================================-->++<!ELEMENT body %Block;>+<!ATTLIST body+  %attrs;+  onload          %Script;   #IMPLIED+  onunload        %Script;   #IMPLIED+  >++<!ELEMENT div %Flow;>  <!-- generic language/style container -->+<!ATTLIST div+  %attrs;+  >++<!--=================== Paragraphs =======================================-->++<!ELEMENT p %Inline;>+<!ATTLIST p+  %attrs;+  >++<!--=================== Headings =========================================-->++<!--+  There are six levels of headings from h1 (the most important)+  to h6 (the least important).+-->++<!ELEMENT h1  %Inline;>+<!ATTLIST h1+   %attrs;+   >++<!ELEMENT h2 %Inline;>+<!ATTLIST h2+   %attrs;+   >++<!ELEMENT h3 %Inline;>+<!ATTLIST h3+   %attrs;+   >++<!ELEMENT h4 %Inline;>+<!ATTLIST h4+   %attrs;+   >++<!ELEMENT h5 %Inline;>+<!ATTLIST h5+   %attrs;+   >++<!ELEMENT h6 %Inline;>+<!ATTLIST h6+   %attrs;+   >++<!--=================== Lists ============================================-->++<!-- Unordered list -->++<!ELEMENT ul (li)+>+<!ATTLIST ul+  %attrs;+  >++<!-- Ordered (numbered) list -->++<!ELEMENT ol (li)+>+<!ATTLIST ol+  %attrs;+  >++<!-- list item -->++<!ELEMENT li %Flow;>+<!ATTLIST li+  %attrs;+  >++<!-- definition lists - dt for term, dd for its definition -->++<!ELEMENT dl (dt|dd)+>+<!ATTLIST dl+  %attrs;+  >++<!ELEMENT dt %Inline;>+<!ATTLIST dt+  %attrs;+  >++<!ELEMENT dd %Flow;>+<!ATTLIST dd+  %attrs;+  >++<!--=================== Address ==========================================-->++<!-- information on author -->++<!ELEMENT address %Inline;>+<!ATTLIST address+  %attrs;+  >++<!--=================== Horizontal Rule ==================================-->++<!ELEMENT hr EMPTY>+<!ATTLIST hr+  %attrs;+  >++<!--=================== Preformatted Text ================================-->++<!-- content is %Inline; excluding "img|object|big|small|sub|sup" -->++<!ELEMENT pre %pre.content;>+<!ATTLIST pre+  %attrs;+  xml:space (preserve) #FIXED 'preserve'+  >++<!--=================== Block-like Quotes ================================-->++<!ELEMENT blockquote %Block;>+<!ATTLIST blockquote+  %attrs;+  cite        %URI;          #IMPLIED+  >++<!--=================== Inserted/Deleted Text ============================-->++<!--+  ins/del are allowed in block and inline content, but its+  inappropriate to include block content within an ins element+  occurring in inline content.+-->+<!ELEMENT ins %Flow;>+<!ATTLIST ins+  %attrs;+  cite        %URI;          #IMPLIED+  datetime    %Datetime;     #IMPLIED+  >++<!ELEMENT del %Flow;>+<!ATTLIST del+  %attrs;+  cite        %URI;          #IMPLIED+  datetime    %Datetime;     #IMPLIED+  >++<!--================== The Anchor Element ================================-->++<!-- content is %Inline; except that anchors shouldn't be nested -->++<!ELEMENT a %a.content;>+<!ATTLIST a+  %attrs;+  charset     %Charset;      #IMPLIED+  type        %ContentType;  #IMPLIED+  name        NMTOKEN        #IMPLIED+  href        %URI;          #IMPLIED+  hreflang    %LanguageCode; #IMPLIED+  rel         %LinkTypes;    #IMPLIED+  rev         %LinkTypes;    #IMPLIED+  accesskey   %Character;    #IMPLIED+  shape       %Shape;        "rect"+  coords      %Coords;       #IMPLIED+  tabindex    %Number;       #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  >++<!--===================== Inline Elements ================================-->++<!ELEMENT span %Inline;> <!-- generic language/style container -->+<!ATTLIST span+  %attrs;+  >++<!ELEMENT bdo %Inline;>  <!-- I18N BiDi over-ride -->+<!ATTLIST bdo+  %coreattrs;+  %events;+  lang        %LanguageCode; #IMPLIED+  xml:lang    %LanguageCode; #IMPLIED+  dir         (ltr|rtl)      #REQUIRED+  >++<!ELEMENT br EMPTY>   <!-- forced line break -->+<!ATTLIST br+  %coreattrs;+  >++<!ELEMENT em %Inline;>   <!-- emphasis -->+<!ATTLIST em %attrs;>++<!ELEMENT strong %Inline;>   <!-- strong emphasis -->+<!ATTLIST strong %attrs;>++<!ELEMENT dfn %Inline;>   <!-- definitional -->+<!ATTLIST dfn %attrs;>++<!ELEMENT code %Inline;>   <!-- program code -->+<!ATTLIST code %attrs;>++<!ELEMENT samp %Inline;>   <!-- sample -->+<!ATTLIST samp %attrs;>++<!ELEMENT kbd %Inline;>  <!-- something user would type -->+<!ATTLIST kbd %attrs;>++<!ELEMENT var %Inline;>   <!-- variable -->+<!ATTLIST var %attrs;>++<!ELEMENT cite %Inline;>   <!-- citation -->+<!ATTLIST cite %attrs;>++<!ELEMENT abbr %Inline;>   <!-- abbreviation -->+<!ATTLIST abbr %attrs;>++<!ELEMENT acronym %Inline;>   <!-- acronym -->+<!ATTLIST acronym %attrs;>++<!ELEMENT q %Inline;>   <!-- inlined quote -->+<!ATTLIST q+  %attrs;+  cite        %URI;          #IMPLIED+  >++<!ELEMENT sub %Inline;> <!-- subscript -->+<!ATTLIST sub %attrs;>++<!ELEMENT sup %Inline;> <!-- superscript -->+<!ATTLIST sup %attrs;>++<!ELEMENT tt %Inline;>   <!-- fixed pitch font -->+<!ATTLIST tt %attrs;>++<!ELEMENT i %Inline;>   <!-- italic font -->+<!ATTLIST i %attrs;>++<!ELEMENT b %Inline;>   <!-- bold font -->+<!ATTLIST b %attrs;>++<!ELEMENT big %Inline;>   <!-- bigger font -->+<!ATTLIST big %attrs;>++<!ELEMENT small %Inline;>   <!-- smaller font -->+<!ATTLIST small %attrs;>++<!--==================== Object ======================================-->+<!--+  object is used to embed objects as part of HTML pages.+  param elements should precede other content. Parameters+  can also be expressed as attribute/value pairs on the+  object element itself when brevity is desired.+-->++<!ELEMENT object (#PCDATA | param | %block; | form | %inline; | %misc;)*>+<!ATTLIST object+  %attrs;+  declare     (declare)      #IMPLIED+  classid     %URI;          #IMPLIED+  codebase    %URI;          #IMPLIED+  data        %URI;          #IMPLIED+  type        %ContentType;  #IMPLIED+  codetype    %ContentType;  #IMPLIED+  archive     %UriList;      #IMPLIED+  standby     %Text;         #IMPLIED+  height      %Length;       #IMPLIED+  width       %Length;       #IMPLIED+  usemap      %URI;          #IMPLIED+  name        NMTOKEN        #IMPLIED+  tabindex    %Number;       #IMPLIED+  >++<!--+  param is used to supply a named property value.+  In XML it would seem natural to follow RDF and support an+  abbreviated syntax where the param elements are replaced+  by attribute value pairs on the object start tag.+-->+<!ELEMENT param EMPTY>+<!ATTLIST param+  id          ID             #IMPLIED+  name        CDATA          #IMPLIED+  value       CDATA          #IMPLIED+  valuetype   (data|ref|object) "data"+  type        %ContentType;  #IMPLIED+  >++<!--=================== Images ===========================================-->++<!--+   To avoid accessibility problems for people who aren't+   able to see the image, you should provide a text+   description using the alt and longdesc attributes.+   In addition, avoid the use of server-side image maps.+   Note that in this DTD there is no name attribute. That+   is only available in the transitional and frameset DTD.+-->++<!ELEMENT img EMPTY>+<!ATTLIST img+  %attrs;+  src         %URI;          #REQUIRED+  alt         %Text;         #REQUIRED+  longdesc    %URI;          #IMPLIED+  height      %Length;       #IMPLIED+  width       %Length;       #IMPLIED+  usemap      %URI;          #IMPLIED+  ismap       (ismap)        #IMPLIED+  >++<!-- usemap points to a map element which may be in this document+  or an external document, although the latter is not widely supported -->++<!--================== Client-side image maps ============================-->++<!-- These can be placed in the same document or grouped in a+     separate document although this isn't yet widely supported -->++<!ELEMENT map ((%block; | form | %misc;)+ | area+)>+<!ATTLIST map+  %i18n;+  %events;+  id          ID             #REQUIRED+  class       CDATA          #IMPLIED+  style       %StyleSheet;   #IMPLIED+  title       %Text;         #IMPLIED+  name        NMTOKEN        #IMPLIED+  >++<!ELEMENT area EMPTY>+<!ATTLIST area+  %attrs;+  shape       %Shape;        "rect"+  coords      %Coords;       #IMPLIED+  href        %URI;          #IMPLIED+  nohref      (nohref)       #IMPLIED+  alt         %Text;         #REQUIRED+  tabindex    %Number;       #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  >++<!--================ Forms ===============================================-->+<!ELEMENT form %form.content;>   <!-- forms shouldn't be nested -->++<!ATTLIST form+  %attrs;+  action      %URI;          #REQUIRED+  method      (get|post)     "get"+  enctype     %ContentType;  "application/x-www-form-urlencoded"+  onsubmit    %Script;       #IMPLIED+  onreset     %Script;       #IMPLIED+  accept      %ContentTypes; #IMPLIED+  accept-charset %Charsets;  #IMPLIED+  >++<!--+  Each label must not contain more than ONE field+  Label elements shouldn't be nested.+-->+<!ELEMENT label %Inline;>+<!ATTLIST label+  %attrs;+  for         IDREF          #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  >++<!ENTITY % InputType+  "(text | password | checkbox |+    radio | submit | reset |+    file | hidden | image | button)"+   >++<!-- the name attribute is required for all but submit & reset -->++<!ELEMENT input EMPTY>     <!-- form control -->+<!ATTLIST input+  %attrs;+  type        %InputType;    "text"+  name        CDATA          #IMPLIED+  value       CDATA          #IMPLIED+  checked     (checked)      #IMPLIED+  disabled    (disabled)     #IMPLIED+  readonly    (readonly)     #IMPLIED+  size        CDATA          #IMPLIED+  maxlength   %Number;       #IMPLIED+  src         %URI;          #IMPLIED+  alt         CDATA          #IMPLIED+  usemap      %URI;          #IMPLIED+  tabindex    %Number;       #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  onselect    %Script;       #IMPLIED+  onchange    %Script;       #IMPLIED+  accept      %ContentTypes; #IMPLIED+  >++<!ELEMENT select (optgroup|option)+>  <!-- option selector -->+<!ATTLIST select+  %attrs;+  name        CDATA          #IMPLIED+  size        %Number;       #IMPLIED+  multiple    (multiple)     #IMPLIED+  disabled    (disabled)     #IMPLIED+  tabindex    %Number;       #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  onchange    %Script;       #IMPLIED+  >++<!ELEMENT optgroup (option)+>   <!-- option group -->+<!ATTLIST optgroup+  %attrs;+  disabled    (disabled)     #IMPLIED+  label       %Text;         #REQUIRED+  >++<!ELEMENT option (#PCDATA)>     <!-- selectable choice -->+<!ATTLIST option+  %attrs;+  selected    (selected)     #IMPLIED+  disabled    (disabled)     #IMPLIED+  label       %Text;         #IMPLIED+  value       CDATA          #IMPLIED+  >++<!ELEMENT textarea (#PCDATA)>     <!-- multi-line text field -->+<!ATTLIST textarea+  %attrs;+  name        CDATA          #IMPLIED+  rows        %Number;       #REQUIRED+  cols        %Number;       #REQUIRED+  disabled    (disabled)     #IMPLIED+  readonly    (readonly)     #IMPLIED+  tabindex    %Number;       #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  onselect    %Script;       #IMPLIED+  onchange    %Script;       #IMPLIED+  >++<!--+  The fieldset element is used to group form fields.+  Only one legend element should occur in the content+  and if present should only be preceded by whitespace.+-->+<!ELEMENT fieldset (#PCDATA | legend | %block; | form | %inline; | %misc;)*>+<!ATTLIST fieldset+  %attrs;+  >++<!ELEMENT legend %Inline;>     <!-- fieldset label -->+<!ATTLIST legend+  %attrs;+  accesskey   %Character;    #IMPLIED+  >++<!--+ Content is %Flow; excluding a, form and form controls+--> +<!ELEMENT button %button.content;>  <!-- push button -->+<!ATTLIST button+  %attrs;+  name        CDATA          #IMPLIED+  value       CDATA          #IMPLIED+  type        (button|submit|reset) "submit"+  disabled    (disabled)     #IMPLIED+  tabindex    %Number;       #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  >++<!--======================= Tables =======================================-->++<!-- Derived from IETF HTML table standard, see [RFC1942] -->++<!--+ The border attribute sets the thickness of the frame around the+ table. The default units are screen pixels.++ The frame attribute specifies which parts of the frame around+ the table should be rendered. The values are not the same as+ CALS to avoid a name clash with the valign attribute.+-->+<!ENTITY % TFrame "(void|above|below|hsides|lhs|rhs|vsides|box|border)">++<!--+ The rules attribute defines which rules to draw between cells:++ If rules is absent then assume:+     "none" if border is absent or border="0" otherwise "all"+-->++<!ENTITY % TRules "(none | groups | rows | cols | all)">+  +<!-- horizontal placement of table relative to document -->+<!ENTITY % TAlign "(left|center|right)">++<!-- horizontal alignment attributes for cell contents++  char        alignment char, e.g. char=':'+  charoff     offset for alignment char+-->+<!ENTITY % cellhalign+  "align      (left|center|right|justify|char) #IMPLIED+   char       %Character;    #IMPLIED+   charoff    %Length;       #IMPLIED"+  >++<!-- vertical alignment attributes for cell contents -->+<!ENTITY % cellvalign+  "valign     (top|middle|bottom|baseline) #IMPLIED"+  >++<!ELEMENT table+     (caption?, (col*|colgroup*), thead?, tfoot?, (tbody+|tr+))>+<!ELEMENT caption  %Inline;>+<!ELEMENT thead    (tr)+>+<!ELEMENT tfoot    (tr)+>+<!ELEMENT tbody    (tr)+>+<!ELEMENT colgroup (col)*>+<!ELEMENT col      EMPTY>+<!ELEMENT tr       (th|td)+>+<!ELEMENT th       %Flow;>+<!ELEMENT td       %Flow;>++<!ATTLIST table+  %attrs;+  summary     %Text;         #IMPLIED+  width       %Length;       #IMPLIED+  border      %Pixels;       #IMPLIED+  frame       %TFrame;       #IMPLIED+  rules       %TRules;       #IMPLIED+  cellspacing %Length;       #IMPLIED+  cellpadding %Length;       #IMPLIED+  >++<!ENTITY % CAlign "(top|bottom|left|right)">++<!ATTLIST caption+  %attrs;+  >++<!--+colgroup groups a set of col elements. It allows you to group+several semantically related columns together.+-->+<!ATTLIST colgroup+  %attrs;+  span        %Number;       "1"+  width       %MultiLength;  #IMPLIED+  %cellhalign;+  %cellvalign;+  >++<!--+ col elements define the alignment properties for cells in+ one or more columns.++ The width attribute specifies the width of the columns, e.g.++     width=64        width in screen pixels+     width=0.5*      relative width of 0.5++ The span attribute causes the attributes of one+ col element to apply to more than one column.+-->+<!ATTLIST col+  %attrs;+  span        %Number;       "1"+  width       %MultiLength;  #IMPLIED+  %cellhalign;+  %cellvalign;+  >++<!--+    Use thead to duplicate headers when breaking table+    across page boundaries, or for static headers when+    tbody sections are rendered in scrolling panel.++    Use tfoot to duplicate footers when breaking table+    across page boundaries, or for static footers when+    tbody sections are rendered in scrolling panel.++    Use multiple tbody sections when rules are needed+    between groups of table rows.+-->+<!ATTLIST thead+  %attrs;+  %cellhalign;+  %cellvalign;+  >++<!ATTLIST tfoot+  %attrs;+  %cellhalign;+  %cellvalign;+  >++<!ATTLIST tbody+  %attrs;+  %cellhalign;+  %cellvalign;+  >++<!ATTLIST tr+  %attrs;+  %cellhalign;+  %cellvalign;+  >+++<!-- Scope is simpler than headers attribute for common tables -->+<!ENTITY % Scope "(row|col|rowgroup|colgroup)">++<!-- th is for headers, td for data and for cells acting as both -->++<!ATTLIST th+  %attrs;+  abbr        %Text;         #IMPLIED+  axis        CDATA          #IMPLIED+  headers     IDREFS         #IMPLIED+  scope       %Scope;        #IMPLIED+  rowspan     %Number;       "1"+  colspan     %Number;       "1"+  %cellhalign;+  %cellvalign;+  >++<!ATTLIST td+  %attrs;+  abbr        %Text;         #IMPLIED+  axis        CDATA          #IMPLIED+  headers     IDREFS         #IMPLIED+  scope       %Scope;        #IMPLIED+  rowspan     %Number;       "1"+  colspan     %Number;       "1"+  %cellhalign;+  %cellvalign;+  >+
+ examples/xhtml/xhtml1-transitional.dtd view
@@ -0,0 +1,1196 @@+<!--+   Extensible HTML version 1.0 Transitional DTD++   This is the same as HTML 4.0 Transitional except for+   changes due to the differences between XML and SGML.++   Namespace = http://www.w3.org/1999/xhtml++   For further information, see: http://www.w3.org/TR/xhtml1++   Copyright (c) 1998-2000 W3C (MIT, INRIA, Keio),+   All Rights Reserved. ++   This DTD module is identified by the PUBLIC and SYSTEM identifiers:++   PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"+   SYSTEM "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"++   $Revision: 1.1 $+   $Date: 2002/10/01 13:47:08 $++-->++<!--================ Character mnemonic entities =========================-->++<!ENTITY % HTMLlat1 PUBLIC+   "-//W3C//ENTITIES Latin 1 for XHTML//EN"+   "xhtml-lat1.ent">+%HTMLlat1;++<!ENTITY % HTMLsymbol PUBLIC+   "-//W3C//ENTITIES Symbols for XHTML//EN"+   "xhtml-symbol.ent">+%HTMLsymbol;++<!ENTITY % HTMLspecial PUBLIC+   "-//W3C//ENTITIES Special for XHTML//EN"+   "xhtml-special.ent">+%HTMLspecial;++<!--================== Imported Names ====================================-->++<!ENTITY % ContentType "CDATA">+    <!-- media type, as per [RFC2045] -->++<!ENTITY % ContentTypes "CDATA">+    <!-- comma-separated list of media types, as per [RFC2045] -->++<!ENTITY % Charset "CDATA">+    <!-- a character encoding, as per [RFC2045] -->++<!ENTITY % Charsets "CDATA">+    <!-- a space separated list of character encodings, as per [RFC2045] -->++<!ENTITY % LanguageCode "NMTOKEN">+    <!-- a language code, as per [RFC1766] -->++<!ENTITY % Character "CDATA">+    <!-- a single character from [ISO10646] -->++<!ENTITY % Number "CDATA">+    <!-- one or more digits -->++<!ENTITY % LinkTypes "CDATA">+    <!-- space-separated list of link types -->++<!ENTITY % MediaDesc "CDATA">+    <!-- single or comma-separated list of media descriptors -->++<!ENTITY % URI "CDATA">+    <!-- a Uniform Resource Identifier, see [RFC2396] -->++<!ENTITY % UriList "CDATA">+    <!-- a space separated list of Uniform Resource Identifiers -->++<!ENTITY % Datetime "CDATA">+    <!-- date and time information. ISO date format -->++<!ENTITY % Script "CDATA">+    <!-- script expression -->++<!ENTITY % StyleSheet "CDATA">+    <!-- style sheet data -->++<!ENTITY % Text "CDATA">+    <!-- used for titles etc. -->++<!ENTITY % FrameTarget "NMTOKEN">+    <!-- render in this frame -->++<!ENTITY % Length "CDATA">+    <!-- nn for pixels or nn% for percentage length -->++<!ENTITY % MultiLength "CDATA">+    <!-- pixel, percentage, or relative -->++<!ENTITY % MultiLengths "CDATA">+    <!-- comma-separated list of MultiLength -->++<!ENTITY % Pixels "CDATA">+    <!-- integer representing length in pixels -->++<!-- these are used for image maps -->++<!ENTITY % Shape "(rect|circle|poly|default)">++<!ENTITY % Coords "CDATA">+    <!-- comma separated list of lengths -->++<!-- used for object, applet, img, input and iframe -->+<!ENTITY % ImgAlign "(top|middle|bottom|left|right)">++<!-- a color using sRGB: #RRGGBB as Hex values -->+<!ENTITY % Color "CDATA">++<!-- There are also 16 widely known color names with their sRGB values:++    Black  = #000000    Green  = #008000+    Silver = #C0C0C0    Lime   = #00FF00+    Gray   = #808080    Olive  = #808000+    White  = #FFFFFF    Yellow = #FFFF00+    Maroon = #800000    Navy   = #000080+    Red    = #FF0000    Blue   = #0000FF+    Purple = #800080    Teal   = #008080+    Fuchsia= #FF00FF    Aqua   = #00FFFF+-->++<!--=================== Generic Attributes ===============================-->++<!-- core attributes common to most elements+  id       document-wide unique id+  class    space separated list of classes+  style    associated style info+  title    advisory title/amplification+-->+<!ENTITY % coreattrs+ "id          ID             #IMPLIED+  class       CDATA          #IMPLIED+  style       %StyleSheet;   #IMPLIED+  title       %Text;         #IMPLIED"+  >++<!-- internationalization attributes+  lang        language code (backwards compatible)+  xml:lang    language code (as per XML 1.0 spec)+  dir         direction for weak/neutral text+-->+<!ENTITY % i18n+ "lang        %LanguageCode; #IMPLIED+  xml:lang    %LanguageCode; #IMPLIED+  dir         (ltr|rtl)      #IMPLIED"+  >++<!-- attributes for common UI events+  onclick     a pointer button was clicked+  ondblclick  a pointer button was double clicked+  onmousedown a pointer button was pressed down+  onmouseup   a pointer button was released+  onmousemove a pointer was moved onto the element+  onmouseout  a pointer was moved away from the element+  onkeypress  a key was pressed and released+  onkeydown   a key was pressed down+  onkeyup     a key was released+-->+<!ENTITY % events+ "onclick     %Script;       #IMPLIED+  ondblclick  %Script;       #IMPLIED+  onmousedown %Script;       #IMPLIED+  onmouseup   %Script;       #IMPLIED+  onmouseover %Script;       #IMPLIED+  onmousemove %Script;       #IMPLIED+  onmouseout  %Script;       #IMPLIED+  onkeypress  %Script;       #IMPLIED+  onkeydown   %Script;       #IMPLIED+  onkeyup     %Script;       #IMPLIED"+  >++<!-- attributes for elements that can get the focus+  accesskey   accessibility key character+  tabindex    position in tabbing order+  onfocus     the element got the focus+  onblur      the element lost the focus+-->+<!ENTITY % focus+ "accesskey   %Character;    #IMPLIED+  tabindex    %Number;       #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED"+  >++<!ENTITY % attrs "%coreattrs; %i18n; %events;">++<!-- text alignment for p, div, h1-h6. The default is+     align="left" for ltr headings, "right" for rtl -->++<!ENTITY % TextAlign "align (left|center|right) #IMPLIED">++<!--=================== Text Elements ====================================-->++<!ENTITY % special+   "br | span | bdo | object | applet | img | map | iframe">++<!ENTITY % fontstyle "tt | i | b | big | small | u+                      | s | strike |font | basefont">++<!ENTITY % phrase "em | strong | dfn | code | q | sub | sup |+                   samp | kbd | var | cite | abbr | acronym">++<!ENTITY % inline.forms "input | select | textarea | label | button">++<!-- these can occur at block or inline level -->+<!ENTITY % misc "ins | del | script | noscript">++<!ENTITY % inline "a | %special; | %fontstyle; | %phrase; | %inline.forms;">++<!-- %Inline; covers inline or "text-level" elements -->+<!ENTITY % Inline "(#PCDATA | %inline; | %misc;)*">++<!--================== Block level elements ==============================-->++<!ENTITY % heading "h1|h2|h3|h4|h5|h6">+<!ENTITY % lists "ul | ol | dl | menu | dir">+<!ENTITY % blocktext "pre | hr | blockquote | address | center | noframes">++<!ENTITY % block+    "p | %heading; | div | %lists; | %blocktext; | isindex |fieldset | table">++<!ENTITY % Block "(%block; | form | %misc;)*">++<!-- %Flow; mixes Block and Inline and is used for list items etc. -->+<!ENTITY % Flow "(#PCDATA | %block; | form | %inline; | %misc;)*">++<!--================== Content models for exclusions =====================-->++<!-- a elements use %Inline; excluding a -->++<!ENTITY % a.content+   "(#PCDATA | %special; | %fontstyle; | %phrase; | %inline.forms; | %misc;)*">++<!-- pre uses %Inline excluding img, object, applet, big, small,+     sub, sup, font, or basefont -->++<!ENTITY % pre.content+   "(#PCDATA | a | br | span | bdo | map | tt | i | b | u | s |+      %phrase; | %inline.forms;)*">++<!-- form uses %Flow; excluding form -->++<!ENTITY % form.content "(#PCDATA | %block; | %inline; | %misc;)*">++<!-- button uses %Flow; but excludes a, form, form controls, iframe -->++<!ENTITY % button.content+   "(#PCDATA | p | %heading; | div | %lists; | %blocktext; |+      table | br | span | bdo | object | applet | img | map |+      %fontstyle; | %phrase; | %misc;)*">++<!--================ Document Structure ==================================-->++<!-- the namespace URI designates the document profile -->++<!ELEMENT html (head, body)>+<!ATTLIST html+  %i18n;+  xmlns       %URI;          #FIXED 'http://www.w3.org/1999/xhtml'+  >++<!--================ Document Head =======================================-->++<!ENTITY % head.misc "(script|style|meta|link|object|isindex)*">++<!-- content model is %head.misc; combined with a single+     title and an optional base element in any order -->++<!ELEMENT head (%head.misc;,+     ((title, %head.misc;, (base, %head.misc;)?) |+      (base, %head.misc;, (title, %head.misc;))))>++<!ATTLIST head+  %i18n;+  profile     %URI;          #IMPLIED+  >++<!-- The title element is not considered part of the flow of text.+       It should be displayed, for example as the page header or+       window title. Exactly one title is required per document.+    -->+<!ELEMENT title (#PCDATA)>+<!ATTLIST title %i18n;>++<!-- document base URI -->++<!ELEMENT base EMPTY>+<!ATTLIST base+  href        %URI;          #IMPLIED+  target      %FrameTarget;  #IMPLIED+  >++<!-- generic metainformation -->+<!ELEMENT meta EMPTY>+<!ATTLIST meta+  %i18n;+  http-equiv  CDATA          #IMPLIED+  name        CDATA          #IMPLIED+  content     CDATA          #REQUIRED+  scheme      CDATA          #IMPLIED+  >++<!--+  Relationship values can be used in principle:++   a) for document specific toolbars/menus when used+      with the link element in document head e.g.+        start, contents, previous, next, index, end, help+   b) to link to a separate style sheet (rel="stylesheet")+   c) to make a link to a script (rel="script")+   d) by stylesheets to control how collections of+      html nodes are rendered into printed documents+   e) to make a link to a printable version of this document+      e.g. a PostScript or PDF version (rel="alternate" media="print")+-->++<!ELEMENT link EMPTY>+<!ATTLIST link+  %attrs;+  charset     %Charset;      #IMPLIED+  href        %URI;          #IMPLIED+  hreflang    %LanguageCode; #IMPLIED+  type        %ContentType;  #IMPLIED+  rel         %LinkTypes;    #IMPLIED+  rev         %LinkTypes;    #IMPLIED+  media       %MediaDesc;    #IMPLIED+  target      %FrameTarget;  #IMPLIED+  >++<!-- style info, which may include CDATA sections -->+<!ELEMENT style (#PCDATA)>+<!ATTLIST style+  %i18n;+  type        %ContentType;  #REQUIRED+  media       %MediaDesc;    #IMPLIED+  title       %Text;         #IMPLIED+  xml:space   (preserve)     #FIXED 'preserve'+  >++<!-- script statements, which may include CDATA sections -->+<!ELEMENT script (#PCDATA)>+<!ATTLIST script+  charset     %Charset;      #IMPLIED+  type        %ContentType;  #REQUIRED+  language    CDATA          #IMPLIED+  src         %URI;          #IMPLIED+  defer       (defer)        #IMPLIED+  xml:space   (preserve)     #FIXED 'preserve'+  >++<!-- alternate content container for non script-based rendering -->++<!ELEMENT noscript %Flow;>+<!ATTLIST noscript+  %attrs;+  >++<!--======================= Frames =======================================-->++<!-- inline subwindow -->++<!ELEMENT iframe %Flow;>+<!ATTLIST iframe+  %coreattrs;+  longdesc    %URI;          #IMPLIED+  name        NMTOKEN        #IMPLIED+  src         %URI;          #IMPLIED+  frameborder (1|0)          "1"+  marginwidth %Pixels;       #IMPLIED+  marginheight %Pixels;      #IMPLIED+  scrolling   (yes|no|auto)  "auto"+  align       %ImgAlign;     #IMPLIED+  height      %Length;       #IMPLIED+  width       %Length;       #IMPLIED+  >++<!-- alternate content container for non frame-based rendering -->++<!ELEMENT noframes %Flow;>+<!ATTLIST noframes+  %attrs;+  >++<!--=================== Document Body ====================================-->++<!ELEMENT body %Flow;>+<!ATTLIST body+  %attrs;+  onload      %Script;       #IMPLIED+  onunload    %Script;       #IMPLIED+  background  %URI;          #IMPLIED+  bgcolor     %Color;        #IMPLIED+  text        %Color;        #IMPLIED+  link        %Color;        #IMPLIED+  vlink       %Color;        #IMPLIED+  alink       %Color;        #IMPLIED+  >++<!ELEMENT div %Flow;>  <!-- generic language/style container -->+<!ATTLIST div+  %attrs;+  %TextAlign;+  >++<!--=================== Paragraphs =======================================-->++<!ELEMENT p %Inline;>+<!ATTLIST p+  %attrs;+  %TextAlign;+  >++<!--=================== Headings =========================================-->++<!--+  There are six levels of headings from h1 (the most important)+  to h6 (the least important).+-->++<!ELEMENT h1  %Inline;>+<!ATTLIST h1+  %attrs;+  %TextAlign;+  >++<!ELEMENT h2 %Inline;>+<!ATTLIST h2+  %attrs;+  %TextAlign;+  >++<!ELEMENT h3 %Inline;>+<!ATTLIST h3+  %attrs;+  %TextAlign;+  >++<!ELEMENT h4 %Inline;>+<!ATTLIST h4+  %attrs;+  %TextAlign;+  >++<!ELEMENT h5 %Inline;>+<!ATTLIST h5+  %attrs;+  %TextAlign;+  >++<!ELEMENT h6 %Inline;>+<!ATTLIST h6+  %attrs;+  %TextAlign;+  >++<!--=================== Lists ============================================-->++<!-- Unordered list bullet styles -->++<!ENTITY % ULStyle "(disc|square|circle)">++<!-- Unordered list -->++<!ELEMENT ul (li)+>+<!ATTLIST ul+  %attrs;+  type        %ULStyle;     #IMPLIED+  compact     (compact)     #IMPLIED+  >++<!-- Ordered list numbering style++    1   arabic numbers      1, 2, 3, ...+    a   lower alpha         a, b, c, ...+    A   upper alpha         A, B, C, ...+    i   lower roman         i, ii, iii, ...+    I   upper roman         I, II, III, ...++    The style is applied to the sequence number which by default+    is reset to 1 for the first list item in an ordered list.+-->+<!ENTITY % OLStyle "CDATA">++<!-- Ordered (numbered) list -->++<!ELEMENT ol (li)+>+<!ATTLIST ol+  %attrs;+  type        %OLStyle;      #IMPLIED+  compact     (compact)      #IMPLIED+  start       %Number;       #IMPLIED+  >++<!-- single column list (DEPRECATED) --> +<!ELEMENT menu (li)+>+<!ATTLIST menu+  %attrs;+  compact     (compact)     #IMPLIED+  >++<!-- multiple column list (DEPRECATED) --> +<!ELEMENT dir (li)+>+<!ATTLIST dir+  %attrs;+  compact     (compact)     #IMPLIED+  >++<!-- LIStyle is constrained to: "(%ULStyle;|%OLStyle;)" -->+<!ENTITY % LIStyle "CDATA">++<!-- list item -->++<!ELEMENT li %Flow;>+<!ATTLIST li+  %attrs;+  type        %LIStyle;      #IMPLIED+  value       %Number;       #IMPLIED+  >++<!-- definition lists - dt for term, dd for its definition -->++<!ELEMENT dl (dt|dd)+>+<!ATTLIST dl+  %attrs;+  compact     (compact)      #IMPLIED+  >++<!ELEMENT dt %Inline;>+<!ATTLIST dt+  %attrs;+  >++<!ELEMENT dd %Flow;>+<!ATTLIST dd+  %attrs;+  >++<!--=================== Address ==========================================-->++<!-- information on author -->++<!ELEMENT address %Inline;>+<!ATTLIST address+  %attrs;+  >++<!--=================== Horizontal Rule ==================================-->++<!ELEMENT hr EMPTY>+<!ATTLIST hr+  %attrs;+  align       (left|center|right) #IMPLIED+  noshade     (noshade)      #IMPLIED+  size        %Pixels;       #IMPLIED+  width       %Length;       #IMPLIED+  >++<!--=================== Preformatted Text ================================-->++<!-- content is %Inline; excluding +        "img|object|applet|big|small|sub|sup|font|basefont" -->++<!ELEMENT pre %pre.content;>+<!ATTLIST pre+  %attrs;+  width       %Number;      #IMPLIED+  xml:space   (preserve)    #FIXED 'preserve'+  >++<!--=================== Block-like Quotes ================================-->++<!ELEMENT blockquote %Flow;>+<!ATTLIST blockquote+  %attrs;+  cite        %URI;          #IMPLIED+  >++<!--=================== Text alignment ===================================-->++<!-- center content -->+<!ELEMENT center %Flow;>+<!ATTLIST center+  %attrs;+  >++<!--=================== Inserted/Deleted Text ============================-->++<!--+  ins/del are allowed in block and inline content, but its+  inappropriate to include block content within an ins element+  occurring in inline content.+-->+<!ELEMENT ins %Flow;>+<!ATTLIST ins+  %attrs;+  cite        %URI;          #IMPLIED+  datetime    %Datetime;     #IMPLIED+  >++<!ELEMENT del %Flow;>+<!ATTLIST del+  %attrs;+  cite        %URI;          #IMPLIED+  datetime    %Datetime;     #IMPLIED+  >++<!--================== The Anchor Element ================================-->++<!-- content is %Inline; except that anchors shouldn't be nested -->++<!ELEMENT a %a.content;>+<!ATTLIST a+  %attrs;+  charset     %Charset;      #IMPLIED+  type        %ContentType;  #IMPLIED+  name        NMTOKEN        #IMPLIED+  href        %URI;          #IMPLIED+  hreflang    %LanguageCode; #IMPLIED+  rel         %LinkTypes;    #IMPLIED+  rev         %LinkTypes;    #IMPLIED+  accesskey   %Character;    #IMPLIED+  shape       %Shape;        "rect"+  coords      %Coords;       #IMPLIED+  tabindex    %Number;       #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  target      %FrameTarget;  #IMPLIED+  >++<!--===================== Inline Elements ================================-->++<!ELEMENT span %Inline;> <!-- generic language/style container -->+<!ATTLIST span+  %attrs;+  >++<!ELEMENT bdo %Inline;>  <!-- I18N BiDi over-ride -->+<!ATTLIST bdo+  %coreattrs;+  %events;+  lang        %LanguageCode; #IMPLIED+  xml:lang    %LanguageCode; #IMPLIED+  dir         (ltr|rtl)      #REQUIRED+  >++<!ELEMENT br EMPTY>   <!-- forced line break -->+<!ATTLIST br+  %coreattrs;+  clear       (left|all|right|none) "none"+  >++<!ELEMENT em %Inline;>   <!-- emphasis -->+<!ATTLIST em %attrs;>++<!ELEMENT strong %Inline;>   <!-- strong emphasis -->+<!ATTLIST strong %attrs;>++<!ELEMENT dfn %Inline;>   <!-- definitional -->+<!ATTLIST dfn %attrs;>++<!ELEMENT code %Inline;>   <!-- program code -->+<!ATTLIST code %attrs;>++<!ELEMENT samp %Inline;>   <!-- sample -->+<!ATTLIST samp %attrs;>++<!ELEMENT kbd %Inline;>  <!-- something user would type -->+<!ATTLIST kbd %attrs;>++<!ELEMENT var %Inline;>   <!-- variable -->+<!ATTLIST var %attrs;>++<!ELEMENT cite %Inline;>   <!-- citation -->+<!ATTLIST cite %attrs;>++<!ELEMENT abbr %Inline;>   <!-- abbreviation -->+<!ATTLIST abbr %attrs;>++<!ELEMENT acronym %Inline;>   <!-- acronym -->+<!ATTLIST acronym %attrs;>++<!ELEMENT q %Inline;>   <!-- inlined quote -->+<!ATTLIST q+  %attrs;+  cite        %URI;          #IMPLIED+  >++<!ELEMENT sub %Inline;> <!-- subscript -->+<!ATTLIST sub %attrs;>++<!ELEMENT sup %Inline;> <!-- superscript -->+<!ATTLIST sup %attrs;>++<!ELEMENT tt %Inline;>   <!-- fixed pitch font -->+<!ATTLIST tt %attrs;>++<!ELEMENT i %Inline;>   <!-- italic font -->+<!ATTLIST i %attrs;>++<!ELEMENT b %Inline;>   <!-- bold font -->+<!ATTLIST b %attrs;>++<!ELEMENT big %Inline;>   <!-- bigger font -->+<!ATTLIST big %attrs;>++<!ELEMENT small %Inline;>   <!-- smaller font -->+<!ATTLIST small %attrs;>++<!ELEMENT u %Inline;>   <!-- underline -->+<!ATTLIST u %attrs;>++<!ELEMENT s %Inline;>   <!-- strike-through -->+<!ATTLIST s %attrs;>++<!ELEMENT strike %Inline;>   <!-- strike-through -->+<!ATTLIST strike %attrs;>++<!ELEMENT basefont EMPTY>  <!-- base font size -->+<!ATTLIST basefont+  id          ID             #IMPLIED+  size        CDATA          #REQUIRED+  color       %Color;        #IMPLIED+  face        CDATA          #IMPLIED+  >++<!ELEMENT font %Inline;> <!-- local change to font -->+<!ATTLIST font+  %coreattrs;+  %i18n;+  size        CDATA          #IMPLIED+  color       %Color;        #IMPLIED+  face        CDATA          #IMPLIED+  >++<!--==================== Object ======================================-->+<!--+  object is used to embed objects as part of HTML pages.+  param elements should precede other content. Parameters+  can also be expressed as attribute/value pairs on the+  object element itself when brevity is desired.+-->++<!ELEMENT object (#PCDATA | param | %block; | form | %inline; | %misc;)*>+<!ATTLIST object+  %attrs;+  declare     (declare)      #IMPLIED+  classid     %URI;          #IMPLIED+  codebase    %URI;          #IMPLIED+  data        %URI;          #IMPLIED+  type        %ContentType;  #IMPLIED+  codetype    %ContentType;  #IMPLIED+  archive     %UriList;      #IMPLIED+  standby     %Text;         #IMPLIED+  height      %Length;       #IMPLIED+  width       %Length;       #IMPLIED+  usemap      %URI;          #IMPLIED+  name        NMTOKEN        #IMPLIED+  tabindex    %Number;       #IMPLIED+  align       %ImgAlign;     #IMPLIED+  border      %Pixels;       #IMPLIED+  hspace      %Pixels;       #IMPLIED+  vspace      %Pixels;       #IMPLIED+  >++<!--+  param is used to supply a named property value.+  In XML it would seem natural to follow RDF and support an+  abbreviated syntax where the param elements are replaced+  by attribute value pairs on the object start tag.+-->+<!ELEMENT param EMPTY>+<!ATTLIST param+  id          ID             #IMPLIED+  name        CDATA          #REQUIRED+  value       CDATA          #IMPLIED+  valuetype   (data|ref|object) "data"+  type        %ContentType;  #IMPLIED+  >++<!--=================== Java applet ==================================-->+<!--+  One of code or object attributes must be present.+  Place param elements before other content.+-->+<!ELEMENT applet (#PCDATA | param | %block; | form | %inline; | %misc;)*>+<!ATTLIST applet+  %coreattrs;+  codebase    %URI;          #IMPLIED+  archive     CDATA          #IMPLIED+  code        CDATA          #IMPLIED+  object      CDATA          #IMPLIED+  alt         %Text;         #IMPLIED+  name        NMTOKEN        #IMPLIED+  width       %Length;       #REQUIRED+  height      %Length;       #REQUIRED+  align       %ImgAlign;     #IMPLIED+  hspace      %Pixels;       #IMPLIED+  vspace      %Pixels;       #IMPLIED+  >++<!--=================== Images ===========================================-->++<!--+   To avoid accessibility problems for people who aren't+   able to see the image, you should provide a text+   description using the alt and longdesc attributes.+   In addition, avoid the use of server-side image maps.+-->++<!ELEMENT img EMPTY>+<!ATTLIST img+  %attrs;+  src         %URI;          #REQUIRED+  alt         %Text;         #REQUIRED+  name        NMTOKEN        #IMPLIED+  longdesc    %URI;          #IMPLIED+  height      %Length;       #IMPLIED+  width       %Length;       #IMPLIED+  usemap      %URI;          #IMPLIED+  ismap       (ismap)        #IMPLIED+  align       %ImgAlign;     #IMPLIED+  border      %Length;       #IMPLIED+  hspace      %Pixels;       #IMPLIED+  vspace      %Pixels;       #IMPLIED+  >++<!-- usemap points to a map element which may be in this document+  or an external document, although the latter is not widely supported -->++<!--================== Client-side image maps ============================-->++<!-- These can be placed in the same document or grouped in a+     separate document although this isn't yet widely supported -->++<!ELEMENT map ((%block; | form | %misc;)+ | area+)>+<!ATTLIST map+  %i18n;+  %events;+  id          ID             #REQUIRED+  class       CDATA          #IMPLIED+  style       %StyleSheet;   #IMPLIED+  title       %Text;         #IMPLIED+  name        CDATA          #IMPLIED+  >++<!ELEMENT area EMPTY>+<!ATTLIST area+  %attrs;+  shape       %Shape;        "rect"+  coords      %Coords;       #IMPLIED+  href        %URI;          #IMPLIED+  nohref      (nohref)       #IMPLIED+  alt         %Text;         #REQUIRED+  tabindex    %Number;       #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  target      %FrameTarget;  #IMPLIED+  >++<!--================ Forms ===============================================-->++<!ELEMENT form %form.content;>   <!-- forms shouldn't be nested -->++<!ATTLIST form+  %attrs;+  action      %URI;          #REQUIRED+  method      (get|post)     "get"+  name        NMTOKEN        #IMPLIED+  enctype     %ContentType;  "application/x-www-form-urlencoded"+  onsubmit    %Script;       #IMPLIED+  onreset     %Script;       #IMPLIED+  accept      %ContentTypes; #IMPLIED+  accept-charset %Charsets;  #IMPLIED+  target      %FrameTarget;  #IMPLIED+  >++<!--+  Each label must not contain more than ONE field+  Label elements shouldn't be nested.+-->+<!ELEMENT label %Inline;>+<!ATTLIST label+  %attrs;+  for         IDREF          #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  >++<!ENTITY % InputType+  "(text | password | checkbox |+    radio | submit | reset |+    file | hidden | image | button)"+   >++<!-- the name attribute is required for all but submit & reset -->++<!ELEMENT input EMPTY>     <!-- form control -->+<!ATTLIST input+  %attrs;+  type        %InputType;    "text"+  name        CDATA          #IMPLIED+  value       CDATA          #IMPLIED+  checked     (checked)      #IMPLIED+  disabled    (disabled)     #IMPLIED+  readonly    (readonly)     #IMPLIED+  size        CDATA          #IMPLIED+  maxlength   %Number;       #IMPLIED+  src         %URI;          #IMPLIED+  alt         CDATA          #IMPLIED+  usemap      %URI;          #IMPLIED+  tabindex    %Number;       #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  onselect    %Script;       #IMPLIED+  onchange    %Script;       #IMPLIED+  accept      %ContentTypes; #IMPLIED+  align       %ImgAlign;     #IMPLIED+  >++<!ELEMENT select (optgroup|option)+>  <!-- option selector -->+<!ATTLIST select+  %attrs;+  name        CDATA          #IMPLIED+  size        %Number;       #IMPLIED+  multiple    (multiple)     #IMPLIED+  disabled    (disabled)     #IMPLIED+  tabindex    %Number;       #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  onchange    %Script;       #IMPLIED+  >++<!ELEMENT optgroup (option)+>   <!-- option group -->+<!ATTLIST optgroup+  %attrs;+  disabled    (disabled)     #IMPLIED+  label       %Text;         #REQUIRED+  >++<!ELEMENT option (#PCDATA)>     <!-- selectable choice -->+<!ATTLIST option+  %attrs;+  selected    (selected)     #IMPLIED+  disabled    (disabled)     #IMPLIED+  label       %Text;         #IMPLIED+  value       CDATA          #IMPLIED+  >++<!ELEMENT textarea (#PCDATA)>     <!-- multi-line text field -->+<!ATTLIST textarea+  %attrs;+  name        CDATA          #IMPLIED+  rows        %Number;       #REQUIRED+  cols        %Number;       #REQUIRED+  disabled    (disabled)     #IMPLIED+  readonly    (readonly)     #IMPLIED+  tabindex    %Number;       #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  onselect    %Script;       #IMPLIED+  onchange    %Script;       #IMPLIED+  >++<!--+  The fieldset element is used to group form fields.+  Only one legend element should occur in the content+  and if present should only be preceded by whitespace.+-->+<!ELEMENT fieldset (#PCDATA | legend | %block; | form | %inline; | %misc;)*>+<!ATTLIST fieldset+  %attrs;+  >++<!ENTITY % LAlign "(top|bottom|left|right)">++<!ELEMENT legend %Inline;>     <!-- fieldset label -->+<!ATTLIST legend+  %attrs;+  accesskey   %Character;    #IMPLIED+  align       %LAlign;       #IMPLIED+  >++<!--+ Content is %Flow; excluding a, form, form controls, iframe+--> +<!ELEMENT button %button.content;>  <!-- push button -->+<!ATTLIST button+  %attrs;+  name        CDATA          #IMPLIED+  value       CDATA          #IMPLIED+  type        (button|submit|reset) "submit"+  disabled    (disabled)     #IMPLIED+  tabindex    %Number;       #IMPLIED+  accesskey   %Character;    #IMPLIED+  onfocus     %Script;       #IMPLIED+  onblur      %Script;       #IMPLIED+  >++<!-- single-line text input control (DEPRECATED) -->+<!ELEMENT isindex EMPTY>+<!ATTLIST isindex+  %coreattrs;+  %i18n;+  prompt      %Text;         #IMPLIED+  >++<!--======================= Tables =======================================-->++<!-- Derived from IETF HTML table standard, see [RFC1942] -->++<!--+ The border attribute sets the thickness of the frame around the+ table. The default units are screen pixels.++ The frame attribute specifies which parts of the frame around+ the table should be rendered. The values are not the same as+ CALS to avoid a name clash with the valign attribute.+-->+<!ENTITY % TFrame "(void|above|below|hsides|lhs|rhs|vsides|box|border)">++<!--+ The rules attribute defines which rules to draw between cells:++ If rules is absent then assume:+     "none" if border is absent or border="0" otherwise "all"+-->++<!ENTITY % TRules "(none | groups | rows | cols | all)">+  +<!-- horizontal placement of table relative to document -->+<!ENTITY % TAlign "(left|center|right)">++<!-- horizontal alignment attributes for cell contents++  char        alignment char, e.g. char=':'+  charoff     offset for alignment char+-->+<!ENTITY % cellhalign+  "align      (left|center|right|justify|char) #IMPLIED+   char       %Character;    #IMPLIED+   charoff    %Length;       #IMPLIED"+  >++<!-- vertical alignment attributes for cell contents -->+<!ENTITY % cellvalign+  "valign     (top|middle|bottom|baseline) #IMPLIED"+  >++<!ELEMENT table+     (caption?, (col*|colgroup*), thead?, tfoot?, (tbody+|tr+))>+<!ELEMENT caption  %Inline;>+<!ELEMENT thead    (tr)+>+<!ELEMENT tfoot    (tr)+>+<!ELEMENT tbody    (tr)+>+<!ELEMENT colgroup (col)*>+<!ELEMENT col      EMPTY>+<!ELEMENT tr       (th|td)+>+<!ELEMENT th       %Flow;>+<!ELEMENT td       %Flow;>++<!ATTLIST table+  %attrs;+  summary     %Text;         #IMPLIED+  width       %Length;       #IMPLIED+  border      %Pixels;       #IMPLIED+  frame       %TFrame;       #IMPLIED+  rules       %TRules;       #IMPLIED+  cellspacing %Length;       #IMPLIED+  cellpadding %Length;       #IMPLIED+  align       %TAlign;       #IMPLIED+  bgcolor     %Color;        #IMPLIED+  >++<!ENTITY % CAlign "(top|bottom|left|right)">++<!ATTLIST caption+  %attrs;+  align       %CAlign;       #IMPLIED+  >++<!--+colgroup groups a set of col elements. It allows you to group+several semantically related columns together.+-->+<!ATTLIST colgroup+  %attrs;+  span        %Number;       "1"+  width       %MultiLength;  #IMPLIED+  %cellhalign;+  %cellvalign;+  >++<!--+ col elements define the alignment properties for cells in+ one or more columns.++ The width attribute specifies the width of the columns, e.g.++     width=64        width in screen pixels+     width=0.5*      relative width of 0.5++ The span attribute causes the attributes of one+ col element to apply to more than one column.+-->+<!ATTLIST col+  %attrs;+  span        %Number;       "1"+  width       %MultiLength;  #IMPLIED+  %cellhalign;+  %cellvalign;+  >++<!--+    Use thead to duplicate headers when breaking table+    across page boundaries, or for static headers when+    tbody sections are rendered in scrolling panel.++    Use tfoot to duplicate footers when breaking table+    across page boundaries, or for static footers when+    tbody sections are rendered in scrolling panel.++    Use multiple tbody sections when rules are needed+    between groups of table rows.+-->+<!ATTLIST thead+  %attrs;+  %cellhalign;+  %cellvalign;+  >++<!ATTLIST tfoot+  %attrs;+  %cellhalign;+  %cellvalign;+  >++<!ATTLIST tbody+  %attrs;+  %cellhalign;+  %cellvalign;+  >++<!ATTLIST tr+  %attrs;+  %cellhalign;+  %cellvalign;+  bgcolor     %Color;        #IMPLIED+  >++<!-- Scope is simpler than headers attribute for common tables -->+<!ENTITY % Scope "(row|col|rowgroup|colgroup)">++<!-- th is for headers, td for data and for cells acting as both -->++<!ATTLIST th+  %attrs;+  abbr        %Text;         #IMPLIED+  axis        CDATA          #IMPLIED+  headers     IDREFS         #IMPLIED+  scope       %Scope;        #IMPLIED+  rowspan     %Number;       "1"+  colspan     %Number;       "1"+  %cellhalign;+  %cellvalign;+  nowrap      (nowrap)       #IMPLIED+  bgcolor     %Color;        #IMPLIED+  width       %Pixels;       #IMPLIED+  height      %Pixels;       #IMPLIED+  >++<!ATTLIST td+  %attrs;+  abbr        %Text;         #IMPLIED+  axis        CDATA          #IMPLIED+  headers     IDREFS         #IMPLIED+  scope       %Scope;        #IMPLIED+  rowspan     %Number;       "1"+  colspan     %Number;       "1"+  %cellhalign;+  %cellvalign;+  nowrap      (nowrap)       #IMPLIED+  bgcolor     %Color;        #IMPLIED+  width       %Pixels;       #IMPLIED+  height      %Pixels;       #IMPLIED+  >+
hxt.cabal view
@@ -1,7 +1,7 @@ -- arch-tag: Haskell XML Toolbox main description file Name:           hxt-Version:        8.5.4-Synopsis:       A collection of tools for processing XML with Haskell. +Version:        9.3.1.22+Synopsis:       A collection of tools for processing XML with Haskell. Description:    The Haskell XML Toolbox bases on the ideas of HaXml and HXML,                 but introduces a more general approach for processing XML with Haskell.                 The Haskell XML Toolbox uses a generic data model for representing XML documents,@@ -10,18 +10,70 @@                 an XPath expression evaluator, an XSLT library, a RelaxNG schema validator                 and funtions for serialization and deserialization of user defined data.                 The library makes extensive use of the arrow approach for processing XML.-                Since version 8.5 XPath and XSLT have been moved to separate packages hxt-xpath and hxt-xslt,-                serialisation is in package hxt-binary-License:        OtherLicense+                Since version 9 the toolbox is partitioned into various (sub-)packages.+                This package contains the core functionality,+                hxt-curl, hxt-tagsoup, hxt-relaxng, hxt-xpath, hxt-xslt,+                hxt-regex-xmlschema contain the extensions.+                hxt-unicode contains encoding and decoding functions,+                hxt-charproperties char properties for unicode and XML.+                Changes from 9.3.1.21: ghc-9.0 compatibility+                .+                Changes from 9.3.1.20: ghc 8.10 and 9.0 compatibility, tuple picker up to 24-tuples, Either instance for xpickle+                .+                Changes from 9.3.1.19: ghc-8.8.2 compatibility+                .+                Changes from 9.3.1.15: Bug in quoting PI instructions in showXmlTrees fixed+                .+                Changes from 9.3.1.14: For ghc-7.10 network-uri is automatically selected +                .+                Changes from 9.3.1.13: ghc-7.10 compatibility+                .+                Changes from 9.3.1.12: Bug when unpickling an empty attribute value removed+                .+                Changes from 9.3.1.11: Bug fix in haddock comments+                .+                Changes from 9.3.1.10: Bug in DTD validation, space and time leak in delta removed+                .+                Changes from 9.3.1.9: lower bound of mtl dependency lowered to 2.0.1+                .+                Changes from 9.3.1.8: Bug in hread removed+                .+                Changes from 9.3.1.7: Foldable and Traversable instances for NTree added+                Control.Except used instead of deprecated Control.Error+                .+                Changes from 9.3.1.6: canonicalize added in hread and hreadDoc+                .+                Changes from 9.3.1.4: conditionally (no default)+                dependency from networt changed to network-uri with flag "network-uri"+                .+                Changes from 9.3.1.3: warnings from ghc-7.8.1 removed+                .+                Changes from 9.3.1.2: https as protocol added+                .+                Changes from 9.3.1.1: new parser xreadDoc+                .+                Changes from 9.3.1.0: in readString all input decoding switched off+                .+                Changes from 9.3.0.1: lower bound for network set to be >= 2.4+                .+                Changes from 9.3.0: upper bound for network set to be < 2.4+                (URI signatures changed in 2.4)+                .+                Changes from 9.2.2: XMLSchema validation integrated+                .+                Changes from 9.2.1: user defined mime type handlers added+                .+                Changes from 9.2.0: New warnings from ghc-7.4 removed+License:        MIT License-file:   LICENSE Author:         Uwe Schmidt, Martin Schmidt, Torben Kuseler Maintainer:     Uwe Schmidt <uwe@fh-wedel.de> Stability:      Stable Category:       XML-Homepage:       http://www.fh-wedel.de/~si/HXmlToolbox/index.html-Copyright:      Copyright (c) 2005-2010 Uwe Schmidt+Homepage:       https://github.com/UweSchmidt/hxt+Copyright:      Copyright (c) 2005-2019 Uwe Schmidt Build-type:     Simple-Cabal-version:  >=1.6+Cabal-version:  >=1.10  extra-source-files:  examples/arrows/absurls/AbsURIs.hs@@ -45,6 +97,7 @@  examples/arrows/HelloWorld/Mini.hs  examples/arrows/hparser/emptyElements.html  examples/arrows/hparser/example1.xml+ examples/arrows/hparser/example1CRLF.xml  examples/arrows/hparser/HXmlParser.hs  examples/arrows/hparser/invalid1.xml  examples/arrows/hparser/invalid2.rng@@ -56,42 +109,56 @@  examples/arrows/hparser/namespace1.xml  examples/arrows/hparser/valid1.rng  examples/arrows/hparser/valid1.xml- examples/arrows/hrelaxng/.ghci- examples/arrows/hrelaxng/HRelaxNG.hs- examples/arrows/hrelaxng/invalid1.xml- examples/arrows/hrelaxng/invalid2.rng- examples/arrows/hrelaxng/invalid3.rng- examples/arrows/hrelaxng/Makefile- examples/arrows/hrelaxng/valid1.rng- examples/arrows/hrelaxng/valid1.xml- examples/arrows/hrelaxng/valid2.rng- examples/arrows/hrelaxng/valid2.xml  examples/arrows/performance/GenDoc.hs  examples/arrows/performance/Makefile  examples/arrows/pickle/Makefile  examples/arrows/pickle/PickleTest.hs- examples/arrows/RegexXMLSchema/Makefile- examples/arrows/RegexXMLSchema/REtest.hs+ examples/xhtml/tmp.xml+ examples/xhtml/xhtml1-frameset.dtd+ examples/xhtml/xhtml1-strict.dtd+ examples/xhtml/xhtml1-transitional.dtd+ examples/xhtml/xhtml-lat1.ent+ examples/xhtml/xhtml-special.ent+ examples/xhtml/xhtml-symbol.ent+ examples/xhtml/xhtml.xml +flag network-uri+  description: Get Network.URI from the network-uri package,+               with ghc <  7.10 default is False,+               with ghc >= 7.10 default is True +  default: False++flag profile+  description: turn profiling on+  default: False+                                           library  exposed-modules:+  Control.Arrow.ArrowExc,   Control.Arrow.ArrowIO,   Control.Arrow.ArrowIf,   Control.Arrow.ArrowList,   Control.Arrow.ArrowNF,+  Control.Arrow.ArrowNavigatableTree,   Control.Arrow.ArrowState,   Control.Arrow.ArrowTree,   Control.Arrow.IOListArrow,   Control.Arrow.IOStateListArrow,   Control.Arrow.ListArrow,   Control.Arrow.ListArrows,+  Control.Arrow.NTreeEdit,   Control.Arrow.StateListArrow,+  Control.FlatSeq,   Data.AssocList,   Data.Atom,-  Data.Char.UTF8,+  Data.Function.Selector,   Data.Tree.Class,   Data.Tree.NTree.TypeDefs,-  Text.XML.HXT.Arrow,+  Data.Tree.NTree.Edit,+  Data.Tree.NTree.Zipper.TypeDefs,+  Data.Tree.NavigatableTree.Class,+  Data.Tree.NavigatableTree.XPathAxis,+  Text.XML.HXT.Arrow.Binary,   Text.XML.HXT.Arrow.DTDProcessing,   Text.XML.HXT.Arrow.DocumentInput,   Text.XML.HXT.Arrow.DocumentOutput,@@ -107,22 +174,27 @@   Text.XML.HXT.Arrow.ReadDocument,   Text.XML.HXT.Arrow.WriteDocument,   Text.XML.HXT.Arrow.XmlArrow,-  Text.XML.HXT.Arrow.XmlIOStateArrow,+  Text.XML.HXT.Arrow.XmlOptions,   Text.XML.HXT.Arrow.XmlRegex,+  Text.XML.HXT.Arrow.XmlState,+  Text.XML.HXT.Arrow.XmlState.ErrorHandling,+  Text.XML.HXT.Arrow.XmlState.MimeTypeTable,+  Text.XML.HXT.Arrow.XmlState.RunIOStateArrow,+  Text.XML.HXT.Arrow.XmlState.TraceHandling,+  Text.XML.HXT.Arrow.XmlState.TypeDefs,+  Text.XML.HXT.Arrow.XmlState.URIHandling,+  Text.XML.HXT.Arrow.XmlState.SystemConfig,+  Text.XML.HXT.Core,   Text.XML.HXT.DOM.FormatXmlTree,   Text.XML.HXT.DOM.Interface,-  Text.XML.HXT.DOM.IsoLatinTables,   Text.XML.HXT.DOM.MimeTypeDefaults,   Text.XML.HXT.DOM.MimeTypes,   Text.XML.HXT.DOM.QualifiedName,   Text.XML.HXT.DOM.ShowXml,   Text.XML.HXT.DOM.TypeDefs,-  Text.XML.HXT.DOM.UTF8Decoding,-  Text.XML.HXT.DOM.Unicode,   Text.XML.HXT.DOM.Util,   Text.XML.HXT.DOM.XmlKeywords,   Text.XML.HXT.DOM.XmlNode,-  Text.XML.HXT.DOM.XmlOptions,   Text.XML.HXT.DTDValidation.AttributeValueValidation,   Text.XML.HXT.DTDValidation.DTDValidation,   Text.XML.HXT.DTDValidation.DocTransformation,@@ -133,10 +205,8 @@   Text.XML.HXT.DTDValidation.Validation,   Text.XML.HXT.DTDValidation.XmlRE,   Text.XML.HXT.IO.GetFILE,-  Text.XML.HXT.IO.GetHTTPLibCurl,   Text.XML.HXT.Parser.HtmlParsec,   Text.XML.HXT.Parser.ProtocolHandlerUtil,-  Text.XML.HXT.Parser.TagSoup,   Text.XML.HXT.Parser.XhtmlEntities,   Text.XML.HXT.Parser.XmlCharParser,   Text.XML.HXT.Parser.XmlDTDParser,@@ -144,44 +214,41 @@   Text.XML.HXT.Parser.XmlEntities,   Text.XML.HXT.Parser.XmlParsec,   Text.XML.HXT.Parser.XmlTokenParser,-  Text.XML.HXT.RelaxNG,-  Text.XML.HXT.RelaxNG.BasicArrows,-  Text.XML.HXT.RelaxNG.CreatePattern,-  Text.XML.HXT.RelaxNG.DataTypeLibMysql,-  Text.XML.HXT.RelaxNG.DataTypeLibUtils,-  Text.XML.HXT.RelaxNG.DataTypeLibraries,-  Text.XML.HXT.RelaxNG.DataTypes,-  Text.XML.HXT.RelaxNG.PatternFunctions,-  Text.XML.HXT.RelaxNG.PatternToString,-  Text.XML.HXT.RelaxNG.Schema,-  Text.XML.HXT.RelaxNG.SchemaGrammar,-  Text.XML.HXT.RelaxNG.Simplification,-  Text.XML.HXT.RelaxNG.Unicode.Blocks,-  Text.XML.HXT.RelaxNG.Unicode.CharProps,-  Text.XML.HXT.RelaxNG.Utils,-  Text.XML.HXT.RelaxNG.Validation,-  Text.XML.HXT.RelaxNG.Validator,-  Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C,-  Text.XML.HXT.RelaxNG.XmlSchema.Regex,-  Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch,-  Text.XML.HXT.RelaxNG.XmlSchema.RegexParser,+  Text.XML.HXT.XMLSchema.DataTypeLibW3CNames,   Text.XML.HXT.Version + default-language: Haskell2010+  hs-source-dirs: src - ghc-options: -Wall+ ghc-options: -Wall -fwarn-tabs - extensions: MultiParamTypeClasses DeriveDataTypeable FunctionalDependencies FlexibleInstances+ if flag(profile)+   ghc-prof-options: -caf-all - build-depends: base       >= 4   && < 5,-                haskell98  >= 1   && < 2,-                containers >= 0.2 && < 1,-                directory  >= 1   && < 2,-                filepath   >= 1   && < 2,-                parsec     >= 2.1 && < 4,-                HUnit      >= 1.2 && < 2,-                network    >= 2.1 && < 3,-                deepseq    >= 1.1 && < 2,-                bytestring >= 0.9 && < 1,-                tagsoup    >= 0.10 && < 0.11,-                curl       >= 1.3 && < 2+ default-extensions: MultiParamTypeClasses DeriveDataTypeable FunctionalDependencies FlexibleInstances CPP++ build-depends: base       >= 4     && < 5,+                containers >= 0.2,+                directory  >= 1,+                filepath   >= 1,+                parsec     >= 2.1   && < 4,+                mtl        >= 2.0.1 && < 3,+                deepseq    >= 1.1,+                bytestring >= 0.9,+                binary     >= 0.5,+                hxt-charproperties  >= 9.1,+                hxt-unicode         >= 9.0.1,+                hxt-regex-xmlschema >= 9.2++ if flag(network-uri)+   build-depends: network-uri >= 2.6+ else+   if impl(ghc >= 7.10)+     build-depends: network-uri >= 2.6+   else+     build-depends: network >= 2.4 && < 2.6++Source-Repository head+  Type:     git+  Location: git://github.com/UweSchmidt/hxt.git
+ src/Control/Arrow/ArrowExc.hs view
@@ -0,0 +1,38 @@+-- ------------------------------------------------------------++{- |+   Module     : Control.Arrow.ArrowExc+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: not portable++   The exception arrow class++-}++-- ------------------------------------------------------------++module Control.Arrow.ArrowExc+    ( ArrowExc(..)+    )+where++import           Control.Arrow+import           Control.Arrow.ArrowIO++import           Control.Exception      ( SomeException+                                        )++class (Arrow a, ArrowChoice a, ArrowZero a, ArrowIO a) => ArrowExc a where+    tryA        :: a b c -> a b (Either SomeException c)++    catchA      :: a b c -> a SomeException c -> a b c+    catchA f h  = tryA f+                  >>>+                  ( h ||| returnA )+++-- ------------------------------------------------------------
src/Control/Arrow/ArrowIO.hs view
@@ -8,9 +8,8 @@    Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)    Stability  : experimental    Portability: portable-   Version    : $Id: ArrowIO.hs,v 1.6 2005/09/02 17:09:39 hxml Exp $ -Lifting of IO actions to arrows+  Lifting of IO actions to arrows  -} @@ -34,6 +33,7 @@     -- | construct an arrow from an IO action without any parameter     arrIO0              :: IO c -> a b c     arrIO0 f            = arrIO (const f)+    {-# INLINE arrIO0 #-}      -- | construction of a 2 argument arrow from a binary IO action     -- |@@ -41,6 +41,7 @@      arrIO2              :: (b1 -> b2 -> IO c) -> a (b1, b2) c     arrIO2 f            = arrIO (\ ~(x1, x2) -> f x1 x2)+    {-# INLINE arrIO2 #-}      -- | construction of a 3 argument arrow from a 3-ary IO action     -- |@@ -48,6 +49,7 @@      arrIO3              :: (b1 -> b2 -> b3 -> IO c) -> a (b1, (b2, b3)) c     arrIO3 f            = arrIO (\ ~(x1, ~(x2, x3)) -> f x1 x2 x3)+    {-# INLINE arrIO3 #-}      -- | construction of a 4 argument arrow from a 4-ary IO action     -- |@@ -55,6 +57,7 @@      arrIO4              :: (b1 -> b2 -> b3 -> b4 -> IO c) -> a (b1, (b2, (b3, b4))) c     arrIO4 f            = arrIO (\ ~(x1, ~(x2, ~(x3, x4))) -> f x1 x2 x3 x4)+    {-# INLINE arrIO4 #-}   -- | the interface for converting an IO predicate into a list arrow
src/Control/Arrow/ArrowIf.hs view
@@ -8,14 +8,12 @@    Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)    Stability  : experimental    Portability: portable-   Version    : $Id: ArrowIf.hs,v 1.8 2006/05/04 14:17:53 hxml Exp $ -Conditionals for List Arrows--This module defines conditional combinators for list arrows.+   Conditionals for List Arrows -The empty list as result represents False, none empty lists True.+   This module defines conditional combinators for list arrows. +   The empty list as result represents False, none empty lists True. -}  -- ------------------------------------------------------------@@ -49,46 +47,55 @@      ifP                 :: (b -> Bool) -> a b d -> a b d -> a b d     ifP p               = ifA (isA p)+    {-# INLINE ifP #-}      -- | negation: @ neg f = ifA f none this @      neg                 :: a b c -> a b b     neg f               = ifA f none this+    {-# INLINE neg #-}      -- | @ f \`when\` g @ : when the predicate g holds, f is applied, else the identity filter this      when                :: a b b -> a b c -> a b b     f `when` g          = ifA g f this+    {-# INLINE when #-}      -- | shortcut: @ f \`whenP\` p = f \`when\` (isA p) @      whenP               :: a b b -> (b -> Bool) -> a b b     f `whenP` g         = ifP g f this+    {-# INLINE whenP #-}      -- | @ f \`whenNot\` g @ : when the predicate g does not hold, f is applied, else the identity filter this      whenNot             :: a b b -> a b c -> a b b     f `whenNot` g       = ifA g this f+    {-# INLINE whenNot #-}      -- | like 'whenP'      whenNotP            :: a b b -> (b -> Bool) -> a b b     f `whenNotP` g      = ifP g this f+    {-# INLINE whenNotP #-}      -- | @ g \`guards\` f @ : when the predicate g holds, f is applied, else none      guards              :: a b c -> a b d -> a b d     f `guards` g        = ifA f g none+    {-# INLINE guards #-}      -- | like 'whenP'      guardsP             :: (b -> Bool) -> a b d -> a b d     f `guardsP` g       = ifP f g none+    {-# INLINE guardsP #-}      -- | shortcut for @ f `guards` this @      filterA             :: a b c -> a b b     filterA f           = ifA f this none+    {-# INLINE filterA #-}      -- | @ f \`containing\` g @ : keep only those results from f for which g holds     --@@ -96,6 +103,7 @@      containing          :: a b c -> a c d -> a b c     f `containing` g    = f >>> g `guards` this+    {-# INLINE containing #-}      -- | @ f \`notContaining\` g @ : keep only those results from f for which g does not hold     --@@ -103,6 +111,7 @@      notContaining       :: a b c -> a c d -> a b c     f `notContaining` g = f >>> ifA g none this+    {-# INLINE notContaining #-}      -- | @ f \`orElse\` g @ : directional choice: if f succeeds, the result of f is the result, else g is applied     orElse              :: a b c -> a b c -> a b c
src/Control/Arrow/ArrowList.hs view
@@ -8,17 +8,18 @@    Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)    Stability  : experimental    Portability: portable-   Version    : $Id: ArrowList.hs,v 1.11 2006/06/01 12:59:04 hxml Exp $ -The List Arrow Class+   The list arrow class -This module defines the interface for list arrows.+   This module defines the interface for list arrows. -A list arrow is a function, that gives a list of results-for a given argument. A single element result represents a normal function.-An empty list oven indicates, the function is undefined for the given argument.-The empty list may also represent False, none empty lists True.-A list with more than one element gives all results for a nondeterministic function.+   A list arrow is a function that gives a list of results+   for a given argument. A single element result represents a normal function.+   An empty list often indicates that the function is undefined+   for the given argument.+   The empty list may also represent False, non-empty lists True.+   A list with more than one element gives all results for a+   so called nondeterministic function.  -} @@ -40,7 +41,7 @@  -- | The interface for list arrows ----- Only 'mkA', 'arr2A', 'isA' '(>>.)' don't have default implementations+-- Only 'mkA', 'isA' '(>>.)' don't have default implementations  class (Arrow a, ArrowPlus a, ArrowZero a, ArrowApply a) => ArrowList a where @@ -50,6 +51,7 @@      arr2                :: (b1 -> b2 -> c) -> a (b1, b2) c     arr2                = arr . uncurry+    {-# INLINE arr2 #-}      -- | construction of a 3 argument arrow from a 3-ary function     -- |@@ -57,6 +59,7 @@      arr3                :: (b1 -> b2 -> b3 -> c) -> a (b1, (b2, b3)) c     arr3 f              = arr (\ ~(x1, ~(x2, x3)) -> f x1 x2 x3)+    {-# INLINE arr3 #-}      -- | construction of a 4 argument arrow from a 4-ary function     -- |@@ -64,10 +67,13 @@      arr4                :: (b1 -> b2 -> b3 -> b4 -> c) -> a (b1, (b2, (b3, b4))) c     arr4 f              = arr (\ ~(x1, ~(x2, ~(x3, x4))) -> f x1 x2 x3 x4)+    {-# INLINE arr4 #-}      -- | construction of a 2 argument arrow from a singe argument arrow      arr2A               :: (b -> a c d) -> a (b, c) d+    arr2A f             = first (arr f) >>> app+    {-# INLINE arr2A #-}      -- | constructor for a list arrow from a function with a list as result @@ -77,16 +83,19 @@      arr2L               :: (b -> c -> [d]) -> a (b, c) d     arr2L               = arrL . uncurry+    {-# INLINE arr2L #-}      -- | constructor for a const arrow: @ constA = arr . const @      constA              :: c -> a b c     constA              = arr . const+    {-# INLINE constA #-}      -- | constructor for a const arrow: @ constL = arrL . const @      constL              :: [c] -> a b c     constL              = arrL . const+    {-# INLINE constL #-}      -- | builds an arrow from a predicate.     -- If the predicate holds, the single list containing the input is returned, else the empty list@@ -105,6 +114,7 @@      (>.)                :: a b c -> ([c] ->  d ) -> a b d     af >. f             = af >>. ((:[]) . f)+    {-# INLINE (>.) #-}      -- | combinator for converting an arrow into a determinstic version with all results collected in a single element list     --@@ -120,6 +130,7 @@      listA               :: a b c -> a b [c]     listA af            = af >>.  (:[])+    {-# INLINE listA #-}      -- | the inverse of 'listA'     --@@ -129,16 +140,19 @@      unlistA             :: a [b] b     unlistA             = arrL id+    {-# INLINE unlistA #-}      -- | the identity arrow, alias for returnA      this                :: a b b     this                = returnA+    {-# INLINE this #-}      -- | the zero arrow, alias for zeroArrow      none                :: a b c     none                = zeroArrow+    {-# INLINE none #-}      -- | converts an arrow, that may fail, into an arrow that always succeeds     --@@ -146,6 +160,7 @@      withDefault         :: a b c -> c -> a b c     withDefault a d     = a >>. \ x -> if null x then [d] else x+    {-# INLINE withDefault #-}      -- | makes a list arrow deterministic, the number of results is at most 1     --@@ -328,6 +343,7 @@      perform             :: a b c -> a b b     perform f           = listA f &&& this >>> arr snd+    {-# INLINE perform #-}      -- | generalization of arrow combinator '<+>'     --@@ -335,6 +351,7 @@      catA                :: [a b c] -> a b c     catA                = foldl (<+>) none+    {-# INLINE catA #-}      -- | generalization of arrow combinator '>>>'     --@@ -342,5 +359,6 @@      seqA                :: [a b b] -> a b b     seqA                = foldl (>>>) this+    {-# INLINE seqA #-}  -- ------------------------------------------------------------
src/Control/Arrow/ArrowNF.hs view
@@ -2,7 +2,7 @@  {- |    Module     : Control.Arrow.ArrowNF-   Copyright  : Copyright (C) 2005-8 Uwe Schmidt+   Copyright  : Copyright (C) 2011 Uwe Schmidt    License    : MIT     Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)@@ -18,9 +18,12 @@ module Control.Arrow.ArrowNF where -import Control.Arrow-import Control.DeepSeq+import           Control.Arrow+import           Control.Arrow.ArrowList +import           Control.DeepSeq+import           Control.FlatSeq+ -- | -- complete evaluation of an arrow result using 'Control.DeepSeq' --@@ -32,7 +35,27 @@ strictA = arr $ \ x -> deepseq x x  class (Arrow a) => ArrowNF a where-    rnfA        :: (NFData c) => a b c -> a b c-    rnfA f      = f >>> strictA+    rnfA                        :: (NFData c) => a b c -> a b c+    rnfA f                      = f >>^ (\ x -> deepseq x x)+    {-# INLINE rnfA #-}++-- |+-- partial evaluation of an arrow result using 'Control.FlatSeq'+--+-- There are two arrows with force the partial evaluation. By convention+-- the 2. should be less lazy than the 1.+--+-- These arrows are sometimes useful for preventing space leaks, especially when parsing+-- complex data structures. In many cases the evaluated AST is more space efficient+-- than the unevaluaded with a lot of closures.++class (Arrow a, ArrowList a) => ArrowWNF a where+    rwnfA                       :: (WNFData c) => a b c -> a b c+    rwnfA f                     = f >>. \ x -> rlnf rwnf x `seq` x+    {-# INLINE rwnfA #-}++    rwnf2A                      :: (WNFData c) => a b c -> a b c+    rwnf2A f                    = f >>. \ x -> rlnf rwnf2 x `seq` x+    {-# INLINE rwnf2A #-}  -- ------------------------------------------------------------
+ src/Control/Arrow/ArrowNavigatableTree.hs view
@@ -0,0 +1,313 @@+-- ------------------------------------------------------------++{- |+   Module     : Control.Arrow.ArrowNavigatableTree+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   List arrows for navigatable trees++   Trees that implement the "Data.Tree.NavigatableTree.Class" interface, can be processed+   with these arrows.+-}++-- ------------------------------------------------------------++module Control.Arrow.ArrowNavigatableTree+where++import           Control.Arrow+import           Control.Arrow.ArrowList+import           Control.Arrow.ArrowIf++import           Data.Maybe++import           Data.Tree.NavigatableTree.Class        ( NavigatableTree+                                                        , NavigatableTreeToTree+                                                        , NavigatableTreeModify+                                                        )+import qualified Data.Tree.NavigatableTree.Class        as T+import qualified Data.Tree.NavigatableTree.XPathAxis    as T++-- ------------------------------------------------------------++-- | The interface for navigatable tree arrows+--+-- all functions have default implementations++class (ArrowList a) => ArrowNavigatableTree a where++    -- move one step towards the root+    moveUp              :: NavigatableTree t => a (t b) (t b)+    moveUp              = arrL $ maybeToList . T.mvUp++    -- descend one step to the leftmost child+    moveDown            :: NavigatableTree t => a (t b) (t b)+    moveDown            = arrL $ maybeToList . T.mvDown++    -- move to the left neighbour+    moveLeft            :: NavigatableTree t => a (t b) (t b)+    moveLeft            = arrL $ maybeToList . T.mvLeft++    -- move to the right neighbour+    moveRight           :: NavigatableTree t => a (t b) (t b)+    moveRight           = arrL $ maybeToList . T.mvRight++-- derived functions++parentAxis              :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+parentAxis              = arrL T.parentAxis++-- | XPath axis: ancestor++ancestorAxis            :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+ancestorAxis            = arrL T.ancestorAxis++-- | XPath axis: ancestor or self++ancestorOrSelfAxis      :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+ancestorOrSelfAxis      = arrL T.ancestorOrSelfAxis++-- | XPath axis: child++childAxis               :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+childAxis               = arrL T.childAxis++-- | XPath axis: descendant++descendantAxis          :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+descendantAxis          = arrL T.descendantAxis++-- | XPath axis: descendant or self++descendantOrSelfAxis    :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+descendantOrSelfAxis    = arrL T.descendantOrSelfAxis++-- | not an XPath axis but useful: descendant or following++descendantOrFollowingAxis    :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+descendantOrFollowingAxis    = descendantAxis <+> followingAxis++-- | not an official XPath axis but useful: reverse descendant or self, used in preceding axis++revDescendantOrSelfAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+revDescendantOrSelfAxis = arrL T.revDescendantOrSelfAxis++-- | XPath axis: following sibling++followingSiblingAxis    :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+followingSiblingAxis    = arrL T.followingSiblingAxis++-- | XPath axis: preceeding sibling++precedingSiblingAxis    :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+precedingSiblingAxis    = arrL T.precedingSiblingAxis++-- | XPath axis: self++selfAxis                :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+selfAxis                = arrL T.selfAxis++-- | XPath axis: following++followingAxis           :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+followingAxis           = arrL T.followingAxis++-- | XPath axis: preceding++precedingAxis           :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+precedingAxis           = arrL T.precedingAxis++-- ------------------------------------------------------------++-- | move to the root++moveToRoot              :: (Arrow a, NavigatableTree t) => a (t b) (t b)+moveToRoot              = arr T.mvToRoot++isAtRoot                :: (ArrowList a, NavigatableTree t) => a (t b) (t b)+isAtRoot                = isA (null . T.ancestorAxis)++-- ------------------------------------------------------------++-- | Conversion from a tree into a navigatable tree++addNav                  :: ( ArrowList a+                           , NavigatableTreeToTree nt t+                           ) =>+                           a (t b) (nt b)+addNav                  = arr T.fromTree+++-- | Conversion from a navigatable tree into an ordinary tree++remNav                  :: ( ArrowList a+                           , NavigatableTreeToTree nt t+                           ) =>+                           a (nt b) (t b)+remNav                  = arr T.toTree++-- | apply an operation using navigation to an ordinary tree+--+-- This root and all children may be visited in arbitrary order++withNav                 :: ( ArrowList a+                           , NavigatableTreeToTree nt t+                           ) =>+                           a (nt b) (nt c) -> a (t b) (t c)+withNav f               = addNav >>> f >>> remNav+++-- | apply a simple operation without use of navigation to a navigatable tree+--+-- This enables to apply arbitrary tree operations to navigatable trees++withoutNav              :: ( ArrowList a+                           , NavigatableTreeToTree nt t+                           , NavigatableTreeModify nt t+                           ) =>+                           a (t b) (t b) -> a (nt b) (nt b)+withoutNav f            = ( (remNav >>> f)                      -- apply the simple arrow to the tree+                            &&&+                            this                                -- remember the navigation context+                          )+                          >>> arr (uncurry T.substThisTree)             -- resore the context+                             +-- ------------------------------------------------------------++-- | Filter an axis with an ordinary tree predicate+--+-- Example: In a tree of Ints find all nodes in the subtrees (in preorder) that have label 42+--+-- > descendantAxis >>> filterAxis (hasNode (== 42))+--+-- Example: In an XML Tree find the following nodes of a node with attribute id and value 42+--+-- > descendantAxis >>> filterAxis (hasAttrValue "id" (=="42")) >>> followingAxis++filterAxis              :: ( ArrowIf a+                           , NavigatableTreeToTree nt t+                           ) =>+                           a (t b) c -> a (nt b) (nt b)++filterAxis p            = (remNav >>> p) `guards` this+{-# INLINE filterAxis #-}+++-- | Move to the next tree on a given axis. Deterministic arrow+--+-- Example: Move to the next node in a preorder visit: next child or else next following+--+-- > moveOn descendantOrFollowingAxis++moveOn                  :: ( ArrowList a+                           , NavigatableTree t+                           ) =>+                           a (t b) (t b) -> a (t b) (t b)+moveOn axis             = single $ axis+{-# INLINE moveOn #-}++-- ------------------------------------------------------------++-- | Change the current subtree of a navigatable tree.+--+-- The arrow for computing the changes should be deterministic. If it fails+-- nothing is changed.++changeThisTree          :: ( ArrowList a+                           , ArrowIf a+                           , NavigatableTreeToTree nt t+                           , NavigatableTreeModify nt t+                           ) =>+                           a (t b) (t b) -> a (nt b) (nt b)+changeThisTree cf       = withoutNav $ single cf `orElse` this++-- | Substitute the current subtree of a navigatable tree by a given tree++substThisTree           :: ( ArrowList a+                           , ArrowIf a+                           , NavigatableTreeToTree nt t+                           , NavigatableTreeModify nt t+                           ) =>+                           t b -> a (nt b) (nt b)+substThisTree t         = changeThisTree (constA t)++-- ------------------------------------------------------------++-- | apply an ordinary arrow to the current subtree of a navigatabe tree and add the result trees in front of the current tree.+--+-- If this arrow is applied to the root, it will fail, because we want a tree as result, not a forest.++addToTheLeft            :: ( ArrowList a+                           , NavigatableTreeToTree nt t+                           , NavigatableTreeModify nt t+                           ) =>+                           a (t b) (t b) -> a (nt b) (nt b)+addToTheLeft            = addToOneSide $+                          foldl (\ acc t -> acc >>= T.addTreeLeft t)+{-# INLINE addToTheLeft #-}++-- | apply an ordinary arrow to the current subtree of a navigatabe tree and add the result trees behind the current tree.+--+-- If this arrow is applied to the root, it will fail, because we want a tree as result, not a forest.++addToTheRight           :: ( ArrowList a+                           , NavigatableTreeToTree nt t+                           , NavigatableTreeModify nt t+                           ) =>+                           a (t b) (t b) -> a (nt b) (nt b)+addToTheRight           = addToOneSide $+                          foldr (\ t acc -> acc >>= T.addTreeRight t)+{-# INLINE addToTheRight #-}+++-- | addToOneSide does the real work for 'addToTheLeft' and 'addToTheRight'++addToOneSide            :: ( ArrowList a+                           , NavigatableTreeToTree nt t+                           , NavigatableTreeModify nt t+                           ) =>+                           ( Maybe (nt b) -> [t b] -> Maybe (nt b) ) ->+                           a (t  b) (t  b) ->+                           a (nt b) (nt b)+addToOneSide side f     = ( ( remNav >>> listA f )+                            &&&+                            this+                          )+                          >>>+                          arrL ( uncurry (\ ts nt -> side (Just nt) ts)+                                 >>>+                                 maybeToList+                               )++-- ------------------------------------------------------------++-- | drop the direct left sibling tree of the given navigatable tree+--+-- If this arrow is applied to the root or a leftmost tree, it will fail, because there is nothing to remove++dropFromTheLeft         :: ( ArrowList a+                           -- , NavigatableTreeToTree nt t+                           , NavigatableTreeModify nt t+                           ) =>+                           a (nt b) (nt b)+dropFromTheLeft            = arrL $ T.dropTreeLeft >>> maybeToList+{-# INLINE dropFromTheLeft #-}++-- | drop the direct left sibling tree of the given navigatable tree+--+-- If this arrow is applied to the root or a rightmost tree, it will fail, because there is nothing to remove++dropFromTheRight        :: ( ArrowList a+                           , NavigatableTreeModify nt t+                           ) =>+                           a (nt b) (nt b)+dropFromTheRight            = arrL $ T.dropTreeRight >>> maybeToList+{-# INLINE dropFromTheRight #-}++-- ------------------------------------------------------------+
src/Control/Arrow/ArrowState.hs view
@@ -9,7 +9,7 @@     Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)    Stability  : experimental-   Portability: multy parameter classes and functional depenedencies required+   Portability: multi parameter classes and functional depenedencies required     Arrows for managing an explicit state @@ -50,12 +50,14 @@      getState            :: a b s     getState            = accessState (\ s _x -> s)+    {-# INLINE getState #-}      -- | overwrite the old state     --     -- definition: @ setState = changeState (\\ s x -> x) @     setState            :: a s s     setState            = changeState (\ _s x -> x)     -- changeState (const id)+    {-# INLINE setState #-}      -- | change state (and ignore input) and return new state     --
src/Control/Arrow/ArrowTree.hs view
@@ -2,19 +2,17 @@  {- |    Module     : Control.Arrow.ArrowTree-   Copyright  : Copyright (C) 2005 Uwe Schmidt+   Copyright  : Copyright (C) 2010 Uwe Schmidt    License    : MIT     Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)-   Stability  : experimental+   Stability  : stable    Portability: portable-   Version    : $Id: ArrowTree.hs,v 1.12 2006/11/30 16:05:24 hxml Exp $ -List arrows for tree processing.--Trees that implement the "Data.Tree.Class" interface, can be processed-with these arrows.+   List arrows for tree processing. +   Trees that implement the "Data.Tree.Class" interface, can be processed+   with these arrows. -}  -- ------------------------------------------------------------@@ -46,41 +44,55 @@      mkLeaf              :: Tree t => b -> a c (t b)     mkLeaf              = constA . T.mkLeaf+    {-# INLINE mkLeaf #-}      -- | construct an inner node      mkTree              :: Tree t => b -> [t b] -> a c (t b)     mkTree n            = constA . T.mkTree n+    {-# INLINE mkTree #-}      -- | select the children of the root of a tree      getChildren         :: Tree t => a (t b) (t b)     getChildren         = arrL T.getChildren+    {-# INLINE getChildren #-} -    -- | select the attribute of the root of a tree+    -- | select the node info of the root of a tree      getNode             :: Tree t => a (t b) b     getNode             = arr T.getNode+    {-# INLINE getNode #-} +    -- | select the attribute of the root of a tree++    hasNode             :: Tree t => (b -> Bool) -> a (t b) (t b)+    hasNode p           = (getNode >>> isA p) `guards` this+    {-# INLINE hasNode #-}+     -- | substitute the children of the root of a tree      setChildren         :: Tree t =>            [t b] -> a (t b) (t b)     setChildren cs      = arr (T.setChildren cs)+    {-# INLINE setChildren #-}      -- | substitute the attribute of the root of a tree      setNode             :: Tree t =>                b -> a (t b) (t b)     setNode n           = arr (T.setNode n)+    {-# INLINE setNode #-}      -- | edit the children of the root of a tree      changeChildren      :: Tree t => ([t b] -> [t b]) -> a (t b) (t b)     changeChildren csf  = arr (T.changeChildren csf)+    {-# INLINE changeChildren #-}      -- | edit the attribute of the root of a tree      changeNode          :: Tree t =>        (b  -> b) -> a (t b) (t b)     changeNode nf       = arr (T.changeNode nf)+    {-# INLINE changeNode #-}                                                                  -- compound arrows @@ -124,6 +136,7 @@      (/>)                :: Tree t => a b (t c) -> a (t c) d -> a b d     f /> g              = f >>> getChildren >>> g+    {-# INLINE (/>) #-}      -- |     -- pronounced \"double slash\", meaning g arbitrarily deep inside f@@ -134,12 +147,13 @@     --     -- This expression selects     -- all top level \"table\" elements within an \"html\" element, an expression.-    -- Attantion: This does not correspond+    -- Attention: This does not correspond     -- to the XPath selection path \"html\/\/table\". The latter on matches all table elements     -- even nested ones, but @\/\/>@ gives in many cases the appropriate functionality.      (//>)               :: Tree t => a b (t c) -> a (t c) d -> a b d     f //> g             = f >>> getChildren >>> deep g+    {-# INLINE (//>) #-}       -- |@@ -149,6 +163,7 @@      (</)                :: Tree t => a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)     f </ g              = f `containing` (getChildren >>> g)+    {-# INLINE (</) #-}       -- | recursively searches a whole tree for subtrees, for which a predicate holds.@@ -181,7 +196,7 @@     -- The search is performed top down. All nodes of the tree are searched, even within the     -- subtrees of trees for which the predicate holds.     ---    -- example: @ multy isHtmlTable @ selects all table elements, even nested ones.+    -- example: @ multi isHtmlTable @ selects all table elements, even nested ones.      multi               :: Tree t => a (t b) c -> a (t b) c     multi f             = f                                     -- combine result for root
src/Control/Arrow/IOListArrow.hs view
@@ -23,14 +23,19 @@  import Control.Category -import           Control.Arrow-import           Control.Arrow.ArrowIf-import           Control.Arrow.ArrowList-import           Control.Arrow.ArrowNF-import           Control.Arrow.ArrowTree-import           Control.Arrow.ArrowIO+import Control.Arrow+import Control.Arrow.ArrowExc+import Control.Arrow.ArrowIf+import Control.Arrow.ArrowIO+import Control.Arrow.ArrowList+import Control.Arrow.ArrowNF+import Control.Arrow.ArrowTree+import Control.Arrow.ArrowNavigatableTree -import           Control.DeepSeq+import Control.DeepSeq+import Control.Exception                ( SomeException+                                        , try+                                        )  -- ------------------------------------------------------------ @@ -117,6 +122,17 @@                                        res <- cmd x                                        return [res] +instance ArrowExc IOLA where+    tryA f              = IOLA $ \ x -> do+                                        res <- try' $ runIOLA f x+                                        return $+                                          case res of+                                          Left  er -> [Left er]+                                          Right ys -> [Right x' | x' <- ys]+        where+        try'            :: IO a -> IO (Either SomeException a)+        try'            = try+ instance ArrowIOIf IOLA where     isIOA p             = IOLA $ \x -> do                                        res <- p x@@ -124,9 +140,14 @@  instance ArrowTree IOLA +instance ArrowNavigatableTree IOLA+ instance ArrowNF IOLA where     rnfA (IOLA f)       = IOLA $ \ x -> do                                         res <- f x-                                        deepseq res $ return res+                                        res `deepseq` return res+++instance ArrowWNF IOLA  -- ------------------------------------------------------------
src/Control/Arrow/IOStateListArrow.hs view
@@ -24,20 +24,27 @@     ) where -import           Prelude hiding (id, (.))--import           Control.Category+import Prelude hiding (id, (.)) -import           Control.Arrow-import           Control.Arrow.ArrowIf-import           Control.Arrow.ArrowIO-import           Control.Arrow.ArrowList-import           Control.Arrow.ArrowNF-import           Control.Arrow.ArrowTree-import           Control.Arrow.ArrowState+import Control.Category -import           Control.DeepSeq+import Control.Arrow+import Control.Arrow.ArrowExc+import Control.Arrow.ArrowIf+import Control.Arrow.ArrowIO+import Control.Arrow.ArrowList+import Control.Arrow.ArrowNF+import Control.Arrow.ArrowTree+import Control.Arrow.ArrowNavigatableTree+import Control.Arrow.ArrowState +import Control.DeepSeq+import Control.Exception                ( SomeException+                                        , try+                                        )+{-+import qualified Debug.Trace as T+-} -- ------------------------------------------------------------  -- | list arrow combined with a state and the IO monad@@ -46,6 +53,7 @@  instance Category (IOSLA s) where     id                  = IOSLA $ \ s x -> return (s, [x])      -- don't defined id = arr id, this gives loops during optimization+    {-# INLINE id #-}      IOSLA g . IOSLA f   = IOSLA $ \ s x -> do                                            (s1, ys) <- f s x@@ -59,6 +67,7 @@  instance Arrow (IOSLA s) where     arr f               = IOSLA $ \ s x -> return (s, [f x])+    {-# INLINE arr #-}      first (IOSLA f)     = IOSLA $ \ s (x1, x2) -> do                                                    (s', ys1) <- f s x1@@ -85,6 +94,7 @@  instance ArrowZero (IOSLA s) where     zeroArrow           = IOSLA $ \ s -> const (return (s, []))+    {-# INLINE zeroArrow #-}   instance ArrowPlus (IOSLA s) where@@ -110,19 +120,27 @@  instance ArrowApply (IOSLA s) where     app                 = IOSLA $ \ s (IOSLA f, x) -> f s x+    {-# INLINE app #-}  instance ArrowList (IOSLA s) where     arrL f              = IOSLA $ \ s x -> return (s, (f x))+    {-# INLINE arrL #-}     arr2A f             = IOSLA $ \ s (x, y) -> runIOSLA (f x) s y+    {-# INLINE arr2A #-}     constA c            = IOSLA $ \ s   -> const (return (s, [c]))+    {-# INLINE constA #-}     isA p               = IOSLA $ \ s x -> return (s, if p x then [x] else [])+    {-# INLINE isA #-}     IOSLA f >>. g       = IOSLA $ \ s x -> do                                            (s1, ys) <- f s x                                            return (s1, g ys)+    {-# INLINE (>>.) #-}+     -- just for efficency     perform (IOSLA f)   = IOSLA $ \ s x -> do                                            (s1, _ys) <- f s x                                            return (s1, [x])+    {-# INLINE perform #-}  instance ArrowIf (IOSLA s) where     ifA (IOSLA p) ta ea = IOSLA $ \ s x -> do@@ -144,15 +162,29 @@     arrIO cmd           = IOSLA $ \ s x -> do                                            res <- cmd x                                            return (s, [res])+    {-# INLINE arrIO #-} +instance ArrowExc (IOSLA s) where+    tryA f              = IOSLA $ \ s x -> do+                                           res <- try' $ runIOSLA f s x+                                           return $ case res of+                                              Left   er      -> (s,  [Left er])+                                              Right (s1, ys) -> (s1, [Right x' | x' <- ys])+        where+        try'            :: IO a -> IO (Either SomeException a)+        try'            = try+ instance ArrowIOIf (IOSLA s) where     isIOA p             = IOSLA $ \ s x -> do                                            res <- p x                                            return (s, if res then [x] else [])+    {-# INLINE isIOA #-}  instance ArrowState s (IOSLA s) where     changeState cf      = IOSLA $ \ s x -> let s' = cf s x in return (seq s' s', [x])+    {-# INLINE changeState #-}     accessState af      = IOSLA $ \ s x -> return (s, [af s x])+    {-# INLINE accessState #-}  -- ------------------------------------------------------------ @@ -186,9 +218,19 @@  instance ArrowTree (IOSLA s) -instance (NFData s) => ArrowNF (IOSLA s) where+instance ArrowNavigatableTree (IOSLA s)++instance ArrowNF (IOSLA s) where     rnfA (IOSLA f)      = IOSLA $ \ s x -> do                                            res <- f s x-                                           deepseq res $ return res+                                           ( -- T.trace "start rnfA for IOSLA" $+                                             snd res+                                             )+                                             `deepseq`+                                              return ( -- T.trace "end rnfA for IOSLA" $+                                                       res+                                                     )++instance ArrowWNF (IOSLA s)  -- ------------------------------------------------------------
src/Control/Arrow/ListArrow.hs view
@@ -30,6 +30,7 @@ import           Control.Arrow.ArrowList import           Control.Arrow.ArrowNF import           Control.Arrow.ArrowTree+import           Control.Arrow.ArrowNavigatableTree  import           Control.DeepSeq @@ -43,10 +44,13 @@  instance Category LA where     id                  = LA $ (:[])+    {-# INLINE id #-}     LA g . LA f         = LA $ concatMap g . f+    {-# INLINE (.) #-}  instance Arrow LA where     arr f               = LA $ \ x -> [f x]+    {-# INLINE arr #-}     first (LA f)        = LA $ \ ~(x1, x2) -> [ (y1, x2) | y1 <- f x1 ]      -- just for efficiency@@ -57,11 +61,12 @@  instance ArrowZero LA where     zeroArrow           = LA $ const []+    {-# INLINE zeroArrow #-}   instance ArrowPlus LA where     LA f <+> LA g       = LA $ \ x -> f x ++ g x-+    {-# INLINE (<+>) #-}  instance ArrowChoice LA where     left  (LA f)        = LA $ either (map Left . f) ((:[]) . Right)@@ -72,20 +77,25 @@  instance ArrowApply LA where     app                 = LA $ \ (LA f, x) -> f x+    {-# INLINE app #-}  instance ArrowList LA where-    arrL                        = LA+    arrL                = LA+    {-# INLINE arrL #-}     arr2A f             = LA $ \ ~(x, y) -> runLA (f x) y+    {-# INLINE arr2A #-}     isA p               = LA $ \ x -> if p x then [x] else []+    {-# INLINE isA #-}     LA f >>. g          = LA $ g . f+    {-# INLINE (>>.) #-}     withDefault a d     = a >>. \ x -> if null x then [d] else x - instance ArrowIf LA where     ifA (LA p) t e      = LA $ \ x -> runLA ( if null (p x)                                               then e                                               else t                                             ) x+    {-# INLINE ifA #-}      (LA f) `orElse` (LA g)                         = LA $ \ x -> ( let@@ -95,6 +105,7 @@                                         then g x                                         else res                                       )+    {-# INLINE orElse #-}      spanA p             = LA $ (:[]) . span (not . null . runLA p) @@ -102,11 +113,15 @@  instance ArrowTree LA +instance ArrowNavigatableTree LA+ instance ArrowNF LA where     rnfA (LA f)         = LA $ \ x -> let res = f x                                       in-                                      deepseq res res+                                      res `deepseq` res +instance ArrowWNF LA+ -- ------------------------------------------------------------  -- | conversion of pure list arrows into other possibly more complex@@ -114,6 +129,7 @@  fromLA          :: ArrowList a => LA b c -> a b c fromLA f        =  arrL (runLA f)+{-# INLINE fromLA #-}  -- ------------------------------------------------------------
src/Control/Arrow/ListArrows.hs view
@@ -17,23 +17,29 @@  module Control.Arrow.ListArrows     ( module Control.Arrow                      -- arrow classes-    , module Control.Arrow.ArrowList+    , module Control.Arrow.ArrowExc     , module Control.Arrow.ArrowIf+    , module Control.Arrow.ArrowIO+    , module Control.Arrow.ArrowList+    , module Control.Arrow.ArrowNavigatableTree     , module Control.Arrow.ArrowNF     , module Control.Arrow.ArrowState     , module Control.Arrow.ArrowTree-    , module Control.Arrow.ArrowIO      , module Control.Arrow.ListArrow            -- arrow types     , module Control.Arrow.StateListArrow     , module Control.Arrow.IOListArrow     , module Control.Arrow.IOStateListArrow++    , module Control.Arrow.NTreeEdit            -- extra arrows     ) where  import Control.Arrow                            -- arrow classes+import Control.Arrow.ArrowExc import Control.Arrow.ArrowList import Control.Arrow.ArrowIf+import Control.Arrow.ArrowNavigatableTree import Control.Arrow.ArrowNF import Control.Arrow.ArrowState import Control.Arrow.ArrowTree@@ -43,5 +49,7 @@ import Control.Arrow.StateListArrow import Control.Arrow.IOListArrow import Control.Arrow.IOStateListArrow++import Control.Arrow.NTreeEdit                  -- extra arrows  -- ------------------------------------------------------------
+ src/Control/Arrow/NTreeEdit.hs view
@@ -0,0 +1,46 @@+-- ------------------------------------------------------------++{- |+   Module     : Control.Arrow.NTreeEdit+   Copyright  : Copyright (C) 2011 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   arrows for efficient editing of rose trees++-}++-- ------------------------------------------------------------++module Control.Arrow.NTreeEdit+where++import Control.Arrow+import Control.Arrow.ArrowIf+import Control.Arrow.ArrowList+import Control.Arrow.ListArrow++import Data.Maybe+import Data.Tree.NTree.TypeDefs+import Data.Tree.NTree.Edit++-- ------------------------------------------------------------++-- | Edit parts of a rose tree+--+-- The subtrees to be modified are selected by the first part of the IfThen pairs+-- The modification by the second part++editNTreeA              :: [IfThen (LA (NTree b) c) (LA (NTree b) (NTree b))] ->+                           LA (NTree b) (NTree b)+editNTreeA cs           = arrL $ editNTreeBottomUp ef+    where+    ef                  = listToMaybe . (runLA . foldr (\ (g :-> h) -> ifA g (listA h)) none $ cs)++fmapNTreeA              :: (b -> Maybe b) -> LA (NTree b) (NTree b)+fmapNTreeA f            = arr $ mapNTree' f++-- eof ------------------------------------------------------------
src/Control/Arrow/StateListArrow.hs view
@@ -4,7 +4,7 @@  {- |    Module     : Control.Arrow.StateListArrow-   Copyright  : Copyright (C) 2005-8 Uwe Schmidt+   Copyright  : Copyright (C) 2010 Uwe Schmidt    License    : MIT     Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)@@ -33,6 +33,7 @@ import           Control.Arrow.ArrowNF import           Control.Arrow.ArrowState import           Control.Arrow.ArrowTree+import           Control.Arrow.ArrowNavigatableTree  import           Control.DeepSeq @@ -44,6 +45,7 @@  instance Category (SLA s) where     id                  = SLA $ \ s x -> (s, [x])+    {-# INLINE id #-}      SLA g . SLA f       = SLA $ \ s x -> let                                          ~(s1, ys) = f s x@@ -60,6 +62,7 @@  instance Arrow (SLA s) where     arr f               = SLA $ \ s x -> (s, [f x])+    {-# INLINE arr #-}      first (SLA f)       = SLA $ \ s ~(x1, x2) -> let                                                  ~(s', ys1) = f s x1@@ -89,6 +92,7 @@  instance ArrowZero (SLA s) where     zeroArrow           = SLA $ \ s -> const (s, [])+    {-# INLINE zeroArrow #-}   instance ArrowPlus (SLA s) where@@ -118,22 +122,29 @@  instance ArrowApply (SLA s) where     app                 = SLA $ \ s (SLA f, x) -> f s x+    {-# INLINE app #-}   instance ArrowList (SLA s) where     arrL f              = SLA $ \ s x -> (s, (f x))+    {-# INLINE arrL #-}     arr2A f             = SLA $ \ s ~(x, y) -> runSLA (f x) s y+    {-# INLINE arr2A #-}     constA c            = SLA $ \ s   -> const (s, [c])+    {-# INLINE constA #-}     isA p               = SLA $ \ s x -> (s, if p x then [x] else [])+    {-# INLINE isA #-}     SLA f >>. g         = SLA $ \ s x -> let                                          ~(s1, ys) = f s x                                          in                                          (s1, g ys)+    {-# INLINE (>>.) #-}     -- just for efficency     perform (SLA f)     = SLA $ \ s x -> let                                          ~(s1, _ys) = f s x                                          in                                          (s1, [x])+    {-# INLINE perform #-}  instance ArrowIf (SLA s) where     ifA (SLA p) ta ea   = SLA $ \ s x -> let@@ -155,15 +166,21 @@  instance ArrowState s (SLA s) where     changeState cf      = SLA $ \ s x -> (cf s x, [x])+    {-# INLINE changeState #-}     accessState af      = SLA $ \ s x -> (s, [af s x])+    {-# INLINE accessState #-}  instance ArrowTree (SLA s) -instance (NFData s) => ArrowNF (SLA s) where+instance ArrowNavigatableTree (SLA s)++instance ArrowNF (SLA s) where     rnfA (SLA f)        = SLA $ \ s x -> let res = f s x                                          in-                                         deepseq res res+                                         snd res `deepseq`  res +instance ArrowWNF (SLA s)+ -- ------------------------------------------------------------  -- | conversion of state list arrows into arbitray other@@ -180,6 +197,7 @@  fromSLA         :: ArrowList a => s -> SLA s b c -> a b c fromSLA s f     =  arrL (snd . (runSLA f s))+{-# INLINE fromSLA #-}   -- ------------------------------------------------------------
+ src/Control/FlatSeq.hs view
@@ -0,0 +1,90 @@+-- ------------------------------------------------------------++{- |+   Module     : Control.FlatSeq+   Copyright  : Copyright (C) 2011 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Force evaluation like deepseq in Control.DeepSeq,+   but control the depth of evaluation.+   flatseq may evaluate more than seq but less than deepseq++-}++-- ------------------------------------------------------------++module Control.FlatSeq+where++import Data.Word++-- ------------------------------------------------------------++infixr 0 $!!++($!!)                           :: WNFData a => (a -> b) -> a -> b+f $!! x                         = rwnf x `seq` f x+{-# INLINE ($!!) #-}++flatseq                         :: WNFData a => a -> b -> b+flatseq a b                     = rwnf a `seq` b+{-# INLINE flatseq #-}++rlnf                            :: (a -> ()) -> [a] -> ()+rlnf _ []                       = ()+rlnf r (x:xs)                   = r x `seq` rlnf r xs+{-# INLINE rlnf #-}++-- | A class of types that can be partially evaluated, but evaluation can be propagated deeper than WHNF++class WNFData a where+    -- | Default for rwnf is reduction to WHNF+    rwnf                        :: a -> ()+    rwnf a                      = a `seq` ()+    {-# INLINE rwnf #-}++    -- | Default for rwnf2 is rwnf+    rwnf2                       :: a -> ()+    rwnf2                       = rwnf+    {-# INLINE rwnf2 #-}++instance WNFData Int +instance WNFData Integer+instance WNFData Float+instance WNFData Double++instance WNFData Char+instance WNFData Bool+instance WNFData ()++instance WNFData Word+instance WNFData Word8+instance WNFData Word16+instance WNFData Word32+instance WNFData Word64++instance WNFData a => WNFData [a] where+    rwnf []                     = ()+    rwnf (x:xs)                 = x `seq` rwnf xs+    {-# INLINE rwnf #-}++instance (WNFData a, WNFData b) => WNFData (a,b) where+    rwnf (x,y)                  = rwnf x `seq` rwnf y+    {-# INLINE rwnf #-}++instance (WNFData a, WNFData b, WNFData c) => WNFData (a,b,c) where+    rwnf (x,y,z)                = rwnf x `seq` rwnf y `seq` rwnf z +    {-# INLINE rwnf #-}++instance (WNFData a, WNFData b, WNFData c, WNFData d) => WNFData (a,b,c,d) where+    rwnf (x1,x2,x3,x4)          = rwnf x1 `seq` +                                  rwnf x2 `seq` +                                  rwnf x3 `seq` +                                  rwnf x4 +    {-# INLINE rwnf #-}++-- ------------------------------------------------------------
src/Data/AssocList.hs view
@@ -1,8 +1,20 @@--- |--- simple key value assocciation list--- implemented as unordered list of pairs------ Version : $Id: AssocList.hs,v 1.2 2005/05/27 13:15:23 hxml Exp $+-- ------------------------------------------------------------++{- |+   Module     : Data.AssocList+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   Simple key value assocciation list+   implemented as unordered list of pairs++-}++-- ------------------------------------------------------------  module Data.AssocList     ( module Data.AssocList
src/Data/Atom.hs view
@@ -14,7 +14,7 @@    Unique Atoms generated from Strings and    managed as flyweights -   Data.Atom can be used for caching and storage optimisation+   Data.Atom can be used for caching and storage optimization    of frequently used strings. An @Atom@ is constructed from a @String@.    For two equal strings the identical atom is returned. @@ -32,8 +32,8 @@    up in the table of atoms. If it is already there, the value in the map is used as atom, else    the new @ByteString@ is inserted into the map. -   Of course the implementation of this name cache uses @unsavePerformIO@ and @MVar@s-   for managing this kind of global state.+   Of course the implementation of this name cache uses @unsavePerformIO@.+   The global cache is managed by ue of an @IORef@ and atomicModifyIORef.     The following laws hold for atoms @@ -42,7 +42,7 @@    > s `compare` t => newAtom s `compare` newAtom t    > show . newAtom == id -   Equality test for @Atom@s runs in /O(1)/, it is just a pointer comarison.+   Equality test for @Atom@s runs in /O(1)/, it is just a pointer comparison.    The @Ord@ comparisons have the same runtime like the @ByteString@ comparisons.    Internally there is an UTF8 comparison, but UTF8 encoding preserves the total order. @@ -59,18 +59,17 @@    share                -- :: String -> String  ) where -import           Control.Concurrent.MVar import           Control.DeepSeq -import           Data.ByteString.Internal       ( toForeignPtr, c2w, w2c )-import           Data.ByteString                ( ByteString, pack, unpack )-import qualified Data.Map                       as M+import           Data.ByteString          (ByteString, pack, unpack)+import           Data.ByteString.Internal (c2w, toForeignPtr, w2c)+import           Data.IORef+import qualified Data.Map                 as M+import           Data.String.Unicode      (unicodeToUtf8)+import           Data.String.UTF8Decoding (decodeUtf8) import           Data.Typeable -import           System.IO.Unsafe               ( unsafePerformIO )--import           Text.XML.HXT.DOM.Unicode       ( unicodeToUtf8 )-import           Text.XML.HXT.DOM.UTF8Decoding  ( decodeUtf8 )+import           System.IO.Unsafe         (unsafePerformIO)  -- ------------------------------------------------------------ @@ -83,8 +82,8 @@  -- | the internal cache for the strings -theAtoms        :: MVar Atoms-theAtoms        = unsafePerformIO (newMVar M.empty)+theAtoms        :: IORef Atoms+theAtoms        = unsafePerformIO (newIORef M.empty) {-# NOINLINE theAtoms #-}  -- | insert a bytestring into the atom cache@@ -104,10 +103,14 @@ -- | The internal operation running in the IO monad newAtom'        :: String -> IO Atom newAtom' s      = do-                  m <- takeMVar theAtoms-                  let (m', a) = insertAtom (pack. map c2w . unicodeToUtf8 $ s) m-                  putMVar theAtoms m'-                  return a+                  -- putStrLn "insert atom into cache"+                  res <- atomicModifyIORef theAtoms insert+                  -- putStrLn "atom cache updated"+                  return res+  where+    insert m    = let r = insertAtom (pack. map c2w . unicodeToUtf8 $ s) m+                  in+                   fst r `seq` r  -- | Insert a @String@ into the atom cache and convert the atom back into a @String@. --@@ -135,5 +138,6 @@     -- show     = show . toForeignPtr . bs                      -- for debug only  instance NFData Atom where+    rnf x = seq x ()  -----------------------------------------------------------------------------
− src/Data/Char/UTF8.hs 
@@ -1,363 +0,0 @@-{---Copyright (c) 2002, members of the Haskell Internationalisation Working-Group All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--* Redistributions of source code must retain the above copyright notice,-   this list of conditions and the following disclaimer.-* Redistributions in binary form must reproduce the above copyright notice,-   this list of conditions and the following disclaimer in the-   documentation and/or other materials provided with the distribution.-* Neither the name of the Haskell Internationalisation Working Group nor-   the names of its contributors may be used to endorse or promote products-   derived from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"-AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS-INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN-CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)-ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE-POSSIBILITY OF SUCH DAMAGE.--This module provides lazy stream encoding/decoding facilities for UTF-8,-the Unicode Transformation Format with 8-bit words.--2002-09-02  Sven Moritz Hallberg <pesco@gmx.de>---}--{---2007-04-30 Henning Thielemann:-Slight changes to make decode lazy.-The calls of 'reverse' in the original version have broken laziness-and thus had memory leaks.---}--module Data.Char.UTF8-  ( encode, decode,-    decodeEmbedErrors,-    encodeOne, decodeOne,-    Error, -- Haddock does not want to document signatures with private types-    -- these functions should be moved to a utility module-  ) where--import Data.Char (ord, chr)-import Data.Word (Word8, Word16, Word32)-import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.))--import Data.List (unfoldr)--import Text.XML.HXT.DOM.Util (partitionEither, swap, toMaybe)------ - UTF-8 in General ----- Adapted from the Unicode standard, version 3.2,--- Table 3.1 "UTF-8 Bit Distribution" (excluded are UTF-16 encodings):----   Scalar                    1st Byte  2nd Byte  3rd Byte  4th Byte---           000000000xxxxxxx  0xxxxxxx---           00000yyyyyxxxxxx  110yyyyy  10xxxxxx---           zzzzyyyyyyxxxxxx  1110zzzz  10yyyyyy  10xxxxxx---   000uuuzzzzzzyyyyyyxxxxxx  11110uuu  10zzzzzz  10yyyyyy  10xxxxxx---- Also from the Unicode standard, version 3.2,--- Table 3.1B "Legal UTF-8 Byte Sequences":----   Code Points         1st Byte  2nd Byte  3rd Byte  4th Byte---     U+0000..U+007F    00..7F---     U+0080..U+07FF    C2..DF    80..BF---     U+0800..U+0FFF    E0        A0..BF    80..BF---     U+1000..U+CFFF    E1..EC    80..BF    80..BF---     U+D000..U+D7FF    ED        80..9F    80..BF---     U+D800..U+DFFF    ill-formed---     U+E000..U+FFFF    EE..EF    80..BF    80..BF---    U+10000..U+3FFFF   F0        90..BF    80..BF    80..BF---    U+40000..U+FFFFF   F1..F3    80..BF    80..BF    80..BF---   U+100000..U+10FFFF  F4        80..8F    80..BF    80..BF------ - Encoding Functions ----- Must the encoder ensure that no illegal byte sequences are output or--- can we trust the Haskell system to supply only legal values?--- For now I include error case for the surrogate values U+D800..U+DFFF and--- out-of-range scalars.---- The function is pretty much a transscript of table 3.1B with error checks.--- It dispatches the actual encoding to functions specific to the number of--- required bytes.--encodeOne :: Char -> [Word8]-encodeOne c-    -- The report guarantees in (6.1.2) that this won't happen:-    --   | n < 0       = error "encodeUTF8: ord returned a negative value"-    | n < 0x0080  = encodeOne_onebyte n8-    | n < 0x0800  = encodeOne_twobyte n16-    | n < 0xD800  = encodeOne_threebyte n16-    | n < 0xE000  = error "encodeUTF8: ord returned a surrogate value"-    | n < 0x10000       = encodeOne_threebyte n16-    -- Haskell 98 only talks about 16 bit characters, but ghc handles 20.1.-    | n < 0x10FFFF      = encodeOne_fourbyte n32-    | otherwise  = error "encodeUTF8: ord returned a value above 0x10FFFF"-    where-    n = ord c            :: Int-    n8 = fromIntegral n  :: Word8-    n16 = fromIntegral n :: Word16-    n32 = fromIntegral n :: Word32----- With the above, a stream decoder is trivial:--encode :: [Char] -> [Word8]-encode = concatMap encodeOne----- Now follow the individual encoders for certain numbers of bytes...---           _---          / |  __  ___  __ __---         / ^| //  /__/ // //---        /.==| \\ //_  // //--- It's  //  || // \_/_//_//_  and it's here to stay!--encodeOne_onebyte :: Word8 -> [Word8]-encodeOne_onebyte cp = [cp]----- 00000yyyyyxxxxxx -> 110yyyyy 10xxxxxx--encodeOne_twobyte :: Word16 -> [Word8]-encodeOne_twobyte cp = [(0xC0.|.ys), (0x80.|.xs)]-    where-    xs, ys :: Word8-    ys = fromIntegral (shiftR cp 6)-    xs = (fromIntegral cp) .&. 0x3F----- zzzzyyyyyyxxxxxx -> 1110zzzz 10yyyyyy 10xxxxxx--encodeOne_threebyte :: Word16 -> [Word8]-encodeOne_threebyte cp = [(0xE0.|.zs), (0x80.|.ys), (0x80.|.xs)]-    where-    xs, ys, zs :: Word8-    xs = (fromIntegral cp) .&. 0x3F-    ys = (fromIntegral (shiftR cp 6)) .&. 0x3F-    zs = fromIntegral (shiftR cp 12)----- 000uuuzzzzzzyyyyyyxxxxxx -> 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx--encodeOne_fourbyte :: Word32 -> [Word8]-encodeOne_fourbyte cp = [0xF0.|.us, 0x80.|.zs, 0x80.|.ys, 0x80.|.xs]-    where-    xs, ys, zs, us :: Word8-    xs = (fromIntegral cp) .&. 0x3F-    ys = (fromIntegral (shiftR cp 6)) .&. 0x3F-    zs = (fromIntegral (shiftR cp 12)) .&. 0x3F-    us = fromIntegral (shiftR cp 18)------ - Decoding ----- The decoding is a bit more involved. The byte sequence could contain all--- sorts of corruptions. The user must be able to either notice or ignore these--- errors.---- I will first look at the decoding of a single character. The process--- consumes a certain number of bytes from the input. It returns the--- remaining input and either an error and the index of its occurance in the--- byte sequence or the decoded character.--data Error---- The first byte in a sequence starts with either zero, two, three, or four--- ones and one zero to indicate the length of the sequence. If it doesn't,--- it is invalid. It is dropped and the next byte interpreted as the start--- of a new sequence.--    = InvalidFirstByte---- All bytes in the sequence except the first match the bit pattern 10xxxxxx.--- If one doesn't, it is invalid. The sequence up to that point is dropped--- and the "invalid" byte interpreted as the start of a new sequence. The error--- includes the length of the partial sequence and the number of expected bytes.--    | InvalidLaterByte Int      -- the byte at relative index n was invalid---- If a sequence ends prematurely, it has been truncated. It dropped and--- decoding stops. The error reports the actual and expected lengths of the--- sequence.--    | Truncated Int Int         -- only n of m expected bytes were present---- Some sequences would represent code points which would be encoded as a--- shorter sequence by a conformant encoder. Such non-shortest sequences are--- considered erroneous and dropped. The error reports the actual and--- expected number of bytes used.--    | NonShortest Int Int       -- n instead of m bytes were used---- Unicode code points are in the range of [0..0x10FFFF]. Any values outside--- of those bounds are simply invalid.--    | ValueOutOfBounds---- There is no such thing as "surrogate pairs" any more in UTF-8. The--- corresponding code points now form illegal byte sequences.--    | Surrogate-      deriving (Show, Eq)----- Second, third, and fourth bytes share the common requirement to start--- with the bit sequence 10. So, here's the function to check that property.--first_bits_not_10 :: Word8 -> Bool-first_bits_not_10 b-    | (b.&.0xC0) /= 0x80  = True-    | otherwise           = False----- Erm, OK, the single-character decoding function's return type is a bit--- longish. It is a tripel:----  - The first component contains the decoded character or an error---    if the byte sequence was erroneous.---  - The second component contains the number of bytes that were consumed---    from the input.---  - The third component contains the remaining bytes of input.--decodeOne :: [Word8] -> (Either Error Char, Int, [Word8])-decodeOne bs@(b1:rest)-    | b1 < 0x80   = decodeOne_onebyte bs-    | b1 < 0xC0   = (Left InvalidFirstByte, 1, rest)-    | b1 < 0xE0   = decodeOne_twobyte bs-    | b1 < 0xF0   = decodeOne_threebyte bs-    | b1 < 0xF5   = decodeOne_fourbyte bs-    | otherwise   = (Left ValueOutOfBounds, 1, rest)-decodeOne [] = error "UTF8.decodeOne: No input"----- 0xxxxxxx -> 000000000xxxxxxx--decodeOne_onebyte :: [Word8] -> (Either Error Char, Int, [Word8])-decodeOne_onebyte (b:bs) = (Right (cpToChar b), 1, bs)-decodeOne_onebyte[] = error "UTF8.decodeOne_onebyte: No input (can't happen)"--cpToChar :: Integral a => a -> Char-cpToChar = chr . fromIntegral----- 110yyyyy 10xxxxxx -> 00000yyyyyxxxxxx--decodeOne_twobyte :: [Word8] -> (Either Error Char, Int, [Word8])-decodeOne_twobyte (_:[])-    = (Left (Truncated 1 2), 1, [])-decodeOne_twobyte (b1:b2:bs)-    | b1 < 0xC2            = (Left (NonShortest 2 1), 2, bs)-    | first_bits_not_10 b2 = (Left (InvalidLaterByte 1), 1, (b2:bs))-    | otherwise            = (Right (cpToChar result), 2, bs)-    where-    xs, ys, result :: Word32-    xs = fromIntegral (b2.&.0x3F)-    ys = fromIntegral (b1.&.0x1F)-    result = shiftL ys 6 .|. xs-decodeOne_twobyte[] = error "UTF8.decodeOne_twobyte: No input (can't happen)"----- 1110zzzz 10yyyyyy 10xxxxxx -> zzzzyyyyyyxxxxxx--decodeOne_threebyte :: [Word8] -> (Either Error Char, Int, [Word8])-decodeOne_threebyte (_:[])   = threebyte_truncated 1-decodeOne_threebyte (_:_:[]) = threebyte_truncated 2-decodeOne_threebyte bs@(b1:b2:b3:rest)-    | first_bits_not_10 b2-        = (Left (InvalidLaterByte 1), 1, drop 1 bs)-    | first_bits_not_10 b3-        = (Left (InvalidLaterByte 2), 2, drop 2 bs)-    | result < 0x0080-        = (Left (NonShortest 3 1), 3, rest)-    | result < 0x0800-        = (Left (NonShortest 3 2), 3, rest)-    | result >= 0xD800 && result < 0xE000-        = (Left Surrogate, 3, rest)-    | otherwise-        = (Right (cpToChar result), 3, rest)-    where-    xs, ys, zs, result :: Word32-    xs = fromIntegral (b3.&.0x3F)-    ys = fromIntegral (b2.&.0x3F)-    zs = fromIntegral (b1.&.0x0F)-    result = shiftL zs 12 .|. shiftL ys 6 .|. xs-decodeOne_threebyte[]- = error "UTF8.decodeOne_threebyte: No input (can't happen)"--threebyte_truncated :: Int -> (Either Error Char, Int, [Word8])-threebyte_truncated n = (Left (Truncated n 3), n, [])----- 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx -> 000uuuzzzzzzyyyyyyxxxxxx--decodeOne_fourbyte :: [Word8] -> (Either Error Char, Int, [Word8])-decodeOne_fourbyte (_:[])     = fourbyte_truncated 1-decodeOne_fourbyte (_:_:[])   = fourbyte_truncated 2-decodeOne_fourbyte (_:_:_:[]) = fourbyte_truncated 3-decodeOne_fourbyte bs@(b1:b2:b3:b4:rest)-    | first_bits_not_10 b2-        = (Left (InvalidLaterByte 1), 1, drop 1 bs)-    | first_bits_not_10 b3-        = (Left (InvalidLaterByte 2), 2, drop 2 bs)-    | first_bits_not_10 b4-        = (Left (InvalidLaterByte 3), 3, drop 3 bs)-    | result < 0x0080-        = (Left (NonShortest 4 1), 4, rest)-    | result < 0x0800-        = (Left (NonShortest 4 2), 4, rest)-    | result < 0x10000-        = (Left (NonShortest 4 3), 4, rest)-    | result > 0x10FFFF-        = (Left ValueOutOfBounds, 4, rest)-    | otherwise-        = (Right (cpToChar result), 4, rest)-    where-    xs, ys, zs, us, result :: Word32-    xs = fromIntegral (b4 .&. 0x3F)-    ys = fromIntegral (b3 .&. 0x3F)-    zs = fromIntegral (b2 .&. 0x3F)-    us = fromIntegral (b1 .&. 0x07)-    result = xs .|. shiftL ys 6 .|. shiftL zs 12 .|. shiftL us 18-decodeOne_fourbyte[]- = error "UTF8.decodeOne_fourbyte: No input (can't happen)"--fourbyte_truncated :: Int -> (Either Error Char, Int, [Word8])-fourbyte_truncated n = (Left (Truncated n 4), n, [])----- The decoder examines all input, recording decoded characters as well as--- error-index pairs along the way.--decode :: [Word8] -> ([Char], [(Error,Int)])-decode = swap . partitionEither . decodeEmbedErrors--decodeEmbedErrors :: [Word8] -> [Either (Error,Int) Char]-decodeEmbedErrors =-   unfoldr (\(pos,xs) ->-       toMaybe-          (not $ null xs)-          (let (c,n,rest) = decodeOne xs-           in  (either (\err -> Left (err,pos)) Right c,-                (pos+n,rest)))) .-   (,) 0
+ src/Data/Function/Selector.hs view
@@ -0,0 +1,91 @@+{-# OPTIONS -XMultiParamTypeClasses -XFunctionalDependencies  -XFlexibleInstances #-}++module Data.Function.Selector+where++import Prelude          hiding (id,(.))++import Control.Arrow+import Control.Category++infixr 3 .&&&.++-- ------------------------------------------------------------++-- | A Selector is a pair of an access function and a modifying function+-- for reading and updating parts of a composite type++data Selector s a       = S { getS :: s -> a+                            , setS :: a -> s -> s+                            }++chgS                    :: Selector s a -> (a -> a) -> (s -> s)+chgS sel f s            = setS sel x s+                          where+                          x = f . getS sel $ s++chgM                    :: (Monad m) => Selector s a -> (a -> m a) -> (s -> m s)+chgM sel f s            = do+                          y <- f x+                          return $ setS sel y s+                          where+                          x = getS sel $ s++-- | Alias for constructor S++mkSelector              :: (s -> a) -> (a -> s -> s) -> Selector s a+mkSelector              = S++-- (.), (>>>), (<<<)++instance Category Selector where+    id                          = S { getS = id+                                    , setS = const+                                    }+    (S g2 s2) . (S g1 s1)       = S { getS = g2 . g1+                                    , setS = \ x s ->+                                            let x1  = g1 s    in+                                            let x1' = s2 x x1 in+                                            s1 x1' s+                                    }++idS                             :: Selector s s+idS                             = id++(.&&&.)                         :: Selector s a -> Selector s b -> Selector s (a, b)+(.&&&.) (S g1 s1) (S g2 s2)     = S { getS = g1 &&& g2+                                    , setS = \ (x, y) -> s2 y . s1 x+                                    }++-- ------------------------------------------------------------++-- | Selectors for pairs and 3-tuples: comp1, comp2, comp3,+-- this can be extended to n-tuples++class Comp1 s a | s -> a where  comp1   :: Selector s a+class Comp2 s a | s -> a where  comp2   :: Selector s a+class Comp3 s a | s -> a where  comp3   :: Selector s a+++instance Comp1 (a, b) a where           comp1   = S { getS = fst+                                                    , setS = \ x1 (_, x2) -> (x1, x2)+                                                    }++instance Comp2 (a, b) b where           comp2   = S { getS = snd+                                                    , setS = \ x2 (x1, _) -> (x1, x2)+                                                    }++instance Comp1 (a, b, c) a where        comp1   = S { getS = \ (x1, _, _) -> x1+                                                    , setS = \ x1 (_, x2, x3) -> (x1, x2, x3)+                                                    }++instance Comp2 (a, b, c) b where        comp2   = S { getS = \ (_, x2, _) -> x2+                                                    , setS = \ x2 (x1, _, x3) -> (x1, x2, x3)+                                                    }++instance Comp3 (a, b, c) c where        comp3   = S { getS = \ (_, _, x3) -> x3+                                                    , setS = \ x3 (x1, x2, _) -> (x1, x2, x3)+                                                    }++-- ------------------------------------------------------------+
src/Data/Tree/Class.hs view
@@ -30,16 +30,19 @@      mkLeaf              ::                       a -> t a     mkLeaf n            = mkTree n []+    {-# INLINE mkLeaf #-}      -- | leaf test: list of children empty?      isLeaf              ::                     t a -> Bool     isLeaf              = null . getChildren+    {-# INLINE isLeaf #-}      -- | innner node test: @ not . isLeaf @      isInner             ::                     t a -> Bool     isInner             = not . isLeaf+    {-# INLINE isInner #-}      -- | select node attribute @@ -61,11 +64,13 @@      setNode             ::                a -> t a -> t a     setNode n           = changeNode (const n)+    {-# INLINE setNode #-}      -- | substitute children: @ setChildren cl = changeChildren (const cl) @      setChildren         ::            [t a] -> t a -> t a     setChildren cl      = changeChildren (const cl)+    {-# INLINE setChildren #-}      -- | fold for trees @@ -74,19 +79,61 @@     -- | all nodes of a tree      nodesTree           ::                     t a -> [a]+    nodesTree           = foldTree (\ n rs -> n : concat rs)+    {-# INLINE nodesTree #-}      -- | depth of a tree      depthTree           ::                     t a -> Int+    depthTree           = foldTree (\ _ rs -> 1 + maximum (0 : rs))      -- | number of nodes in a tree      cardTree            ::                     t a -> Int+    cardTree            = foldTree (\ _ rs -> 1 + sum rs)      -- | format tree for readable trace output     --     -- a /graphical/ representation of the tree in text format      formatTree          ::    (a -> String) -> t a -> String+    formatTree nf n     = formatNTree' nf (showString "---") (showString "   ") n ""  -- ------------------------------------------------------------+-- |+-- convert a tree into a pseudo graphical string representation++formatNTree'    :: Tree t => (a -> String) -> (String -> String) -> (String -> String) -> t a -> String -> String++formatNTree' node2String pf1 pf2 tree+    = formatNode+      . formatChildren pf2 l+    where+    n           = getNode     tree+    l           = getChildren tree+    formatNode  = pf1 . foldr (.) id (map trNL (node2String n)) . showNL+    trNL '\n'   = showNL . pf2+    trNL c      = showChar c+    showNL      = showChar '\n'+    formatChildren _ []+        = id+    formatChildren pf (t:ts)+        | null ts+            = pfl'+              . formatTr pf2' t+        | otherwise+            = pfl'+              . formatTr pf1' t+              . formatChildren pf ts+        where+        pf0'    = pf . showString indent1+        pf1'    = pf . showString indent2+        pf2'    = pf . showString indent3+        pfl'    = pf . showString indent4+        formatTr        = formatNTree' node2String pf0'+        indent1 = "+---"+        indent2 = "|   "+        indent3 = "    "+        indent4 = "|\n"++-- eof ------------------------------------------------------------
+ src/Data/Tree/NTree/Edit.hs view
@@ -0,0 +1,98 @@+-- ------------------------------------------------------------++{- |+   Module     : +   Copyright  : Copyright (C) 2011 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Space and time efficient editing of rose trees+-}++-- ------------------------------------------------------------++module Data.Tree.NTree.Edit+where++import Data.Maybe++import Data.Tree.NTree.TypeDefs++-- import           Debug.Trace+++-- | editNTreeBottomUp is a space optimized tree edit function+--+-- The nodes in a tree are visited bottom up. An edit function is applied to+-- all nodes. A Nothing result of the editing function indicates no changes.+-- This is used to share the input tree within the resulting tree.+--+-- The following law holds:+--+-- > editNTreeBottomUp (const Nothing) t == [t]+--+-- In this case the resulting tree does not only represent the same value+-- but it is the same machine value (relative to some evaluations of closures+-- during the tree walk+--+-- With a simple fold like editing function the whole tree would be reconstructed+-- in memory++editNTreeBottomUp               :: (NTree a -> Maybe [NTree a]) -> NTree a -> [NTree a]+editNTreeBottomUp f t0          = maybe [t0] id . editNTreeBU $ t0+    where++ -- editNTreeBU                 :: NTree a -> Maybe [NTree a]+    editNTreeBU t@(NTree n cs)+        | isNothing r'+          &&+          isJust cl'            = Just [t']                     -- children have been change but not the node itself+        | otherwise             = r'                            -- nothing has been changes or node has been changed +        where+        cl'                     = editNTreesBU cs               -- the edited children+        t'                      = case cl' of                   -- the node to be processed with f+                                  Nothing       -> t            -- possibly with the new children (bottom up)+                                  Just cs'      -> NTree n cs'+        r'                      = f t'                          -- the edited result++ -- editNTreesBU                :: [NTree a] -> Maybe [NTree a]+    editNTreesBU []             = Nothing+    editNTreesBU (t : ts)       = mergeRes+                                  (editNTreeBU  t )+                                  (editNTreesBU ts)+        where+        mergeRes r'             = case r' of+                                  Nothing       -> maybe Nothing (Just . (t :))+                                  Just ts'      -> Just . (ts' ++) . fromMaybe ts+++-- | A space optimized map for NTrees+--+-- Subtrees, that are not changed are reused in the resulting tree+-- See also: editNTreeBottomUp++mapNTree'                       :: (a -> Maybe a) -> NTree a -> NTree a+mapNTree' f t0                  = maybe t0 id . map' $ t0+    where++    -- map'                     :: NTree a -> Maybe (NTree a)+    map' (NTree n cs)           = mergeRes (f n) (maps' cs)+        where+        mergeRes Nothing Nothing        = Nothing+        mergeRes Nothing (Just cs')     = Just (NTree n             cs')+        mergeRes (Just n') cl           = Just (NTree n' (fromMaybe cs cl))++    -- maps'                    :: [NTree a] -> Maybe [NTree a]+    maps' []                    = Nothing+    maps' (t : ts)              = mergeRes+                                  (map'  t )+                                  (maps' ts)+        where+        mergeRes r'             = case r' of+                                  Nothing       -> maybe Nothing (Just . (t :))+                                  Just t'       -> Just . (t' :) . fromMaybe ts++-- eof ------------------------------------------------------------
src/Data/Tree/NTree/TypeDefs.hs view
@@ -1,14 +1,15 @@+{-# LANGUAGE CPP                #-} {-# LANGUAGE DeriveDataTypeable #-}  -- ------------------------------------------------------------  {- |    Module     : Data.Tree.NTree.TypeDefs-   Copyright  : Copyright (C) 2005-2008 Uwe Schmidt+   Copyright  : Copyright (C) 2005-2010 Uwe Schmidt    License    : MIT     Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)-   Stability  : experimental+   Stability  : stable    Portability: portable     Interface definition for trees@@ -20,16 +21,35 @@ -- ------------------------------------------------------------  module Data.Tree.NTree.TypeDefs-    ( module Data.Tree.Class-    , module Data.Tree.NTree.TypeDefs-    ) where -import Control.DeepSeq+import           Control.DeepSeq     (NFData (..))+import           Control.FlatSeq     (WNFData (..), rlnf) -import Data.Tree.Class-import Data.Typeable+import           Data.Binary+import           Data.Tree.Class     (Tree (..))+import           Data.Typeable       (Typeable) +#if MIN_VERSION_base(4,13,0)+#else+import           Data.Monoid         ((<>))+#endif++#if MIN_VERSION_base(4,8,2)+#else+import           Control.Applicative ((<$>))+#endif++#if MIN_VERSION_base(4,8,0)+#else+import           Control.Applicative (Applicative (..))+import           Data.Foldable       (Foldable (..))+import           Data.Monoid         (Monoid (..))+import           Data.Traversable    (Traversable (..), sequenceA)+#endif++-- ------------------------------------------------------------+ -- | n-ary ordered tree (rose trees) -- -- a tree consists of a node and a possible empty list of children.@@ -50,64 +70,69 @@  instance (NFData a) => NFData (NTree a) where     rnf (NTree n cl)                    = rnf n `seq` rnf cl+    {-# INLINE rnf #-} +instance (WNFData a) => WNFData (NTree a) where+    rwnf (NTree n cl)                   = rwnf n `seq` rwnf cl+    {-# INLINE rwnf #-}++    -- | Evaluate a tree 2 steps deep, the top node and all children are evaluated with rwnf+    rwnf2 (NTree n cl)                  = rwnf n `seq` rlnf rwnf cl+    {-# INLINE rwnf2 #-}++-- ------------------------------------------------------------++instance (Binary a) => Binary (NTree a) where+    put (NTree n cs)    = put n >> put cs+    get                 = do+                          n  <- get+                          cs <- get+                          return (NTree n cs)++-- ------------------------------------------------------------+ -- | NTree implements class Functor  instance Functor NTree where-    fmap f ~(NTree n cl)                = NTree (f n) (map (fmap f) cl)+    fmap f (NTree n cl)                 = NTree (f n) (map (fmap f) cl)+    {-# INLINE fmap #-} +-- ------------------------------------------------------------ +-- | NTree implements class Foldable++instance Foldable NTree where+    foldMap f (NTree n cl)              = f n <> mconcat (map (foldMap f) cl)+    {-# INLINE foldMap #-}+++-- ------------------------------------------------------------++-- | NTree implements class Taversable++instance Traversable NTree where+    traverse f (NTree n cl)             = NTree <$> f n <*> sequenceA (map (traverse f) cl)+    {-# INLINE traverse #-}++-- ------------------------------------------------------------+ -- | Implementation of "Data.Tree.Class" interface for rose trees  instance Tree NTree where     mkTree n cl                         = NTree n cl+    {-# INLINE mkTree #-}      getNode           ~(NTree n _ )     = n+    {-# INLINE getNode #-}     getChildren       ~(NTree _ cl)     = cl+    {-# INLINE getChildren #-}      changeNode     cf ~(NTree n cl)     = NTree (cf n) cl+    {-# INLINE changeNode #-}     changeChildren cf ~(NTree n cl)     = NTree n (cf cl)+    {-# INLINE changeChildren #-}      foldTree        f ~(NTree n cs)     = f n (map (foldTree f) cs)--    nodesTree           = foldTree (\ n rs -> n : concat rs)-    depthTree           = foldTree (\ _ rs -> 1 + maximum (0 : rs))-    cardTree            = foldTree (\ _ rs -> 1 + sum rs)-    formatTree nf n     = formatNTreeF nf (showString "---") (showString "   ") n ""---- --------------------------------------------------------------- |--- convert a tree into a pseudo graphical string reprsentation--formatNTreeF    :: (node -> String) -> (String -> String) -> (String -> String) -> NTree node -> String -> String--formatNTreeF node2String pf1 pf2 (NTree n l)-    = formatNode-      . formatChildren pf2 l-    where-    formatNode  = pf1 . foldr (.) id (map trNL (node2String n)) . showNL-    trNL '\n'   = showNL . pf2-    trNL c      = showChar c-    showNL      = showChar '\n'-    formatChildren _ []-        = id-    formatChildren pf (t:ts)-        | null ts-            = pfl'-              . formatTr pf2' t-        | otherwise-            = pfl'-              . formatTr pf1' t-              . formatChildren pf ts-        where-        pf0'    = pf . showString indent1-        pf1'    = pf . showString indent2-        pf2'    = pf . showString indent3-        pfl'    = pf . showString indent4-        formatTr        = formatNTreeF node2String pf0'-        indent1 = "+---"-        indent2 = "|   "-        indent3 = "    "-        indent4 = "|\n"+    {-# INLINE foldTree #-}  -- eof ------------------------------------------------------------
+ src/Data/Tree/NTree/Zipper/TypeDefs.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+{-# OPTIONS -fno-warn-orphans #-}++-- ------------------------------------------------------------++{- |+   Module     : Data.Tree.NTree.Zipper.TypeDefs+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : stable+   Portability: portable++   Implementation of navigateble trees for+   rose trees. The implementation is done with zippers.+   A description and introductory tutorial about zippers+   can be found in <http://learnyouahaskell.com/zippers>+-}++-- ------------------------------------------------------------++module Data.Tree.NTree.Zipper.TypeDefs+{-+    ( NTZipper+    , NTree+    , toNTZipper+    , fromNTZipper+    )+-}+where++import Data.Tree.Class++import Data.Tree.NavigatableTree.Class+import Data.Tree.NavigatableTree.XPathAxis      ( childAxis )++import Data.Tree.NTree.TypeDefs++-- ------------------------------------------------------------++-- | Zipper for rose trees+--+-- A zipper consist of the current tree and the branches on the way back to the root++data NTZipper a         = NTZ+                          { ntree   :: (NTree a)+                          , context :: (NTBreadCrumbs a)+                          }+                          deriving (Show)++-- | The list of unzipped nodes from a current tree back to the root++type NTBreadCrumbs a    = [NTCrumb a]++-- | One unzipped step consists of the left siblings, the node info and the right siblings++data NTCrumb a          = NTC+                          (NTrees a)            -- left side+                          a                     -- node+                          (NTrees a)            -- right side+                          deriving (Show)++-- ------------------------------------------------------------++-- | Conversion of a rose tree into a navigatable rose tree++toNTZipper              :: NTree a -> NTZipper a+toNTZipper t            = NTZ t []++{-# INLINE toNTZipper #-}++-- | Conversion of a navigatable rose tree into an ordinary rose tree.+--+-- The context, the parts for moving up to the root are just removed from the tree.+-- So when transforming a navigatable tree by moving around and by changing some nodes,+-- one has to navigate back+-- to the root, else that parts are removed from the result++fromNTZipper            :: NTZipper a -> NTree a+fromNTZipper            = ntree++{-# INLINE fromNTZipper #-}++-- ------------------------------------------------------------++up                      :: NTZipper a -> Maybe (NTZipper a)+up z+    | isTop z           = Nothing+    | otherwise         = Just $ NTZ (up1 t bc) bcs+    where+    NTZ t (bc : bcs)    = z++{-# INLINE up #-}++down                    :: NTZipper a -> Maybe (NTZipper a)+down (NTZ (NTree n cs) bcs)+          | null cs     = Nothing+          | otherwise   = Just $ NTZ (head cs) (NTC [] n (tail cs) : bcs)++{-# INLINE down #-}++toTheRight                   :: NTZipper a -> Maybe (NTZipper a)+toTheRight z+    | isTop z+      ||+      null rs           = Nothing+    | otherwise         = Just $ NTZ t' (bc' : bcs)+    where+    (NTZ t (bc : bcs))  = z+    (NTC ls n rs)       = bc+    t'                  = head rs+    bc'                 = NTC (t : ls) n (tail rs)++{-# INLINE toTheRight #-}++toTheLeft                    :: NTZipper a -> Maybe (NTZipper a)+toTheLeft z+    | isTop z+      ||+      null ls           = Nothing+    | otherwise         = Just $ NTZ t' (bc' : bcs)+    where+    (NTZ t (bc : bcs))  = z+    (NTC ls n rs)       = bc+    t'                  = head ls+    bc'                 = NTC (tail ls) n (t : rs)++{-# INLINE toTheLeft #-}++addToTheLeft            :: NTree a -> NTZipper a -> Maybe (NTZipper a)+addToTheLeft t z+    | isTop z           = Nothing+    | otherwise         = Just $ NTZ t' (NTC (t:ls) n rs : bcs)+    where+    (NTZ t' (bc : bcs)) = z+    (NTC ls n rs)       = bc+{-# INLINE addToTheLeft #-}++addToTheRight            :: NTree a -> NTZipper a -> Maybe (NTZipper a)+addToTheRight t z+    | isTop z           = Nothing+    | otherwise         = Just $ NTZ t' (NTC ls n (t:rs) : bcs)+    where+    (NTZ t' (bc : bcs)) = z+    (NTC ls n rs)       = bc+{-# INLINE addToTheRight #-}++dropFromTheLeft            :: NTZipper a -> Maybe (NTZipper a)+dropFromTheLeft z+    | isTop z           = Nothing+    | null ls           = Nothing+    | otherwise         = Just $ NTZ t' (NTC (tail ls) n rs : bcs)+    where+    (NTZ t' (bc : bcs)) = z+    (NTC ls n rs)       = bc+{-# INLINE dropFromTheLeft #-}++dropFromTheRight        :: NTZipper a -> Maybe (NTZipper a)+dropFromTheRight z+    | isTop z           = Nothing+    | null rs           = Nothing+    | otherwise         = Just $ NTZ t' (NTC ls n (tail rs) : bcs)+    where+    (NTZ t' (bc : bcs)) = z+    (NTC ls n rs)       = bc+{-# INLINE dropFromTheRight #-}++-- ------------------------------------------------------------++isTop                   :: NTZipper a -> Bool+isTop                   = null . context++{-# INLINE isTop #-}++up1                     :: NTree a -> NTCrumb a -> NTree a+up1 t (NTC ls n rs)     = NTree n (foldl (flip (:)) (t : rs) ls)++{-# INLINE up1 #-}++-- ------------------------------------------------------------++instance Functor NTZipper where+    fmap f (NTZ t xs)   = NTZ (fmap f t) (map (fmap f) xs)+    {-# INLINE fmap #-}++instance Functor NTCrumb where+    fmap f (NTC xs x ys)= NTC (map (fmap f) xs) (f x) (map (fmap f) ys)+    {-# INLINE fmap #-}++instance Tree NTZipper where+    mkTree n cl         = toNTZipper . mkTree n $ map ntree cl++    getNode             = getNode . ntree+    {-# INLINE getNode #-}+    getChildren         = childAxis+    {-# INLINE getChildren #-}++    changeNode     cf t = t { ntree = changeNode cf (ntree t) }+    changeChildren cf t = t { ntree = setChildren (map ntree . cf . childAxis $ t) (ntree t) }++    foldTree f          = foldTree f . ntree+    {-# INLINE foldTree #-}++instance NavigatableTree NTZipper where+    mvDown              = down+    {-# INLINE mvDown #-}++    mvUp                = up+    {-# INLINE mvUp #-}++    mvLeft              = toTheLeft+    {-# INLINE mvLeft #-}++    mvRight             = toTheRight+    {-# INLINE mvRight #-}++instance NavigatableTreeToTree NTZipper NTree where+    fromTree            = toNTZipper+    {-# INLINE fromTree #-}++    toTree              = fromNTZipper+    {-# INLINE toTree #-}++instance NavigatableTreeModify NTZipper NTree where+    addTreeLeft         = addToTheLeft+    {-# INLINE addTreeLeft #-}++    addTreeRight        = addToTheRight+    {-# INLINE addTreeRight #-}++    dropTreeLeft        = dropFromTheLeft+    {-# INLINE dropTreeLeft #-}++    dropTreeRight       = dropFromTheRight+    {-# INLINE dropTreeRight #-}++    substThisTree t nt  = nt { ntree = t }+    {-# INLINE substThisTree #-}++-- ------------------------------------------------------------
+ src/Data/Tree/NavigatableTree/Class.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}++-- ------------------------------------------------------------++{- |+   Module     : Data.Tree.NavigatableTree.Class+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Interface definition for navigatable trees.+   Navigatable trees need to have operations to move up, down, left and right.+   With these elementary operations, most of the XPath axises can be defined.+-}++-- ------------------------------------------------------------++module Data.Tree.NavigatableTree.Class+where++-- ------------------------------------------------------------++-- | The interface for navigatable trees++class NavigatableTree t where+    -- | move one step towards the root+    mvUp                :: t a -> Maybe (t a)++    -- | descend one step to the leftmost child+    mvDown              :: t a -> Maybe (t a)++    -- | move to the left neighbour+    mvLeft              :: t a -> Maybe (t a)++    -- | move to the right neighbour+    mvRight             :: t a -> Maybe (t a)++-- ------------------------------------------------------------++-- | Conversion between trees and navigatable trees,+--+-- There is only a single navigatable tree implementation for a given tree allowed+-- (see the functional dependencies)++class NavigatableTreeToTree nt t | t -> nt, nt -> t where+    -- | construct a navigatable tree+    fromTree            :: t a -> nt a++    -- | remove navigation+    toTree              :: nt a -> t a++-- ------------------------------------------------------------++-- | Edit operation on navigatable trees+--+-- There is only a single navigatable tree implementation for a given tree allowed+-- (see the functional dependencies)++class NavigatableTreeModify nt t | t -> nt, nt -> t where++    -- | add an ordinary tree in front of the given navigatable tree+    addTreeLeft         :: t a -> nt a -> Maybe (nt a)++    -- | add an ordinary tree behind of the given navigatable tree+    addTreeRight        :: t a -> nt a -> Maybe (nt a)++    -- | drop the direct left sibling tree of the given navigatable tree+    dropTreeLeft        :: nt a -> Maybe (nt a)++    -- | drop the direct right sibling tree of the given navigatable tree+    dropTreeRight       :: nt a -> Maybe (nt a)++    -- | change the tree but remain the navigation+    substThisTree       :: t a -> nt a -> nt a++-- ------------------------------------------------------------
+ src/Data/Tree/NavigatableTree/XPathAxis.hs view
@@ -0,0 +1,128 @@+-- ------------------------------------------------------------++{- |+   Module     : Data.Tree.NavigatableTree.XPathAxis+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Navigatable trees need to have operations to move up, down, left and right.+   With these elementary operations, the XPath axises can be defined.+-}++-- ------------------------------------------------------------++module Data.Tree.NavigatableTree.XPathAxis+where++import Data.Maybe               ( maybeToList )+import Data.Tree.NavigatableTree.Class++import Control.Arrow            ( (>>>) )+import Control.Monad            ( (>=>) )++-- ------------------------------------------------------------+--+-- mothers little helpers++-- | collect all trees by moving into one direction, starting tree is included++maybeStar               :: (a -> Maybe a) -> (a -> [a])+maybeStar f x            = x : maybe [] (maybeStar f) (f x)++-- | collect all trees by moving into one direction, starting tree is not included++maybePlus               :: (a -> Maybe a) -> (a -> [a])+maybePlus f x           =      maybe [] (maybeStar f) (f x)++{-# INLINE maybePlus #-}++-- ------------------------------------------------------------+-- XPath axis++-- | XPath axis: parent++parentAxis              :: NavigatableTree t => t a -> [t a]+parentAxis              = maybeToList . mvUp+{-# INLINE parentAxis #-}++-- | XPath axis: ancestor++ancestorAxis            :: NavigatableTree t => t a -> [t a]+ancestorAxis            = maybePlus mvUp+{-# INLINE ancestorAxis #-}++-- | XPath axis: ancestor or self++ancestorOrSelfAxis      :: NavigatableTree t => t a -> [t a]+ancestorOrSelfAxis      = maybeStar mvUp+{-# INLINE ancestorOrSelfAxis #-}++-- | XPath axis: child++childAxis               :: NavigatableTree t => t a -> [t a]+childAxis               = (mvDown >>> maybeToList) >=> maybeStar mvRight+{-# INLINE childAxis #-}++-- | XPath axis: descendant++descendantAxis          :: NavigatableTree t => t a -> [t a]+descendantAxis          = descendantOrSelfAxis >>> tail+{-# INLINE descendantAxis #-}++-- | XPath axis: descendant or self++descendantOrSelfAxis    :: NavigatableTree t => t a -> [t a]+descendantOrSelfAxis    = visit []+    where+    visit  k t          = t : maybe k (visit' k) (mvDown t)+    visit' k t          = visit (maybe k (visit' k) (mvRight t)) t++-- | not an official XPath axis but useful: reverse descendant or self, used in preceding axis++revDescendantOrSelfAxis :: NavigatableTree t => t a -> [t a]+revDescendantOrSelfAxis t+                        = t : concatMap revDescendantOrSelfAxis (reverse $ childAxis t)++-- | XPath axis: following sibling++followingSiblingAxis    :: NavigatableTree t => t a -> [t a]+followingSiblingAxis    = maybePlus mvRight+{-# INLINE followingSiblingAxis #-}++-- | XPath axis: preceeding sibling++precedingSiblingAxis    :: NavigatableTree t => t a -> [t a]+precedingSiblingAxis    = maybePlus mvLeft+{-# INLINE precedingSiblingAxis #-}++-- | XPath axis: self++selfAxis                :: NavigatableTree t => t a -> [t a]+selfAxis                = (:[])+{-# INLINE selfAxis #-}++-- | XPath axis: following++followingAxis           :: NavigatableTree t => t a -> [t a]+followingAxis           = ancestorOrSelfAxis >=> followingSiblingAxis >=> descendantOrSelfAxis++-- | XPath axis: preceding++precedingAxis           :: NavigatableTree t => t a -> [t a]+precedingAxis           = ancestorOrSelfAxis >=> precedingSiblingAxis >=> revDescendantOrSelfAxis++-- | move to the root++mvToRoot                :: NavigatableTree t => t a -> t a+mvToRoot                = ancestorOrSelfAxis >>> last+{-# INLINE mvToRoot #-}++isAtRoot                :: NavigatableTree t => t a -> Bool+isAtRoot                = null . ancestorAxis+{-# INLINE isAtRoot #-}++-- ------------------------------------------------------------
− src/Text/XML/HXT/Arrow.hs 
@@ -1,64 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.Arrow-   Copyright  : Copyright (C) 2006-2010 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : stable-   Portability: portable--   The HXT arrow interface--   The application programming interface to the arrow modules of the Haskell XML Toolbox.-   This module exports all important arrows for input, output, parsing, validating and transforming XML.-   It also exports all basic datatypes and functions of the toolbox.---}---- --------------------------------------------------------------module Text.XML.HXT.Arrow-    ( module Control.Arrow.ListArrows--    , module Text.XML.HXT.DOM.Interface--    , module Text.XML.HXT.Arrow.XmlArrow-    , module Text.XML.HXT.Arrow.XmlIOStateArrow--    , module Text.XML.HXT.Arrow.DocumentInput-    , module Text.XML.HXT.Arrow.DocumentOutput-    , module Text.XML.HXT.Arrow.Edit-    , module Text.XML.HXT.Arrow.GeneralEntitySubstitution-    , module Text.XML.HXT.Arrow.Namespace-    , module Text.XML.HXT.Arrow.ProcessDocument-    , module Text.XML.HXT.Arrow.ReadDocument-    , module Text.XML.HXT.Arrow.WriteDocument-    , module Text.XML.HXT.Arrow.Pickle--    , module Text.XML.HXT.Version-    )-where--import Control.Arrow.ListArrows                 -- arrow classes--import Data.Atom ()                             -- import this explicitly--import Text.XML.HXT.DOM.Interface-import Text.XML.HXT.Arrow.DocumentInput-import Text.XML.HXT.Arrow.DocumentOutput-import Text.XML.HXT.Arrow.Edit-import Text.XML.HXT.Arrow.GeneralEntitySubstitution-import Text.XML.HXT.Arrow.Namespace-import Text.XML.HXT.Arrow.Pickle-import Text.XML.HXT.Arrow.ProcessDocument-import Text.XML.HXT.Arrow.ReadDocument-import Text.XML.HXT.Arrow.WriteDocument-import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlIOStateArrow-import Text.XML.HXT.Arrow.XmlRegex ()           -- import this explicitly--import Text.XML.HXT.Version---- ------------------------------------------------------------
+ src/Text/XML/HXT/Arrow/Binary.hs view
@@ -0,0 +1,82 @@+-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.Arrow.Binary+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   De-/Serialisation arrows for XmlTrees and other arbitrary values with a Binary instance+-}++-- ------------------------------------------------------------++module Text.XML.HXT.Arrow.Binary+    ( readBinaryValue+    , writeBinaryValue+    )+where++import           Control.Arrow                             ()+import           Control.Arrow.ArrowExc+import           Control.Arrow.ArrowIO+import           Control.Arrow.ArrowList++import           Data.Binary+import qualified Data.ByteString.Lazy                      as B++import           System.IO                                 (IOMode (..), hClose,+                                                            openBinaryFile)++import           Text.XML.HXT.Arrow.XmlState.ErrorHandling+import           Text.XML.HXT.Arrow.XmlState.TypeDefs++-- ------------------------------------------------------------++readBinaryValue         :: (Binary a) => String -> IOStateArrow s b a+readBinaryValue file+                        = (uncurry $ decodeBinaryValue file)+                          $< getSysVar ( theStrictDeserialize+                                         .&&&.+                                         theBinaryDeCompression+                                       )++-- | Read a serialied value from a file, optionally decompress it and decode the value+-- In case of an error, the error message is issued and the arrow fails++decodeBinaryValue         :: (Binary a) => String -> Bool -> DeCompressionFct -> IOStateArrow s b a+decodeBinaryValue file strict decompress+                          = arrIO0 dec+                            `catchA`+                            issueExc "readBinaryValue"+    where+    dec                 = ( if strict+                            then readItAll+                            else B.readFile file+                          ) >>= return . decode . decompress+    readItAll           = do+                          h <- openBinaryFile file ReadMode+                          c <- B.hGetContents h+                          B.length c `seq`+                           do+                           hClose h+                           return c     -- hack: force reading whole file and close it immediately++-- | Serialize a value, optionally compress it, and write it to a file.+-- In case of an error, the error message is issued and the arrow fails++writeBinaryValue        :: (Binary a) => String -> IOStateArrow s a ()+writeBinaryValue file   = flip encodeBinaryValue file $< getSysVar theBinaryCompression++encodeBinaryValue        :: (Binary a) => CompressionFct -> String -> IOStateArrow s a ()+encodeBinaryValue compress file+                         = arrIO enc+                           `catchA`+                           issueExc "writeBinaryXmlTree"+    where+    enc                  = B.writeFile file . compress . encode++-- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/DTDProcessing.hs view
@@ -8,7 +8,6 @@    Maintainer : Uwe Schmidt (uwe@fh-wedel.de)    Stability  : experimental    Portability: portable-   Version    : $Id: DTDProcessing.hs,v 1.9 2006/05/11 14:47:19 hxml Exp $     DTD processing function for    including external parts of a DTD@@ -34,7 +33,7 @@ import qualified Text.XML.HXT.DOM.XmlNode as XN  import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlIOStateArrow+import Text.XML.HXT.Arrow.XmlState  import Text.XML.HXT.Arrow.ParserInterface     ( parseXmlDTDdecl@@ -127,27 +126,16 @@       processRoot           = ( traceMsg 1 ("processDTD: process parameter entities")               >>>-              setParamString a_standalone ""-              >>>-              ( addDocType-                `whenNot`-                ( getChildren >>> isDTDDoctype )-              )+              setSysAttrString a_standalone ""               >>>               processChildren substParamEntities               >>>               setDocumentStatusFromSystemState "in XML DTD processing"+              >>>+              traceMsg 1 ("processDTD: parameter entities processed")             )             `when`             documentStatusOk-          where-          addDocType-              = replaceChildren ( (getChildren >>> isXmlPi)-                                  <+>-                                  mkDTDDoctype [] none-                                  <+>-                                  (getChildren >>> neg isXmlPi)-                                )  substParamEntities      :: IOStateArrow s XmlTree XmlTree substParamEntities@@ -215,8 +203,10 @@                               >>>                               parseXmlDTDdecl                               >>>-                              substRefsInEntityValue+                              substPeRefsInEntityValue                               >>>+                              traceDTD "ENTITY declaration after PE substitution"+                              >>>                               processEntityDecl                               >>>                               traceDTD "ENTITY declaration after DTD declaration parsing"@@ -260,17 +250,24 @@         processExternalEntity                                           -- only the current base uri must be remembered             = setDTDAttrValue a_url $< ( getDTDAttrValue k_system >>> mkAbsURI ) -        processInternalEntity   :: DTDStateArrow XmlTree XmlTree        -- just combine all parts of the entity value-        processInternalEntity                                           -- into one string-            = replaceChildren (xshow getChildren >>> mkText)+        processInternalEntity   :: DTDStateArrow XmlTree XmlTree+        processInternalEntity+            = this                                                      -- everything is already done in substPeRefsInEntityValue          processParamEntity      :: String -> DTDStateArrow XmlTree XmlTree         processParamEntity peName             = ifA (constA peName >>> getPeValue)-              ( issueWarn ("parameter entity " ++ show peName ++ " already defined") )+              ( issueWarn ("parameter entity " ++ show peName ++ " already defined")+                >>>+                none                                                    -- second def must be ignored+              )               ( ( ifA ( hasDTDAttr k_system )                           -- is external param entity ?-                  ( runInLocalURIContext getExternalParamEntityValue )-                  ( replaceChildren (xshow getChildren >>> mkText) )    -- just combine all parts of the entity value into one string+                  ( setDTDAttrValue a_url $<                            -- store absolut url+                    ( getDTDAttrValue k_system >>> mkAbsURI )+                  )+                  -- this is too early, pe may be not referenced and file may be not there+                  -- ( runInLocalURIContext getExternalParamEntityValue )+                  ( this )                                              -- everything is already done in substPeRefsInEntityValue                 )                 >>>                 addPe peName@@ -279,32 +276,50 @@     substPERef                  :: String -> DTDStateArrow XmlTree XmlTree     substPERef pn         = choiceA-          [ isInternalRef       :-> issueErr ("a parameter entity reference of " ++ show pn ++ " occurs in the internal subset of the DTD")-          , isUndefinedRef      :-> issueErr ("parameter entity " ++ show pn ++ " not found (forward reference?)")+          [ isUndefinedRef      :-> issueErr ("parameter entity " ++ show pn ++ " not found (forward reference?)")+          , isInternalRef       :-> issueErr ("a parameter entity reference of " ++ show pn ++ " occurs in the internal subset of the DTD")+          , isUnreadExternalRef :-> ( perform+                                      ( peVal                           -- load the external pe value+                                        >>>                             -- update the pe env+                                        getExternalParamEntityValue pn  -- and try again+                                        >>>+                                        addPe pn+                                      )+                                      >>>+                                      substPERef pn+                                    )           , this                :-> substPE           ]           `when`           isDTDPERef         where-        isInternalRef   = isA (const (loc == Internal))-        peVal           = constA pn >>> getPeValue+        peVal                   = constA pn >>> getPeValue++        isUnreadExternalRef     = ( peVal+                                    >>>+                                    getDTDAttrValue a_url+                                    >>>+                                    isA (not . null)+                                  )+                                  `guards`+                                  this++        isInternalRef   = none -- isA (const (loc == Internal))         -- TODO: check this restriction, it seams rather meaningless         isUndefinedRef  = neg peVal-        substPE-            = replaceChildren (peVal >>> getChildren)                   -- store PE value in children component-              >>>-              ( ( setBase $< (peVal >>> getDTDAttrValue a_url) )        -- store base uri for external refs-                `orElse`-                this-              )-            where-            setBase uri = setDTDAttrValue a_url uri+        substPE         = replaceChildren (peVal >>> getChildren)       -- store PE value in children component -    substRefsInEntityValue      :: DTDStateArrow XmlTree XmlTree-    substRefsInEntityValue-        = ( ( processChildren ( transfCharRef-                                >>>-                                substPeRefsInValue []-                              )+    substPeRefsInEntityValue      :: DTDStateArrow XmlTree XmlTree+    substPeRefsInEntityValue+        = ( ( replaceChildren+              ( xshow ( getChildren                                     -- substitute char entites+                        >>>                                             -- and parameter references+                        transfCharRef                                   -- combine all pieces to a single string+                        >>>                                             -- as the new entity value+                        substPeRefsInValue []+                      )+                >>>+                mkText+              )             )             `whenNot`             hasDTDAttr k_system                                         -- only apply for internal entities@@ -366,8 +381,8 @@               >>>               parseXmlDTDEntityValue               >>>-              transfCharRef-              >>>+              -- transfCharRef             this must be done somewhere else+              -- >>>               substPeRefsInValue (pn : recl)      substPeRefsInCondSect       :: RecList -> DTDStateArrow XmlTree XmlTree@@ -474,36 +489,30 @@       >>>       getChildren -getExternalParamEntityValue     :: DTDStateArrow XmlTree XmlTree-getExternalParamEntityValue+getExternalParamEntityValue     :: String -> DTDStateArrow XmlTree XmlTree+getExternalParamEntityValue pn     = isDTDPEntity       `guards`-      ( setEntityValue $<<< ( getDTDAttrl-                              &&&-                              listA ( getEntityValue $< getDTDAttrl )-                              &&&-                              getBaseURI-                            )-      )+      ( setEntityValue $< ( listA ( getEntityValue $< getDTDAttrValue a_url ) ) )     where-    getEntityValue      :: Attributes -> DTDStateArrow XmlTree XmlTree-    getEntityValue al-        = root [sattr a_source (lookup1 k_system al){- <+> catA (map (uncurry sattr) al)-}] []+    getEntityValue      :: String -> DTDStateArrow XmlTree XmlTree+    getEntityValue url+        = root [sattr a_source url] []           >>>-          getXmlEntityContents+          runInLocalURIContext getXmlEntityContents           >>>-          traceMsg 2 "getExternalParamEntityValue: contents read"+          traceMsg 2 ("getExternalParamEntityValue: contents read for " ++ show pn ++ " from " ++ show url)           >>>           getChildren -    setEntityValue      :: Attributes -> XmlTrees -> String -> DTDStateArrow XmlTree XmlTree-    setEntityValue al res base+    setEntityValue      :: XmlTrees -> DTDStateArrow XmlTree XmlTree+    setEntityValue res         | null res-            = issueErr ("illegal external parameter entity value for entity %" ++ peName ++";")+            = issueErr ("illegal external parameter entity value for entity %" ++ pn ++";")         | otherwise-            = mkDTDElem PENTITY ((a_url, base) : al) (arrL $ const res)-        where-        peName = lookup1 a_name al+            = replaceChildren (constL res)+              >>>+              setDTDAttrValue a_url ""                          -- mark entity as read  traceDTD        :: String -> DTDStateArrow XmlTree XmlTree traceDTD msg    = traceMsg 3 msg >>> traceTree
src/Text/XML/HXT/Arrow/DocumentInput.hs view
@@ -8,7 +8,6 @@    Maintainer : Uwe Schmidt (uwe@fh-wedel.de)    Stability  : experimental    Portability: portable-   Version    : $Id$     State arrows for document input -}@@ -16,42 +15,38 @@ -- ------------------------------------------------------------  module Text.XML.HXT.Arrow.DocumentInput-    ( getURIContents-    , getXmlContents+    ( getXmlContents     , getXmlEntityContents     , getEncoding     , getTextEncoding     , decodeDocument+    , addInputError     ) where -import Control.Arrow                            -- arrow classes-import Control.Arrow.ArrowList-import Control.Arrow.ArrowIf-import Control.Arrow.ArrowTree-import Control.Arrow.ArrowIO-import Control.Arrow.ListArrow--import Data.List                                ( isPrefixOf )+import           Control.Arrow+import           Control.Arrow.ArrowIf+import           Control.Arrow.ArrowIO+import           Control.Arrow.ArrowList+import           Control.Arrow.ArrowTree+import           Control.Arrow.ListArrow -import System.FilePath                          ( takeExtension )+import           Data.List                            (isPrefixOf)+import           Data.String.Unicode                  (getDecodingFct,+                                                       guessEncoding,+                                                       normalizeNL) -import Text.XML.HXT.DOM.Unicode                 ( getDecodingFct-                                                , guessEncoding-                                                , normalizeNL-                                                )+import           System.FilePath                      (takeExtension) -import qualified Text.XML.HXT.IO.GetFILE        as FILE-import qualified Text.XML.HXT.IO.GetHTTPLibCurl as LibCURL+import qualified Text.XML.HXT.IO.GetFILE              as FILE -import Text.XML.HXT.DOM.Interface+import           Text.XML.HXT.DOM.Interface -import Text.XML.HXT.Arrow.ParserInterface       ( parseXmlDocEncodingSpec-                                                , parseXmlEntityEncodingSpec-                                                , removeEncodingSpec-                                                )-import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlIOStateArrow+import           Text.XML.HXT.Arrow.ParserInterface   (parseXmlDocEncodingSpec, parseXmlEntityEncodingSpec,+                                                       removeEncodingSpec)+import           Text.XML.HXT.Arrow.XmlArrow+import           Text.XML.HXT.Arrow.XmlState+import           Text.XML.HXT.Arrow.XmlState.TypeDefs  -- ---------------------------------------------------------- @@ -59,6 +54,7 @@ protocolHandlers     = [ ("file",        getFileContents)       , ("http",        getHttpContents)+      , ("https",       getHttpContents)       , ("stdin",       getStdinContents)       ] @@ -101,10 +97,7 @@  getFileContents         :: IOStateArrow s XmlTree XmlTree getFileContents-    = applyA ( ( ( getAttrValue  a_strict_input-                   >>>-                   arr isTrueValue-                 )+    = applyA ( ( getSysVar theStrictInput                  &&&                  ( getAttrValue transferURI                    >>>@@ -116,7 +109,7 @@                >>>                arrIO (uncurry FILE.getCont)                >>>-               ( arr (uncurry addError) -- io error occured+               ( arr (uncurry addInputError) -- io error occured                  |||                  arr addTxtContent      -- content read                )@@ -126,20 +119,18 @@  getStdinContents                :: IOStateArrow s XmlTree XmlTree getStdinContents-    = applyA (  getAttrValue  a_strict_input-                >>>-                arr isTrueValue+    = applyA (  getSysVar theStrictInput                 >>>                 arrIO FILE.getStdinCont                >>>-               ( arr (uncurry addError) -- io error occured+               ( arr (uncurry addInputError) -- io error occured                  |||-                 arr addTxtContent      -- content read+                 arr addTxtContent           -- content read                )              ) -addError                :: [(String, String)] -> String -> IOStateArrow s XmlTree XmlTree-addError al e+addInputError                :: Attributes -> String -> IOStateArrow s XmlTree XmlTree+addInputError al e     = issueFatal e       >>>       seqA (map (uncurry addAttr) al)@@ -148,9 +139,15 @@  addMimeType     :: IOStateArrow s XmlTree XmlTree addMimeType-    = addMime $< ( getAttrValue transferURI-                   >>>-                   ( uriToMime $< getSysParam xio_mimeTypes )+    = addMime $< ( ( getSysVar theFileMimeType+                     >>>+                     isA (not . null)+                   )+                   `orElse`+                   ( getAttrValue transferURI+                     >>>+                     ( uriToMime $< getMimeTypeTable )+                   )                  )     where     addMime mt@@ -158,9 +155,9 @@     uriToMime mtt         = arr $ ( \ uri -> extensionToMimeType (drop 1 . takeExtension $ uri) mtt ) -addTxtContent   :: String -> IOStateArrow s XmlTree XmlTree-addTxtContent c-    = replaceChildren (txt c)+addTxtContent   :: Blob -> IOStateArrow s XmlTree XmlTree+addTxtContent bc+    = replaceChildren (blb bc)       >>>       addAttr transferMessage "OK"       >>>@@ -168,71 +165,33 @@  getHttpContents         :: IOStateArrow s XmlTree XmlTree getHttpContents-    = getCont $<< ( getAttrValue transferURI-                    &&&-                    ( ( getAttrlAsAssoc         -- get all attributes of root node-                        &&&-                        getAllParamsString      -- get all system params-                      )-                      >>^ uncurry addEntries    -- merge them, attributes overwrite system params-                    )-                  )-      where-      getAttrlAsAssoc                           -- get the attributes as assoc list-          = listA ( getAttrl-                    >>> ( getName-                          &&&-                          xshow getChildren-                        )-                  )--      getCont uri options-          = applyA ( ( traceMsg 2 ( "get HTTP via libcurl, uri=" ++ show uri ++ " options=" ++ show options )-                       >>>-                       arrIO0 ( LibCURL.getCont options uri )-                     )-                     >>>-                     ( arr (uncurry addError)-                       |||-                       arr addContent-                     )-                   )--      addContent        :: (AssocList String String, String) -> IOStateArrow s XmlTree XmlTree-      addContent (al, c)-          = replaceChildren (txt c)-            >>>-            seqA (map (uncurry addAttr) al)+    = withoutUserState $ applyA $ getSysVar theHttpHandler -getURIContents          :: IOStateArrow s XmlTree XmlTree-getURIContents-    = getContentsFromString-      `orElse`-      getContentsFromDoc-    where-    getContentsFromString-        = ( getAttrValue a_source-            >>>-            isA (isPrefixOf stringProtocol)-          )-          `guards`-          getStringContents+getContentsFromString   :: IOStateArrow s XmlTree XmlTree+getContentsFromString+    = ( getAttrValue a_source+        >>>+        isA (isPrefixOf stringProtocol)+      )+      `guards`+      getStringContents -    getContentsFromDoc-        = ( ( addTransferURI $< getBaseURI-              >>>-              getCont-            )-            `when`-            ( setAbsURI $< ( getAttrValue a_source-                             >>^-                             ( \ src-> (if null src then "stdin:" else src) )   -- empty document name -> read from stdin-                           )-            )-          )+getContentsFromDoc      :: IOStateArrow s XmlTree XmlTree+getContentsFromDoc+    = ( ( addTransferURI $< getBaseURI           >>>-          setDocumentStatusFromSystemState "getURIContents"-+          getCont+        )+        `when`+        ( setAbsURI $< ( getAttrValue a_source+                         >>^+                         ( \ src-> (if null src then "stdin:" else src) )   -- empty document name -> read from stdin+                       )+        )+      )+      >>>+      setDocumentStatusFromSystemState "getContentsFromDoc"+    where     setAbsURI src         = ifA ( constA src >>> changeBaseURI )           this@@ -244,7 +203,7 @@     getCont         = applyA ( getBaseURI                           -- compute the handler and call it                    >>>-                   traceValue 2 (("getURIContents: reading " ++) . show)+                   traceValue 2 (("getContentsFromDoc: reading " ++) . show)                    >>>                    getSchemeFromURI                    >>>@@ -272,7 +231,7 @@    If the source name is empty, the input is read from standard input.     The source is transformed into an absolute URI. If the source is a relative URI, or a file name,-   it is expanded into an absolut URI with respect to the current base URI.+   it is expanded into an absolute URI with respect to the current base URI.    The default base URI is of protocol \"file\" and points to the current working directory.     The currently supported protocols are \"http\", \"file\", \"stdin\" and \"string\".@@ -293,35 +252,48 @@  getXmlEntityContents            :: IOStateArrow s XmlTree XmlTree getXmlEntityContents-    = getXmlContents' parseXmlEntityEncodingSpec+    = traceMsg 2 "getXmlEntityContents"       >>>-      processChildren removeEncodingSpec+      addAttr transferMimeType text_xml_external_parsed_entity  -- the default transfer mimetype       >>>+      getXmlContents' parseXmlEntityEncodingSpec+      >>>+      addAttr transferMimeType text_xml_external_parsed_entity+      >>>+      processChildren+      ( removeEncodingSpec+        >>>+        changeText normalizeNL                  -- newline normalization must be done here+      )                                         -- the following calls of the parsers don't do this+      >>>       setBaseURIFromDoc+      >>>+      traceMsg 2 "getXmlEntityContents done"  getXmlContents'         :: IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree getXmlContents' parseEncodingSpec-    = ( getURIContents-        >>>-        choiceA-        [ isXmlHtmlDoc  :-> ( parseEncodingSpec-                              >>>-                              filterErrorMsg-                              >>>-                              decodeDocument-                            )-        , isTextDoc     :->  decodeDocument-        , this          :-> this-        ]-        >>>-        perform ( getAttrValue transferURI-                  >>>-                  traceValue 1 (("getXmlContents: content read and decoded for " ++) . show)-                )-        >>>-        traceTree-        >>>-        traceSource+    = ( getContentsFromString    -- no decoding done for string: protocol+        `orElse`+        ( getContentsFromDoc+          >>>+          choiceA+          [ isXmlHtmlDoc  :-> ( parseEncodingSpec+                                >>>+                                filterErrorMsg+                                >>>+                                decodeDocument+                              )+          , isTextDoc     :-> decodeDocument+          , this          :-> this+          ]+          >>>+          perform ( getAttrValue transferURI+                    >>>+                    traceValue 1 (("getXmlContents: content read and decoded for " ++) . show)+                  )+          >>>+          traceDoc "getXmlContents'"+        )       )       `when`       isRoot@@ -349,7 +321,7 @@              arr guessEncoding            , getAttrValue transferEncoding      -- 2. guess: take the transfer encoding            , getAttrValue a_encoding            -- 3. guess: take encoding parameter in root node-           , getParamString a_encoding          -- 4. guess: take encoding parameter in global state+           , getSysVar  theInputEncoding        -- 4. guess: take encoding parameter in global state            , constA utf8                        -- default : utf8            ]       >. (head . filter (not . null))           -- make the filter deterministic: take 1. entry from list of guesses@@ -358,7 +330,7 @@ getTextEncoding     = catA [ getAttrValue transferEncoding      -- 1. guess: take the transfer encoding            , getAttrValue a_encoding            -- 2. guess: take encoding parameter in root node-           , getParamString a_encoding          -- 3. guess: take encoding parameter in global state+           , getSysVar theInputEncoding         -- 3. guess: take encoding parameter in global state            , constA isoLatin1                   -- default : no encoding            ]       >. (head . filter (not . null))           -- make the filter deterministic: take 1. entry from list of guesses@@ -367,19 +339,27 @@ decodeDocument  :: IOStateArrow s XmlTree XmlTree decodeDocument     = choiceA-      [ ( isRoot >>> isXmlHtmlDoc )   :-> ( decodeArr normalizeNL  $< getEncoding )-      , ( isRoot >>> isTextDoc )      :-> ( decodeArr id           $< getTextEncoding )+      [ ( isRoot >>> isXmlHtmlDoc )   :-> ( decodeX   $< getSysVar theExpat)+      , ( isRoot >>> isTextDoc )      :-> ( decodeArr $< getTextEncoding )       , this                          :-> this       ]     where-    decodeArr   :: (String -> String) -> String -> IOStateArrow s XmlTree XmlTree-    decodeArr normalizeNewline enc+    decodeX             :: Bool -> IOStateArrow s XmlTree XmlTree+    decodeX False       = decodeArr $< getEncoding+    decodeX True        = noDecode  $< getEncoding         -- parse with expat++    noDecode enc        = traceMsg 2 ("no decoding (done by expat): encoding is " ++ show enc)+                          >>>+                          addAttr transferEncoding enc++    decodeArr   :: String -> IOStateArrow s XmlTree XmlTree+    decodeArr enc         = maybe notFound found . getDecodingFct $ enc         where         found df             = traceMsg 2 ("decodeDocument: encoding is " ++ show enc)               >>>-              ( decodeText df $< getAttrValue a_ignore_encoding_errors )+              ( decodeText df $< getSysVar theEncodingErrors )               >>>               addAttr transferEncoding enc @@ -388,17 +368,20 @@               >>>               setDocumentStatusFromSystemState "decoding document" -        decodeText df ignoreErrs+{- just for performance test+        decodeText _ _ = this+-}+        decodeText df withEncErrors             = processChildren               ( getText                                                 -- get the document content+                -- the following 3 lines+                -- don't seem to raise the space problem in decodeText+                -- space is allocated in blobToString and in parsec                 >>> arr df                                              -- decode the text, result is (string, [errMsg])-                >>> ( ( (fst >>> normalizeNewline)                      -- take decoded string, normalize newline and build text node-                        ^>> mkText-                      )+                >>> ( ( fst ^>> mkText )                                -- take decoded string and build text node                       <+>-                      ( if isTrueValue ignoreErrs-                        then none                                       -- encoding errors are ignored-                        else+                      ( if withEncErrors+                        then                         ( arrL snd                                      -- take the error messages                           >>>                           arr ((enc ++) . (" encoding error" ++))       -- prefix with enc error@@ -407,6 +390,7 @@                           >>>                           none                                          -- neccessary for type match with <+>                         )+                        else none                       )                     )               )
src/Text/XML/HXT/Arrow/DocumentOutput.hs view
@@ -24,84 +24,99 @@     ) where -import Control.Arrow                            -- arrow classes-import Control.Arrow.ArrowList-import Control.Arrow.ArrowIf-import Control.Arrow.ArrowTree-import Control.Arrow.ArrowIO-import Control.Arrow.ListArrow--import Text.XML.HXT.DOM.Unicode                 ( getOutputEncodingFct )-import Text.XML.HXT.DOM.Interface+import           Control.Arrow+import           Control.Arrow.ArrowExc+import           Control.Arrow.ArrowIf+import           Control.Arrow.ArrowIO+import           Control.Arrow.ArrowList+import           Control.Arrow.ArrowTree+import           Control.Arrow.ListArrow -import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlIOStateArrow+import qualified Data.ByteString.Lazy                 as BS+import           Data.Maybe+import           Data.String.Unicode                  (getOutputEncodingFct') -import Text.XML.HXT.Arrow.Edit                  ( addHeadlineToXmlDoc-                                                , addXmlPi-                                                , addXmlPiEncoding-                                                , indentDoc-                                                , numberLinesInXmlDoc-                                                , treeRepOfXmlDoc-                                                )+import           Text.XML.HXT.DOM.Interface+import qualified Text.XML.HXT.DOM.ShowXml             as XS -import System.IO                                ( Handle-                                                , IOMode(..)-                                                , openFile-                                                , openBinaryFile-                                                , hSetBinaryMode-                                                , hPutStrLn-                                                , hClose-                                                , stdout-                                                )+import           Text.XML.HXT.Arrow.Edit              (addHeadlineToXmlDoc,+                                                       addXmlPi,+                                                       addXmlPiEncoding,+                                                       escapeHtmlRefs,+                                                       escapeXmlRefs, indentDoc,+                                                       numberLinesInXmlDoc,+                                                       treeRepOfXmlDoc)+import           Text.XML.HXT.Arrow.XmlArrow+import           Text.XML.HXT.Arrow.XmlState+import           Text.XML.HXT.Arrow.XmlState.TypeDefs -import System.IO.Error                          ( try )+import           System.IO                            (Handle, IOMode (..),+                                                       hClose, hPutStrLn,+                                                       hSetBinaryMode,+                                                       openBinaryFile, openFile,+                                                       stdout)  -- ------------------------------------------------------------ ----- output arrows+-- | Write the contents of a document tree into an output stream (file or stdout).+--+-- If textMode is set, writing is done with Haskell string output, else (default)+-- writing is done with lazy ByteString output  putXmlDocument  :: Bool -> String -> IOStateArrow s XmlTree XmlTree putXmlDocument textMode dst-    = perform ( xshow getChildren+    = perform putDoc+      where+      putDoc+          = ( if textMode+              then ( xshow getChildren+                     >>>+                     tryA (arrIO (\ s -> hPutDocument (\h -> hPutStrLn h s)))+                   )+              else ( xshowBlob getChildren+                     >>>+                     tryA (arrIO (\ s -> hPutDocument (\h -> do BS.hPutStr h s+                                                                BS.hPutStr h (stringToBlob "\n")+                                                      )+                                 )+                          )+                   )+            )+            >>>+            ( ( traceMsg 1 ("io error, document not written to " ++ outFile)                 >>>-                arrIO (\ s -> try ( hPutDocument (\h -> hPutStrLn h s)))+                arr show >>> mkError c_fatal                 >>>-                ( ( traceMsg 1 ("io error, document not written to " ++ outFile)-                    >>>-                    arr show >>> mkError c_fatal-                    >>>-                    filterErrorMsg-                  )-                  |||-                  ( traceMsg 2 ("document written to " ++ outFile)-                    >>>-                    none-                  )-                )+                filterErrorMsg               )-      where-      isStdout  = null dst || dst == "-"+              |||+              ( traceMsg 2 ("document written to " ++ outFile ++ ", textMode = " ++ show textMode)+                >>>+                none+              )+            )+          where+          isStdout  = null dst || dst == "-" -      outFile   = if isStdout-                  then "stdout"-                       else show dst+          outFile   = if isStdout+                      then "stdout"+                      else show dst -      hPutDocument      :: (Handle -> IO ()) -> IO ()-      hPutDocument action-          | isStdout-              = do-                hSetBinaryMode stdout (not textMode)-                action stdout-                hSetBinaryMode stdout False-          | otherwise-              = do-                handle <- ( if textMode-                            then openFile-                            else openBinaryFile-                          ) dst WriteMode-                action handle-                hClose handle+          hPutDocument      :: (Handle -> IO ()) -> IO ()+          hPutDocument action+              | isStdout+                  = do+                    hSetBinaryMode stdout (not textMode)+                    action stdout+                    hSetBinaryMode stdout False+              | otherwise+                  = do+                    handle <- ( if textMode+                                then openFile+                                else openBinaryFile+                              ) dst WriteMode+                    action handle+                    hClose handle  -- | -- write the tree representation of a document to a file@@ -135,9 +150,9 @@  getEncodingParam        :: IOStateArrow s XmlTree String getEncodingParam-    = catA [ getParamString a_output_encoding   -- 4. guess: take output encoding parameter from global state-           , getParamString a_encoding          -- 5. guess: take encoding parameter from global state-           , constA utf8                        -- default : utf8+    = catA [ getSysVar theOutputEncoding   -- 4. guess: take output encoding parameter from global state+           , getSysVar theInputEncoding    -- 5. guess: take encoding parameter from global state+           , constA utf8                   -- default : utf8            ]       >. (head . filter (not . null)) @@ -147,14 +162,14 @@     where     getEC enc' = fromLA $ getOutputEncoding' defaultEnc enc' -encodeDocument  :: Bool -> String -> IOStateArrow s XmlTree XmlTree-encodeDocument supressXmlPi defaultEnc+encodeDocument  :: Bool -> Bool -> String -> IOStateArrow s XmlTree XmlTree+encodeDocument quoteXml supressXmlPi defaultEnc     = encode $< getOutputEncoding defaultEnc     where     encode enc         = traceMsg 2 ("encodeDocument: encoding is " ++ show enc)           >>>-          ( encodeDocument' supressXmlPi enc+          ( encodeDocument' quoteXml supressXmlPi enc             `orElse`             ( issueFatal ("encoding scheme not supported: " ++ show enc)               >>>@@ -164,9 +179,21 @@  -- ------------------------------------------------------------ +isBinaryDoc               :: LA XmlTree XmlTree+isBinaryDoc               = ( ( getAttrValue transferMimeType >>^ stringToLower )+                              >>>+                              isA (\ t -> not (null t || isTextMimeType t || isXmlMimeType t))+                            )+                            `guards` this+ getOutputEncoding'      :: String -> String -> LA XmlTree String getOutputEncoding' defaultEnc defaultEnc2-    =  catA [ getChildren                       -- 1. guess: evaluate <?xml ... encoding="..."?>+    =  catA [ isBinaryDoc+              >>>                               -- 0. guess: binary data found: no encoding at all+              constA isoLatin1                  --           the content should usually be a blob+                                                --           this handling is like the decoding in DocumentInput,+                                                --           there nothing is decoded for non text or non xml contents+            , getChildren                       -- 1. guess: evaluate <?xml ... encoding="..."?>               >>>               ( ( isPi >>> hasName t_xml )                 `guards`@@ -178,29 +205,66 @@             ]       >. (head . filter (not . null))           -- make the filter deterministic: take 1. entry from list of guesses -encodeDocument' :: ArrowXml a => Bool -> String -> a XmlTree XmlTree-encodeDocument' supressXmlPi defaultEnc+encodeDocument' :: ArrowXml a => Bool -> Bool -> String -> a XmlTree XmlTree+encodeDocument' quoteXml supressXmlPi defaultEnc     = fromLA (encode $< getOutputEncoding' defaultEnc utf8)     where     encode      :: String -> LA XmlTree XmlTree     encode encodingScheme-        = case getOutputEncodingFct encodingScheme of-          Nothing       -> none-          Just ef       -> ( if supressXmlPi-                             then processChildren (none `when` isXmlPi)-                             else ( addXmlPi-                                    >>>-                                    addXmlPiEncoding encodingScheme-                                  )-                           )-                           >>>-                           replaceChildren ( xshow getChildren-                                             >>>-                                             arr ef-                                             >>>-                                             mkText-                                           )-                           >>>-                           addAttr a_output_encoding encodingScheme+        | encodingScheme == unicodeString+            = replaceChildren+              ( (getChildren >. XS.xshow'' cQuot aQuot)+                >>>+                mkText+              )+        | isNothing encodeFct+            = none+        | otherwise+            = ( if supressXmlPi+                then processChildren (none `when` isXmlPi)+                else ( addXmlPi+                       >>>+                       addXmlPiEncoding encodingScheme+                     )+              )+              >>>+              ( isLatin1Blob+                `orElse`+                encodeDoc (fromJust encodeFct)+              )+              >>>+              addAttr a_output_encoding encodingScheme+        where+        (cQuot, aQuot)+            | quoteXml  = escapeXmlRefs+            | otherwise = escapeHtmlRefs++        encodeFct       = getOutputEncodingFct' encodingScheme++        encodeDoc ef    = replaceChildren+                          ( xshowBlobWithEnc cQuot aQuot ef getChildren+                            >>>+                            mkBlob+                          )+        xshowBlobWithEnc cenc aenc enc f+                        = f >. XS.xshow' cenc aenc enc++        -- if encoding scheme is isolatin1 and the contents is a single blob (bytestring)+        -- the encoding is the identity.+        -- This optimization enables processing (copying) of none XML contents+        -- without any conversions from and to strings+        isLatin1Blob+            | encodingScheme /= isoLatin1+                        = none+            | otherwise = childIsSingleBlob `guards` this+            where+            childIsSingleBlob+                        = listA getChildren+                          >>>+                          isA (length >>> (== 1))+                          >>>+                          unlistA+                          >>>+                          isBlob  -- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/Edit.hs view
@@ -2,7 +2,7 @@  {- |    Module     : Text.XML.HXT.Arrow.Edit-   Copyright  : Copyright (C) 2006-9 Uwe Schmidt+   Copyright  : Copyright (C) 2011 Uwe Schmidt    License    : MIT     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)@@ -24,8 +24,8 @@      , xshowEscapeXml -    , escapeXmlDoc-    , escapeHtmlDoc+    , escapeXmlRefs+    , escapeHtmlRefs      , haskellRepOfXmlDoc     , treeRepOfXmlDoc@@ -46,6 +46,9 @@     , transfCharRef     , transfAllCharRef +    , substAllXHTMLEntityRefs+    , substXHTMLEntityRef+     , rememberDTDAttrl     , addDefaultDTDecl @@ -61,22 +64,25 @@ where  import           Control.Arrow-import           Control.Arrow.ArrowList import           Control.Arrow.ArrowIf+import           Control.Arrow.ArrowList import           Control.Arrow.ArrowTree import           Control.Arrow.ListArrow+import           Control.Arrow.NTreeEdit +import           Data.Char.Properties.XMLCharProps (isXmlSpaceChar)+ import           Text.XML.HXT.Arrow.XmlArrow+import           Text.XML.HXT.DOM.FormatXmlTree    (formatXmlTree) import           Text.XML.HXT.DOM.Interface-import qualified Text.XML.HXT.DOM.XmlNode       as XN-import           Text.XML.HXT.DOM.Unicode               ( isXmlSpaceChar )-import           Text.XML.HXT.DOM.FormatXmlTree         ( formatXmlTree )-import           Text.XML.HXT.Parser.HtmlParsec         ( emptyHtmlTags )-import           Text.XML.HXT.Parser.XmlEntities        ( xmlEntities )-import           Text.XML.HXT.Parser.XhtmlEntities      ( xhtmlEntities )+import qualified Text.XML.HXT.DOM.ShowXml          as XS+import qualified Text.XML.HXT.DOM.XmlNode          as XN+import           Text.XML.HXT.Parser.HtmlParsec    (emptyHtmlTags)+import           Text.XML.HXT.Parser.XhtmlEntities (xhtmlEntities)+import           Text.XML.HXT.Parser.XmlEntities   (xmlEntities) -import           Data.List                              ( isPrefixOf )-import qualified Data.Map                       as M+import           Data.List                         (isPrefixOf)+import qualified Data.Map                          as M import           Data.Maybe  -- ------------------------------------------------------------@@ -84,7 +90,7 @@ -- | -- Applies some "Canonical XML" rules to a document tree. ----- The rule differ slightly for canonical XML and XPath in handling of comments+-- The rules differ slightly for canonical XML and XPath in handling of comments -- -- Note: This is not the whole canonicalization as it is specified by the W3C -- Recommendation. Adding attribute defaults or sorting attributes in lexicographic@@ -102,30 +108,47 @@  canonicalizeTree'       :: LA XmlTree XmlTree -> LA XmlTree XmlTree canonicalizeTree' toBeRemoved-    = processChildren (none `when` isText)+    = ( processChildren+        ( (none `when` (isText <+> isXmlPi))    -- remove XML PI and all text around XML root element+          >>>+          (deep isPi `when` isDTD)              -- remove DTD parts, except PIs whithin DTD+        )+        `when` isRoot+      )       >>>-      processBottomUp canonicalize1Node-      where-      canonicalize1Node :: LA XmlTree XmlTree-      canonicalize1Node-          = (deep isPi `when` isDTD)            -- remove DTD parts, except PIs-            >>>-            (none `when` toBeRemoved)           -- remove unintersting nodes-            >>>-            ( processAttrl ( processChildren transfCharRef-                             >>>-                             collapseXText-                           )-              `when` isElem-            )-            >>>-            transfCdata                         -- CDATA -> text-            >>>-            transfCharRef                       -- Char refs -> text-            >>>-            collapseXText                       -- combine text+      canonicalizeNodes toBeRemoved +canonicalizeNodes       :: LA XmlTree XmlTree -> LA XmlTree XmlTree+canonicalizeNodes toBeRemoved+    = editNTreeA $+      [ toBeRemoved     :-> none+      , ( isElem >>> getAttrl >>> getChildren >>> isCharRef )   -- canonicalize attribute list+                        :-> ( processAttrl+                              ( processChildren transfCharRef+                                >>>+                                collapseXText'                  -- combine text in attribute values+                              )+                              >>>+                              ( collapseXText'                  -- and combine text in content+                                `when`+                                (getChildren >>. has2XText)+                              )+                            )+      , ( isElem >>> (getChildren >>. has2XText) )+                        :-> collapseXText'                      -- combine text in content +      , isCharRef       :-> ( getCharRef+                              >>>+                              arr (\ i -> [toEnum i])+                              >>>+                              mkText+                            )+      , isCdata         :-> ( getCdata+                              >>>+                              mkText+                            )+      ]+ -- | -- Applies some "Canonical XML" rules to a document tree. --@@ -146,12 +169,9 @@ --  - Special characters in attribute values and character content are replaced by character references  canonicalizeAllNodes    :: ArrowList a => a XmlTree XmlTree-canonicalizeAllNodes-    = fromLA $-      canonicalizeTree' ( isCmt         -- remove comment-                          <+>-                          isXmlPi       -- remove xml declaration-                        )+canonicalizeAllNodes    = fromLA $+                          canonicalizeTree' isCmt                       -- remove comment+{-# INLINE canonicalizeAllNodes #-}  -- | -- Canonicalize a tree for XPath@@ -160,9 +180,8 @@ -- see 'canonicalizeAllNodes'  canonicalizeForXPath    :: ArrowList a => a XmlTree XmlTree-canonicalizeForXPath-    = fromLA $-      canonicalizeTree' isXmlPi+canonicalizeForXPath    = fromLA $ canonicalizeTree' none               -- comment remains there+{-# INLINE canonicalizeForXPath #-}  -- | -- Canonicalize the contents of a document@@ -174,27 +193,20 @@ -- see 'canonicalizeAllNodes'  canonicalizeContents    :: ArrowList a => a XmlTree XmlTree-canonicalizeContents-    = fromLA $-      processBottomUp canonicalize1Node-      where-      canonicalize1Node :: LA XmlTree XmlTree-      canonicalize1Node-          = ( processAttrl ( processChildren transfCharRef-                             >>>-                             collapseXText-                           )-              `when` isElem-            )-            >>>-            transfCdata                         -- CDATA -> text-            >>>-            transfCharRef                       -- Char refs -> text-            >>>-            collapseXText                       -- combine text+canonicalizeContents    = fromLA $+                          canonicalizeNodes none+{-# INLINE canonicalizeContents #-}  -- ------------------------------------------------------------ +has2XText               :: XmlTrees -> XmlTrees+has2XText ts0@(t1 : ts1@(t2 : ts2))+    | XN.isText t1      = if XN.isText t2+                          then ts0+                          else has2XText ts2+    | otherwise         = has2XText ts1+has2XText _             = []+ collapseXText'          :: LA XmlTree XmlTree collapseXText'     = replaceChildren ( listA getChildren >>> arrL (foldr mergeText' []) )@@ -216,9 +228,7 @@ -- This is useful, e.g. after char and entity reference substitution  collapseXText           :: ArrowList a => a XmlTree XmlTree-collapseXText-    = fromLA $-      collapseXText'+collapseXText           = fromLA collapseXText'  -- | -- Applies collapseXText recursively.@@ -227,24 +237,24 @@ -- see also : 'collapseXText'  collapseAllXText        :: ArrowList a => a XmlTree XmlTree-collapseAllXText-    = fromLA $-      processBottomUp collapseXText'+collapseAllXText        = fromLA $ processBottomUp collapseXText'  -- ------------------------------------------------------------  -- | apply an arrow to the input and convert the resulting XML trees into an XML escaped string ----- This is a save variant for converting a tree into an XML string representation that is parsable with 'Text.XML.HXT.Arrow.ReadDocument'.--- It is implemented with 'Text.XML.HXT.Arrow.XmlArrow.xshow', but xshow does no XML escaping. The XML escaping is done with+-- This is a save variant for converting a tree into an XML string representation+-- that is parsable with 'Text.XML.HXT.Arrow.ReadDocument'.+-- It is implemented with 'Text.XML.HXT.Arrow.XmlArrow.xshow',+-- but xshow does no XML escaping. The XML escaping is done with -- 'Text.XML.HXT.Arrow.Edit.escapeXmlDoc' before xshow is applied. -- -- So the following law holds ----- > xshowEscape f >>> xread == f+-- > xshowEscapeXml f >>> xread == f  xshowEscapeXml          :: ArrowXml a => a n XmlTree -> a n String-xshowEscapeXml f        = xshow (f >>> escapeXmlDoc)+xshowEscapeXml f        = f >. (uncurry XS.xshow'' escapeXmlRefs)  -- ------------------------------------------------------------ @@ -257,131 +267,97 @@ xmlEntityRefTable  , xhtmlEntityRefTable  :: EntityRefTable -xmlEntityRefTable   = buildEntityRefTable $ xmlEntities-xhtmlEntityRefTable = buildEntityRefTable $ xhtmlEntities+xmlEntityRefTable       = buildEntityRefTable $ xmlEntities+xhtmlEntityRefTable     = buildEntityRefTable $ xhtmlEntities  buildEntityRefTable     :: [(String, Int)] -> EntityRefTable buildEntityRefTable     = M.fromList . map (\ (x,y) -> (y,x) ) -escapeText''    :: (Char -> XmlTree) -> (Char -> Bool) -> XmlTree -> XmlTrees-escapeText'' escChar isEsc t-    = maybe [t] escape' . XN.getText $ t-    where-    escape' "" = [t]            -- empty text nodes remain empty text nodes-    escape' s  = escape s       -- they do not disapear--    escape ""-        = []-    escape (c:s1)-        | isEsc c-            = escChar c : escape s1-    escape s-        = XN.mkText s1 : escape s2-        where-        (s1, s2) = break isEsc s--{--escapeCharRef   :: Char -> XmlTree-escapeCharRef   = XN.mkCharRef . fromEnum--}--escapeEntityRef :: EntityRefTable -> Char -> XmlTree-escapeEntityRef entityTable c-    = maybe (XN.mkCharRef c') XN.mkEntityRef . M.lookup c' $ entityTable-    where-    c' = fromEnum c--escapeXmlEntityRef      :: Char -> XmlTree-escapeXmlEntityRef      = escapeEntityRef xmlEntityRefTable+type EntitySubstTable   = M.Map String String -escapeHtmlEntityRef     :: Char -> XmlTree-escapeHtmlEntityRef     = escapeEntityRef xhtmlEntityRefTable+xhtmlEntitySubstTable   :: EntitySubstTable+xhtmlEntitySubstTable   = M.fromList . map (second $ (:[]) . toEnum) $ xhtmlEntities  -- ------------------------------------------------------------ --- |--- escape all special XML chars into XML entity references or char references------ convert the special XML chars \< and & in text nodes into prefefiened XML entity references,--- in attribute values also \', \", \>, \\n, \\r and \\t are converted into entity or char references,--- in comments nothing is converted (see XML standard 2.4, useful e.g. for JavaScript).--escapeXmlDoc            :: ArrowList a => a XmlTree XmlTree-escapeXmlDoc-    = fromLA $ escapeDoc escXmlText escXmlAttrValue+substXHTMLEntityRef     :: LA XmlTree XmlTree+substXHTMLEntityRef+    = ( getEntityRef+        >>>+        arrL subst+        >>>+        mkText+      )+      `orElse` this     where-    escXmlText-        = arrL $ escapeText'' escapeXmlEntityRef (`elem` "<&")          -- no escape for ", ' and > required: XML standard 2.4-    escXmlAttrValue-        = arrL $ escapeText'' escapeXmlEntityRef (`elem` "<>\"\'&\n\r\t")-+      subst name+          = maybe [] (:[]) $ M.lookup name xhtmlEntitySubstTable --- |--- escape all special HTML chars into XHTML entity references or char references------ convert the special XML chars \< and & and all none ASCII chars in text nodes into prefefiened XML or XHTML entity references,--- in attribute values also \', \", \>, \\n, \\r and \\t are converted into entity or char references,--- in comments nothing is converted+substAllXHTMLEntityRefs :: ArrowXml a => a XmlTree XmlTree+substAllXHTMLEntityRefs+    = fromLA $+      processBottomUp substXHTMLEntityRef  -- ------------------------------------------------------------ -escapeHtmlDoc           :: ArrowList a => a XmlTree XmlTree-escapeHtmlDoc-    = fromLA $ escapeDoc escHtmlText escHtmlAttrValue+escapeXmlRefs           :: (Char -> String -> String, Char -> String -> String)+escapeXmlRefs           = (cquote, aquote)     where-    escHtmlText-        = arrL $ escapeText'' escapeHtmlEntityRef isHtmlTextEsc-    escHtmlAttrValue-        = arrL $ escapeText'' escapeHtmlEntityRef isHtmlAttrEsc+    cquote c+        | c `elem` "<&" = ('&' :)+                          . ((lookupRef c xmlEntityRefTable) ++)+                          . (';' :)+        | otherwise     = (c :)+    aquote c+        | c `elem` "<>\"\'&\n\r\t"+                        = ('&' :)+                          . ((lookupRef c xmlEntityRefTable) ++)+                          . (';' :)+        | otherwise     = (c :) -    isHtmlTextEsc c-        = c >= toEnum(128) || ( c `elem` "<&" )-    isHtmlAttrEsc c-        = c >= toEnum(128) || ( c `elem` "<>\"\'&\n\r\t" )+escapeHtmlRefs          :: (Char -> String -> String, Char -> String -> String)+escapeHtmlRefs          = (cquote, aquote)+    where+    cquote c+        | isHtmlTextEsc c+                        = ('&' :)+                          . ((lookupRef c xhtmlEntityRefTable) ++)+                          . (';' :)+        | otherwise     = (c :)+    aquote c+        | isHtmlAttrEsc c+                        = ('&' :)+                          . ((lookupRef c xhtmlEntityRefTable) ++)+                          . (';' :)+        | otherwise     = (c :) --- ------------------------------------------------------------+    isHtmlTextEsc c     = c >= toEnum(128) || ( c `elem` "<&" )+    isHtmlAttrEsc c     = c >= toEnum(128) || ( c `elem` "<>\"\'&\n\r\t" ) -escapeDoc               :: LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree-escapeDoc escText escAttr-    = escape-    where-    escape-        = choiceA-          [ isElem  :-> ( processChildren escape-                          >>>-                          processAttrl escVal-                        )-          , isText  :-> escText-          -- , isCmt   :-> escCmt-          , isDTD   :-> processTopDown escDTD-          , this    :-> this-          ]-    escVal   = processChildren escAttr-    escDTD   = escVal `when` ( isDTDEntity <+> isDTDPEntity )+lookupRef               :: Char -> EntityRefTable -> String+lookupRef c             = fromMaybe ('#' : show (fromEnum c))+                          . M.lookup (fromEnum c)+{-# INLINE lookupRef #-}  -- ------------------------------------------------------------  preventEmptyElements    :: ArrowList a => [String] -> Bool -> a XmlTree XmlTree preventEmptyElements ns isHtml-    = fromLA $ insertDummyElem+    = fromLA $+      editNTreeA [ ( isElem+                     >>>+                     isNoneEmpty+                     >>>+                     neg getChildren+                   )+                   :-> replaceChildren (txt "")+                 ]     where     isNoneEmpty         | not (null ns) = hasNameWith (localPart >>> (`elem` ns))         | isHtml        = hasNameWith (localPart >>> (`notElem` emptyHtmlTags))         | otherwise     = this -    insertDummyElem-        = processBottomUp-          ( replaceChildren (txt "")-            `when`-            ( isElem-              >>>-              isNoneEmpty-              >>>-              neg getChildren-            )-          )- -- ------------------------------------------------------------  -- |@@ -440,25 +416,19 @@  -- ------------------------------------------------------------ -removeComment'          :: LA XmlTree XmlTree-removeComment'          = none `when` isCmt- -- |--- remove Comments: @none `when` isCmt@+-- remove a Comment node  removeComment           :: ArrowXml a => a XmlTree XmlTree-removeComment           = fromLA $ removeComment'+removeComment           = none `when` isCmt  -- |--- remove all comments recursively+-- remove all comments in a tree recursively  removeAllComment        :: ArrowXml a => a XmlTree XmlTree-removeAllComment        = fromLA $ processBottomUp removeComment'---- ----------+removeAllComment        = fromLA $ editNTreeA [isCmt :-> none] -removeWhiteSpace'       :: LA XmlTree XmlTree-removeWhiteSpace'       = none `when` isWhiteSpace+-- ------------------------------------------------------------  -- | -- simple filter for removing whitespace.@@ -469,7 +439,7 @@ -- see also : 'removeAllWhiteSpace', 'removeDocWhiteSpace'  removeWhiteSpace        :: ArrowXml a => a XmlTree XmlTree-removeWhiteSpace        = fromLA $ removeWhiteSpace'+removeWhiteSpace        = fromLA $ none `when` isWhiteSpace  -- | -- simple recursive filter for removing all whitespace.@@ -480,8 +450,11 @@ -- see also : 'removeWhiteSpace', 'removeDocWhiteSpace'  removeAllWhiteSpace     :: ArrowXml a => a XmlTree XmlTree-removeAllWhiteSpace     = fromLA $ processBottomUp removeWhiteSpace'+removeAllWhiteSpace     = fromLA $ editNTreeA [isWhiteSpace :-> none]+                       -- fromLA $ processBottomUp removeWhiteSpace'    -- less efficient +-- ------------------------------------------------------------+ -- | -- filter for removing all not significant whitespace. --@@ -672,43 +645,33 @@  -- ------------------------------------------------------------ -transfCdata'            :: LA XmlTree XmlTree-transfCdata'            = (getCdata >>> mkText) `when` isCdata- -- |--- converts a CDATA section node into a normal text node+-- converts a CDATA section into normal text nodes  transfCdata             :: ArrowXml a => a XmlTree XmlTree transfCdata             = fromLA $-                          transfCdata'+                          (getCdata >>> mkText) `when` isCdata  -- | -- converts CDATA sections in whole document tree into normal text nodes  transfAllCdata          :: ArrowXml a => a XmlTree XmlTree-transfAllCdata          = fromLA $-                          processBottomUp transfCdata'------transfCharRef'          :: LA XmlTree XmlTree-transfCharRef'          = ( getCharRef >>> arr (\ i -> [toEnum i]) >>> mkText )-                          `when`-                          isCharRef+transfAllCdata          = fromLA $ editNTreeA [isCdata :-> (getCdata >>> mkText)]  -- |--- converts character references to normal text+-- converts a character reference to normal text  transfCharRef           :: ArrowXml a => a XmlTree XmlTree transfCharRef           = fromLA $-                          transfCharRef'+                          ( getCharRef >>> arr (\ i -> [toEnum i]) >>> mkText )+                          `when`+                          isCharRef  -- | -- recursively converts all character references to normal text  transfAllCharRef        :: ArrowXml a => a XmlTree XmlTree-transfAllCharRef        = fromLA $-                          processBottomUp transfCharRef'+transfAllCharRef        = fromLA $ editNTreeA [isCharRef :-> (getCharRef >>> arr (\ i -> [toEnum i]) >>> mkText)]  -- ------------------------------------------------------------ @@ -740,7 +703,7 @@             <+>             txt "\n"             <+>-            ( getChildren >>> (none `when` isDTDDoctype) )      -- remove old DTD stuff+            ( getChildren >>> (none `when` isDTDDoctype) )      -- remove old DTD decl           )  -- ------------------------------------------------------------@@ -761,7 +724,7 @@ addXmlPi                :: ArrowXml a => a XmlTree XmlTree addXmlPi     = fromLA-      ( insertChildrenAt 0 ( ( mkPi (mkSNsName t_xml) none+      ( insertChildrenAt 0 ( ( mkPi (mkName t_xml) none                                >>>                                addAttr a_version "1.0"                              )
src/Text/XML/HXT/Arrow/GeneralEntitySubstitution.hs view
@@ -8,7 +8,6 @@    Maintainer : Uwe Schmidt (uwe@fh-wedel.de)    Stability  : experimental    Portability: portable-   Version    : $Id: GeneralEntitySubstitution.hs,v 1.13 2006/05/01 18:56:24 hxml Exp $     general entity substitution @@ -26,12 +25,13 @@ import Control.Arrow.ArrowTree  import Text.XML.HXT.DOM.Interface+ import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlIOStateArrow+import Text.XML.HXT.Arrow.XmlState  import Text.XML.HXT.Arrow.ParserInterface-    ( parseXmlAttrValue-    , parseXmlGeneralEntityValue+    ( parseXmlEntityValueAsAttrValue+    , parseXmlEntityValueAsContent     )  import Text.XML.HXT.Arrow.Edit@@ -71,7 +71,7 @@ emptyGeEnv      :: GEEnv emptyGeEnv      = GEEnv M.empty -lookupGeEnv             :: String -> GEEnv -> Maybe GESubstArrow+lookupGeEnv     :: String -> GEEnv -> Maybe GESubstArrow lookupGeEnv k (GEEnv env)     = M.lookup k env @@ -108,10 +108,10 @@                                       >>>                                       processChildren (processGeneralEntity context recl)                                     )+              , isEntityRef     :-> substEntityRef               , isDTDDoctype    :-> processChildren (processGeneralEntity context recl)               , isDTDEntity     :-> addEntityDecl               , isDTDAttlist    :-> substEntitiesInAttrDefaultValue-              , isEntityRef     :-> substEntityRef               , this            :-> this               ]     where@@ -129,45 +129,35 @@      addInternalEntity   :: GEArrow XmlTree b     addInternalEntity-        = ( ( getDTDAttrValue a_name+        = insertInternal $<<+          ( ( getDTDAttrValue a_name               >>>               traceValue 2 (("processGeneralEntity: general entity definition for " ++) . show)             )             &&&             xshow (getChildren >>> isText)           )-          >>>-          applyA ( arr2 $ \ entity str ->-                   listA ( ( ( txt str-                               >>>-                               parseXmlGeneralEntityValue ("general internal entity" ++ show entity)-                               >>>-                               filterErrorMsg-                             )-                             `orElse` txt ""-                           )-                           >>>-                           processGeneralEntity ReferenceInEntityValue (entity : recl)-                         )-                   >>>-                   applyA (arr $ \ ts -> insertEntity (substInternal ts) entity)-                 )-          >>>-          none+        where+        insertInternal entity contents+            = insertEntity (substInternal contents) entity+              >>>+              none      addExternalEntity   :: GEArrow XmlTree b     addExternalEntity-        = ( ( getDTDAttrValue a_name+        = insertExternal $<<+          ( ( getDTDAttrValue a_name               >>>               traceValue 2 (("processGeneralEntity: external entity definition for " ++) . show)             )             &&&             getDTDAttrValue a_url                       -- the absolute URL, not the relative in attr: k_system           )-          >>>-          applyA (arr2 $ \ entity uri -> insertEntity (substExternalParsed1Time uri) entity)-          >>>-          none+        where+        insertExternal entity uri+            = insertEntity (substExternalParsed1Time uri) entity+              >>>+              none      addUnparsedEntity   :: GEArrow XmlTree b     addUnparsedEntity@@ -194,6 +184,8 @@             ok  = this             alreadyDefined _                 = issueWarn ("entity " ++ show entity ++ " already defined, repeated definition ignored")+                  >>>+                  none      addEntity   :: (String -> GESubstArrow) -> String -> GEArrow b b     addEntity fct entity@@ -207,8 +199,8 @@                            >>>                                          -- substitute entities                            mkText                                       -- and convert value into a string                            >>>-                           parseXmlAttrValue "default value of attribute"-                           >>>+                           parseXmlEntityValueAsAttrValue "default value of attribute"+                           >>>                                                                     filterErrorMsg                            >>>                            substEntitiesInAttrValue@@ -244,7 +236,6 @@                    ) >>>                    arr2 substA                  )-          `orElse` this           where           substA        :: String -> GEEnv -> GEArrow XmlTree XmlTree           substA entity geEnv@@ -268,45 +259,43 @@                     >>>                     runInLocalURIContext ( root [sattr a_source uri] []         -- uri must be an absolute uri                                            >>>                                  -- abs uri is computed during parameter entity handling-                                           listA ( getXmlEntityContents-                                                   >>>-                                                   processExternalEntityContents-                                                 )+                                           getXmlEntityContents+                                           >>>+                                           processExternalEntityContents                                          )                     >>>-                    applyA ( arr $ \ ts -> addEntity (substExternalParsed ts) entity )+                    applyA ( arr $ \ s -> addEntity (substExternalParsed s) entity )                   )           >>>           processGeneralEntity cx rl         where-        processExternalEntityContents   :: IOStateArrow s XmlTree XmlTree+        processExternalEntityContents   :: IOStateArrow s XmlTree String         processExternalEntityContents-            = ( ( documentStatusOk                              -- reading entity succeeded-                  >>>                                           -- with content stored in a text node-                  (getChildren >>> isText)-                )-                `guards`-                ( getChildren-                  >>>-                  parseXmlGeneralEntityValue ("external parsed entity " ++ show entity)-                  >>>-                  filterErrorMsg+            = ( ( ( documentStatusOk                              -- reading entity succeeded+                    >>>                                           -- with content stored in a text node+                    (getChildren >>> isText)+                  )+                  `guards`+                  this                 )+                `orElse`+                issueErr ("illegal value for external parsed entity " ++ show entity)               )-              `orElse`-              issueErr ("illegal value for external parsed entity " ++ show entity)+              >>>+              xshow (getChildren >>> isText) -    substExternalParsed                                 :: XmlTrees -> String -> GESubstArrow-    substExternalParsed ts entity ReferenceInContent rl = includedIfValidating ts rl entity-    substExternalParsed _  entity ReferenceInAttributeValue _++    substExternalParsed                                 :: String -> String -> GESubstArrow+    substExternalParsed s entity ReferenceInContent rl  = includedIfValidating s rl entity+    substExternalParsed _ entity ReferenceInAttributeValue _                                                         = forbidden entity "external parsed general" "in attribute value"-    substExternalParsed _  _      ReferenceInEntityValue _+    substExternalParsed _ _      ReferenceInEntityValue _                                                         = bypassed -    substInternal                                       :: XmlTrees -> String -> GESubstArrow-    substInternal ts entity ReferenceInContent rl       = included          ts rl entity-    substInternal ts entity ReferenceInAttributeValue rl= includedInLiteral ts rl entity-    substInternal _  _      ReferenceInEntityValue _    = bypassed+    substInternal                                       :: String -> String -> GESubstArrow+    substInternal s entity ReferenceInContent rl        = included          s rl entity+    substInternal s entity ReferenceInAttributeValue rl = includedInLiteral s rl entity+    substInternal _ _      ReferenceInEntityValue _     = bypassed      substUnparsed                                       :: String -> GESubstArrow     substUnparsed entity ReferenceInContent        _    = forbidden entity "unparsed" "content"@@ -314,27 +303,37 @@     substUnparsed entity ReferenceInEntityValue    _    = forbidden entity "unparsed" "entity value"                                                                          -- XML 1.0 chapter 4.4.2-    included            :: XmlTrees -> RecList -> String -> GEArrow XmlTree XmlTree-    included ts rl entity-        = arrL (const ts)+    included            :: String -> RecList -> String -> GEArrow XmlTree XmlTree+    included s rl entity+        = traceMsg 3 ("substituting general entity " ++ show entity ++ " with value " ++ show s)           >>>+          txt s+          >>>+          parseXmlEntityValueAsContent ("substituting general entity " ++ show entity ++ " in contents")+          >>>+          filterErrorMsg+          >>>           processGeneralEntity context (entity : rl)                                                                          -- XML 1.0 chapter 4.4.3-    includedIfValidating                :: XmlTrees -> RecList -> String -> GEArrow XmlTree XmlTree+    includedIfValidating                :: String -> RecList -> String -> GEArrow XmlTree XmlTree     includedIfValidating         = included-                                                                         -- XML 1.0 chapter 4.4.4     forbidden           :: String -> String -> String -> GEArrow XmlTree XmlTree     forbidden entity msg cx         = issueErr ("reference of " ++ msg ++ show entity ++ " forbidden in " ++ cx)                                                                          -- XML 1.0 chapter 4.4.5-    includedInLiteral           :: XmlTrees -> RecList -> String -> GEArrow XmlTree XmlTree-    includedInLiteral-        = included-+    includedInLiteral           :: String -> RecList -> String -> GEArrow XmlTree XmlTree+    includedInLiteral s rl entity+        = txt s+          >>>+          parseXmlEntityValueAsAttrValue ("substituting general entity " ++ show entity ++ " in attribute value")+          >>>+          filterErrorMsg+          >>>+          processGeneralEntity context (entity : rl)                                                                         -- XML 1.0 chapter 4.4.7     bypassed            :: GEArrow XmlTree XmlTree     bypassed
src/Text/XML/HXT/Arrow/Namespace.hs view
@@ -53,6 +53,7 @@ isNamespaceDeclAttr     = fromLA $       (getAttrName >>> isA isNameSpaceName) `guards` this+{-# INLINE isNamespaceDeclAttr #-}  -- | get the namespace prefix and the namespace URI out of -- an attribute tree with a namespace declaration (see 'isNamespaceDeclAttr')@@ -109,14 +110,14 @@  -- ------------------------------------------------------------ --- | generate unique namespaces and add all namespace declarations to the root element+-- | generate unique namespaces and add all namespace declarations to all top nodes containing a namespace declaration+-- Usually the top node containing namespace declarations is the root node, but this isn't mandatory. -- -- Calls 'cleanupNamespaces' with 'collectNamespaceDecl' -uniqueNamespaces                :: ArrowXml a => a XmlTree XmlTree-uniqueNamespaces-    = fromLA $-      cleanupNamespaces collectNamespaceDecl+uniqueNamespaces                        :: ArrowXml a => a XmlTree XmlTree+uniqueNamespaces                        = fromLA $+                                          cleanupNamespaces' collectNamespaceDecl  -- | generate unique namespaces and add all namespace declarations for all prefix-uri pairs in all qualified names --@@ -124,10 +125,22 @@ -- Calls 'cleanupNamespaces' with @ collectNamespaceDecl \<+> collectPrefixUriPairs @  uniqueNamespacesFromDeclAndQNames       :: ArrowXml a => a XmlTree XmlTree-uniqueNamespacesFromDeclAndQNames-    = fromLA $-      cleanupNamespaces (collectNamespaceDecl <+> collectPrefixUriPairs)+uniqueNamespacesFromDeclAndQNames       = fromLA $+                                          cleanupNamespaces' ( collectNamespaceDecl+                                                               <+>+                                                               collectPrefixUriPairs+                                                             ) +cleanupNamespaces'                      :: LA XmlTree (String, String) -> LA XmlTree XmlTree+cleanupNamespaces' collectNamespaces    = processTopDownUntil+                                          ( hasNamespaceDecl `guards` cleanupNamespaces collectNamespaces )+    where+    hasNamespaceDecl                    = isElem+                                          >>>+                                          getAttrl+                                          >>>+                                          isNamespaceDeclAttr+ -- | does the real work for namespace cleanup. -- -- The parameter is used for collecting namespace uris and prefixes from the input tree@@ -148,7 +161,7 @@             changeQName renamePrefix                    -- update namespace prefix of element names           )           >>>-          attachEnv env1                                -- all all namespaces as attributes to the root node attribute list+          attachEnv env1                                -- add all namespaces as attributes to the root node attribute list         where         renamePrefix    :: QName -> QName         renamePrefix n@@ -261,11 +274,11 @@      nsDeclToAttr        :: (XName, XName) -> LA XmlTree XmlTree     nsDeclToAttr (n, uri)-        = mkAttr qn (txt (show uri))+        = mkAttr qn (txt (unXN uri))         where         qn :: QName-        qn | isNullXName n      = mkQName' nullXName  xmlnsXName xmlnsNamespaceXName-           | otherwise          = mkQName' xmlnsXName n          xmlnsNamespaceXName+        qn | isNullXName n      = newQName xmlnsXName nullXName  xmlnsNamespaceXName+           | otherwise          = newQName n          xmlnsXName xmlnsNamespaceXName  -- ----------------------------------------------------------------------------- @@ -362,7 +375,7 @@                           , ( getQName >>> isA (not . isWellformedNSDecl )                            )-                           `guards`  nsError (\ n -> "illegal namespace declaration for name " ++ n ++ " starting with reserved prefix " ++ show "xml" )+                           `guards`  nsError (\ n -> "illegal namespace declaration for name " ++ show n ++ " starting with reserved prefix " ++ show "xml" )                          ]        , isDTD   :-> catA [ isDTDDoctype <+> isDTDAttlist <+> isDTDElement <+> isDTDName@@ -401,11 +414,11 @@                          ]       ]     where-    nsError     :: (String -> String) -> LA XmlTree XmlTree+    nsError     :: (QName -> String) -> LA XmlTree XmlTree     nsError msg-        = (getQName >>> arr show) >>> nsErr msg+        = getQName >>> nsErr msg -    nsErr       :: (String -> String) -> LA String XmlTree+    nsErr       :: (a -> String) -> LA a XmlTree     nsErr msg   = arr msg >>> mkError c_err      doubleOcc   :: String -> LA XmlTree XmlTree
src/Text/XML/HXT/Arrow/ParserInterface.hs view
@@ -1,29 +1,31 @@--- |--- interface to the HXT XML and DTD parsers------ version: $Id: ParserInterface.hs,v 1.1 2006/05/01 18:56:24 hxml Exp $+-- ------------------------------------------------------------ +{- |+   Module     : Text.XML.HXT.Arrow.ParserInterface+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   interface to the HXT XML and DTD parsers+-}++-- ------------------------------------------------------------+ module Text.XML.HXT.Arrow.ParserInterface     ( module Text.XML.HXT.Arrow.ParserInterface ) where -import Control.Arrow import Control.Arrow.ArrowList-import Control.Arrow.ArrowIf-import Control.Arrow.ArrowTree-import Control.Arrow.ListArrow -import Text.XML.HXT.Parser.XmlEntities  ( xmlEntities   )-import Text.XML.HXT.Parser.XhtmlEntities( xhtmlEntities )- import Text.XML.HXT.DOM.Interface import Text.XML.HXT.Arrow.XmlArrow -import qualified Text.XML.HXT.Parser.TagSoup             as TS import qualified Text.XML.HXT.Parser.HtmlParsec          as HP import qualified Text.XML.HXT.Parser.XmlParsec           as XP import qualified Text.XML.HXT.Parser.XmlDTDParser        as DP-import qualified Text.XML.HXT.DTDValidation.Validation   as VA  -- ------------------------------------------------------------ @@ -33,9 +35,12 @@ parseXmlDTDPart                 :: ArrowXml a => a (String, XmlTree) XmlTree parseXmlDTDPart                 =  arr2L XP.parseXmlDTDPart -parseXmlContent                 :: ArrowXml a => a String XmlTree-parseXmlContent                 =  arrL XP.xread+xreadCont                       :: ArrowXml a => a String XmlTree+xreadCont                       =  arrL XP.xread +xreadDoc                        :: ArrowXml a => a String XmlTree+xreadDoc                        =  arrL XP.xreadDoc+ parseXmlEntityEncodingSpec   , parseXmlDocEncodingSpec   , removeEncodingSpec          :: ArrowXml a => a XmlTree XmlTree@@ -54,82 +59,21 @@ parseXmlDTDEntityValue          :: ArrowXml a => a XmlTree XmlTree parseXmlDTDEntityValue          =  arrL DP.parseXmlDTDEntityValue -parseXmlAttrValue               :: ArrowXml a => String -> a XmlTree XmlTree-parseXmlAttrValue context       =  arrL (XP.parseXmlAttrValue context)+parseXmlEntityValueAsContent    :: ArrowXml a => String -> a XmlTree XmlTree+parseXmlEntityValueAsContent    =  arrL . XP.parseXmlEntityValueAsContent -parseXmlGeneralEntityValue      :: ArrowXml a => String -> a XmlTree XmlTree-parseXmlGeneralEntityValue context-                                =  arrL (XP.parseXmlGeneralEntityValue context)+parseXmlEntityValueAsAttrValue  :: ArrowXml a => String -> a XmlTree XmlTree+parseXmlEntityValueAsAttrValue  =  arrL . XP.parseXmlEntityValueAsAttrValue  -- ------------------------------------------------------------  parseHtmlDoc                    :: ArrowList a => a (String, String) XmlTree parseHtmlDoc                    = arr2L HP.parseHtmlDocument -parseHtmlContent                :: ArrowList a => a String XmlTree-parseHtmlContent                = arrL  HP.parseHtmlContent--parseHtmlTagSoup                :: ArrowList a => Bool -> Bool -> Bool -> Bool -> Bool -> a (String, String) XmlTree-parseHtmlTagSoup withNamespaces withWarnings preserveCmt removeWS asHtml-                                = arr2L (TS.parseHtmlTagSoup withNamespaces withWarnings preserveCmt removeWS asHtml)---- --------------------------------------------------------------validateDoc                     :: ArrowList a => a XmlTree XmlTree-validateDoc                     = fromLA ( VA.validate-                                           `when`-                                           VA.getDTDSubset      -- validate only when DTD decl is present-                                         )--transformDoc                    :: ArrowList a => a XmlTree XmlTree-transformDoc                    = fromLA VA.transform---- old stuff--- validateDoc                  = arrL VA.validate--- transformDoc                 = arrL VA.transform---- ---------------------------------------------------------------- | substitution of all predefined XHTMT entities for none ASCII chars------ This arrow recurses through a whole XML tree and substitutes all--- entity refs within text nodes and attribute values by a text node--- containing of a single char corresponding to this entity.------ Unknown entity refs remain unchanged--substHtmlEntityRefs             :: ArrowList a => a XmlTree XmlTree-substHtmlEntityRefs             = substEntityRefs xhtmlEntities----- | substitution of the five predefined XMT entities, works like 'substHtmlEntityRefs'--substXmlEntityRefs              :: ArrowList a => a XmlTree XmlTree-substXmlEntityRefs              = substEntityRefs xmlEntities---- | the entity substitution arrow called from 'substXmlEntityRefs' and 'substHtmlEntityRefs'--substEntityRefs         :: ArrowList a => [(String, Int)] -> a XmlTree XmlTree-substEntityRefs entities-    = fromLA substEntities-    where-    substEntities               :: LA XmlTree XmlTree-    substEntities-        = choiceA-          [ isEntityRef :-> ( substEntity $< getEntityRef )-          , isElem      :-> ( processAttrl (processChildren substEntities)-                              >>>-                              processChildren substEntities-                            )-          , this        :-> this-          ]-        where-        substEntity en-            = case (lookup en entities) of-              Just i-                  -> txt [toEnum i]     -- constA i >>> mkCharRef-              Nothing-                  -> this+hread                           :: ArrowList a => a String XmlTree+hread                           = arrL   HP.parseHtmlContent +hreadDoc                        :: ArrowList a => a String XmlTree+hreadDoc                        = arrL $ HP.parseHtmlDocument "string"  -- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/Pickle.hs view
@@ -8,7 +8,6 @@    Maintainer : Uwe Schmidt (uwe@fh-wedel.de)    Stability  : experimental    Portability: portable-   Version    : $Id$  Pickler functions for converting between user defined data types and XmlTree data. Usefull for persistent storage and retreival@@ -16,7 +15,7 @@  This module is an adaptation of the pickler combinators developed by Andrew Kennedy-( http:\/\/research.microsoft.com\/~akenn\/fun\/picklercombinators.pdf )+( https:\/\/www.microsoft.com\/en-us\/research\/wp-content\/uploads\/2004\/01\/picklercombinators.pdf )  The difference to Kennedys approach is that the target is not a list of Chars but a list of XmlTrees. The basic picklers will@@ -50,25 +49,55 @@       -- from Text.XML.HXT.Arrow.Pickle.Xml     , pickleDoc     , unpickleDoc+    , unpickleDoc'+    , showPickled      , PU(..)-    , XmlPickler+    , XmlPickler(..)      , xp4Tuple     , xp5Tuple     , xp6Tuple+    , xp7Tuple+    , xp8Tuple+    , xp9Tuple+    , xp10Tuple+    , xp11Tuple+    , xp12Tuple+    , xp13Tuple+    , xp14Tuple+    , xp15Tuple+    , xp16Tuple+    , xp17Tuple+    , xp18Tuple+    , xp19Tuple+    , xp20Tuple+    , xp21Tuple+    , xp22Tuple+    , xp23Tuple+    , xp24Tuple+     , xpAddFixedAttr+    , xpAddNSDecl     , xpAlt     , xpAttr     , xpAttrFixed     , xpAttrImplied+    , xpAttrNS+    , xpCheckEmpty+    , xpCheckEmptyAttributes+    , xpCheckEmptyContents+    , xpTextAttr     , xpChoice-    , xpCondSeq     , xpDefault     , xpElem+    , xpElemNS     , xpElemWithAttrValue-    , xpickle+    , xpFilterAttr+    , xpFilterCont+    , xpInt     , xpLift+    , xpLiftEither     , xpLiftMaybe     , xpList     , xpList1@@ -77,6 +106,7 @@     , xpPair     , xpPrim     , xpSeq+    , xpSeq'     , xpText     , xpText0     , xpTextDT@@ -86,6 +116,7 @@     , xpTriple     , xpUnit     , xpWrap+    , xpWrapEither     , xpWrapMaybe     , xpXmlText     , xpZero@@ -97,15 +128,15 @@     ) where -import           Data.Maybe- import           Control.Arrow.ListArrows  import           Text.XML.HXT.DOM.Interface-import           Text.XML.HXT.Arrow.XmlArrow-import           Text.XML.HXT.Arrow.XmlIOStateArrow+ import           Text.XML.HXT.Arrow.ReadDocument import           Text.XML.HXT.Arrow.WriteDocument+import           Text.XML.HXT.Arrow.XmlArrow+import           Text.XML.HXT.Arrow.XmlState+import           Text.XML.HXT.Arrow.XmlState.TypeDefs  import           Text.XML.HXT.Arrow.Pickle.Xml import           Text.XML.HXT.Arrow.Pickle.Schema@@ -123,21 +154,25 @@ -- An option evaluated by this arrow is 'a_addDTD'. -- If 'a_addDTD' is set ('v_1'), the pickler DTD is added as an inline DTD into the document. -xpickleDocument         :: PU a -> Attributes -> String -> IOStateArrow s a XmlTree-xpickleDocument xp al dest-    = xpickleVal xp+xpickleDocument         :: PU a -> SysConfigList -> String -> IOStateArrow s a XmlTree+xpickleDocument xp config dest+    = localSysEnv+      $+      configSysVars config       >>>+      xpickleVal xp+      >>>       traceMsg 1 "xpickleVal applied"       >>>-      ( if lookup1 a_addDTD al == v_1-        then replaceChildren ( (constA undefined >>> xpickleDTD xp >>> getChildren)-                               <+>-                               getChildren-                             )-        else this-      )+      ifA ( getSysAttr a_addDTD >>> isA (== v_1) )+          ( replaceChildren ( (constA undefined >>> xpickleDTD xp >>> getChildren)+                              <+>+                              getChildren+                            )+          )+          this       >>>-      writeDocument al dest+      writeDocument [] dest  -- | Option for generating and adding DTD when document is pickled @@ -154,9 +189,9 @@ -- when applied with the appropriate options. When during pickling indentation is switched on, -- the whitespace must be removed during unpickling. -xunpickleDocument       :: PU a -> Attributes -> String -> IOStateArrow s b a-xunpickleDocument xp al src-                        = readDocument al src+xunpickleDocument       :: PU a -> SysConfigList -> String -> IOStateArrow s b a+xunpickleDocument xp conf src+                        = readDocument conf src                           >>>                           traceMsg 1 ("xunpickleVal for " ++ show src ++ " started")                           >>>@@ -166,11 +201,11 @@  -- | Write out the DTD generated out of a pickler. Calls 'xpicklerDTD' -xpickleWriteDTD         :: PU b -> Attributes -> String -> IOStateArrow s b XmlTree-xpickleWriteDTD xp al dest+xpickleWriteDTD         :: PU b -> SysConfigList -> String -> IOStateArrow s b XmlTree+xpickleWriteDTD xp config dest                         = xpickleDTD xp                           >>>-                          writeDocument al dest+                          writeDocument config dest  -- | The arrow for generating the DTD out of a pickler --@@ -204,15 +239,9 @@                                   >>>                                   writeDocumentToString []                                   >>>-                                  readFromString [(a_validate, v_1)]+                                  readFromString [withValidate True]                                   >>>-                                  ( xunpickleVal xp-                                    `orElse`-                                    ( issueErr "unpickling the document failed"-                                      >>>-                                      none-                                    )-                                  )+                                  xunpickleVal xp                                 )                                 &&&                                 this@@ -230,9 +259,31 @@  -- | The arrow version of the unpickler function +{- old version, runs outside IO xunpickleVal            :: ArrowXml a => PU b -> a XmlTree b-xunpickleVal xp         = arrL (maybeToList . unpickleDoc xp)+xunpickleVal xp         = ( processChildren (none `whenNot` isElem)     -- remove all stuff surrounding the root element+                            `when`+                            isRoot+                          )+                          >>>+                          arrL (maybeToList . unpickleDoc xp)+-- -} +xunpickleVal           :: PU b -> IOStateArrow s XmlTree b+xunpickleVal xp        = ( processChildren (none `whenNot` isElem)     -- remove all stuff surrounding the root element+                            `when`+                            isRoot+                          )+                          >>>+                          arr (unpickleDoc' xp)+                          >>>+                          ( ( (issueFatal $< arr ("document unpickling failed\n" ++))+                              >>>+                              none+                            )+                            |||+                            this+                          )  -- | Compute the associated DTD of a pickler @@ -240,5 +291,3 @@ thePicklerDTD           = dtdDescrToXml . dtdDescr . theSchema  -- --------------------------------------------------------------
src/Text/XML/HXT/Arrow/Pickle/DTD.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+ -- ------------------------------------------------------------  {- |@@ -26,7 +28,7 @@  import           Text.XML.HXT.DOM.Interface import           Text.XML.HXT.Arrow.Pickle.Schema-import           Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C+import           Text.XML.HXT.XMLSchema.DataTypeLibW3CNames  -- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/Pickle/Schema.hs view
@@ -23,7 +23,7 @@ where  import Text.XML.HXT.DOM.TypeDefs-import Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C+import Text.XML.HXT.XMLSchema.DataTypeLibW3CNames  import Data.List     ( sort )
src/Text/XML/HXT/Arrow/Pickle/Xml.hs view
@@ -1,694 +1,1518 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.Arrow.Pickle.Xml-   Copyright  : Copyright (C) 2005-2008 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : experimental-   Portability: portable--   Pickler functions for converting between user defined data types-   and XmlTree data. Usefull for persistent storage and retreival-   of arbitray data as XML documents--   This module is an adaptation of the pickler combinators-   developed by Andrew Kennedy-   ( http:\/\/research.microsoft.com\/~akenn\/fun\/picklercombinators.pdf )--   The difference to Kennedys approach is that the target is not-   a list of Chars but a list of XmlTrees. The basic picklers will-   convert data into XML text nodes. New are the picklers for-   creating elements and attributes.--   One extension was neccessary: The unpickling may fail.-   Therefore the unpickler has a Maybe result type.-   Failure is used to unpickle optional elements-   (Maybe data) and lists of arbitray length--   There is an example program demonstrating the use-   of the picklers for a none trivial data structure.-   (see \"examples\/arrows\/pickle\" directory)---}---- --------------------------------------------------------------module Text.XML.HXT.Arrow.Pickle.Xml-where--import           Data.Maybe-import           Data.Map (Map)-import qualified Data.Map as M--import           Text.XML.HXT.DOM.Interface-import qualified Text.XML.HXT.DOM.XmlNode as XN--import           Control.Arrow.ListArrows-import           Text.XML.HXT.Arrow.XmlArrow-import           Text.XML.HXT.Arrow.Pickle.Schema-import           Text.XML.HXT.Arrow.ReadDocument  (xread)-import           Text.XML.HXT.Arrow.Edit          (xshowEscapeXml)---- --------------------------------------------------------------data St         = St { attributes :: [XmlTree]-                     , contents   :: [XmlTree]-                     }--data PU a       = PU { appPickle   :: (a, St) -> St-                     , appUnPickle :: St -> (Maybe a, St)-                     , theSchema   :: Schema-                     }--emptySt         :: St-emptySt         =  St { attributes = []-                      , contents   = []-                      }--addAtt          :: XmlTree -> St -> St-addAtt x s      = s {attributes = x : attributes s}--addCont         :: XmlTree -> St -> St-addCont x s     = s {contents = x : contents s}--dropCont        :: St -> St-dropCont s      = s { contents = drop 1 (contents s) }--getAtt          :: QName -> St -> Maybe XmlTree-getAtt qn s-    = listToMaybe $-      runLA ( arrL attributes-              >>>-              isAttr >>> hasQName qn-            ) s--getCont         :: St -> Maybe XmlTree-getCont s       = listToMaybe . contents $ s---- ---------------------------------------------------------------- | conversion of an arbitrary value into an XML document tree.------ The pickler, first parameter, controls the conversion process.--- Result is a complete document tree including a root node--pickleDoc       :: PU a -> a -> XmlTree-pickleDoc p v-    = XN.mkRoot (attributes st) (contents st)-    where-    st = appPickle p (v, emptySt)---- | Conversion of an XML document tree into an arbitrary data type------ The inverse of 'pickleDoc'.--- This law should hold for all picklers: @ unpickle px . pickle px $ v == Just v @.--- Not every possible combination of picklers make sense.--- For reconverting a value from an XML tree, is becomes neccessary,--- to introduce \"enough\" markup for unpickling the value--unpickleDoc :: PU a -> XmlTree -> Maybe a-unpickleDoc p t-    | XN.isRoot t-        = fst . appUnPickle p $ St { attributes = fromJust . XN.getAttrl $  t-                                   , contents   =            XN.getChildren t-                                   }-    | otherwise-        = unpickleDoc p (XN.mkRoot [] [t])---- ---------------------------------------------------------------- | The zero pickler------ Encodes nothing, fails always during unpickling--xpZero                  :: PU a-xpZero                  =  PU { appPickle   = snd-                              , appUnPickle = \ s -> (Nothing, s)-                              , theSchema   = scNull-                              }---- unit pickler--xpUnit                  :: PU ()-xpUnit                  = xpLift ()---- | Lift a value to a pickler------ When pickling, nothing is encoded, when unpickling, the given value is inserted.--- This pickler always succeeds.--xpLift                  :: a -> PU a-xpLift x                =  PU { appPickle   = snd-                              , appUnPickle = \ s -> (Just x, s)-                              , theSchema   = scEmpty-                              }---- | Lift a Maybe value to a pickler.------ @Nothing@ is mapped to the zero pickler, @Just x@ is pickled with @xpLift x@.--xpLiftMaybe             :: Maybe a -> PU a-xpLiftMaybe v           = (xpLiftMaybe' v) { theSchema = scOption scEmpty }-    where-    xpLiftMaybe' Nothing        = xpZero-    xpLiftMaybe' (Just x)       = xpLift x----- | pickle\/unpickle combinator for sequence and choice.------ When the first unpickler fails,--- the second one is taken, else the third one configured with the result from the first--- is taken. This pickler is a generalisation for 'xpSeq' and 'xpChoice' .------ The schema must be attached later, e.g. in xpPair or other higher level combinators--xpCondSeq       :: PU b -> (b -> a) -> PU a -> (a -> PU b) -> PU b-xpCondSeq pd f pa k-    = PU { appPickle   = ( \ (b, s) ->-                           let-                           a  = f b-                           pb = k a-                           in-                           appPickle pa (a, (appPickle pb (b, s)))-                         )-         , appUnPickle = ( \ s ->-                           let-                           (a, s') = appUnPickle pa s-                           in-                           case a of-                           Nothing -> appUnPickle pd     s-                           Just a' -> appUnPickle (k a') s'-                         )-         , theSchema   = undefined-         }----- | Combine two picklers sequentially.------ If the first fails during--- unpickling, the whole unpickler fails--xpSeq   :: (b -> a) -> PU a -> (a -> PU b) -> PU b-xpSeq   = xpCondSeq xpZero----- | combine tow picklers with a choice------ Run two picklers in sequence like with xpSeq.--- When during unpickling the first one fails,--- an alternative pickler (first argument) is applied.--- This pickler is only used as combinator for unpickling.--xpChoice                :: PU b -> PU a -> (a -> PU b) -> PU b-xpChoice pb     = xpCondSeq pb undefined----- | map value into another domain and apply pickler there------ One of the most often used picklers.--xpWrap                  :: (a -> b, b -> a) -> PU a -> PU b-xpWrap (i, j) pa        = (xpSeq j pa (xpLift . i)) { theSchema = theSchema pa }---- | like 'xpWrap', but if the inverse mapping is undefined, the unpickler fails------ Map a value into another domain. If the inverse mapping is--- undefined (Nothing), the unpickler fails--xpWrapMaybe             :: (a -> Maybe b, b -> a) -> PU a -> PU b-xpWrapMaybe (i, j) pa   = (xpSeq j pa (xpLiftMaybe . i)) { theSchema = theSchema pa }---- | pickle a pair of values sequentially------ Used for pairs or together with wrap for pickling--- algebraic data types with two components--xpPair  :: PU a -> PU b -> PU (a, b)-xpPair pa pb-    = ( xpSeq fst pa (\ a ->-        xpSeq snd pb (\ b ->-        xpLift (a,b)))-      ) { theSchema = scSeq (theSchema pa) (theSchema pb) }---- | Like 'xpPair' but for triples--xpTriple        :: PU a -> PU b -> PU c -> PU (a, b, c)-xpTriple pa pb pc-    = xpWrap (toTriple, fromTriple) (xpPair pa (xpPair pb pc))-    where-    toTriple   ~(a, ~(b, c)) = (a,  b, c )-    fromTriple ~(a,   b, c ) = (a, (b, c))---- | Like 'xpPair' and 'xpTriple' but for 4-tuples--xp4Tuple        :: PU a -> PU b -> PU c -> PU d -> PU (a, b, c, d)-xp4Tuple pa pb pc pd-    = xpWrap (toQuad, fromQuad) (xpPair pa (xpPair pb (xpPair pc pd)))-    where-    toQuad   ~(a, ~(b, ~(c, d))) = (a,  b,  c, d  )-    fromQuad ~(a,   b,   c, d  ) = (a, (b, (c, d)))---- | Like 'xpPair' and 'xpTriple' but for 5-tuples--xp5Tuple        :: PU a -> PU b -> PU c -> PU d -> PU e -> PU (a, b, c, d, e)-xp5Tuple pa pb pc pd pe-    = xpWrap (toQuint, fromQuint) (xpPair pa (xpPair pb (xpPair pc (xpPair pd pe))))-    where-    toQuint   ~(a, ~(b, ~(c, ~(d, e)))) = (a,  b,  c,  d, e   )-    fromQuint ~(a,   b,   c,   d, e   ) = (a, (b, (c, (d, e))))---- | Like 'xpPair' and 'xpTriple' but for 6-tuples--xp6Tuple        :: PU a -> PU b -> PU c -> PU d -> PU e -> PU f -> PU (a, b, c, d, e, f)-xp6Tuple pa pb pc pd pe pf-    = xpWrap (toSix, fromSix) (xpPair pa (xpPair pb (xpPair pc (xpPair pd (xpPair pe pf)))))-    where-    toSix   ~(a, ~(b, ~(c, ~(d, ~(e, f))))) = (a,  b,  c,  d,  e, f    )-    fromSix ~(a,   b,   c,   d,   e, f)     = (a, (b, (c, (d, (e, f)))))---- | Pickle a string into an XML text node------ One of the most often used primitive picklers. Attention:--- For pickling empty strings use 'xpText0'. If the text has a more--- specific datatype than xsd:string, use 'xpTextDT'--xpText  :: PU String-xpText  = xpTextDT scString1---- | Pickle a string into an XML text node------ Text pickler with a description of the structure of the text--- by a schema. A schema for a data type can be defined by 'Text.XML.HXT.Arrow.Pickle.Schema.scDT'.--- In 'Text.XML.HXT.Arrow.Pickle.Schema' there are some more functions for creating--- simple datatype descriptions.--xpTextDT        :: Schema -> PU String-xpTextDT sc-    = PU { appPickle   = \ (s, st) -> addCont (XN.mkText s) st-         , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleString st)-         , theSchema   = sc-         }-    where-    unpickleString st-        = do-          t <- getCont st-          s <- XN.getText t-          return (Just s, dropCont st)---- | Pickle a possibly empty string into an XML node.------ Must be used in all places, where empty strings are legal values.--- If the content of an element can be an empty string, this string disapears--- during storing the DOM into a document and reparse the document.--- So the empty text node becomes nothing, and the pickler must deliver an empty string,--- if there is no text node in the document.--xpText0 :: PU String-xpText0 = xpText0DT scString1---- | Pickle a possibly empty string with a datatype description into an XML node.------ Like 'xpText0' but with extra Parameter for datatype description as in 'xpTextDT'.--xpText0DT       :: Schema -> PU String-xpText0DT sc-    = xpWrap (fromMaybe "", emptyToNothing) $ xpOption $ xpTextDT sc-    where-    emptyToNothing "" = Nothing-    emptyToNothing x  = Just x---- | Pickle an arbitrary value by applyling show during pickling--- and read during unpickling.------ Real pickling is then done with 'xpText'.--- One of the most often used pimitive picklers. Applicable for all--- types which are instances of @Read@ and @Show@--xpPrim  :: (Read a, Show a) => PU a-xpPrim-    = xpWrapMaybe (readMaybe, show) xpText-    where-    readMaybe   :: Read a => String -> Maybe a-    readMaybe str-        = val (reads str)-        where-        val [(x,"")] = Just x-        val _        = Nothing---- ---------------------------------------------------------------- | Pickle an XmlTree by just adding it------ Usefull for components of type XmlTree in other data structures--xpTree  :: PU XmlTree-xpTree  = PU { appPickle   = \ (s, st) -> addCont s st-             , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleTree st)-             , theSchema   = Any-             }-    where-    unpickleTree st-        = do-          t <- getCont st-          return (Just t, dropCont st)---- | Pickle a whole list of XmlTrees by just adding the list, unpickle is done by taking all element contents.------ This pickler should always be combined with 'xpElem' for taking the whole contents of an element.--xpTrees :: PU [XmlTree]-xpTrees = (xpList xpTree) { theSchema = Any }---- | Pickle a string representing XML contents by inserting the tree representation into the XML document.------ Unpickling is done by converting the contents with--- 'Text.XML.HXT.Arrow.Edit.xshowEscapeXml' into a string,--- this function will escape all XML special chars, such that pickling the value back becomes save.--- Pickling is done with 'Text.XML.HXT.Arrow.ReadDocument.xread'--xpXmlText       :: PU String-xpXmlText-    = xpWrap ( showXML, readXML ) $ xpTrees-    where-    showXML = concat . runLA ( xshowEscapeXml unlistA )-    readXML = runLA xread---- ---------------------------------------------------------------- | Encoding of optional data by ignoring the Nothing case during pickling--- and relying on failure during unpickling to recompute the Nothing case------ The default pickler for Maybe types--xpOption        :: PU a -> PU (Maybe a)-xpOption pa-    = PU { appPickle   = ( \ (a, st) ->-                           case a of-                           Nothing -> st-                           Just x  -> appPickle pa (x, st)-                         )--         , appUnPickle = appUnPickle $-                         xpChoice (xpLift Nothing) pa (xpLift . Just)--         , theSchema   = scOption (theSchema pa)-         }---- | Optional conversion with default value------ The default value is not encoded in the XML document,--- during unpickling the default value is inserted if the pickler fails--xpDefault       :: (Eq a) => a -> PU a -> PU a-xpDefault df-    = xpWrap ( fromMaybe df-             , \ x -> if x == df then Nothing else Just x-             ) .-      xpOption---- ---------------------------------------------------------------- | Encoding of list values by pickling all list elements sequentially.------ Unpickler relies on failure for detecting the end of the list.--- The standard pickler for lists. Can also be used in combination with 'xpWrap'--- for constructing set and map picklers--xpList  :: PU a -> PU [a]-xpList pa-    = PU { appPickle   = ( \ (a, st) ->-                           case a of-                           []  -> st-                           _:_ -> appPickle pc (a, st)-                         )-         , appUnPickle = appUnPickle $-                         xpChoice (xpLift []) pa-                           (\ x -> xpSeq id (xpList pa) (\xs -> xpLift (x:xs)))--         , theSchema   = scList (theSchema pa)-         }-      where-      pc = xpSeq head  pa       (\ x ->-           xpSeq tail (xpList pa) (\ xs ->-           xpLift (x:xs)))---- | Encoding of a none empty list of values------ Attention: when calling this pickler with an empty list,--- an internal error \"head of empty list is raised\".--xpList1 :: PU a -> PU [a]-xpList1 pa-    = ( xpWrap (\ (x, xs) -> x : xs-               ,\ (x : xs) -> (x, xs)-               ) $-        xpPair pa (xpList pa)-      ) { theSchema = scList1 (theSchema pa) }---- ---------------------------------------------------------------- | Standard pickler for maps------ This pickler converts a map into a list of pairs.--- All key value pairs are mapped to an element with name (1.arg),--- the key is encoded as an attribute named by the 2. argument,--- the 3. arg is the pickler for the keys, the last one for the values--xpMap   :: Ord k => String -> String -> PU k -> PU v -> PU (Map k v)-xpMap en an xpk xpv-    = xpWrap ( M.fromList-             , M.toList-             ) $-      xpList $-      xpElem en $-      xpPair ( xpAttr an $ xpk ) xpv----- ---------------------------------------------------------------- | Pickler for sum data types.------ Every constructor is mapped to an index into the list of picklers.--- The index is used only during pickling, not during unpickling, there the 1. match is taken--xpAlt   :: (a -> Int) -> [PU a] -> PU a-xpAlt tag ps-    = PU { appPickle   = ( \ (a, st) ->-                           let-                           pa = ps !! (tag a)-                           in-                           appPickle pa (a, st)-                         )-         , appUnPickle = appUnPickle $-                         ( case ps of-                           []     -> xpZero-                           pa:ps1 -> xpChoice (xpAlt tag ps1) pa xpLift-                         )-         , theSchema   = scAlts (map theSchema ps)-         }---- ---------------------------------------------------------------- | Pickler for wrapping\/unwrapping data into an XML element------ Extra parameter is the element name given as a QName. THE pickler for constructing--- nested structures------ Example:------ > xpElemQN (mkName "number") $ xpickle------ will map an (42::Int) onto------ > <number>42</number>--xpElemQN        :: QName -> PU a -> PU a-xpElemQN qn pa-    = PU { appPickle   = ( \ (a, st) ->-                           let-                           st' = appPickle pa (a, emptySt)-                           in-                           addCont (XN.mkElement qn (attributes st') (contents st')) st-                         )-         , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st)-         , theSchema   = scElem (qualifiedName qn) (theSchema pa)-         }-      where-      unpickleElement st-          = do-            t <- getCont st-            n <- XN.getElemName t-            if n /= qn-               then fail ("element name " ++ show n ++ " does not match" ++ show qn)-               else do-                    let cs = XN.getChildren t-                    al <- XN.getAttrl t-                    res <- fst . appUnPickle pa $ St {attributes = al, contents = cs}-                    return (Just res, dropCont st)---- | convenient Pickler for xpElemQN------ > xpElem n = xpElemQN (mkName n)--xpElem          :: String -> PU a -> PU a-xpElem          = xpElemQN . mkName---- ---------------------------------------------------------------- | Pickler for wrapping\/unwrapping data into an XML element with an attribute with given value------ To make XML structures flexible but limit the number of different elements, it's sometimes--- useful to use a kind of generic element with a key value structure------ Example:------ > <attr name="key1">value1</attr>--- > <attr name="key2">value2</attr>--- > <attr name="key3">value3</attr>------ the Haskell datatype may look like this------ > type T = T { key1 :: Int ; key2 :: String ; key3 :: Double }------ Then the picker for that type looks like this------ > xpT :: PU T--- > xpT = xpWrap ( uncurry3 T, \ t -> (key1 t, key2 t, key3 t) ) $--- >       xpTriple (xpElemWithAttrValue "attr" "name" "key1" $ xpickle)--- >                (xpElemWithAttrValue "attr" "name" "key2" $ xpText0)--- >                (xpElemWithAttrValue "attr" "name" "key3" $ xpickle)--xpElemWithAttrValue     :: String -> String -> String -> PU a -> PU a-xpElemWithAttrValue name an av pa-    = PU { appPickle   = ( \ (a, st) ->-                           let-                           st' = appPickle pa' (a, emptySt)-                           in-                           addCont (XN.mkElement (mkName name) (attributes st') (contents st')) st-                         )-         , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st)-         , theSchema   = scElem name (theSchema pa')-         }-      where-      pa' = xpAddFixedAttr an av $ pa-      noMatch = null . runLA ( isElem-                               >>>-                               hasName name-                               >>>-                               hasAttrValue an (==av)-                             )-      unpickleElement st-          = do-            t <- getCont st-            if noMatch t-               then fail "element name or attr value does not match"-               else do-                    let cs = XN.getChildren t-                    al <- XN.getAttrl t-                    res <- fst . appUnPickle pa $ St {attributes = al, contents = cs}-                    return (Just res, dropCont st)---- ---------------------------------------------------------------- | Pickler for storing\/retreiving data into\/from an attribute value------ The attribute is inserted in the surrounding element constructed by the 'xpElem' pickler--xpAttrQN        :: QName -> PU a -> PU a-xpAttrQN qn pa-    = PU { appPickle   = ( \ (a, st) ->-                           let-                           st' = appPickle pa (a, emptySt)-                           in-                           addAtt (XN.mkAttr qn (contents st')) st-                         )-         , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleAttr st)-         , theSchema   = scAttr (qualifiedName qn) (theSchema pa)-         }-      where-      unpickleAttr st-          = do-            a <- getAtt qn st-            let av = XN.getChildren a-            res <- fst . appUnPickle pa $ St {attributes = [], contents = av}-            return (Just res, st)       -- attribute is not removed from attribute list,-                                        -- attributes are selected by name---- | convenient Pickler for xpAttrQN------ > xpAttr n = xpAttrQN (mkName n)--xpAttr          :: String -> PU a -> PU a-xpAttr          = xpAttrQN . mkName---- | Add an optional attribute for an optional value (Maybe a).--xpAttrImplied   :: String -> PU a -> PU (Maybe a)-xpAttrImplied name pa-    = xpOption $ xpAttr name pa--xpAttrFixed     :: String -> String -> PU ()-xpAttrFixed name val-    = ( xpWrapMaybe ( \ v -> if v == val then Just () else Nothing-                    , const val-                    ) $-        xpAttr name xpText-      ) { theSchema   = scAttr name (scFixed val) }---- | Add an attribute with a fixed value.------ Useful e.g. to declare namespaces. Is implemented by 'xpAttrFixed'--xpAddFixedAttr  :: String -> String -> PU a -> PU a-xpAddFixedAttr name val pa-    = xpWrap ( snd-             , (,) ()-             ) $-      xpPair (xpAttrFixed name val) pa---- ---------------------------------------------------------------- | The class for overloading 'xpickle', the default pickler--class XmlPickler a where-    xpickle :: PU a--instance XmlPickler Int where-    xpickle = xpPrim--instance XmlPickler Integer where-    xpickle = xpPrim--{--  no instance of XmlPickler Char-  because then every text would be encoded-  char by char, because of the instance for lists--instance XmlPickler Char where-    xpickle = xpPrim--}--instance XmlPickler () where-    xpickle = xpUnit--instance (XmlPickler a, XmlPickler b) => XmlPickler (a,b) where-    xpickle = xpPair xpickle xpickle--instance (XmlPickler a, XmlPickler b, XmlPickler c) => XmlPickler (a,b,c) where-    xpickle = xpTriple xpickle xpickle xpickle--instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d) => XmlPickler (a,b,c,d) where-    xpickle = xp4Tuple xpickle xpickle xpickle xpickle--instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e) => XmlPickler (a,b,c,d,e) where-    xpickle = xp5Tuple xpickle xpickle xpickle xpickle xpickle--instance XmlPickler a => XmlPickler [a] where-    xpickle = xpList xpickle--instance XmlPickler a => XmlPickler (Maybe a) where-    xpickle = xpOption xpickle---- ------------------------------------------------------------+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances  #-}++-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.Arrow.Pickle.Xml+   Copyright  : Copyright (C) 2005-2021 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   Pickler functions for converting between user defined data types+   and XmlTree data. Usefull for persistent storage and retreival+   of arbitray data as XML documents.++   This module is an adaptation of the pickler combinators+   developed by Andrew Kennedy+   ( https:\/\/www.microsoft.com\/en-us\/research\/wp-content\/uploads\/2004\/01\/picklercombinators.pdf )++   The difference to Kennedys approach is that the target is not+   a list of Chars but a list of XmlTrees. The basic picklers will+   convert data into XML text nodes. New are the picklers for+   creating elements and attributes.++   One extension was neccessary: The unpickling may fail.++   Old: Therefore the unpickler has a Maybe result type.+   Failure is used to unpickle optional elements+   (Maybe data) and lists of arbitray length.++   Since hxt-9.2.0: The unpicklers are implemented as+   a parser monad with an Either err val result type.+   This enables appropriate error messages , when unpickling+   XML stuff, that is not generated with the picklers and which contains+   some elements and/or attributes that are not handled when unpickling.++   There is an example program demonstrating the use+   of the picklers for a none trivial data structure.+   (see \"examples\/arrows\/pickle\" directory in the hxt distribution)++-}++-- ------------------------------------------------------------++module Text.XML.HXT.Arrow.Pickle.Xml+where++#if MIN_VERSION_base(4,8,0)+#else+import           Control.Applicative              (Applicative (..))+#endif++import           Control.Arrow.ArrowList+import           Control.Arrow.ListArrows+import           Control.Monad                    ()++#if MIN_VERSION_mtl(2,2,0)+import           Control.Monad.Except             (MonadError (..))+#else+import           Control.Monad.Error              (MonadError (..))+#endif++import           Control.Monad.State              (MonadState (..), gets,+                                                   modify)++import           Data.Char                        (isDigit)+import           Data.List                        (foldl')+import           Data.Map                         (Map)+import qualified Data.Map                         as M+import           Data.Maybe                       (fromJust, fromMaybe)++import           Text.XML.HXT.Arrow.Edit          (xshowEscapeXml)+import           Text.XML.HXT.Arrow.Pickle.Schema+import           Text.XML.HXT.Arrow.ReadDocument  (xread)+import           Text.XML.HXT.Arrow.WriteDocument (writeDocumentToString)+import           Text.XML.HXT.Arrow.XmlState+import           Text.XML.HXT.DOM.Interface+import qualified Text.XML.HXT.DOM.ShowXml         as XN+import qualified Text.XML.HXT.DOM.XmlNode         as XN++{- just for embedded test cases, prefix with -- to activate+import           Text.XML.HXT.Arrow.XmlArrow+import qualified Control.Arrow.ListArrows         as X+-- -}++{- debug code+import qualified Debug.Trace                      as T+-- -}++-- ------------------------------------------------------------++data St         = St { attributes :: [XmlTree]+                     , contents   :: [XmlTree]+                     , nesting    :: Int                -- the remaining 3 fields are used only for unpickling+                     , pname      :: QName              -- to generate appropriate error messages+                     , pelem      :: Bool+                     } deriving (Show)++data PU a       = PU { appPickle   :: Pickler a         -- (a, St) -> St+                     , appUnPickle :: Unpickler a+                     , theSchema   :: Schema+                     }++-- --------------------+--+-- The pickler++type Pickler a          = a -> St -> St++-- --------------------+--+-- The unpickler monad, a combination of state and error monad++newtype Unpickler a     = UP { runUP :: St -> (UnpickleVal a, St) }++type UnpickleVal a      = Either UnpickleErr a++type UnpickleErr        = (String, St)++instance Functor Unpickler where+    fmap f u    = UP $ \ st ->+                  let (r, st') = runUP u st in (fmap f r, st')++instance Applicative Unpickler where+    pure a      = UP $ \ st -> (Right a, st)+    uf <*> ua   = UP $ \ st ->+                  let (f, st') = runUP uf st in+                  case f of+                    Left err -> (Left err, st')+                    Right f' -> runUP (fmap f' ua) st'++instance Monad Unpickler where+    return      = pure+    u >>= f     = UP $ \ st ->+                  let (r, st') = runUP u st in+                  case r of+                    Left err -> (Left err, st')+                    Right v  -> runUP (f v) st'++instance MonadState St Unpickler where+    get         = UP $ \ st -> (Right st, st)+    put st      = UP $ \ _  -> (Right (), st)++instance MonadError UnpickleErr Unpickler where+    throwError err+                = UP $ \ st -> (Left err, st)++    -- redundant, not (yet) used+    catchError u handler+                = UP $ \ st ->+                  let (r, st') = runUP u st in+                  case r of+                    Left err -> runUP (handler err) st  -- not st', state will be reset in error case+                    _        -> (r, st')++throwMsg        :: String -> Unpickler a+throwMsg msg    = UP $ \ st -> (Left (msg, st), st)++-- | Choice combinator for unpickling+--+-- first 2 arguments are applied sequentially, but if the 1. one fails the+-- 3. arg is applied++mchoice         :: Unpickler a -> (a -> Unpickler b) -> Unpickler b -> Unpickler b+mchoice u f v   = UP $ \ st ->+                  let (r, st') = runUP u st in+                  case r of+                    Right x+                        -> runUP (f x) st'                      -- success+                    Left e@(_msg, st'')+                        -> if nesting st'' == nesting st        -- true: failure in parsing curr contents+                           then runUP v st                      -- try the alternative unpickler+                           else (Left e, st')                   -- false: failure in unpickling a subtree of+                                                                -- the current contents, so the whole unpickler+                                                                -- must fail++-- | Lift a Maybe value into the Unpickler monad.+--+-- The 1. arg is the attached error message++liftMaybe       :: String -> Maybe a -> Unpickler a+liftMaybe e v  = case v of+                    Nothing -> throwMsg e+                    Just x  -> return x++-- | Lift an Either value into the Unpickler monad++liftUnpickleVal         :: UnpickleVal a -> Unpickler a+liftUnpickleVal v       = UP $ \ st -> (v, st)++-- --------------------++getCont         :: Unpickler XmlTree+getCont         = do cs <- gets contents+                     case cs of+                       []       -> throwMsg "no more contents to be read"+                       (x : xs) -> do modify (\ s -> s {contents = xs})+                                      return x++getAtt          :: QName -> Unpickler XmlTree+getAtt qn       = do as <- gets attributes+                     case findAtt as of+                       Nothing -> throwMsg $ "no attribute value found for " ++ show qn+                       Just (a, as') -> do modify (\ s -> s {attributes = as'})+                                           return $ nonEmptyVal a+    where+      findAtt     = findElem (maybe False (== qn) . XN.getAttrName)+      nonEmptyVal a'+          | null (XN.getChildren a') = XN.setChildren [et] a'+          | otherwise                = a'+          where+            et = XN.mkText ""++getNSAtt        :: String -> Unpickler ()+getNSAtt ns     = do as <- gets attributes+                     case findNS as of+                       Nothing        -> throwMsg $+                                         "no namespace declaration found for namespace " ++ show ns+                       Just (_a, as') -> do modify (\ s -> s {attributes = as'})+                                            return ()+    where+      isNS t    = (fromMaybe False . fmap isNameSpaceName . XN.getAttrName $ t)+                  &&+                  XN.xshow (XN.getChildren t) == ns+      findNS    = findElem isNS++-- --------------------++emptySt         :: St+emptySt         =  St { attributes = []+                      , contents   = []+                      , nesting    = 0+                      , pname      = mkName "/"+                      , pelem      = True+                      }++putAtt          :: QName -> [XmlTree] -> St -> St+putAtt qn v s   = s {attributes = x : attributes s}+                  where+                    x = XN.mkAttr qn v+{-# INLINE putAtt #-}++putCont         :: XmlTree -> St -> St+putCont x s     = s {contents = x : contents s}+{-# INLINE putCont #-}++-- --------------------+--+-- generally useful function for splitting a value from a list++findElem       :: (a -> Bool) -> [a] -> Maybe (a, [a])+findElem p     = find' id+    where+      find' _ []         = Nothing+      find' prefix (x : xs)+          | p x          = Just (x, prefix xs)+          | otherwise    = find' (prefix . (x:)) xs++-- ------------------------------------------------------------+--+-- | Format the context of an error message.++formatSt                :: St -> String+formatSt st             = fcx +++                          fa (attributes st) +++                          fc (contents   st)+    where+      fcx               = "\n" ++ "context:    " +++                          ( if pelem st+                            then "element"+                            else "attribute"+                          ) +++                          " " ++ show (pname st)+      fc []             = ""+      fc cs             = "\n" ++ "contents:   " ++ formatXML cs+      fa []             = ""+      fa as             = "\n" ++ "attributes: " ++ formatXML as+      formatXML         = format 80 . showXML+      showXML           = concat . runLA ( xshowEscapeXml unlistA )+      format n s        = let s' = take (n + 1) s in+                          if length s' <= n then s' else take n s ++ "..."++-- ------------------------------------------------------------++-- | conversion of an arbitrary value into an XML document tree.+--+-- The pickler, first parameter, controls the conversion process.+-- Result is a complete document tree including a root node++pickleDoc       :: PU a -> a -> XmlTree+pickleDoc p v   = XN.mkRoot (attributes st) (contents st)+    where+      st        = appPickle p v emptySt++-- | Conversion of an XML document tree into an arbitrary data type+--+-- The inverse of 'pickleDoc'.+-- This law should hold for all picklers: @ unpickle px . pickle px $ v == Just v @.+-- Not every possible combination of picklers does make sense.+-- For reconverting a value from an XML tree, is becomes neccessary,+-- to introduce \"enough\" markup for unpickling the value++unpickleDoc     :: PU a -> XmlTree -> Maybe a+unpickleDoc p   = either (const Nothing) Just+                  . unpickleDoc' p++-- | Like unpickleDoc but with a (sometimes) useful error message, when unpickling failed.++unpickleDoc'    :: PU a -> XmlTree -> Either String a+unpickleDoc' p t+    | XN.isRoot t       = mapErr $+                          unpickleElem' p 0              t+    | otherwise         = unpickleDoc'  p (XN.mkRoot [] [t])+    where+      mapErr            = either ( Left .+                                   \ (msg, st) -> msg ++ formatSt st+                                 ) Right++-- | The main entry for unpickling, called by unpickleDoc++unpickleElem'   :: PU a -> Int -> XmlTree -> UnpickleVal a+unpickleElem' p l t+    = -- T.trace ("unpickleElem': " ++ show t) $+      ( fst . runUP (appUnPickle p) )+      $ St { attributes = fromMaybe [] .+                          XN.getAttrl $  t+           , contents   = XN.getChildren t+           , nesting    = l+           , pname      = fromJust .+                          XN.getName  $  t+           , pelem      = XN.isElem      t+           }++-- ------------------------------------------------------------++-- | Pickles a value, then writes the document to a string.++showPickled :: (XmlPickler a) => SysConfigList -> a -> String+showPickled a = concat . (pickleDoc xpickle >>> runLA (writeDocumentToString a))++-- ------------------------------------------------------------++-- | The zero pickler+--+-- Encodes nothing, fails always during unpickling++xpZero                  :: String -> PU a+xpZero err              =  PU { appPickle   = const id+                              , appUnPickle = throwMsg err+                              , theSchema   = scNull+                              }++-- | unit pickler++xpUnit                  :: PU ()+xpUnit                  = xpLift ()++-- | Check EOF pickler.+--+-- When pickling, this behaves like the unit pickler.+-- The unpickler fails, when there is some unprocessed XML contents left.++xpCheckEmptyContents    :: PU a -> PU a+xpCheckEmptyContents pa =  PU { appPickle   = appPickle pa+                              , appUnPickle = do res <- appUnPickle pa+                                                 cs <- gets contents+                                                 if null cs+                                                    then return res+                                                    else contentsLeft+                              , theSchema   = scNull+                              }+    where+      contentsLeft      = throwMsg+                          "xpCheckEmptyContents: unprocessed XML content detected"++-- | Like xpCheckEmptyContents, but checks the attribute list++xpCheckEmptyAttributes  :: PU a -> PU a+xpCheckEmptyAttributes pa+                        =  PU { appPickle   = appPickle pa+                              , appUnPickle = do res <- appUnPickle pa+                                                 as <- gets attributes+                                                 if null as+                                                    then return res+                                                    else attributesLeft+                              , theSchema   = scNull+                              }+    where+      attributesLeft    = throwMsg+                          "xpCheckEmptyAttributes: unprocessed XML attribute(s) detected"++-- | Composition of xpCheckEmptyContents and xpCheckAttributes++xpCheckEmpty            :: PU a -> PU a+xpCheckEmpty            = xpCheckEmptyAttributes . xpCheckEmptyContents++xpLift                  :: a -> PU a+xpLift x                =  PU { appPickle   = const id+                              , appUnPickle = return x+                              , theSchema   = scEmpty+                              }++-- | Lift a Maybe value to a pickler.+--+-- @Nothing@ is mapped to the zero pickler, @Just x@ is pickled with @xpLift x@.++xpLiftMaybe                     :: Maybe a -> PU a+xpLiftMaybe v                   = (xpLiftMaybe'' v) { theSchema = scOption scEmpty }+    where+    xpLiftMaybe'' Nothing       = xpZero "xpLiftMaybe: got Nothing"+    xpLiftMaybe'' (Just x)      = xpLift x++xpLiftEither                    :: Either String a -> PU a+xpLiftEither v                  = (xpLiftEither'' v) { theSchema = scOption scEmpty }+    where+    xpLiftEither'' (Left err)   = xpZero err+    xpLiftEither'' (Right x)    = xpLift x++-- | Combine two picklers sequentially.+--+-- If the first fails during+-- unpickling, the whole unpickler fails++xpSeq           :: (b -> a) -> PU a -> (a -> PU b) -> PU b+xpSeq f pa k+    = PU { appPickle  = ( \ b ->+                          let a = f b in+                          appPickle pa a . appPickle (k a) b+                         )+         , appUnPickle = appUnPickle pa >>= (appUnPickle . k)+         , theSchema   = undefined+         }++-- | First apply a fixed pickler/unpickler, then a 2. one+--+-- If the first fails during unpickling, the whole pickler fails.+-- This can be used to check some properties of the input, e.g. whether+-- a given fixed attribute or a namespace declaration exists+-- ('xpAddFixedAttr', 'xpAddNSDecl')+-- or to filter the input, e.g. to ignore some elements or attributes+-- ('xpFilterCont', 'xpFilterAttr').+--+-- When pickling, this can be used to insert some fixed XML pieces,+-- e.g. namespace declarations,+-- class attributes or other stuff.++xpSeq'          :: PU () -> PU a -> PU a+xpSeq' pa       = xpWrap ( snd+                         , \ y -> ((), y)+                         ) .+                  xpPair pa++-- | combine two picklers with a choice+--+-- Run two picklers in sequence like with xpSeq.+-- If during unpickling the first one fails,+-- an alternative pickler (first argument) is applied.+-- This pickler is only used as combinator for unpickling.++xpChoice                :: PU b -> PU a -> (a -> PU b) -> Unpickler b+xpChoice pb pa k        = mchoice (appUnPickle pa) (appUnPickle . k) (appUnPickle pb)+++-- | map value into another domain and apply pickler there+--+-- One of the most often used picklers.++xpWrap                  :: (a -> b, b -> a) -> PU a -> PU b+xpWrap (i, j) pa        = (xpSeq j pa (xpLift . i)) { theSchema = theSchema pa }++-- | like 'xpWrap', but if the inverse mapping is undefined, the unpickler fails+--+-- Map a value into another domain. If the inverse mapping is+-- undefined (Nothing), the unpickler fails+--+-- Deprecated: Use xpWrapEither, this gives better error messages++xpWrapMaybe             :: (a -> Maybe b, b -> a) -> PU a -> PU b+xpWrapMaybe (i, j) pa   = (xpSeq j pa (xpLiftMaybe . i)) { theSchema = theSchema pa }++-- | like 'xpWrap', but if the inverse mapping is undefined, the unpickler fails+--+-- Map a value into another domain. If the inverse mapping is+-- undefined, the unpickler fails with an error message in the Left component++xpWrapEither             :: (a -> Either String b, b -> a) -> PU a -> PU b+xpWrapEither (i, j) pa   = (xpSeq j pa (xpLiftEither . i)) { theSchema = theSchema pa }++-- ------------------------------------------------------------++-- | pickle a pair of values sequentially+--+-- Used for pairs or together with wrap for pickling+-- algebraic data types with two components++xpPair  :: PU a -> PU b -> PU (a, b)+xpPair pa pb+    = ( xpSeq fst pa (\ a ->+        xpSeq snd pb (\ b ->+        xpLift (a,b)))+      ) { theSchema = scSeq (theSchema pa) (theSchema pb) }++-- | Like 'xpPair' but for triples++xpTriple        :: PU a -> PU b -> PU c -> PU (a, b, c)+xpTriple pa pb pc+    = xpWrap (toTriple, fromTriple) (xpPair pa (xpPair pb pc))+    where+    toTriple   ~(a, ~(b, c)) = (a,  b, c )+    fromTriple ~(a,   b, c ) = (a, (b, c))++-- | Like 'xpPair' and 'xpTriple' but for 4-tuples++xp4Tuple        :: PU a -> PU b -> PU c -> PU d -> PU (a, b, c, d)+xp4Tuple pa pb pc pd+    = xpWrap (toQuad, fromQuad) (xpPair pa (xpPair pb (xpPair pc pd)))+    where+    toQuad   ~(a, ~(b, ~(c, d))) = (a,  b,  c, d  )+    fromQuad ~(a,   b,   c, d  ) = (a, (b, (c, d)))++-- | Like 'xpPair' and 'xpTriple' but for 5-tuples++xp5Tuple        :: PU a -> PU b -> PU c -> PU d -> PU e -> PU (a, b, c, d, e)+xp5Tuple pa pb pc pd pe+    = xpWrap (toQuint, fromQuint) (xpPair pa (xpPair pb (xpPair pc (xpPair pd pe))))+    where+    toQuint   ~(a, ~(b, ~(c, ~(d, e)))) = (a,  b,  c,  d, e   )+    fromQuint ~(a,   b,   c,   d, e   ) = (a, (b, (c, (d, e))))++-- | Like 'xpPair' and 'xpTriple' but for 6-tuples++xp6Tuple        :: PU a -> PU b -> PU c -> PU d -> PU e -> PU f -> PU (a, b, c, d, e, f)+xp6Tuple pa pb pc pd pe pf+    = xpWrap (toSix, fromSix) (xpPair pa (xpPair pb (xpPair pc (xpPair pd (xpPair pe pf)))))+    where+    toSix   ~(a, ~(b, ~(c, ~(d, ~(e, f))))) = (a,  b,  c,  d,  e, f    )+    fromSix ~(a,   b,   c,   d,   e, f)     = (a, (b, (c, (d, (e, f)))))++-- ------------------------------------------------------------++-- | Like 'xpPair' and 'xpTriple' but for 7-tuples+--+-- Thanks to Tony Morris for doing xp7Tuple, ..., xp24Tuple.++xp7Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+            PU f -> PU g -> PU (a, b, c, d, e, f, g)+xp7Tuple a b c d e f g+    = xpWrap ( \ (a, (b, c, d, e, f, g)) -> (a, b, c, d, e, f, g)+             , \ (a, b, c, d, e, f, g)   -> (a, (b, c, d, e, f, g))+             )+      (xpPair a (xp6Tuple b c d e f g))++xp8Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+            PU f -> PU g -> PU h -> PU (a, b, c, d, e, f, g, h)+xp8Tuple a b c d e f g h+    = xpWrap ( \ ((a, b), (c, d, e, f, g, h)) -> (a, b, c, d, e, f, g, h)+             , \ (a, b, c, d, e, f, g, h) -> ((a, b), (c, d, e, f, g, h))+             )+      (xpPair (xpPair a b) (xp6Tuple c d e f g h))++xp9Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+            PU f -> PU g -> PU h -> PU i -> PU (a, b, c, d, e, f, g, h, i)+xp9Tuple a b c d e f g h i+    = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i)) -> (a, b, c, d, e, f, g, h, i)+             , \ (a, b, c, d, e, f, g, h, i) -> ((a, b, c), (d, e, f, g, h, i))+             )+      (xpPair (xpTriple a b c) (xp6Tuple d e f g h i))++xp10Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU (a, b, c, d, e, f, g, h, i, j)+xp10Tuple a b c d e f g h i j+    = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j)) -> (a, b, c, d, e, f, g, h, i, j)+             , \ (a, b, c, d, e, f, g, h, i, j) -> ((a, b, c, d), (e, f, g, h, i, j))+             )+      (xpPair (xp4Tuple a b c d) (xp6Tuple e f g h i j))++xp11Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU (a, b, c, d, e, f, g, h, i, j, k)+xp11Tuple a b c d e f g h i j k+    = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k)) -> (a, b, c, d, e, f, g, h, i, j, k)+             , \ (a, b, c, d, e, f, g, h, i, j, k) -> ((a, b, c, d, e), (f, g, h, i, j, k))+             )+      (xpPair (xp5Tuple a b c d e) (xp6Tuple f g h i j k))++xp12Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU l -> PU (a, b, c, d, e, f, g, h, i, j, k, l)+xp12Tuple a b c d e f g h i j k l+    = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l)) -> (a, b, c, d, e, f, g, h, i, j, k, l)+             , \ (a, b, c, d, e, f, g, h, i, j, k, l) -> ((a, b, c, d, e, f), (g, h, i, j, k, l))+             )+      (xpPair (xp6Tuple a b c d e f) (xp6Tuple g h i j k l))++xp13Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU l -> PU m -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m)+xp13Tuple a b c d e f g h i j k l m+    = xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m)+             , \ (a, b, c, d, e, f, g, h, i, j, k, l, m) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m))+             )+      (xpTriple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m))++xp14Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU l -> PU m -> PU n -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+xp14Tuple a b c d e f g h i j k l m n+    = xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+             , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n))+             )+      (xpTriple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n))++xp15Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU l -> PU m -> PU n -> PU o ->+             PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+xp15Tuple a b c d e f g h i j k l m n o+    = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+             , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o))+             )+      (xpTriple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o))++xp16Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU l -> PU m -> PU n -> PU o ->+             PU p -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+xp16Tuple a b c d e f g h i j k l m n o p+    = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+             , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p))+             )+      (xpTriple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p))++xp17Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU l -> PU m -> PU n -> PU o ->+             PU p -> PU q -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)+xp17Tuple a b c d e f g h i j k l m n o p q+    = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)+             , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q))+             )+      (xpTriple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q))++xp18Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU l -> PU m -> PU n -> PU o ->+             PU p -> PU q -> PU r -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)+xp18Tuple a b c d e f g h i j k l m n o p q r+    = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)+             , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r))+             )+      (xpTriple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r))++xp19Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU l -> PU m -> PU n -> PU o ->+             PU p -> PU q -> PU r -> PU s -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)+xp19Tuple a b c d e f g h i j k l m n o p q r s+    = xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)+             , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s))+             )+      (xp4Tuple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m) (xp6Tuple n o p q r s))++xp20Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU l -> PU m -> PU n -> PU o ->+             PU p -> PU q -> PU r -> PU s -> PU t ->+             PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)+xp20Tuple a b c d e f g h i j k l m n o p q r s t+    = xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)+             , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t))+             )+      (xp4Tuple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n) (xp6Tuple o p q r s t))++xp21Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU l -> PU m -> PU n -> PU o ->+             PU p -> PU q -> PU r -> PU s -> PU t ->+             PU u -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)+xp21Tuple a b c d e f g h i j k l m n o p q r s t u+    = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)+             , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u))+             )+      (xp4Tuple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o) (xp6Tuple p q r s t u))++xp22Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU l -> PU m -> PU n -> PU o ->+             PU p -> PU q -> PU r -> PU s -> PU t ->+             PU u -> PU v -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)+xp22Tuple a b c d e f g h i j k l m n o p q r s t u v+    = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)+             , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v))+             )+      (xp4Tuple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p) (xp6Tuple q r s t u v))++xp23Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU l -> PU m -> PU n -> PU o ->+             PU p -> PU q -> PU r -> PU s -> PU t ->+             PU u -> PU v -> PU w -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)+xp23Tuple a b c d e f g h i j k l m n o p q r s t u v w+    = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)+             , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w))+             )+      (xp4Tuple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q) (xp6Tuple r s t u v w))++-- | Hopefully no one needs a xp25Tuple++xp24Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+             PU f -> PU g -> PU h -> PU i -> PU j ->+             PU k -> PU l -> PU m -> PU n -> PU o ->+             PU p -> PU q -> PU r -> PU s -> PU t ->+             PU u -> PU v -> PU w -> PU x -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)+xp24Tuple a b c d e f g h i j k l m n o p q r s t u v w x+    = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)+             , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x))+             )+      (xp4Tuple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r) (xp6Tuple s t u v w x))++-- ------------------------------------------------------------+++-- | Pickle a string into an XML text node+--+-- One of the most often used primitive picklers. Attention:+-- For pickling empty strings use 'xpText0'. If the text has a more+-- specific datatype than xsd:string, use 'xpTextDT'++xpText  :: PU String+xpText  = xpTextDT scString1+{-# INLINE xpText #-}++-- | Pickle a string into an XML text node+--+-- Text pickler with a description of the structure of the text+-- by a schema. A schema for a data type can be defined by 'Text.XML.HXT.Arrow.Pickle.Schema.scDT'.+-- In 'Text.XML.HXT.Arrow.Pickle.Schema' there are some more functions for creating+-- simple datatype descriptions.++xpTextDT        :: Schema -> PU String+xpTextDT sc     = PU { appPickle   = putCont . XN.mkText+                     , appUnPickle = do t <- getCont+                                        liftMaybe "xpText: XML text expected" $ XN.getText t+                     , theSchema   = sc+                     }++-- | Pickle a possibly empty string into an XML node.+--+-- Must be used in all places, where empty strings are legal values.+-- If the content of an element can be an empty string, this string disapears+-- during storing the DOM into a document and reparse the document.+-- So the empty text node becomes nothing, and the pickler must deliver an empty string,+-- if there is no text node in the document.++xpText0         :: PU String+xpText0         = xpText0DT scString1+{-# INLINE xpText0 #-}++-- | Pickle a possibly empty string with a datatype description into an XML node.+--+-- Like 'xpText0' but with extra Parameter for datatype description as in 'xpTextDT'.++xpText0DT       :: Schema -> PU String+xpText0DT sc    = xpWrap (fromMaybe "", emptyToNothing) $+                  xpOption $+                  xpTextDT sc+    where+    emptyToNothing "" = Nothing+    emptyToNothing x  = Just x++-- | Pickle an arbitrary value by applyling show during pickling+-- and read during unpickling.+--+-- Real pickling is then done with 'xpText'.+-- One of the most often used pimitive picklers. Applicable for all+-- types which are instances of @Read@ and @Show@++xpPrim                  :: (Read a, Show a) => PU a+xpPrim                  = xpWrapEither (readMaybe, show) xpText+    where+    readMaybe           :: Read a => String -> Either String a+    readMaybe str       = val (reads str)+        where+          val [(x,"")]  = Right x+          val _         = Left $ "xpPrim: reading string " ++ show str ++ " failed"++-- | Pickle an Int+xpInt                   :: PU Int+xpInt                   = xpWrapEither (readMaybe, show) xpText+    where+      readMaybe xs@(_:_)+          | all isDigit xs = Right . foldl' (\ r c -> 10 * r + (fromEnum c - fromEnum '0')) 0 $ xs+      readMaybe ('-' : xs) = fmap (0 -) . readMaybe $ xs+      readMaybe ('+' : xs) =              readMaybe $ xs+      readMaybe        xs  = Left $ "xpInt: reading an Int from string " ++ show xs ++ " failed"++-- ------------------------------------------------------------++-- | Pickle an XmlTree by just adding it+--+-- Usefull for components of type XmlTree in other data structures++xpTree          :: PU XmlTree+xpTree          = PU { appPickle   = putCont+                     , appUnPickle = getCont+                     , theSchema   = Any+                     }++-- | Pickle a whole list of XmlTrees by just adding the list, unpickle is done by taking all element contents.+--+-- This pickler should always be combined with 'xpElem' for taking the whole contents of an element.++xpTrees         :: PU [XmlTree]+xpTrees         = (xpList xpTree) { theSchema = Any }++-- | Pickle a string representing XML contents by inserting the tree representation into the XML document.+--+-- Unpickling is done by converting the contents with+-- 'Text.XML.HXT.Arrow.Edit.xshowEscapeXml' into a string,+-- this function will escape all XML special chars, such that pickling the value back becomes save.+-- Pickling is done with 'Text.XML.HXT.Arrow.ReadDocument.xread'++xpXmlText       :: PU String+xpXmlText       = xpWrap ( showXML, readXML ) $ xpTrees+    where+      showXML   = concat . runLA ( xshowEscapeXml unlistA )+      readXML   = runLA xread++-- ------------------------------------------------------------++-- | Encoding of optional data by ignoring the Nothing case during pickling+-- and relying on failure during unpickling to recompute the Nothing case+--+-- The default pickler for Maybe types++xpOption        :: PU a -> PU (Maybe a)+xpOption pa     = PU { appPickle  = ( \ a ->+                                      case a of+                                        Nothing -> id+                                        Just x  -> appPickle pa x+                                    )++                     , appUnPickle = xpChoice (xpLift Nothing) pa (xpLift . Just)++                     , theSchema   = scOption (theSchema pa)+                     }++-- | Optional conversion with default value+--+-- The default value is not encoded in the XML document,+-- during unpickling the default value is inserted if the pickler fails++xpDefault       :: (Eq a) => a -> PU a -> PU a+xpDefault df    = xpWrap ( fromMaybe df+                         , \ x -> if x == df then Nothing else Just x+                         ) .+                  xpOption++-- ------------------------------------------------------------++-- | Encoding of list values by pickling all list elements sequentially.+--+-- Unpickler relies on failure for detecting the end of the list.+-- The standard pickler for lists. Can also be used in combination with 'xpWrap'+-- for constructing set and map picklers++xpList          :: PU a -> PU [a]+xpList pa       = PU { appPickle  = ( \ a ->+                                      case a of+                                        []  -> id+                                        _:_ -> appPickle pc a+                                    )+                     , appUnPickle = xpChoice+                                     (xpLift [])+                                     pa+                                     (\ x -> xpSeq id (xpList pa) (\xs -> xpLift (x:xs)))++                     , theSchema   = scList (theSchema pa)+                     }+      where+      pc        = xpSeq head  pa         (\ x  ->+                  xpSeq tail (xpList pa) (\ xs ->+                  xpLift (x:xs)          ))++-- | Encoding of a none empty list of values+--+-- Attention: when calling this pickler with an empty list,+-- an internal error \"head of empty list is raised\".++xpList1         :: PU a -> PU [a]+xpList1 pa      = ( xpWrap (\ (x, xs) -> x : xs+                           ,\ x -> (head x, tail x)+                           ) $+                    xpPair pa (xpList pa)+                  ) { theSchema = scList1 (theSchema pa) }++-- ------------------------------------------------------------++-- | Standard pickler for maps+--+-- This pickler converts a map into a list of pairs.+-- All key value pairs are mapped to an element with name (1.arg),+-- the key is encoded as an attribute named by the 2. argument,+-- the 3. arg is the pickler for the keys, the last one for the values++xpMap           :: Ord k => String -> String -> PU k -> PU v -> PU (Map k v)+xpMap en an xpk xpv+                = xpWrap ( M.fromList+                         , M.toList+                         ) $+                  xpList $+                  xpElem en $+                  xpPair ( xpAttr an $ xpk ) xpv++-- ------------------------------------------------------------++-- | Pickler for sum data types.+--+-- Every constructor is mapped to an index into the list of picklers.+-- The index is used only during pickling, not during unpickling, there the 1. match is taken++xpAlt           :: (a -> Int) -> [PU a] -> PU a+xpAlt tag ps    = PU { appPickle   = \ a ->+                                     appPickle (ps !! tag a) a++                     , appUnPickle = case ps of+                                       []     -> throwMsg "xpAlt: no matching unpickler found for a sum datatype"+                                       pa:ps1 -> xpChoice (xpAlt tag ps1) pa xpLift++                     , theSchema   = scAlts (map theSchema ps)+                     }++-- ------------------------------------------------------------++-- | Pickler for wrapping\/unwrapping data into an XML element+--+-- Extra parameter is the element name given as a QName. THE pickler for constructing+-- nested structures+--+-- Example:+--+-- > xpElemQN (mkName "number") $ xpickle+--+-- will map an (42::Int) onto+--+-- > <number>42</number>++xpElemQN        :: QName -> PU a -> PU a+xpElemQN qn pa  = PU { appPickle   = ( \ a ->+                                       let st' = appPickle pa a emptySt in+                                       putCont (XN.mkElement qn (attributes st') (contents st'))+                                     )+                     , appUnPickle = upElem+                     , theSchema   = scElem (qualifiedName qn) (theSchema pa)+                     }+      where+      upElem    = do t <- getCont+                     n <- liftMaybe "xpElem: XML element expected" $ XN.getElemName t+                     if n /= qn+                        then throwMsg ("xpElem: got element name " ++ show n ++ ", but expected " ++ show qn)+                        else do l <- gets nesting+                                liftUnpickleVal $ unpickleElem' (xpCheckEmpty pa) (l + 1) t++-- | convenient Pickler for xpElemQN+--+-- > xpElem n = xpElemQN (mkName n)++xpElem          :: String -> PU a -> PU a+xpElem          = xpElemQN . mkName++-- | convenient Pickler for xpElemQN+--   for pickling elements with respect to namespaces+--+-- > xpElemNS ns px lp = xpElemQN (mkQName px lp ns)++xpElemNS        :: String -> String -> String -> PU a -> PU a+xpElemNS ns px lp+                = xpElemQN $ mkQName px lp ns++-- ------------------------------------------------------------++-- | Pickler for wrapping\/unwrapping data into an XML element with an attribute with given value+--+-- To make XML structures flexible but limit the number of different elements, it's sometimes+-- useful to use a kind of generic element with a key value structure+--+-- Example:+--+-- > <attr name="key1">value1</attr>+-- > <attr name="key2">value2</attr>+-- > <attr name="key3">value3</attr>+--+-- the Haskell datatype may look like this+--+-- > type T = T { key1 :: Int ; key2 :: String ; key3 :: Double }+--+-- Then the picker for that type looks like this+--+-- > xpT :: PU T+-- > xpT = xpWrap ( uncurry3 T, \ t -> (key1 t, key2 t, key3 t) ) $+-- >       xpTriple (xpElemWithAttrValue "attr" "name" "key1" $ xpickle)+-- >                (xpElemWithAttrValue "attr" "name" "key2" $ xpText0)+-- >                (xpElemWithAttrValue "attr" "name" "key3" $ xpickle)++xpElemWithAttrValue     :: String -> String -> String -> PU a -> PU a+xpElemWithAttrValue name an av pa+                = xpElem name $+                  xpAddFixedAttr an av $+                  pa++-- ------------------------------------------------------------++-- | Pickler for storing\/retreiving data into\/from an attribute value+--+-- The attribute is inserted in the surrounding element constructed by the 'xpElem' pickler++xpAttrQN        :: QName -> PU a -> PU a+xpAttrQN qn pa  = PU { appPickle   = ( \ a ->+                                       let st' = appPickle pa a emptySt in+                                       putAtt qn (contents st')+                                     )+                     , appUnPickle = upAttr+                     , theSchema   = scAttr (qualifiedName qn) (theSchema pa)+                     }+      where+      upAttr    = do a <- getAtt qn+                     l <- gets nesting+                     liftUnpickleVal $ unpickleElem' (xpCheckEmptyContents pa) l a++-- | convenient Pickler for xpAttrQN+--+-- > xpAttr n = xpAttrQN (mkName n)++xpAttr          :: String -> PU a -> PU a+xpAttr          = xpAttrQN . mkName++-- | convenient Pickler for xpAttrQN+--+-- > xpAttr ns px lp = xpAttrQN (mkQName px lp ns)++xpAttrNS        :: String -> String -> String -> PU a -> PU a+xpAttrNS ns px lp+                = xpAttrQN (mkQName px lp ns)++-- | A text attribute.+xpTextAttr      :: String -> PU String+xpTextAttr      = flip xpAttr xpText++-- | Add an optional attribute for an optional value (Maybe a).++xpAttrImplied   :: String -> PU a -> PU (Maybe a)+xpAttrImplied name pa+                = xpOption $ xpAttr name pa++xpAttrFixed     :: String -> String -> PU ()+xpAttrFixed name val+                = ( xpWrapEither ( \ v ->+                                   if v == val+                                   then Right ()+                                   else Left ( "xpAttrFixed: value "+                                               ++ show val+                                               ++ " expected, but got "+                                               ++ show v+                                             )+                                 , const val+                                 ) $+                    xpAttr name xpText+                  ) { theSchema   = scAttr name (scFixed val) }++-- | Add/Check an attribute with a fixed value.+--++xpAddFixedAttr  :: String -> String -> PU a -> PU a+xpAddFixedAttr name val+                = xpSeq' $ xpAttrFixed name val++-- | Add a namespace declaration.+--+-- When generating XML the namespace decl is added,+-- when reading a document, the unpickler checks+-- whether there is a namespace declaration for the given+-- namespace URI (2. arg)++xpAddNSDecl  :: String -> String -> PU a -> PU a+xpAddNSDecl name val+                = xpSeq' $ xpAttrNSDecl name' val+    where+      name'+          | null name = "xmlns"+          | otherwise = "xmlns:" ++ name++xpAttrNSDecl     :: String -> String -> PU ()+xpAttrNSDecl name ns+                 = PU { appPickle   = const $ putAtt (mkName name) [XN.mkText ns]+                      , appUnPickle = getNSAtt ns+                      , theSchema   = scAttr name (scFixed ns)+                      }++-- ------------------------------------------------------------++xpIgnoreCont    :: LA XmlTree XmlTree -> PU ()+xpIgnoreCont    = xpIgnoreInput $ \ mf s -> s {contents   = mf $ contents   s}++xpIgnoreAttr    :: LA XmlTree XmlTree -> PU ()+xpIgnoreAttr    = xpIgnoreInput $ \ mf s -> s {attributes = mf $ attributes s}++-- | When unpickling, filter the contents of the element currently processed,+-- before applying the pickler argument+--+-- Maybe useful to ignore some stuff in the input, or to do some cleanup before unpickling.++xpFilterCont    :: LA XmlTree XmlTree -> PU a -> PU a+xpFilterCont f  = xpSeq' $ xpIgnoreCont f++-- | Same as 'xpFilterCont' but for the  attribute list of the element currently processed.+--+-- Maybe useful to ignore some stuff in the input, e.g. class attributes, or to do some cleanup before unpickling.++xpFilterAttr    :: LA XmlTree XmlTree -> PU a -> PU a+xpFilterAttr f  = xpSeq' $ xpIgnoreAttr f++xpIgnoreInput   :: (([XmlTree] -> [XmlTree]) -> St -> St) -> LA XmlTree XmlTree -> PU ()+xpIgnoreInput m f+                =  PU { appPickle   = const id+                      , appUnPickle = do modify (m filterCont)+                                         return ()+                      , theSchema   = scNull+                      }+    where+      filterCont = runLA (unlistA >>> f)++-- ------------------------------------------------------------++-- | The class for overloading 'xpickle', the default pickler++class XmlPickler a where+    xpickle :: PU a++instance XmlPickler Int where+    xpickle = xpPrim++instance XmlPickler Integer where+    xpickle = xpPrim++{-+  no instance of XmlPickler Char+  because then every text would be encoded+  char by char, because of the instance for lists++instance XmlPickler Char where+    xpickle = xpPrim+-}++instance XmlPickler () where+    xpickle = xpUnit++instance (XmlPickler a, XmlPickler b) => XmlPickler (a,b) where+    xpickle = xpPair xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c) => XmlPickler (a,b,c) where+    xpickle = xpTriple xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d) => XmlPickler (a,b,c,d) where+    xpickle = xp4Tuple xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e) => XmlPickler (a,b,c,d,e) where+    xpickle = xp5Tuple xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f) => XmlPickler (a, b, c, d, e, f) where+  xpickle = xp6Tuple xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g) => XmlPickler (a, b, c, d, e, f, g) where+  xpickle = xp7Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h) => XmlPickler (a, b, c, d, e, f, g, h) where+  xpickle = xp8Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i) => XmlPickler (a, b, c, d, e, f, g, h, i) where+  xpickle = xp9Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j) => XmlPickler (a, b, c, d, e, f, g, h, i, j) where+  xpickle = xp10Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k) where+  xpickle = xp11Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l) where+  xpickle = xp12Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m) where+  xpickle = xp13Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+  xpickle = xp14Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+  xpickle = xp15Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where+  xpickle = xp16Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) where+  xpickle = xp17Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) where+  xpickle = xp18Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r, XmlPickler s) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) where+  xpickle = xp19Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r, XmlPickler s, XmlPickler t) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) where+  xpickle = xp20Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r, XmlPickler s, XmlPickler t, XmlPickler u) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) where+  xpickle = xp21Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r, XmlPickler s, XmlPickler t, XmlPickler u, XmlPickler v) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) where+  xpickle = xp22Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r, XmlPickler s, XmlPickler t, XmlPickler u, XmlPickler v, XmlPickler w) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) where+  xpickle = xp23Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r, XmlPickler s, XmlPickler t, XmlPickler u, XmlPickler v, XmlPickler w, XmlPickler x) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) where+  xpickle = xp24Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance XmlPickler a => XmlPickler [a] where+    xpickle = xpList xpickle++instance XmlPickler a => XmlPickler (Maybe a) where+    xpickle = xpOption xpickle++-- | Pickler for an arbitrary datum of type 'Either'.+instance (XmlPickler l, XmlPickler r) => XmlPickler (Either l r) where+        xpickle = pick xpickle xpickle+          where+            pick :: PU l -> PU r -> PU (Either l r)+            pick lPickler rPickler =+              xpAlt (const 0 `either` const 1)+              [ xpWrap (   Left            -- Construct.+                       , \ (Left l ) -> l  -- Deconstruct.+                       ) lPickler+              , xpWrap (    Right          -- Construct.+                       , \ (Right r) -> r  -- Deconstruct.+                       ) rPickler+              ]++-- ------------------------------------------------------------++{-+-- Thanks to treeowl:++-- This script was used to generate the tuple instances:++import Data.List (intercalate)++-- | Generates XmlPickler instances for tuples of size 4 <= n <= 24+mkInstance :: Int -> String+mkInstance n =+    "instance (" ++ constrainsts ++ ") => XmlPickler (" ++ tuple ++ ") where\n" +++    "  xpickle = xp" ++ show n ++ "Tuple " ++ xpickleStrings+  where+    xpickleStrings = intercalate " " (replicate n "xpickle")+    tuple = intercalate ", " letters+    letters = map (:[]) $ take n ['a'..'z']+    constrainsts = intercalate ", " $ map oneConstr letters+    oneConstr a = "XmlPickler " ++ a++mkInstances :: String+mkInstances = intercalate "\n\n" $ mkInstance <$> [6..24]+-}++-- ------------------------------------------------------------++{- begin embeded test cases++-- ------------------------------------------------------------+--+-- a somewhat complex data structure+-- for representing programs of a simple+-- imperative language++type Program    = Stmt++type StmtList   = [Stmt]++data Stmt+    = Assign  Ident  Expr+    | Stmts   StmtList+    | If      Expr  Stmt (Maybe Stmt)+    | While   Expr  Stmt+      deriving (Eq, Show)++type Ident      = String++data Expr+    = IntConst  Int+    | BoolConst Bool+    | Var       Ident+    | UnExpr    UnOp  Expr+    | BinExpr   Op    Expr  Expr+      deriving (Eq, Show)++data Op+    = Add | Sub | Mul | Div | Mod | Eq | Neq+      deriving (Eq, Ord, Enum, Show)++data UnOp+    = UPlus | UMinus | Neg+      deriving (Eq, Ord, Read, Show)++-- ------------------------------------------------------------+--+-- the pickler definition for the data types++-- the main pickler++xpProgram :: PU Program+xpProgram = xpElem "program" $+            xpAddNSDecl "" "program42" $+            xpickle++xpMissingRootElement    :: PU Program+xpMissingRootElement    = xpickle++instance XmlPickler UnOp where+    xpickle = xpPrim++instance XmlPickler Op where+    xpickle = xpWrap (toEnum, fromEnum) xpPrim++instance XmlPickler Expr where+    xpickle = xpAlt tag ps+        where+        tag (IntConst _    ) = 0+        tag (BoolConst _   ) = 1+        tag (Var _         ) = 2+        tag (UnExpr _ _    ) = 3+        tag (BinExpr _ _ _ ) = 4+        ps = [ xpWrap ( IntConst+                      , \ (IntConst i ) -> i+                      ) $+               ( xpElem "int"   $+                 xpAttr "value" $+                 xpickle+               )++             , xpWrap ( BoolConst+                      , \ (BoolConst b) -> b+                      ) $+               ( xpElem "bool"  $+                 xpAttr "value" $+                 xpWrap (toEnum, fromEnum) xpickle+               )++             , xpWrap ( Var+                      , \ (Var n)       -> n+                      ) $+               ( xpElem "var"   $+                 xpAttr "name"  $+                 xpText+               )++             , xpWrap ( uncurry UnExpr+                      , \ (UnExpr op e) -> (op, e)+                      ) $+               ( xpElem "unex" $+                 xpPair (xpAttr "op" xpickle)+                         xpickle+               )++             , xpWrap ( uncurry3 $ BinExpr+                      , \ (BinExpr op e1 e2) -> (op, e1, e2)+                      ) $+               ( xpElem "binex" $+                 xpTriple (xpAttr "op" xpickle)+                           xpickle+                           xpickle+               )+             ]++instance XmlPickler Stmt where+    xpickle = xpAlt tag ps+        where+        tag ( Assign _ _ ) = 0+        tag ( Stmts _ )    = 1+        tag ( If _ _ _ )   = 2+        tag ( While _ _ )  = 3+        ps = [ xpWrap ( uncurry Assign+                      , \ (Assign n v) -> (n, v)+                      ) $+               ( xpElem "assign" $+                 xpFilterCont (neg $ hasName "comment" <+> isText) $  -- test case test7: remove uninteresting stuff+                 xpPair (xpAttr "name" xpText)+                         xpickle+               )+             , xpWrap ( Stmts+                      , \ (Stmts sl) -> sl+                      ) $+               ( xpElem "block" $+                 xpList xpickle+               )+             , xpWrap ( uncurry3 If+                      , \ (If c t e) -> (c, t, e)+                      ) $+               ( xpElem "if" $+                 xpTriple xpickle+                          xpickle+                          xpickle+               )+             , xpWrap ( uncurry While+                      , \ (While c b) -> (c, b)+                      ) $+               ( xpElem "while" $+                 xpPair xpickle+                        xpickle+               )+             ]++-- ------------------------------------------------------------+--+-- example programs++progs   :: [Program]+progs   = [p0, p1, p2]++p0, p1, p2 :: Program++p0 = Stmts []           -- the empty program++p1 = Stmts+     [ Assign i ( UnExpr UMinus ( IntConst (-22) ) )+     , Assign j ( IntConst 20 )+     , While+       ( BinExpr Neq ( Var i ) ( IntConst 0 ) )+       ( Stmts+         [ Assign i ( BinExpr Sub ( Var i ) ( IntConst 1 ) )+         , Assign j ( BinExpr Add ( Var j ) ( IntConst 1 ) )+         , If ( IntConst 0 ) (Stmts []) Nothing+         ]+       )+     ]+    where+    i = "i"+    j = "j"++p2 = Stmts+     [ Assign x (IntConst 6)+     , Assign y (IntConst 7)+     , Assign p (IntConst 0)+     , While+       ( BinExpr Neq (Var x) (IntConst 0) )+       ( If ( BinExpr Neq ( BinExpr Mod (Var x) (IntConst 2) ) (IntConst 0) )+            ( Stmts+              [ Assign x ( BinExpr Sub (Var x) (IntConst 1) )+              , Assign p ( BinExpr Add (Var p) (Var y) )+              ]+            )+            ( Just ( Stmts+                     [ Assign x ( BinExpr Div (Var x) (IntConst 2) )+                     , Assign y ( BinExpr Mul (Var y) (IntConst 2) )+                     ]+                   )+            )+       )+     ]+    where+    x = "x"+    y = "y"+    p = "p"++-- ------------------------------------------------------------++test0 = putStrLn . head . runLA+        ( xshow (arr (pickleDoc xpProgram)+                 >>> getChildren+                )+        )++test0' f = runLA+        ( xshow (arr (pickleDoc xpProgram)+                 >>> getChildren+                )+          >>>+          root [] [xread]+          >>>+          f+        )++test1' f = runLA+        ( xshow (arr (pickleDoc xpProgram)+                 >>> getChildren+                )+          >>>+          root [] [xread]+          >>>+          f+          >>>+          arr (unpickleDoc' xpProgram)+        )++test1 = test0' (processTopDown (setQName (mkName "real") `X.when` hasName "int"))+test2 = test1' this+test3 = test1' (processTopDown (setQName (mkName "real") `X.when` hasName "int"))+test4 = test1' (processTopDown (setQName (mkName "xxx")  `X.when` hasName "program"))+test5 = test1' (processTopDown (setQName (mkName "xxx")  `X.when` hasName "assign"))+test6 = test1' (processTopDownWithAttrl  (txt "xxx"      `X.when` hasText (== "UMinus")))+test7 = test1' (processTopDown (insertComment            `X.when` hasName "assign"))+    where insertComment = replaceChildren (getChildren <+> eelem "comment" <+> txt "zzz")++-- ------------------------------------------------------------++-- end embeded test cases -}
src/Text/XML/HXT/Arrow/ProcessDocument.hs view
@@ -2,13 +2,12 @@  {- |    Module     : Text.XML.HXT.Arrow.ProcessDocument-   Copyright  : Copyright (C) 2005 Uwe Schmidt+   Copyright  : Copyright (C) 2011 Uwe Schmidt    License    : MIT     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)    Stability  : experimental    Portability: portable-   Version    : $Id: ProcessDocument.hs,v 1.3 2006/08/30 16:20:52 hxml Exp $     Compound arrows for reading, parsing, validating and writing XML documents @@ -19,52 +18,46 @@  module Text.XML.HXT.Arrow.ProcessDocument     ( parseXmlDocument+    , parseXmlDocumentWithExpat     , parseHtmlDocument     , validateDocument     , propagateAndValidateNamespaces+    , andValidateNamespaces     , getDocumentContents     ) where -import Control.Arrow                            -- arrow classes-import Control.Arrow.ArrowList-import Control.Arrow.ArrowIf-import Control.Arrow.ArrowTree+import           Control.Arrow+import           Control.Arrow.ArrowIf+import           Control.Arrow.ArrowList+import           Control.Arrow.ArrowTree+import           Control.Arrow.ListArrow                      (fromLA)+import           Control.Arrow.NTreeEdit -import Text.XML.HXT.DOM.Interface-import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlIOStateArrow+import           Text.XML.HXT.DOM.Interface -import Text.XML.HXT.Arrow.ParserInterface-    ( parseXmlDoc-    , parseHtmlDoc-    , parseHtmlTagSoup-    , substHtmlEntityRefs-    , validateDoc-    , transformDoc-    )+import           Text.XML.HXT.Arrow.XmlArrow+import           Text.XML.HXT.Arrow.XmlState+import           Text.XML.HXT.Arrow.XmlState.TypeDefs -import Text.XML.HXT.Arrow.Edit-    ( transfAllCharRef-    )+import           Text.XML.HXT.Arrow.ParserInterface           (parseHtmlDoc,+                                                               parseXmlDoc) -import Text.XML.HXT.Arrow.GeneralEntitySubstitution-    ( processGeneralEntities-    )+import           Text.XML.HXT.Arrow.Edit                      (substAllXHTMLEntityRefs,+                                                               transfAllCharRef) -import Text.XML.HXT.Arrow.DTDProcessing-    ( processDTD-    )+import           Text.XML.HXT.Arrow.GeneralEntitySubstitution (processGeneralEntities) -import Text.XML.HXT.Arrow.DocumentInput-    ( getXmlContents-    )+import           Text.XML.HXT.Arrow.DTDProcessing             (processDTD) -import Text.XML.HXT.Arrow.Namespace-    ( propagateNamespaces-    , validateNamespaces-    )+import           Text.XML.HXT.Arrow.DocumentInput             (getXmlContents) +import           Text.XML.HXT.Arrow.Namespace                 (propagateNamespaces, validateNamespaces)+import           Text.XML.HXT.DTDValidation.Validation        (generalEntitiesDefined,+                                                               getDTDSubset,+                                                               transform,+                                                               validate)+ -- ------------------------------------------------------------  {- |@@ -86,8 +79,8 @@ This parser is useful for applications processing correct XML documents. -} -parseXmlDocument        :: Bool -> IOStateArrow s XmlTree XmlTree-parseXmlDocument validate+parseXmlDocument        :: Bool -> Bool -> Bool -> Bool -> IOStateArrow s XmlTree XmlTree+parseXmlDocument validateD substDTD substHTML validateRX     = ( replaceChildren ( ( getAttrValue a_source                             &&&                             xshow getChildren@@ -100,21 +93,75 @@         >>>         setDocumentStatusFromSystemState "parse XML document"         >>>-        processDTD-        >>>-        processGeneralEntities-        >>>-        transfAllCharRef-        >>>-        ( if validate-          then validateDocument-          else this+        ( ifA (fromLA getDTDSubset)+          ( processDTDandEntities+            >>>+            ( if validate'                      -- validation only possible if there is a DTD+              then validateDocument+              else this+            )+          )+          ( if validate'                        -- validation only consists of checking+                                                -- for undefined entity refs+                                                -- predefined XML entity refs are substituted+                                                -- in the XML parser into char refs+                                                -- so there is no need for an entity substitution+            then traceMsg 2 "checkUndefinedEntityRefs: looking for undefined entity refs"+                 >>>+                 perform checkUndefinedEntityRefs+                 >>>+                 traceMsg 2 "checkUndefinedEntityRefs: looking for undefined entity refs done"+                 >>>+                 setDocumentStatusFromSystemState "decoding document"+            else this+          )         )       )       `when` documentStatusOk+    where+      validate'+          = validateD && not validateRX +      processDTDandEntities+          = ( if validateD || substDTD+              then processDTD+              else this+            )+            >>>+            ( if substDTD+              then ( processGeneralEntities             -- DTD contains general entity definitions+                     `when`+                     fromLA generalEntitiesDefined+                   )+              else if substHTML+                   then substAllXHTMLEntityRefs+                   else this+            )+            >>>+            transfAllCharRef++checkUndefinedEntityRefs        :: IOStateArrow s XmlTree XmlTree+checkUndefinedEntityRefs+    = deep isEntityRef+      >>>+      getEntityRef+      >>>+      arr (\ en -> "general entity reference \"&" ++ en ++ ";\" is undefined")+      >>>+      mkError c_err+      >>>+      filterErrorMsg+ -- ------------------------------------------------------------ +parseXmlDocumentWithExpat        :: IOStateArrow s XmlTree XmlTree+parseXmlDocumentWithExpat+    = ( withoutUserState $< getSysVar theExpatParser+      )+      `when` documentStatusOk++-- ------------------------------------------------------------+ {- | HTML parser @@ -129,19 +176,16 @@  -} -parseHtmlDocument       :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IOStateArrow s XmlTree XmlTree-parseHtmlDocument withTagSoup withNamespaces warnings preserveCmt removeWhitespace asHtml-    = ( perform ( getAttrValue a_source >>> traceValue 1 (("parseHtmlDoc: parse HTML document " ++) . show) )+parseHtmlDocument       :: IOStateArrow s XmlTree XmlTree+parseHtmlDocument+    = ( perform ( getAttrValue a_source+                  >>>+                  traceValue 1 (("parseHtmlDoc: parse HTML document " ++) . show)+                )         >>>-        replaceChildren ( ( getAttrValue a_source               -- get source name-                            &&&-                            xshow getChildren-                          )                                     -- get string to be parsed-                          >>>-                          parseHtml-                        )+        ( parseHtml      $< getSysVar (theTagSoup  .&&&. theExpat) )         >>>-        removeWarnings+        ( removeWarnings $< getSysVar (theWarnings .&&&. theTagSoup) )         >>>         setDocumentStatusFromSystemState "parse HTML document"         >>>@@ -156,31 +200,31 @@       )       `when` documentStatusOk     where-    parseHtml-        | withTagSoup   = traceMsg 1 ("parse document with tagsoup " ++-                                      ( if asHtml then "HT" else "X" ) ++ "ML parser"-                                     )-                          >>>-                          parseHtmlTagSoup withNamespaces warnings preserveCmt removeWhitespace asHtml+    parseHtml (withTagSoup', withExpat')+        | withExpat'    = withoutUserState $< getSysVar theExpatParser +        | withTagSoup'  = withoutUserState $< getSysVar theTagSoupParser+         | otherwise     = traceMsg 1 ("parse document with parsec HTML parser")                           >>>-                          parseHtmlDoc                          -- run parser-                          >>>-                          substHtmlEntityRefs                   -- substitute entity refs-    removeWarnings-        | withTagSoup-          &&-          not warnings  = this-        | otherwise     = processTopDownWithAttrl-                          ( if warnings                         -- remove warnings inserted by parser and entity subst-                            then filterErrorMsg-                            else ( none-                                   `when`-                                   isError-                                 )+                          replaceChildren+                          ( ( getAttrValue a_source             -- get source name+                              &&&+                              xshow getChildren+                            )                                   -- get string to be parsed+                            >>>+                            parseHtmlDoc                        -- run parser, entity substituion is done in parser                           ) +    removeWarnings (warnings, withTagSoup')+        | warnings      = processTopDownWithAttrl               -- remove warnings inserted by parser and entity subst+                          filterErrorMsg+        | withTagSoup'  = this                                  -- warnings are not generated in tagsoup++        | otherwise     = fromLA $+                          editNTreeA [isError :-> none]         -- remove all warnings from document++ -- ------------------------------------------------------------  {- | Document validation@@ -209,9 +253,11 @@         >>>         setDocumentStatusFromSystemState "document validation"         >>>+        traceMsg 1 "document validated, transforming doc with respect to DTD"+        >>>         transformDoc         >>>-        traceMsg 1 "document validated"+        traceMsg 1 "document transformed"         >>>         traceSource         >>>@@ -245,7 +291,14 @@         >>>         traceDoc "propagating namespaces done"         >>>-        traceMsg 1 "validating namespaces"+        andValidateNamespaces+      )+      `when`+      documentStatusOk++andValidateNamespaces  :: IOStateArrow s XmlTree XmlTree+andValidateNamespaces+    = ( traceMsg 1 "validating namespaces"         >>>         ( setDocumentStatusFromSystemState "namespace propagation"           `when`@@ -269,16 +322,25 @@    For supported protocols see 'Text.XML.HXT.Arrow.DocumentInput.getXmlContents' -} -getDocumentContents     :: Attributes -> String -> IOStateArrow s b XmlTree-getDocumentContents options src+getDocumentContents     :: String -> IOStateArrow s b XmlTree+getDocumentContents src     = root [] []       >>>       addAttr a_source src       >>>-      seqA (map (uncurry addAttr) options)                                      -- add all options to doc root-      >>>                                                                       -- e.g. getXmlContents needs some of these       traceMsg 1 ("readDocument: start processing document " ++ show src)       >>>       getXmlContents++-- ------------------------------------------------------------++validateDoc                     :: ArrowList a => a XmlTree XmlTree+validateDoc                     = fromLA ( validate+                                           `when`+                                           getDTDSubset      -- validate only when DTD decl is present+                                         )++transformDoc                    :: ArrowList a => a XmlTree XmlTree+transformDoc                    = fromLA transform  -- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/ReadDocument.hs view
@@ -2,15 +2,14 @@  {- |    Module     : Text.XML.HXT.Arrow.ReadDocument-   Copyright  : Copyright (C) 2005 Uwe Schmidt+   Copyright  : Copyright (C) 2005-2013 Uwe Schmidt    License    : MIT     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : experimental+   Stability  : stable    Portability: portable-   Version    : $Id: ReadDocument.hs,v 1.10 2006/11/24 07:41:37 hxml Exp $ -Compound arrows for reading an XML\/HTML document or an XML\/HTML string+   Compound arrows for reading an XML\/HTML document or an XML\/HTML string  -} @@ -22,185 +21,217 @@     , readString     , readFromString     , hread+    , hreadDoc     , xread+    , xreadDoc     ) where  import Control.Arrow.ListArrows -import Data.Char                                ( isDigit )+import Data.Maybe                               ( fromMaybe )+import qualified Data.Map                       as M++ import Text.XML.HXT.DOM.Interface-import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlIOStateArrow +import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.Edit                  ( canonicalizeAllNodes                                                 , canonicalizeForXPath                                                 , canonicalizeContents                                                 , rememberDTDAttrl                                                 , removeDocWhiteSpace                                                 )--import Text.XML.HXT.Arrow.ParserInterface-+import qualified Text.XML.HXT.Arrow.ParserInterface as PI import Text.XML.HXT.Arrow.ProcessDocument       ( getDocumentContents                                                 , parseXmlDocument+                                                , parseXmlDocumentWithExpat                                                 , parseHtmlDocument                                                 , propagateAndValidateNamespaces+                                                , andValidateNamespaces                                                 )--import Text.XML.HXT.RelaxNG.Validator           ( validateDocumentWithRelaxSchema )+import Text.XML.HXT.Arrow.XmlState+import Text.XML.HXT.Arrow.XmlState.TypeDefs  -- -------------------------------------------------------------+-- {- | the main document input filter -this filter can be configured by an option list, a value of type 'Text.XML.HXT.DOM.TypeDefs.Attributes'--available options:--* 'a_parse_html': use HTML parser, else use XML parser (default)--- 'a_tagsoup' : use light weight and lazy parser based on tagsoup lib--- 'a_parse_by_mimetype' : select the parser by the mime type of the document-                          (pulled out of the HTTP header). When the mime type is set to \"text\/html\"-                          the HTML parser (parsec or tagsoup) is taken, when it\'s set to-                          \"text\/xml\" or \"text\/xhtml\" the XML parser (parsec or tagsoup) is taken.-                          If the mime type is something else no further processing is performed,-                          the contents is given back to the application in form of a single text node.-                          If the default document encoding ('a_encoding') is set to isoLatin1, this even enables processing-                          of arbitray binary data.--- 'a_validate' : validate document againsd DTD (default), else skip validation--- 'a_relax_schema' : validate document with Relax NG, the options value is the schema URI-                     this implies using XML parser, no validation against DTD, and canonicalisation--- 'a_check_namespaces' : check namespaces, else skip namespace processing (default)--- 'a_canonicalize' : canonicalize document (default), else skip canonicalization--- 'a_preserve_comment' : preserve comments during canonicalization, else remove comments (default)--- 'a_remove_whitespace' : remove all whitespace, used for document indentation, else skip this step (default)--- 'a_indent' : indent document by inserting whitespace, else skip this step (default)--- 'a_issue_warnings' : issue warnings, when parsing HTML (default), else ignore HTML parser warnings--- 'a_issue_errors' : issue all error messages on stderr (default), or ignore all error messages--- 'a_ignore_encoding_errors': ignore all encoding errors, default is issue all encoding errors--- 'a_ignore_none_xml_contents': ignore document contents of none XML\/HTML documents.-                                This option can be useful for implementing crawler like applications, e.g. an URL checker.-                                In those cases net traffic can be reduced.--- 'a_trace' : trace level: values: 0 - 4+this filter can be configured by a list of configuration options,+a value of type 'Text.XML.HXT.XmlState.TypeDefs.SysConfig' -- 'a_proxy' : proxy for http access, e.g. www-cache:3128+for all available options see module 'Text.XML.HXT.Arrow.XmlState.SystemConfig' -- 'a_redirect' : automatically follow redirected URIs, default is yes+- @withValidate yes\/no@ :+  switch on\/off DTD validation. Only for XML parsed documents, not for HTML parsing. -- 'a_use_curl' : obsolete and ignored, HTTP acccess is always done with curl bindings for libcurl+- @withSubstDTDEntities yes\/no@ :+  switch on\/off entity substitution for general entities defined in DTD validation.+  Default is @yes@.+  Switching this option and the validation off can lead to faster parsing, in that case+  reading the DTD documents is not longer necessary.+  Only used with XML parsed documents, not with HTML parsing. -- 'a_strict_input' : file input is done strictly using the 'Data.ByteString' input functions. This ensures correct closing of files, especially when working with-                     the tagsoup parser and not processing the whole input data. Default is off. The @ByteString@ input usually is not faster than the buildin @hGetContents@-                     for strings.+- @withSubstHTMLEntities yes\/no@ :+  switch on\/off entity substitution for general entities defined in HTML validation.+  Default is @no@.+  Switching this option on and the validation and substDTDEntities off can lead to faster parsing,+  in that case+  reading the DTD documents is not longer necessary, HTML general entities are still substituted.+  Only used with XML parsed documents, not with HTML parsing. -- 'a_options_curl' : deprecated but for compatibility reasons still supported.-                     More options passed to the curl binding.-                     Instead of using this option to set a whole bunch of options at once for curl-                     it is recomended to use the @curl-.*@ options syntax described below.+- @withParseHTML yes\/no@ :+  switch on HTML parsing. -- 'a_encoding' : default document encoding ('utf8', 'isoLatin1', 'usAscii', 'iso8859_2', ... , 'iso8859_16', ...).-                 Only XML, HTML and text documents are decoded,-                 default decoding for XML\/HTML is utf8, for text iso latin1 (no decoding).-                 The whole content is returned in a single text node.+- @withParseByMimeType yes\/no@ :+  select XML\/HTML parser by document mime type.+  text\/xml and text\/xhtml are parsed as XML, text\/html as HTML. -- 'a_mime_types' : set the mime type table for file input with given file. The format of this config file must be in the syntax of a debian linux \"mime.types\" config file+- @withCheckNamespaces yes\/no@ :+  Switch on\/off namespace propagation and checking -- 'a_if_modified_since' : read document conditionally, only if the document is newer than the given date and time argument, the contents is delivered,-                          else just the root node with the meta data is returned. The date and time must be given in "System.Locale.rfc822DateFormat".+- @withInputEncoding \<encoding-spec\>@ :+  Set default encoding. -- curl options : the HTTP interface with libcurl can be configured with a lot of options. To support these options in an easy way, there is a naming convetion:-                 Every option, which has the prefix @curl@ and the rest of the name forms an option as described in the curl man page, is passed to the curl binding lib.-                 See 'Text.XML.HXT.IO.GetHTTPLibCurl.getCont' for examples. Currently most of the options concerning HTTP requests are implemented.+- @withTagSoup@ :+  use light weight and lazy parser based on tagsoup lib.+  This is only available when package hxt-tagsoup is installed and+  the source contains an @import Text.XML.HXT.TagSoup@. -All attributes not evaluated by readDocument are stored in the created document root node for easy access of the various-options in e.g. the input\/output modules+- @withRelaxNG \<schema.rng\>@ :+  validate document with Relax NG, the parameter is for the schema URI.+  This implies using XML parser, no validation against DTD, and canonicalisation. -If the document name is the empty string or an uri of the form \"stdin:\", the document is read from standard input.+- @withCurl [\<curl-option\>...]@ :+  Use the libCurl binding for HTTP access.+  This is only available when package hxt-curl is installed and+  the source contains an @import Text.XML.HXT.Curl@.+                   +- @withHTTP [\<http-option\>...]@ :+  Use the Haskell HTTP package for HTTP access.+  This is only available when package hxt-http is installed and+  the source contains an @import Text.XML.HXT.HTTP@.  examples: -> readDocument [ ] "test.xml"+> readDocument [] "test.xml"  reads and validates a document \"test.xml\", no namespace propagation, only canonicalization is performed -> readDocument [ (a_validate, "0")->              , (a_encoding, isoLatin1)->              , (a_parse_by_mimetype, "1")+> ...+> import Text.XML.HXT.Curl+> ...+>+> readDocument [ withValidate        no+>              , withInputEncoding   isoLatin1+>              , withParseByMimeType yes+>              , withCurl [] >              ] "http://localhost/test.php"  reads document \"test.php\", parses it as HTML or XML depending on the mimetype given from the server, but without validation, default encoding 'isoLatin1'.-+HTTP access is done via libCurl. -> readDocument [ (a_parse_html, "1")->              , (a_encoding, isoLatin1)+> readDocument [ withParseHTML       yes+>              , withInputEncoding   isoLatin1 >              ] ""  reads a HTML document from standard input, no validation is done when parsing HTML, default encoding is 'isoLatin1',-parsing is done with tagsoup parser, but input is read strictly -> readDocument [ (a_encoding, isoLatin1)->              , (a_mime_type,    "/etc/mime.types")->              , (a_tagsoup,      "1")->              , (a_strict_input, "1")+> readDocument [ withInputEncoding  isoLatin1+>              , withValidate       no+>              , withMimeTypeFile   "/etc/mime.types"+>              , withStrictInput    yes >              ] "test.svg" -reads an SVG document from standard input, sets the mime type by looking in the system mimetype config file, default encoding is 'isoLatin1',-parsing is done with the lightweight tagsoup parser, which implies no validation.+reads an SVG document from \"test.svg\", sets the mime type by looking in the system mimetype config file,+default encoding is 'isoLatin1', -> readDocument [ (a_parse_html,     "1")->              , (a_proxy,          "www-cache:3128")->              , (a_curl,           "1")->              , (a_issue_warnings, "0")+> ...+> import Text.XML.HXT.Curl+> import Text.XML.HXT.TagSoup+> ...+>+> readDocument [ withParseHTML      yes+>              , withTagSoup+>              , withProxy          "www-cache:3128"+>              , withCurl           []+>              , withWarnings       no >              ] "http://www.haskell.org/" -reads Haskell homepage with HTML parser ignoring any warnings, with http access via external program curl and proxy \"www-cache\" at port 3128+reads Haskell homepage with HTML parser, ignoring any warnings+(at the time of writing, there were some HTML errors),+with http access via libCurl interface+and proxy \"www-cache\" at port 3128,+parsing is done with tagsoup HTML parser.+This requires packages \"hxt-curl\" and \"hxt-tagsoup\" to be installed -> readDocument [ (a_validate,          "1")->              , (a_check_namespace,   "1")->              , (a_remove_whitespace, "1")->              , (a_trace,             "2")+> readDocument [ withValidate          yes+>              , withCheckNamespaces   yes+>              , withRemoveWS          yes+>              , withTrace             2+>              , withHTTP              [] >              ] "http://www.w3c.org/" -read w3c home page (xhtml), validate and check namespaces, remove whitespace between tags, trace activities with level 2+read w3c home page (xhtml), validate and check namespaces, remove whitespace between tags,+trace activities with level 2.+HTTP access is done with Haskell HTTP package -for minimal complete examples see 'Text.XML.HXT.Arrow.WriteDocument.writeDocument' and 'runX', the main starting point for running an XML arrow.+> readDocument [ withValidate          no+>              , withSubstDTDEntities  no+>              ...+>              ] "http://www.w3c.org/"++read w3c home page (xhtml), but without accessing the DTD given in that document.+Only the predefined XML general entity refs are substituted.++> readDocument [ withValidate          no+>              , withSubstDTDEntities  no+>              , withSubstHTMLEntities yes+>              ...+>              ] "http://www.w3c.org/"++same as above, but with substituion of all general entity refs defined in XHTML.++for minimal complete examples see 'Text.XML.HXT.Arrow.WriteDocument.writeDocument'+and 'runX', the main starting point for running an XML arrow. -} -readDocument    :: Attributes -> String -> IOStateArrow s b XmlTree-readDocument userOptions src-    = case getTraceLev of-      Nothing   ->                    readDocument' userOptions src-      Just l    -> withTraceLevel l $ readDocument' userOptions src-    where-    getTraceLev = do-                  s <- lookup a_trace $ userOptions-                  if not (null s) && all isDigit s-                      then return (read s)-                      else fail "not a number"+readDocument    :: SysConfigList -> String -> IOStateArrow s b XmlTree+readDocument config src+    = localSysEnv+      $+      readDocument' config src -readDocument'   :: Attributes -> String -> IOStateArrow s b XmlTree-readDocument' userOptions src-    = loadMineTypes (lookup1 a_mime_types userOptions)+readDocument'   :: SysConfigList -> String -> IOStateArrow s b XmlTree+readDocument' config src+    = configSysVars config       >>>-      getDocumentContents options src+      readD $< getSysVar theWithCache+    where+    readD True+        = constA undefined              -- just for generalizing the signature to: IOStateArrow s b       XmlTree+          >>>                           -- instead of                              IOStateArrow s XmlTree XmlTree+          (withoutUserState $< (getSysVar theCacheRead >>^ ($ src)))+    readD False+        = readDocument'' src++readDocument''   :: String -> IOStateArrow s b XmlTree+readDocument'' src+    = getDocumentContents src       >>>-      ( processDoc $< getMimeType )+      ( processDoc+        $<<+        ( getMimeType+          &&&+          getSysVar (theParseByMimeType   .&&&.+                     theParseHTML         .&&&.+                     theAcceptedMimeTypes .&&&.+                     theRelaxValidate     .&&&.+                     theXmlSchemaValidate+                    )+        )+      )       >>>       traceMsg 1 ("readDocument: " ++ show src ++ " processed")       >>>@@ -208,50 +239,86 @@       >>>       traceTree     where-    options-        = addEntries userOptions defaultOptions--    defaultOptions-        = [ ( a_parse_html,               v_0 )-          , ( a_tagsoup,                  v_0 )-          , ( a_strict_input,             v_0 )-          , ( a_validate,                 v_1 )-          , ( a_issue_warnings,           v_1 )-          , ( a_check_namespaces,         v_0 )-          , ( a_canonicalize,             v_1 )-          , ( a_preserve_comment,         v_0 )-          , ( a_remove_whitespace,        v_0 )-          , ( a_parse_by_mimetype,        v_0 )-          , ( a_ignore_encoding_errors,   v_0 )-          , ( a_ignore_none_xml_contents, v_0 )-          , ( a_accept_mimetypes,         ""  )-          ]--    loadMineTypes ""    = this-    loadMineTypes f     = setMimeTypeTableFromFile f+    processNoneEmptyDoc p+        = ifA (fromLA hasEmptyBody)+              (replaceChildren none)+              p+        where+          hasEmptyBody+              = hasAttrValue transferStatus (/= "200")        -- test on empty response body for not o.k. responses+                `guards`                                      -- e.g. 3xx status values+                ( neg getChildren+                  <+>+                  ( getChildren >>> isWhiteSpace )+                )      getMimeType         = getAttrValue transferMimeType >>^ stringToLower -    processDoc mimeType+    applyMimeTypeHandler mt+        = withoutUserState (applyMTH $< getSysVar theMimeTypeHandlers)+        where+          applyMTH mtTable+              = fromMaybe none $+                fmap (\ f -> processNoneEmptyDoc+                             (traceMimeStart >>> f >>> traceMimeEnd)+                     ) $+                M.lookup mt mtTable+          traceMimeStart+              = traceMsg 2 $+                "readDocument: calling user defined document parser"+          traceMimeEnd+              = traceMsg 2 $+                "readDocument: user defined document parser finished"++    processDoc mimeType options         = traceMsg 1 (unwords [ "readDocument:", show src-                              , "(mime type:", show mimeType, ") will be processed"])+                              , "(mime type:", show mimeType, ") will be processed"+                              ]+                     )           >>>-          ( if isAcceptedMimeType (lookup1 a_accept_mimetypes options) mimeType-            then ( ifA (fromLA hasEmptyBody)-                   ( replaceChildren none )                                     -- empty response, e.g. in if-modified-since request-                   ( parse+          ( applyMimeTypeHandler mimeType       -- try user defined document handlers+            `orElse`+            processDoc' mimeType options+          )++    processDoc' mimeType ( parseByMimeType+                         , ( parseHtml+                           , ( acceptedMimeTypes+                             , ( validateWithRelax+                               , validateWithXmlSchema+                               ))))+        = ( if isAcceptedMimeType acceptedMimeTypes mimeType+            then ( processNoneEmptyDoc+                   ( ( parse $< getSysVar (theValidate              .&&&.+                                           theSubstDTDEntities      .&&&.+                                           theSubstHTMLEntities     .&&&.+                                           theIgnoreNoneXmlContents .&&&.+                                           theTagSoup               .&&&.+                                           theExpat+                                          )+                     )                      >>>                      ( if isXmlOrHtml-                       then ( checknamespaces+                       then ( ( checknamespaces $< getSysVar (theCheckNamespaces .&&&.+                                                              theTagSoup+                                                             )+                              )                               >>>                               rememberDTDAttrl                               >>>-                              canonicalize+                              ( canonicalize $< getSysVar (thePreserveComment .&&&.+                                                           theCanonicalize    .&&&.+                                                           theTagSoup+                                                          )+                              )                               >>>-                              whitespace+                              ( whitespace $< getSysVar (theRemoveWS .&&&.+                                                         theTagSoup+                                                        )+                              )                               >>>-                              relax+                              relaxOrXmlSchema                             )                        else this                      )@@ -260,19 +327,11 @@             else ( traceMsg 1 (unwords [ "readDocument:", show src                                        , "mime type:", show mimeType, "not accepted"])                    >>>-                   replaceChildren none-                 )                                                                      -- remove contents of not accepted mimetype+                   replaceChildren none         -- remove contents of not accepted mimetype+                 )           )         where-        hasEmptyBody                    :: LA XmlTree XmlTree-        hasEmptyBody                    = hasAttrValue transferStatus (/= "200")        -- test on empty response body for not o.k. responses-                                          `guards`                                      -- e.g. 3xx status values-                                          ( neg getChildren-                                            <+>-                                            ( getChildren >>> isWhiteSpace )-                                          )--        isAcceptedMimeType              :: String -> String -> Bool+        isAcceptedMimeType              :: [String] -> String -> Bool         isAcceptedMimeType mts mt             | null mts               ||@@ -280,9 +339,7 @@             | otherwise                 = foldr (matchMt mt') False $ mts'             where             mt'                         = parseMt mt-            mts'                        = words-                                          >>>-                                          map parseMt+            mts'                        = map parseMt                                           $                                           mts             parseMt                     = break (== '/')@@ -293,75 +350,97 @@                                             (mi == mis || mis == "*")                                           )                                           || r-        parse+        parse ( validate+              , ( substDTD+                , ( substHTML+                  , ( removeNoneXml+                    , ( withTagSoup'+                      , withExpat'+                      )))))+            | not isXmlOrHtml           = if removeNoneXml+                                          then replaceChildren none             -- don't parse, if mime type is not XML nor HTML+                                          else this                             -- but remove contents when option is set+             | isHtml               ||-              withTagSoup               = parseHtmlDocument                     -- parse as HTML or with tagsoup XML-                                          withTagSoup-                                          withNamespaces-                                          issueW-                                          (not (hasOption a_canonicalize) && preserveCmt)-                                          removeWS-                                          isHtml-            | validateWithRelax         = parseXmlDocument False                -- for Relax NG use XML parser without validation-            | isXml                     = parseXmlDocument validate             -- parse as XML-            | removeNoneXml             = replaceChildren none                  -- don't parse, if mime type is not XML nor HTML-            | otherwise                 = this                                  -- but remove contents when option is set-        checknamespaces-            | (withNamespaces && not withTagSoup)+              withTagSoup'              = configSysVar (setS theLowerCaseNames isHtml)+                                          >>>+                                          parseHtmlDocument                     -- parse as HTML or with tagsoup XML++            | isXml                     = if withExpat'+                                          then parseXmlDocumentWithExpat+                                          else parseXmlDocument+                                               validate+                                               substDTD+                                               substHTML+                                               validateWithRelax+                                                                                -- parse as XML+            | otherwise                 = this                                  -- suppress warning++        checknamespaces (withNamespaces, withTagSoup')+            | withNamespaces+              &&+              withTagSoup'              = andValidateNamespaces                 -- propagation is done in tagsoup++            | withNamespaces               ||-              validateWithRelax         = propagateAndValidateNamespaces+              validateWithRelax+              ||+              validateWithXmlSchema+                                        = propagateAndValidateNamespaces        -- RelaxNG and XML Schema require correct namespaces+             | otherwise                 = this-        canonicalize-            | withTagSoup               = this                                  -- tagsoup already removes redundant stuff-            | validateWithRelax         = canonicalizeAllNodes-            | hasOption a_canonicalize++        canonicalize (preserveCmt, (canonicalize', withTagSoup'))+            | withTagSoup'              = this                                  -- tagsoup already removes redundant stuff+            | validateWithRelax+              ||+              validateWithXmlSchema     = canonicalizeAllNodes                  -- no comments in schema validation++            | canonicalize'               &&               preserveCmt               = canonicalizeForXPath-            | hasOption a_canonicalize  = canonicalizeAllNodes+            | canonicalize'             = canonicalizeAllNodes             | otherwise                 = this-        relax-            | validateWithRelax         = validateDocumentWithRelaxSchema options relaxSchema++        relaxOrXmlSchema+            | validateWithXmlSchema     = withoutUserState $< getSysVar theXmlSchemaValidator+            | validateWithRelax         = withoutUserState $< getSysVar theRelaxValidator             | otherwise                 = this-        whitespace-            | removeWS++        whitespace (removeWS, withTagSoup')+            | ( removeWS+                ||+                validateWithXmlSchema                                           -- XML Schema does not like WS+              )               &&-              not withTagSoup           = removeDocWhiteSpace                   -- tagsoup already removes whitespace+              not withTagSoup'          = removeDocWhiteSpace                   -- tagsoup already removes whitespace             | otherwise                 = this-        validateWithRelax       = hasEntry a_relax_schema options-        relaxSchema             = lookup1 a_relax_schema options-        parseHtml               = hasOption a_parse_html-        isHtml                  = parseHtml                                     -- force HTML-                                  ||-                                  ( parseByMimeType && isHtmlMimeType mimeType )-        isXml                   = ( not parseByMimeType && not parseHtml )-                                  ||-                                  ( parseByMimeType-                                    &&-                                    ( isXmlMimeType mimeType-                                      ||-                                      null mimeType-                                    )                                           -- mime type is XML or not known-                                  )++        isHtml                          = ( not parseByMimeType && parseHtml )  -- force HTML+                                          ||+                                          ( parseByMimeType && isHtmlMimeType mimeType )++        isXml                           = ( not parseByMimeType && not parseHtml )+                                          ||+                                          ( parseByMimeType+                                            &&+                                            ( isXmlMimeType mimeType+                                              ||+                                              null mimeType+                                            )                                   -- mime type is XML or not known+                                          )+         isXmlOrHtml     = isHtml || isXml-        parseByMimeType = hasOption a_parse_by_mimetype-        validate        = hasOption a_validate-        withNamespaces  = hasOption a_check_namespaces-        withTagSoup     = hasOption a_tagsoup-        issueW          = hasOption a_issue_warnings-        removeWS        = hasOption a_remove_whitespace-        preserveCmt     = hasOption a_preserve_comment-        removeNoneXml   = hasOption a_ignore_none_xml_contents-        hasOption n     = optionIsSet n options  -- ------------------------------------------------------------  -- | -- the arrow version of 'readDocument', the arrow input is the source URI -readFromDocument        :: Attributes -> IOStateArrow s String XmlTree-readFromDocument userOptions-    = applyA ( arr $ readDocument userOptions )+readFromDocument :: SysConfigList -> IOStateArrow s String XmlTree+readFromDocument config+    = applyA ( arr $ readDocument config )  -- ------------------------------------------------------------ @@ -369,53 +448,88 @@ -- read a document that is stored in a normal Haskell String -- -- the same function as readDocument, but the parameter forms the input.--- All options available for 'readDocument' are applicable for readString.+-- All options available for 'readDocument' are applicable for readString,+-- except input encoding options. ----- Default encoding: No encoding is done, the String argument is taken as Unicode string+-- Encoding: No decoding is done, the String argument is taken as Unicode string+-- All decoding must be done before calling readString, even if the+-- XML document contains an encoding spec. -readString      :: Attributes -> String -> IOStateArrow s b XmlTree-readString userOptions content-    = readDocument ( (a_encoding, unicodeString) : userOptions ) (stringProtocol ++ content)+readString :: SysConfigList -> String -> IOStateArrow s b XmlTree+readString config content+    = readDocument config (stringProtocol ++ content)  -- ------------------------------------------------------------  -- | -- the arrow version of 'readString', the arrow input is the source URI -readFromString  :: Attributes -> IOStateArrow s String XmlTree-readFromString userOptions-    = applyA ( arr $ readString userOptions )+readFromString :: SysConfigList -> IOStateArrow s String XmlTree+readFromString config+    = applyA ( arr $ readString config )  -- ------------------------------------------------------------  -- |--- parse a string as HTML content, substitute all HTML entity refs and canonicalize tree+-- parse a string as HTML content, substitute all HTML entity refs and canonicalize tree. -- (substitute char refs, ...). Errors are ignored. ----- A simpler version of 'readFromString' but with less functionality.--- Does not run in the IO monad+-- This arrow delegates all work to the parseHtmlContent parser in module HtmlParser.+--+-- This is a simpler version of 'readFromString' without any options,+-- but it does not run in the IO monad. -hread                   :: ArrowXml a => a String XmlTree+hread :: ArrowXml a => a String XmlTree hread-    = parseHtmlContent+    = fromLA $+      PI.hread                              -- substHtmlEntityRefs is done in parser+      >>>                                   -- as well as subst HTML char refs+      editNTreeA [isError :-> none]         -- ignores all errors       >>>-      substHtmlEntityRefs+      canonicalizeContents                  -- combine text nodes, substitute char refs+                                            -- comments are not removed++-- | like hread, but accepts a whole document, not a HTML content++hreadDoc :: ArrowXml a => a String XmlTree+hreadDoc+    = fromLA $+      root [] [PI.hreadDoc]                 -- substHtmlEntityRefs is done in parser+      >>>                                   -- as well as subst HTML char refs+      editNTreeA [isError :-> none]         -- ignores all errors       >>>-      processTopDown ( none `when` isError )+      canonicalizeForXPath                  -- remove DTD spec and text in content of root node+                                            -- and do a canonicalizeContents       >>>-      canonicalizeContents+      getChildren+      +-- ------------------------------------------------------------  -- |--- parse a string as XML content, substitute all predefined XML entity refs and canonicalize tree--- (substitute char refs, ...)+-- parse a string as XML CONTENT, (no xml decl or doctype decls are allowed),+-- substitute all predefined XML entity refs and canonicalize tree+-- This xread arrow delegates all work to the xread parser function in module XmlParsec -xread                   :: ArrowXml a => a String XmlTree-xread-    = parseXmlContent-      >>>-      substXmlEntityRefs-      >>>-      canonicalizeContents+xread :: ArrowXml a => a String XmlTree+xread = PI.xreadCont++-- |+-- a more general version of xread which+-- parses a whole document including a prolog+-- (xml decl, doctype decl) and processing+-- instructions. Doctype decls remain uninterpreted,+-- but are in the list of results trees.++xreadDoc :: ArrowXml a => a String XmlTree+xreadDoc = PI.xreadDoc++{- -- the old version, where the parser does not subst char refs and cdata+xread                   = root [] [parseXmlContent]       -- substXmlEntityRefs is done in parser+                          >>>+                          canonicalizeContents+                          >>>+                          getChildren+-- -}  -- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/WriteDocument.hs view
@@ -17,6 +17,7 @@  module Text.XML.HXT.Arrow.WriteDocument     ( writeDocument+    , writeDocument'     , writeDocumentToString     , prepareContents     )@@ -28,25 +29,27 @@ import Control.Arrow.ArrowTree  import Text.XML.HXT.DOM.Interface-import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlIOStateArrow -import Text.XML.HXT.Arrow.Edit                  ( escapeHtmlDoc-                                                , escapeXmlDoc-                                                , haskellRepOfXmlDoc+import Text.XML.HXT.Arrow.XmlArrow+import Text.XML.HXT.Arrow.XmlState+import Text.XML.HXT.Arrow.XmlState.TypeDefs+import Text.XML.HXT.Arrow.XmlState.RunIOStateArrow+                                                ( initialSysState+                                                )+import Text.XML.HXT.Arrow.Edit                  ( haskellRepOfXmlDoc                                                 , indentDoc                                                 , addDefaultDTDecl                                                 , preventEmptyElements                                                 , removeDocWhiteSpace                                                 , treeRepOfXmlDoc                                                 )- import Text.XML.HXT.Arrow.DocumentOutput        ( putXmlDocument                                                 , encodeDocument                                                 , encodeDocument'                                                 )  -- ------------------------------------------------------------+--  {- | the main filter for writing documents@@ -57,38 +60,39 @@  if @ destination @ is the empty string or \"-\", stdout is used as output device -available options are+for available options see 'Text.XML.HXT.Arrow.XmlState.SystemConfig' -* 'a_indent' : indent document for readability, (default: no indentation) -- 'a_remove_whitespace' : remove all redundant whitespace for shorten text (default: no removal)--- 'a_output_encoding' : encoding of document, default is 'a_encoding' or 'utf8'--- 'a_output_xml' : (default) issue XML: quote special XML chars \>,\<,\",\',& where neccessary+- @withOutputXML@ :+ (default) issue XML: quote special XML chars \>,\<,\",\',& where neccessary                    add XML processing instruction-                   and encode document with respect to 'a_output_encoding',-                   if explicitly switched of, the plain text is issued, this is useful-                   for non XML output, e.g. generated Haskell code, LaTex, Java, ...+                   and encode document with respect to output encoding, -- 'a_output_html' : issue XHTML: quote alle XML chars, use HTML entity refs or char refs for none ASCII chars+- @withOutputHTML@ :+ issue HTML: translate all special XML chars and all HTML chars with a corresponding entity reference+ into entity references. Do not generate empty elements, e.g. @<script .../>@ for HTML elements, that are allowed+ to contain a none empty body. Result is for the example is @<script ...></script>@.+ The short form introduces trouble in various browsers. -- 'a_no_empty_elements' : do not write the short form \<name .../\> for empty elements. When 'a_output_html' is set,-                          the always empty HTML elements are still written in short form, but not the others, as e.g. the script element.-                          Empty script elements, like \<script href=\"...\"/\>, are always a problem for firefox and others.-                          When XML output is generated with this option, all empty elements are written in the long form.+- @withOutputXHTML@ :+ same as @withOutputHTML@, but all none ASCII chars are substituted by char references. -- 'a_no_empty_elem_for' : do not generate empty elements for the element names given in the comma separated list of this option value.-                          This option overwrites the above described 'a_no_empty_elements' option+- @withOutputPLAIN@ :+ Do not substitute any chars. This is useful when generating something else than XML/HTML, e.g. Haskell source code. -- 'a_add_default_dtd' : if the document to be written was build by reading another document containing a Document Type Declaration,-                        this DTD is inserted into the output document (default: no insert)+- @withXmlPi yes/no@ :+ Add a @<?xml version=... encoding=... ?>@ processing instruction to the beginning of the document.+ Default is yes. -- 'a_no_xml_pi' : suppress generation of \<?xml ... ?\> processing instruction+- @withAddDefaultDTD@ :+  if the document to be written was build by reading another document containing a Document Type Declaration,+  this DTD is inserted into the output document (default: no insert) -- 'a_show_tree' : show tree representation of document (for debugging)+- @withShowTree yes/no@ :+  show DOM tree representation of document (for debugging) -- 'a_show_haskell' : show Haskell representaion of document (for debugging)+- @withShowHaskell yes/no@ :+  show Haskell representaion of document (for debugging)   a minimal main program for copying a document  has the following structure:@@ -96,7 +100,7 @@ > module Main > where >-> import Text.XML.HXT.Arrow+> import Text.XML.HXT.Core > > main        :: IO () > main@@ -107,46 +111,68 @@ >            ) >       return () -an example for copying a document to standard output with tracing and evaluation of+an example for copying a document from the web to standard output with global trace level 1, input trace level 2,+output encoding isoLatin1,+and evaluation of error code is:  > module Main > where >-> import Text.XML.HXT.Arrow+> import Text.XML.HXT.Core+> import Text.XML.HXT.Curl+> -- or+> -- import Text.XML.HXT.HTTP > import System.Exit > > main        :: IO () > main >     = do->       [rc] <- runX ( readDocument  [ (a_trace, "1")->                                    ] "hello.xml"->                      >>>->                      writeDocument [ (a_output_encoding, isoLatin1)->                                    ] "-"        -- output to stdout->                      >>>->                      getErrStatus->                    )+>       [rc] <- runX+>               ( configSysVars [ withTrace 1          -- set the defaults for all read-,+>                               , withCurl []          -- write- and other operations+>                                 -- or withHTTP []+>                               ]+>                 >>>+>                 readDocument  [ withTrace     2      -- use these additional+>                               , withParseHTML yes    -- options only for this read+>                               ]+>                               "http://www.haskell.org/"+>                 >>>+>                 writeDocument [ withOutputEncoding isoLatin1+>                               ]+>                               ""                     -- output to stdout+>                 >>>+>                 getErrStatus+>               ) >       exitWith ( if rc >= c_err >                  then ExitFailure 1 >                  else ExitSuccess >                ) -} -writeDocument   :: Attributes -> String -> IOStateArrow s XmlTree XmlTree-writeDocument userOptions dst-    = perform ( traceMsg 1 ("writeDocument: destination is " ++ show dst)-                >>>-                prepareContents userOptions encodeDocument-                >>>-                putXmlDocument textMode dst-                >>>-                traceMsg 1 "writeDocument: finished"-              )+writeDocument           :: SysConfigList -> String -> IOStateArrow s XmlTree XmlTree+writeDocument config dst+    = localSysEnv+      $+      configSysVars config+      >>>+      perform ( (flip writeDocument') dst $< getSysVar theTextMode )++writeDocument'          :: Bool -> String -> IOStateArrow s XmlTree XmlTree+writeDocument' textMode dst+    = ( traceMsg 1 ("writeDocument: destination is " ++ show dst)+        >>>+        ( (flip prepareContents) encodeDocument $< getSysVar idS )+        >>>+        traceDoc "document after encoding"+        >>>+        putXmlDocument textMode dst+        >>>+        traceMsg 1 "writeDocument: finished"+      )       `when`       documentStatusOk-    where-    textMode    = optionIsSet a_text_mode userOptions  -- ------------------------------------------------------------ @@ -154,7 +180,7 @@ -- Convert a document into a string. Formating is done the same way -- and with the same options as in 'writeDocument'. Default output encoding is -- no encoding, that means the result is a normal unicode encode haskell string.--- The default may be overwritten with the 'Text.XML.HXT.XmlKeywords.a_output_encoding' option.+-- The default may be overwritten with the 'Text.XML.HXT.Arrow.XmlState.SystemConfig.withOutputEncoding' option. -- The XML PI can be suppressed by the 'Text.XML.HXT.XmlKeywords.a_no_xml_pi' option. -- -- This arrow fails, when the encoding scheme is not supported.@@ -162,13 +188,13 @@ -- The XML PI is suppressed, if not explicitly turned on with an -- option @ (a_no_xml_pi, v_0) @ -writeDocumentToString   :: ArrowXml a => Attributes  -> a XmlTree String-writeDocumentToString userOptions-    = prepareContents ( addEntries-                        userOptions-                        [ (a_output_encoding, unicodeString)-                        , (a_no_xml_pi, v_1)-                        ]+writeDocumentToString   :: ArrowXml a => SysConfigList  -> a XmlTree String+writeDocumentToString config+    = prepareContents ( foldr (>>>) id (withOutputEncoding unicodeString :+                                        withXmlPi          no            :+                                        config+                                       )+                        $ initialSysState                       ) encodeDocument'       >>>       xshow getChildren@@ -178,70 +204,53 @@ -- | -- indent and format output -prepareContents :: ArrowXml a => Attributes -> (Bool -> String -> a XmlTree XmlTree) -> a XmlTree XmlTree-prepareContents userOptions encodeDoc+prepareContents :: ArrowXml a => XIOSysState -> (Bool -> Bool -> String -> a XmlTree XmlTree) -> a XmlTree XmlTree+prepareContents config encodeDoc     = indent       >>>       addDtd       >>>       format     where-    formatEmptyElems-        | not (null noEmptyElemFor)     = preventEmptyElements noEmptyElemFor-        | hasOption a_no_empty_elements-          ||-          hasOption a_output_xhtml      = preventEmptyElements []-        | otherwise                     = const this+    indent'      = getS theIndent      config+    removeWS'    = getS theRemoveWS    config+    showTree'    = getS theShowTree    config+    showHaskell' = getS theShowHaskell config+    outHtml'     = getS theOutputFmt   config ==  HTMLoutput+    outXhtml'    = getS theOutputFmt   config == XHTMLoutput+    outXml'      = getS theOutputFmt   config ==   XMLoutput+    noPi'        = not $ getS theXmlPi       config+    noEEsFor'    = getS theNoEmptyElemFor  config+    addDDTD'     = getS theAddDefaultDTD   config+    outEnc'      = getS theOutputEncoding  config+     addDtd-        | hasOption a_add_default_dtd   = addDefaultDTDecl+        | addDDTD'                      = addDefaultDTDecl         | otherwise                     = this     indent-        | hasOption a_indent            = indentDoc                     -- document indentation-        | hasOption a_remove_whitespace = removeDocWhiteSpace           -- remove all whitespace between tags+        | indent'                       = indentDoc                     -- document indentation+        | removeWS'                     = removeDocWhiteSpace           -- remove all whitespace between tags         | otherwise                     = this      format-        | hasOption a_show_tree         = treeRepOfXmlDoc-        | hasOption a_show_haskell      = haskellRepOfXmlDoc-        | hasOption a_output_html       = formatEmptyElems True-                                          >>>-                                          escapeHtmlDoc                 -- escape al XML and HTML chars >= 128+        | showTree'                     = treeRepOfXmlDoc+        | showHaskell'                  = haskellRepOfXmlDoc+        | outHtml'                      = preventEmptyElements noEEsFor' True                                           >>>                                           encodeDoc                     -- convert doc into text with respect to output encoding with ASCII as default-                                            suppressXmlPi ( lookupDef usAscii a_output_encoding options )-        | hasOption a_output_xml        = formatEmptyElems (hasOption a_output_xhtml)+                                            False noPi' ( if null outEnc' then usAscii else outEnc' )++        | outXhtml'                     = preventEmptyElements noEEsFor' True                                           >>>-                                          escapeXmlDoc                  -- escape lt, gt, amp, quot,+                                          encodeDoc                     -- convert doc into text with respect to output encoding+                                            True noPi' outEnc'+        | outXml'                       = ( if null noEEsFor'+                                            then this+                                            else preventEmptyElements noEEsFor' False+                                          )                                           >>>                                           encodeDoc                     -- convert doc into text with respect to output encoding-                                            suppressXmlPi ( lookupDef "" a_output_encoding options )+                                            True noPi' outEnc'         | otherwise                     = this--    suppressXmlPi                                                       -- remove <?xml ... ?> when set-        = hasOption a_no_xml_pi--    noEmptyElemFor-        = words-          . map (\ c -> if c == ',' then ' ' else c)-          . lookup1 a_no_empty_elem_for-          $ options--    hasOption n-        = optionIsSet n options--    options = addEntries-              userOptions-              [ ( a_indent,             v_0 )-              , ( a_remove_whitespace,  v_0 )-              , ( a_output_xml,         v_1 )-              , ( a_show_tree,          v_0 )-              , ( a_show_haskell,       v_0 )-              , ( a_output_html,        v_0 )-              , ( a_output_xhtml,       v_0 )-              , ( a_no_xml_pi,          v_0 )-              , ( a_no_empty_elements,  v_0 )-              , ( a_no_empty_elem_for,  ""  )-              , ( a_add_default_dtd,    v_0 )-              ]  -- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/XmlArrow.hs view
@@ -2,7 +2,7 @@  {- |    Module     : Text.XML.HXT.Arrow.XmlArrow-   Copyright  : Copyright (C) 2005-9 Uwe Schmidt+   Copyright  : Copyright (C) 2011 Uwe Schmidt    License    : MIT     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)@@ -31,11 +31,10 @@ import           Control.Arrow.IOListArrow import           Control.Arrow.IOStateListArrow +import           Data.Char.Properties.XMLCharProps        ( isXmlSpaceChar ) import           Data.Maybe  import           Text.XML.HXT.DOM.Interface-import           Text.XML.HXT.DOM.Unicode       ( isXmlSpaceChar-                                                ) import qualified Text.XML.HXT.DOM.XmlNode as XN import qualified Text.XML.HXT.DOM.ShowXml as XS @@ -64,26 +63,36 @@     -- | test for text nodes     isText              :: a XmlTree XmlTree     isText              = isA XN.isText+    {-# INLINE isText #-} +    isBlob              :: a XmlTree XmlTree+    isBlob              = isA XN.isBlob+    {-# INLINE isBlob #-}+     -- | test for char reference, used during parsing     isCharRef           :: a XmlTree XmlTree     isCharRef           = isA XN.isCharRef+    {-# INLINE isCharRef #-}      -- | test for entity reference, used during parsing     isEntityRef         :: a XmlTree XmlTree     isEntityRef         = isA XN.isEntityRef+    {-# INLINE isEntityRef #-}      -- | test for comment     isCmt               :: a XmlTree XmlTree     isCmt               = isA XN.isCmt+    {-# INLINE isCmt #-}      -- | test for CDATA section, used during parsing     isCdata             :: a XmlTree XmlTree     isCdata             = isA XN.isCdata+    {-# INLINE isCdata #-}      -- | test for processing instruction     isPi                :: a XmlTree XmlTree     isPi                = isA XN.isPi+    {-# INLINE isPi #-}      -- | test for processing instruction \<?xml ...\>     isXmlPi             :: a XmlTree XmlTree@@ -92,22 +101,27 @@     -- | test for element     isElem              :: a XmlTree XmlTree     isElem              = isA XN.isElem+    {-# INLINE isElem #-}      -- | test for DTD part, used during parsing     isDTD               :: a XmlTree XmlTree     isDTD               = isA XN.isDTD+    {-# INLINE isDTD #-}      -- | test for attribute tree     isAttr              :: a XmlTree XmlTree     isAttr              = isA XN.isAttr+    {-# INLINE isAttr #-}      -- | test for error message     isError             :: a XmlTree XmlTree     isError             = isA XN.isError+    {-# INLINE isError #-}      -- | test for root node (element with name \"\/\")     isRoot              :: a XmlTree XmlTree     isRoot              = isA XN.isRoot+    {-# INLINE isRoot #-}      -- | test for text nodes with text, for which a predicate holds     --@@ -122,52 +136,61 @@      isWhiteSpace        :: a XmlTree XmlTree     isWhiteSpace        = hasText (all isXmlSpaceChar)+    {-# INLINE isWhiteSpace #-}      -- |     -- test whether a node (element, attribute, pi) has a name with a special property      hasNameWith         :: (QName  -> Bool) -> a XmlTree XmlTree     hasNameWith p       = (getQName        >>> isA p) `guards` this+    {-# INLINE hasNameWith #-}      -- |     -- test whether a node (element, attribute, pi) has a specific qualified name     -- useful only after namespace propagation     hasQName            :: QName  -> a XmlTree XmlTree     hasQName n          = (getQName        >>> isA (== n)) `guards` this+    {-# INLINE hasQName #-}      -- |-    -- test whether a node has a specific name (prefix:localPart ore localPart),+    -- test whether a node has a specific name (prefix:localPart or localPart),     -- generally useful, even without namespace handling     hasName             :: String -> a XmlTree XmlTree     hasName n           = (getName         >>> isA (== n)) `guards` this+    {-# INLINE hasName #-}      -- |     -- test whether a node has a specific name as local part,     -- useful only after namespace propagation     hasLocalPart        :: String -> a XmlTree XmlTree     hasLocalPart n      = (getLocalPart    >>> isA (== n)) `guards` this+    {-# INLINE hasLocalPart #-}      -- |     -- test whether a node has a specific name prefix,     -- useful only after namespace propagation     hasNamePrefix       :: String -> a XmlTree XmlTree     hasNamePrefix n     = (getNamePrefix   >>> isA (== n)) `guards` this+    {-# INLINE hasNamePrefix #-}      -- |     -- test whether a node has a specific namespace URI     -- useful only after namespace propagation     hasNamespaceUri     :: String -> a XmlTree XmlTree     hasNamespaceUri n   = (getNamespaceUri >>> isA (== n)) `guards` this+    {-# INLINE hasNamespaceUri #-}      -- |     -- test whether an element node has an attribute node with a specific name     hasAttr             :: String -> a XmlTree XmlTree     hasAttr n           = (getAttrl        >>> hasName n)  `guards` this+    {-# INLINE hasAttr #-}      -- |     -- test whether an element node has an attribute node with a specific qualified name     hasQAttr            :: QName -> a XmlTree XmlTree     hasQAttr n          = (getAttrl        >>> hasQName n)  `guards` this+    {-# INLINE hasQAttr #-}      -- |     -- test whether an element node has an attribute with a specific value@@ -184,22 +207,32 @@     -- | text node construction arrow     mkText              :: a String XmlTree     mkText              = arr  XN.mkText+    {-# INLINE mkText #-} +    -- | blob node construction arrow+    mkBlob              :: a Blob XmlTree+    mkBlob              = arr  XN.mkBlob+    {-# INLINE mkBlob #-}+     -- | char reference construction arrow, useful for document output     mkCharRef           :: a Int    XmlTree     mkCharRef           = arr  XN.mkCharRef+    {-# INLINE mkCharRef #-}      -- | entity reference construction arrow, useful for document output     mkEntityRef         :: a String XmlTree     mkEntityRef         = arr  XN.mkEntityRef+    {-# INLINE mkEntityRef #-}      -- | comment node construction, useful for document output     mkCmt               :: a String XmlTree     mkCmt               = arr  XN.mkCmt+    {-# INLINE mkCmt #-}      -- | CDATA construction, useful for document output     mkCdata             :: a String XmlTree     mkCdata             = arr  XN.mkCdata+    {-# INLINE mkCdata #-}      -- | error node construction, useful only internally     mkError             :: Int -> a String XmlTree@@ -212,6 +245,7 @@     mkElement n af cf   = (listA af &&& listA cf)                           >>>                           arr2 (\ al cl -> XN.mkElement n al cl)+     -- | attribute node construction:     -- | the attribute value is computed by applying an arrow to the input     mkAttr              :: QName -> a n XmlTree -> a n XmlTree@@ -236,164 +270,208 @@      mkqelem             :: QName -> [a n XmlTree] -> [a n XmlTree] -> a n XmlTree     mkqelem  n afs cfs  = mkElement n (catA afs) (catA cfs)+    {-# INLINE mkqelem #-}      -- | convenient arrow for element construction with strings instead of qualified names as element names, see also 'mkElement' and 'mkelem'     mkelem              :: String -> [a n XmlTree] -> [a n XmlTree] -> a n XmlTree     mkelem  n afs cfs   = mkElement (mkName n) (catA afs) (catA cfs)+    {-# INLINE mkelem #-} -    -- | convenient arrow for element constrution with attributes but without content, simple variant of 'mkelem' and 'mkElement'+    -- | convenient arrow for element construction with attributes but without content, simple variant of 'mkelem' and 'mkElement'     aelem               :: String -> [a n XmlTree]                  -> a n XmlTree     aelem n afs         = catA afs >. \ al -> XN.mkElement (mkName n) al []+    {-# INLINE aelem #-} -    -- | convenient arrow for simple element constrution without attributes, simple variant of 'mkelem' and 'mkElement'+    -- | convenient arrow for simple element construction without attributes, simple variant of 'mkelem' and 'mkElement'     selem               :: String                  -> [a n XmlTree] -> a n XmlTree     selem n cfs         = catA cfs >.         XN.mkElement (mkName n) []+    {-# INLINE selem #-} -    -- | convenient arrow for constrution of empty elements without attributes, simple variant of 'mkelem' and 'mkElement'+    -- | convenient arrow for construction of empty elements without attributes, simple variant of 'mkelem' and 'mkElement'     eelem               :: String                                   -> a n XmlTree     eelem n             = constA      (XN.mkElement (mkName n) [] [])+    {-# INLINE eelem #-}      -- | construction of an element node with name \"\/\" for document roots     root                ::           [a n XmlTree] -> [a n XmlTree] -> a n XmlTree     root                = mkelem t_root+    {-# INLINE root #-}      -- | alias for 'mkAttr'     qattr               :: QName -> a n XmlTree -> a n XmlTree     qattr               = mkAttr+    {-# INLINE qattr #-} -    -- | convenient arrow for attribute constrution, simple variant of 'mkAttr'+    -- | convenient arrow for attribute construction, simple variant of 'mkAttr'     attr                :: String -> a n XmlTree -> a n XmlTree     attr                = mkAttr . mkName+    {-# INLINE attr #-}      -- constant arrows (ignoring the input) for tree construction ------------------------------      -- | constant arrow for text nodes     txt                 :: String -> a n XmlTree     txt                 = constA .  XN.mkText+    {-# INLINE txt #-} +    -- | constant arrow for blob nodes+    blb                 :: Blob -> a n XmlTree+    blb                 = constA .  XN.mkBlob+    {-# INLINE blb #-}+     -- | constant arrow for char reference nodes     charRef             :: Int    -> a n XmlTree     charRef             = constA .  XN.mkCharRef+    {-# INLINE charRef #-}      -- | constant arrow for entity reference nodes     entityRef           :: String -> a n XmlTree     entityRef           = constA .  XN.mkEntityRef+    {-# INLINE entityRef #-}      -- | constant arrow for comment     cmt                 :: String -> a n XmlTree     cmt                 = constA .  XN.mkCmt+    {-# INLINE cmt #-}      -- | constant arrow for warning     warn                :: String -> a n XmlTree     warn                = constA . (XN.mkError c_warn)+    {-# INLINE warn #-}      -- | constant arrow for errors     err                 :: String -> a n XmlTree     err                 = constA . (XN.mkError c_err)+    {-# INLINE err #-}      -- | constant arrow for fatal errors     fatal               :: String -> a n XmlTree     fatal               = constA . (XN.mkError c_fatal)+    {-# INLINE fatal #-}      -- | constant arrow for simple processing instructions, see 'mkPi'     spi                 :: String -> String -> a n XmlTree-    spi piName piCont   = constA (XN.mkPi   (mkName piName) [XN.mkText piCont])+    spi piName piCont   = constA (XN.mkPi (mkName piName) [XN.mkAttr (mkName a_value) [XN.mkText piCont]])+    {-# INLINE spi #-}      -- | constant arrow for attribute nodes, attribute name is a qualified name and value is a text,     -- | see also 'mkAttr', 'qattr', 'attr'     sqattr              :: QName -> String -> a n XmlTree     sqattr an av        = constA (XN.mkAttr an                 [XN.mkText av])+    {-# INLINE sqattr #-}      -- | constant arrow for attribute nodes, attribute name and value are     -- | given by parameters, see 'mkAttr'     sattr               :: String -> String -> a n XmlTree     sattr an av         = constA (XN.mkAttr (mkName an)     [XN.mkText av])+    {-# INLINE sattr #-}      -- selector arrows --------------------------------------------------      -- | select the text of a text node     getText             :: a XmlTree String     getText             = arrL (maybeToList  . XN.getText)+    {-# INLINE getText #-}      -- | select the value of a char reference     getCharRef          :: a XmlTree Int     getCharRef          = arrL (maybeToList  . XN.getCharRef)+    {-# INLINE getCharRef #-}      -- | select the name of a entity reference node     getEntityRef        :: a XmlTree String     getEntityRef        = arrL (maybeToList  . XN.getEntityRef)+    {-# INLINE getEntityRef #-}      -- | select the comment of a comment node     getCmt              :: a XmlTree String     getCmt              = arrL (maybeToList  . XN.getCmt)+    {-# INLINE getCmt #-}      -- | select the content of a CDATA node     getCdata            :: a XmlTree String     getCdata            = arrL (maybeToList  . XN.getCdata)+    {-# INLINE getCdata #-}      -- | select the name of a processing instruction     getPiName           :: a XmlTree QName     getPiName           = arrL (maybeToList  . XN.getPiName)+    {-# INLINE getPiName #-}      -- | select the content of a processing instruction     getPiContent        :: a XmlTree XmlTree     getPiContent        = arrL (fromMaybe [] . XN.getPiContent)+    {-# INLINE getPiContent #-}      -- | select the name of an element node     getElemName         :: a XmlTree QName     getElemName         = arrL (maybeToList  . XN.getElemName)+    {-# INLINE getElemName #-}      -- | select the attribute list of an element node     getAttrl            :: a XmlTree XmlTree     getAttrl            = arrL (fromMaybe [] . XN.getAttrl)+    {-# INLINE getAttrl #-}      -- | select the DTD type of a DTD node     getDTDPart          :: a XmlTree DTDElem     getDTDPart          = arrL (maybeToList  . XN.getDTDPart)+    {-# INLINE getDTDPart #-}      -- | select the DTD attributes of a DTD node     getDTDAttrl         :: a XmlTree Attributes     getDTDAttrl         = arrL (maybeToList  . XN.getDTDAttrl)+    {-# INLINE getDTDAttrl #-}      -- | select the name of an attribute     getAttrName         :: a XmlTree QName     getAttrName         = arrL (maybeToList  . XN.getAttrName)+    {-# INLINE getAttrName #-}      -- | select the error level (c_warn, c_err, c_fatal) from an error node     getErrorLevel       :: a XmlTree Int     getErrorLevel       = arrL (maybeToList  . XN.getErrorLevel)+    {-# INLINE getErrorLevel #-}      -- | select the error message from an error node     getErrorMsg         :: a XmlTree String     getErrorMsg         = arrL (maybeToList  . XN.getErrorMsg)+    {-# INLINE getErrorMsg #-}      -- | select the qualified name from an element, attribute or pi     getQName            :: a XmlTree QName     getQName            = arrL (maybeToList  . XN.getName)+    {-# INLINE getQName #-}      -- | select the prefix:localPart or localPart from an element, attribute or pi     getName             :: a XmlTree String     getName             = arrL (maybeToList  . XN.getQualifiedName)+    {-# INLINE getName #-}      -- | select the univeral name ({namespace URI} ++ localPart)     getUniversalName    :: a XmlTree String     getUniversalName    = arrL (maybeToList  . XN.getUniversalName)+    {-# INLINE getUniversalName #-}      -- | select the univeral name (namespace URI ++ localPart)     getUniversalUri     :: a XmlTree String     getUniversalUri     = arrL (maybeToList  . XN.getUniversalUri)+    {-# INLINE getUniversalUri #-}      -- | select the local part     getLocalPart        :: a XmlTree String     getLocalPart        = arrL (maybeToList  . XN.getLocalPart)+    {-# INLINE getLocalPart #-}      -- | select the name prefix     getNamePrefix       :: a XmlTree String     getNamePrefix       = arrL (maybeToList  . XN.getNamePrefix)+    {-# INLINE getNamePrefix #-}      -- | select the namespace URI     getNamespaceUri     :: a XmlTree String     getNamespaceUri     = arrL (maybeToList  . XN.getNamespaceUri)+    {-# INLINE getNamespaceUri #-}      -- | select the value of an attribute of an element node,     -- always succeeds with empty string as default value \"\"@@ -419,6 +497,10 @@     changeText          :: (String -> String) -> a XmlTree XmlTree     changeText cf       = arr (XN.changeText     cf) `when` isText +    -- | edit the blob of a blob node+    changeBlob          :: (Blob -> Blob) -> a XmlTree XmlTree+    changeBlob cf       = arr (XN.changeBlob     cf) `when` isBlob+     -- | edit the comment string of a comment node     changeCmt           :: (String -> String) -> a XmlTree XmlTree     changeCmt  cf       = arr (XN.changeCmt      cf) `when` isCmt@@ -462,30 +544,37 @@     -- | replace an element, attribute or pi name     setQName            :: QName -> a XmlTree XmlTree     setQName  n         = changeQName  (const n)+    {-# INLINE setQName #-}      -- | replace an element name     setElemName         :: QName -> a XmlTree XmlTree     setElemName  n      = changeElemName  (const n)+    {-# INLINE setElemName #-}      -- | replace an attribute name     setAttrName         :: QName -> a XmlTree XmlTree     setAttrName n       = changeAttrName (const n)+    {-# INLINE setAttrName #-}      -- | replace an element name     setPiName           :: QName -> a XmlTree XmlTree     setPiName  n        = changePiName  (const n)+    {-# INLINE setPiName #-}      -- | replace an atribute list of an element node     setAttrl            :: a XmlTree XmlTree -> a XmlTree XmlTree     setAttrl            = changeAttrl (const id)                -- (\ x y -> y)+    {-# INLINE setAttrl #-}      -- | add a list of attributes to an element     addAttrl            :: a XmlTree XmlTree -> a XmlTree XmlTree     addAttrl            = changeAttrl (XN.mergeAttrl)+    {-# INLINE addAttrl #-}      -- | add (or replace) an attribute     addAttr             :: String -> String  -> a XmlTree XmlTree     addAttr an av       = addAttrl (sattr an av)+    {-# INLINE addAttr #-}      -- | remove an attribute     removeAttr          :: String  -> a XmlTree XmlTree@@ -552,9 +641,20 @@                             | otherwise                                 = XN.changeChildren (++ [c]) t +     -- | apply an arrow to the input and convert the resulting XML trees into a string representation+     xshow               :: a n XmlTree -> a n String     xshow f             = f >. XS.xshow+    {-# INLINE xshow #-}+++    -- | apply an arrow to the input and convert the resulting XML trees into a string representation++    xshowBlob           :: a n XmlTree -> a n Blob+    xshowBlob f         = f >. XS.xshowBlob+    {-# INLINE xshowBlob #-}+  {- | Document Type Definition arrows
− src/Text/XML/HXT/Arrow/XmlIOStateArrow.hs 
@@ -1,989 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.Arrow.XmlIOStateArrow-   Copyright  : Copyright (C) 2010 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : stable-   Portability: portable--   the basic state arrows for XML processing--   A state is needed for global processing options,-   like encoding options, document base URI, trace levels-   and error message handling--   The state is separated into a user defined state-   and a system state. The system state contains variables-   for error message handling, for tracing, for the document base-   for accessing XML documents with relative references, e.g. DTDs,-   and a global key value store. This assoc list has strings as keys-   and lists of XmlTrees as values. It is used to store arbitrary-   XML and text values, e.g. user defined global options.--   The user defined part of the store is in the default case empty, defined as ().-   It can be extended with an arbitray data type---}---- --------------------------------------------------------------module Text.XML.HXT.Arrow.XmlIOStateArrow-    ( -- * Data Types-      XIOState(..),-      XIOSysState(..),-      IOStateArrow,-      IOSArrow,--      -- * Running Arrows-      initialState,-      initialSysState,-      runX,--      -- * User State Manipulation-      getUserState,-      setUserState,-      changeUserState,-      withExtendedUserState,-      withOtherUserState,--      -- * Global System State Access-      getSysParam,-      changeSysParam,--      setParamList,-      setParam,-      unsetParam,-      getParam,-      getAllParams,-      getAllParamsString,-      setParamString,-      getParamString,-      setParamInt,-      getParamInt,--      -- * Error Message Handling-      clearErrStatus,-      setErrStatus,-      getErrStatus,-      setErrMsgStatus,-      setErrorMsgHandler,--      errorMsgStderr,-      errorMsgCollect,-      errorMsgStderrAndCollect,-      errorMsgIgnore,--      getErrorMessages,--      filterErrorMsg,-      issueWarn,-      issueErr,-      issueFatal,-      setDocumentStatus,-      setDocumentStatusFromSystemState,-      documentStatusOk,--      -- * Document Base-      setBaseURI,-      getBaseURI,-      changeBaseURI,-      setDefaultBaseURI,-      getDefaultBaseURI,-      runInLocalURIContext,--      -- * Tracing-      setTraceLevel,-      getTraceLevel,-      withTraceLevel,-      setTraceCmd,-      getTraceCmd,-      trace,-      traceMsg,-      traceValue,-      traceString,-      traceSource,-      traceTree,-      traceDoc,-      traceState,--      -- * URI Manipulation-      expandURIString,-      expandURI,-      mkAbsURI,--      getFragmentFromURI,-      getPathFromURI,-      getPortFromURI,-      getQueryFromURI,-      getRegNameFromURI,-      getSchemeFromURI,-      getUserInfoFromURI,--      -- * Mime Type Handling-      setMimeTypeTable,-      setMimeTypeTableFromFile-      )-where--import Control.Arrow                            -- arrow classes-import Control.Arrow.ArrowList-import Control.Arrow.ArrowIf-import Control.Arrow.ArrowTree-import Control.Arrow.ArrowIO-import Control.Arrow.IOStateListArrow--import Control.Monad                    ( mzero-                                        , mplus )-import Control.DeepSeq--import Text.XML.HXT.DOM.Interface-import Text.XML.HXT.Arrow.XmlArrow--import Text.XML.HXT.Arrow.Edit          ( addHeadlineToXmlDoc-                                        , treeRepOfXmlDoc-                                        , indentDoc-                                        )--import Data.Maybe--import Network.URI                      ( URI-                                        , escapeURIChar-                                        , isUnescapedInURI-                                        , nonStrictRelativeTo-                                        , parseURIReference-                                        , uriAuthority-                                        , uriFragment-                                        , uriPath-                                        , uriPort-                                        , uriQuery-                                        , uriRegName-                                        , uriScheme-                                        , uriUserInfo-                                        )--import System.IO                        ( hPutStrLn-                                        , hFlush-                                        , stderr-                                        )--import System.Directory                 ( getCurrentDirectory )---- -------------------------------------------------------------{- $datatypes -}----- |--- predefined system state data type with all components for the--- system functions, like trace, error handling, ...--data XIOSysState        = XIOSys  { xio_trace                   :: ! Int-                                  , xio_traceCmd                ::   Int -> String -> IO ()-                                  , xio_errorStatus             :: ! Int-                                  , xio_errorModule             :: ! String-                                  , xio_errorMsgHandler         ::   String -> IO ()-                                  , xio_errorMsgCollect         :: ! Bool-                                  , xio_errorMsgList            :: ! XmlTrees-                                  , xio_baseURI                 :: ! String-                                  , xio_defaultBaseURI          :: ! String-                                  , xio_attrList                :: ! (AssocList String XmlTrees)-                                  , xio_mimeTypes               ::   MimeTypeTable-                                  }--instance NFData XIOSysState where-    rnf (XIOSys tr _trc es em _emh emc eml bu du al _mt)-        = rnf tr `seq` rnf es `seq` rnf em `seq` rnf emc `seq` rnf eml `seq` rnf bu `seq` rnf du `seq` rnf al---- |--- state datatype consists of a system state and a user state--- the user state is not fixed--data XIOState us        = XIOState { xio_sysState               :: ! XIOSysState-                                   , xio_userState              :: ! us-                                   }--instance (NFData us) => NFData (XIOState us) where-    rnf (XIOState sys usr)      = rnf sys `seq` rnf usr---- |--- The arrow type for stateful arrows--type IOStateArrow s b c = IOSLA (XIOState s) b c---- |--- The arrow for stateful arrows with no user defined state--type IOSArrow b c       = IOStateArrow () b c---- ----------------------------------------------------------------- | the default global state, used as initial state when running an 'IOSArrow' with 'runIOSLA' or--- 'runX'--initialState    :: us -> XIOState us-initialState s  = XIOState { xio_sysState       = initialSysState-                           , xio_userState      = s-                           }--initialSysState :: XIOSysState-initialSysState = XIOSys { xio_trace            = 0-                         , xio_traceCmd         = traceOutputToStderr-                         , xio_errorStatus      = c_ok-                         , xio_errorModule      = ""-                         , xio_errorMsgHandler  = hPutStrLn stderr-                         , xio_errorMsgCollect  = False-                         , xio_errorMsgList     = []-                         , xio_baseURI          = ""-                         , xio_defaultBaseURI   = ""-                         , xio_attrList         = []-                         , xio_mimeTypes        = defaultMimeTypeTable-                         }---- ---------------------------------------------------------------- |--- apply an 'IOSArrow' to an empty root node with 'initialState' () as initial state------ the main entry point for running a state arrow with IO------ when running @ runX f@ an empty XML root node is applied to @f@.--- usually @f@ will start with a constant arrow (ignoring the input), e.g. a 'Text.XML.HXT.Arrow.ReadDocument.readDocument' arrow.------ for usage see examples with 'Text.XML.HXT.Arrow.WriteDocument.writeDocument'------ if input has to be feed into the arrow use 'Control.Arrow.IOStateListArrow.runIOSLA' like in @ runIOSLA f emptyX inputDoc @--runX            :: IOSArrow XmlTree c -> IO [c]-runX            = runXIOState (initialState ())--runXIOState     :: XIOState s -> IOStateArrow s XmlTree c -> IO [c]-runXIOState s0 f-    = do-      (_finalState, res) <- runIOSLA (emptyRoot >>> f) s0 undefined-      return res-    where-    emptyRoot    = root [] []---- --------------------------------------------------------------{- user state -}---- | read the user defined part of the state--getUserState    :: IOStateArrow s b s-getUserState-    = IOSLA $ \ s _ ->-      return (s, [xio_userState s])---- | change the user defined part of the state--changeUserState         :: (b -> s -> s) -> IOStateArrow s b b-changeUserState cf-    = IOSLA $ \ s v ->-      let s' = s { xio_userState = cf v (xio_userState s) }-      in return (s', [v])---- | set the user defined part of the state--setUserState            :: IOStateArrow s s s-setUserState-    = changeUserState const---- | extend user state------ Run an arrow with an extended user state component, The old component--- is stored together with a new one in a pair, the arrow is executed with this--- extended state, and the augmented state component is removed form the state--- when the arrow has finished its execution--withExtendedUserState   :: s1 -> IOStateArrow (s1, s0) b c -> IOStateArrow s0 b c-withExtendedUserState initS1 f-    = IOSLA $ \ s0 x ->-      do-      ~(finalS, res) <- runIOSLA f ( XIOState { xio_sysState  =          xio_sysState  s0-                                              , xio_userState = (initS1, xio_userState s0)-                                              }-                                   ) x-      return ( XIOState { xio_sysState  =      xio_sysState  finalS-                        , xio_userState = snd (xio_userState finalS)-                        }-             , res-             )---- | change the type of user state------ This conversion is useful, when running a state arrow with another--- structure of the user state, e.g. with () when executing some IO arrows--withOtherUserState      :: s1 -> IOStateArrow s1 b c -> IOStateArrow s0 b c-withOtherUserState s1 f-    = IOSLA $ \ s x ->-      do-      (s', res) <- runIOSLA f ( XIOState { xio_sysState  = xio_sysState s-                                         , xio_userState = s1-                                         }-                              ) x-      return ( XIOState { xio_sysState  = xio_sysState  s'-                        , xio_userState = xio_userState s-                        }-             , res-             )---- --------------------------------------------------------------{- $system state params -}--getSysParam     :: (XIOSysState -> c) -> IOStateArrow s b c-getSysParam f-    = IOSLA $ \ s _x ->-      return (s, (:[]) . f . xio_sysState $ s)--changeSysParam          :: (b -> XIOSysState -> XIOSysState) -> IOStateArrow s b b-changeSysParam cf-    = ( IOSLA $ \ s v ->-        let s' = changeSysState (cf v) s-        in return (s', [v])-      )-    where-    changeSysState css s = s { xio_sysState = css (xio_sysState s) }---- | store a single XML tree in global state under a given attribute name--setParam        :: String -> IOStateArrow s XmlTree XmlTree-setParam n-    = (:[]) ^>> setParamList n---- | store a list of XML trees in global system state under a given attribute name--setParamList    :: String -> IOStateArrow s XmlTrees XmlTree-setParamList n-    = changeSysParam addE-      >>>-      arrL id-    where-    addE x s = s { xio_attrList = addEntry n x (xio_attrList s) }---- | remove an entry in global state, arrow input remains unchanged--unsetParam      :: String -> IOStateArrow s b b-unsetParam n-    = changeSysParam delE-    where-    delE _ s = s { xio_attrList = delEntry n (xio_attrList s) }---- | read an attribute value from global state--getParam        :: String -> IOStateArrow s b XmlTree-getParam n-    = getAllParams-      >>>-      arrL (lookup1 n)---- | read all attributes from global state--getAllParams    :: IOStateArrow s b (AssocList String XmlTrees)-getAllParams-    = getSysParam xio_attrList---- | read all attributes from global state--- and convert the values to strings--getAllParamsString      :: IOStateArrow s b (AssocList String String)-getAllParamsString-    = getAllParams-      >>>-      listA ( unlistA-              >>>-              second (xshow unlistA)-            )--setParamString  :: String -> String -> IOStateArrow s b b-setParamString n v-    = perform ( txt v-                >>>-                setParam n-              )---- | read a string value from global state,--- if parameter not set \"\" is returned--getParamString  :: String -> IOStateArrow s b String-getParamString n-    = xshow (getParam n)---- | store an int value in global state--setParamInt     :: String -> Int -> IOStateArrow s b b-setParamInt n v-    = setParamString n (show v)---- | read an int value from global state------ > getParamInt 0 myIntAttr--getParamInt     :: Int -> String -> IOStateArrow s b Int-getParamInt def n-    = getParamString n-      >>^-      (\ x -> if null x then def else read x)---- ---------------------------------------------------------------- | reset global error variable--changeErrorStatus       :: (Int -> Int -> Int) -> IOStateArrow s Int Int-changeErrorStatus f-    = changeSysParam (\ l s -> s { xio_errorStatus = f l (xio_errorStatus s) })--clearErrStatus          :: IOStateArrow s b b-clearErrStatus-    = perform (constA 0 >>> changeErrorStatus min)---- | set global error variable--setErrStatus            :: IOStateArrow s Int Int-setErrStatus-    = changeErrorStatus max---- | read current global error status--getErrStatus            :: IOStateArrow s XmlTree Int-getErrStatus-    = getSysParam xio_errorStatus---- | raise the global error status level to that of the input tree--setErrMsgStatus :: IOStateArrow s XmlTree XmlTree-setErrMsgStatus-    = perform ( getErrorLevel-                >>>-                setErrStatus-              )---- | set the error message handler and the flag for collecting the errors--setErrorMsgHandler      :: Bool -> (String -> IO ()) -> IOStateArrow s b b-setErrorMsgHandler c f-    = changeSysParam cf-    where-    cf _ s = s { xio_errorMsgHandler = f-               , xio_errorMsgCollect = c }---- | error message handler for output to stderr--sysErrorMsg             :: IOStateArrow s XmlTree XmlTree-sysErrorMsg-    = perform ( getErrorLevel &&& getErrorMsg-                >>>-                arr formatErrorMsg-                >>>-                ( IOSLA $ \ s e ->-                  do-                  (xio_errorMsgHandler . xio_sysState $ s) e-                  return (s, undefined)-                )-              )-    where-    formatErrorMsg (level, msg) = "\n" ++ errClass level ++ ": " ++ msg-    errClass l-        = fromMaybe "fatal error" . lookup l $ msgList-          where-          msgList       = [ (c_ok,      "no error")-                          , (c_warn,    "warning")-                          , (c_err,     "error")-                          , (c_fatal,   "fatal error")-                          ]----- | the default error message handler: error output to stderr--errorMsgStderr          :: IOStateArrow s b b-errorMsgStderr          = setErrorMsgHandler False (hPutStrLn stderr)---- | error message handler for collecting errors--errorMsgCollect         :: IOStateArrow s b b-errorMsgCollect         = setErrorMsgHandler True (const $ return ())---- | error message handler for output to stderr and collecting--errorMsgStderrAndCollect        :: IOStateArrow s b b-errorMsgStderrAndCollect        = setErrorMsgHandler True (hPutStrLn stderr)---- | error message handler for ignoring errors--errorMsgIgnore          :: IOStateArrow s b b-errorMsgIgnore          = setErrorMsgHandler False (const $ return ())---- |--- if error messages are collected by the error handler for--- processing these messages by the calling application,--- this arrow reads the stored messages and clears the error message store--getErrorMessages        :: IOStateArrow s b XmlTree-getErrorMessages-    = getSysParam (reverse . xio_errorMsgList)          -- reverse the list of errors-      >>>-      clearErrorMsgList                                 -- clear the error list in the system state-      >>>-      arrL id--clearErrorMsgList       :: IOStateArrow s b b-clearErrorMsgList-    = changeSysParam (\ _ s -> s { xio_errorMsgList = [] } )--addToErrorMsgList       :: IOStateArrow s XmlTree XmlTree-addToErrorMsgList-    = changeSysParam cf-    where-    cf t s = if xio_errorMsgCollect s-             then s { xio_errorMsgList = t : xio_errorMsgList s }-             else s---- ---------------------------------------------------------------- |--- filter error messages from input trees and issue errors--filterErrorMsg          :: IOStateArrow s XmlTree XmlTree-filterErrorMsg-    = ( setErrMsgStatus-        >>>-        sysErrorMsg-        >>>-        addToErrorMsgList-        >>>-        none-      )-      `when`-      isError---- | generate a warnig message--issueWarn               :: String -> IOStateArrow s b b-issueWarn msg           = perform (warn msg  >>> filterErrorMsg)---- | generate an error message-issueErr                :: String -> IOStateArrow s b b-issueErr msg            = perform (err msg   >>> filterErrorMsg)---- | generate a fatal error message, e.g. document not found--issueFatal              :: String -> IOStateArrow s b b-issueFatal msg          = perform (fatal msg >>> filterErrorMsg)---- |--- add the error level and the module where the error occured--- to the attributes of a document root node and remove the children when level is greater or equal to 'c_err'.--- called by 'setDocumentStatusFromSystemState' when the system state indicates an error--setDocumentStatus       :: Int -> String -> IOStateArrow s XmlTree XmlTree-setDocumentStatus level msg-    = ( addAttrl ( sattr a_status (show level)-                   <+>-                   sattr a_module msg-                 )-        >>>-        ( if level >= c_err-          then setChildren []-          else this-        )-      )-      `when`-      isRoot---- |--- check whether the error level attribute in the system state--- is set to error, in this case the children of the document root are--- removed and the module name where the error occured and the error level are added as attributes with 'setDocumentStatus'--- else nothing is changed--setDocumentStatusFromSystemState                :: String -> IOStateArrow s XmlTree XmlTree-setDocumentStatusFromSystemState msg-    = setStatus $< getErrStatus-    where-    setStatus level-        | level <= c_warn       = this-        | otherwise             = setDocumentStatus level msg----- |--- check whether tree is a document root and the status attribute has a value less than 'c_err'--documentStatusOk        :: ArrowXml a => a XmlTree XmlTree-documentStatusOk-    = isRoot-      >>>-      ( (getAttrValue a_status-         >>>-         isA (\ v -> null v || ((read v)::Int) <= c_warn)-        )-        `guards`-        this-      )---- ---------------------------------------------------------------- | set the base URI of a document, used e.g. for reading includes, e.g. external entities,--- the input must be an absolute URI--setBaseURI              :: IOStateArrow s String String-setBaseURI-    = changeSysParam (\ b s -> s { xio_baseURI = b } )-      >>>-      traceValue 2 (("setBaseURI: new base URI is " ++) . show)---- | read the base URI from the globale state--getBaseURI              :: IOStateArrow s b String-getBaseURI-    = getSysParam xio_baseURI-      >>>-      ( ( getDefaultBaseURI-          >>>-          setBaseURI-          >>>-          getBaseURI-        )-        `when`-        isA null                                -- set and get it, if not yet done-      )---- | change the base URI with a possibly relative URI, can be used for--- evaluating the xml:base attribute. Returns the new absolute base URI.--- Fails, if input is not parsable with parseURIReference------ see also: 'setBaseURI', 'mkAbsURI'--changeBaseURI           :: IOStateArrow s String String-changeBaseURI-    = mkAbsURI-      >>>-      setBaseURI---- | set the default base URI, if parameter is null, the system base (@ file:\/\/\/\<cwd\>\/ @) is used,--- else the parameter, must be called before any document is read--setDefaultBaseURI       :: String -> IOStateArrow s b String-setDefaultBaseURI base-    = ( if null base-        then arrIO getDir-        else constA base-      )-      >>>-      changeSysParam (\ b s -> s { xio_defaultBaseURI = b } )-      >>>-      traceValue 2 (("setDefaultBaseURI: new default base URI is " ++) . show)-    where-    getDir _ = do-               cwd <- getCurrentDirectory-               return ("file://" ++ normalize cwd ++ "/")--    -- under Windows getCurrentDirectory returns something like: "c:\path\to\file"-    -- backslaches are not allowed in URIs and paths must start with a /-    -- so this is transformed into "/c:/path/to/file"--    normalize wd'@(d : ':' : _)-        | d `elem` ['A'..'Z'] || d `elem` ['a'..'z']-            = '/' : concatMap win32ToUriChar wd'-    normalize wd'-        = concatMap escapeNonUriChar wd'--    win32ToUriChar '\\' = "/"-    win32ToUriChar c    = escapeNonUriChar c--    escapeNonUriChar c  = escapeURIChar isUnescapedInURI c   -- from Network.URI----- | get the default base URI--getDefaultBaseURI       :: IOStateArrow s b String-getDefaultBaseURI-    = getSysParam xio_defaultBaseURI            -- read default uri in system  state-      >>>-      ( setDefaultBaseURI ""                    -- set the default uri in system state-        >>>-        getDefaultBaseURI ) `when` isA null     -- when uri not yet set---- ---------------------------------------------------------------- | remember base uri, run an arrow and restore the base URI, used with external entity substitution--runInLocalURIContext    :: IOStateArrow s b c -> IOStateArrow s b c-runInLocalURIContext f-    = ( getBaseURI &&& this )-      >>>-      ( this *** listA f )-      >>>-      ( setBaseURI *** this )-      >>>-      arrL snd---- ---------------------------------------------------------------- | set the global trace level--setTraceLevel   :: Int -> IOStateArrow s b b-setTraceLevel l-    = changeSysParam (\ _ s -> s { xio_trace = l } )---- | read the global trace level--getTraceLevel   :: IOStateArrow s b Int-getTraceLevel-    = getSysParam xio_trace---- | set the global trace command. This command does the trace output--setTraceCmd     :: (Int -> String -> IO ()) -> IOStateArrow s b b-setTraceCmd c-    = changeSysParam (\ _ s -> s { xio_traceCmd = c } )---- | acces the command for trace output--getTraceCmd     :: IOStateArrow a b (Int -> String -> IO ())-getTraceCmd-    = getSysParam xio_traceCmd---- | run an arrow with a given trace level, the old trace level is restored after the arrow execution--withTraceLevel  :: Int -> IOStateArrow s b c -> IOStateArrow s b c-withTraceLevel level f-    = ( getTraceLevel       &&& this )-      >>>-      ( setTraceLevel level *** listA f )-      >>>-      ( restoreTraceLevel   *** this )-      >>>-      arrL snd-    where-    restoreTraceLevel   :: IOStateArrow s Int Int-    restoreTraceLevel-        = setTraceLevel $< this---- | apply a trace arrow and issue message to stderr--trace           :: Int -> IOStateArrow s b String -> IOStateArrow s b b-trace level trc-    = perform ( trc-                >>>-                ( getTraceCmd &&& this )-                >>>-                arrIO (\ (cmd, msg) -> cmd level msg)-              )-      `when` ( getTraceLevel-               >>>-               isA (>= level)-             )--traceOutputToStderr     :: Int -> String -> IO ()-traceOutputToStderr _level msg-    = do-      hPutStrLn stderr msg-      hFlush stderr---- | trace the current value transfered in a sequence of arrows.------ The value is formated by a string conversion function. This is a substitute for--- the old and less general traceString function--traceValue              :: Int -> (b -> String) -> IOStateArrow s b b-traceValue level trc-    = trace level (arr $ (('-' : "- (" ++ show level ++ ") ") ++) . trc)---- | an old alias for 'traceValue'--traceString             :: Int -> (b -> String) -> IOStateArrow s b b-traceString             = traceValue---- | issue a string message as trace--traceMsg        :: Int -> String -> IOStateArrow s b b-traceMsg level msg-    = traceValue level (const msg)---- | issue the source representation of a document if trace level >= 3------ for better readability the source is formated with indentDoc--traceSource     :: IOStateArrow s XmlTree XmlTree-traceSource-    = trace 3 $-      xshow-      ( choiceA [ isRoot :-> ( indentDoc-                               >>>-                               getChildren-                             )-                , isElem :-> ( root [] [this]-                               >>> indentDoc-                               >>> getChildren-                               >>> isElem-                             )-                , this   :-> this-                ]-      )---- | issue the tree representation of a document if trace level >= 4-traceTree       :: IOStateArrow s XmlTree XmlTree-traceTree-    = trace 4 $-      xshow ( treeRepOfXmlDoc-              >>>-              addHeadlineToXmlDoc-              >>>-              getChildren-            )---- | trace a main computation step--- issue a message when trace level >= 1, issue document source if level >= 3, issue tree when level is >= 4--traceDoc        :: String -> IOStateArrow s XmlTree XmlTree-traceDoc msg-    = traceMsg 1 msg-      >>>-      traceSource-      >>>-      traceTree---- | trace the global state--traceState      :: IOStateArrow s b b-traceState-    = perform ( xshow ( (getAllParams >>. concat)-                        >>>-                        applyA (arr formatParam)-                      )-                >>>-                traceValue 2 ("global state:\n" ++)-              )-      where-      -- formatParam    :: (String, XmlTrees) -> IOStateArrow s b1 XmlTree-      formatParam (n, v)-          = mkelem "param" [sattr "name" n] [arrL (const v)] <+> txt "\n"---- -------------------------------------------------------------- | parse a URI reference, in case of a failure,--- try to escape unescaped chars, convert backslashes to slashes for windows paths,--- and try parsing again--parseURIReference'      :: String -> Maybe URI-parseURIReference' uri-    = parseURIReference uri-      `mplus`-      ( if unesc-        then parseURIReference uri'-        else mzero-      )-    where-    unesc       = not . all isUnescapedInURI $ uri--    escape '\\' = "/"-    escape c    = escapeURIChar isUnescapedInURI c--    uri'        = concatMap escape uri---- | compute the absolut URI for a given URI and a base URI--expandURIString :: String -> String -> Maybe String-expandURIString uri base-    = do-      base' <- parseURIReference' base-      uri'  <- parseURIReference' uri-      abs'  <- nonStrictRelativeTo uri' base'-      return $ show abs'---- | arrow variant of 'expandURIString', fails if 'expandURIString' returns Nothing--expandURI               :: ArrowXml a => a (String, String) String-expandURI-    = arrL (maybeToList . uncurry expandURIString)---- | arrow for expanding an input URI into an absolute URI using global base URI, fails if input is not a legal URI--mkAbsURI                :: IOStateArrow s String String-mkAbsURI-    = ( this &&& getBaseURI ) >>> expandURI---- | arrow for selecting the scheme (protocol) of the URI, fails if input is not a legal URI.------ See Network.URI for URI components--getSchemeFromURI        :: ArrowList a => a String String-getSchemeFromURI        = getPartFromURI scheme-    where-    scheme = init . uriScheme---- | arrow for selecting the registered name (host) of the URI, fails if input is not a legal URI--getRegNameFromURI       :: ArrowList a => a String String-getRegNameFromURI       = getPartFromURI host-    where-    host = maybe "" uriRegName . uriAuthority---- | arrow for selecting the port number of the URI without leading \':\', fails if input is not a legal URI--getPortFromURI          :: ArrowList a => a String String-getPortFromURI          = getPartFromURI port-    where-    port = dropWhile (==':') . maybe "" uriPort . uriAuthority---- | arrow for selecting the user info of the URI without trailing \'\@\', fails if input is not a legal URI--getUserInfoFromURI              :: ArrowList a => a String String-getUserInfoFromURI              = getPartFromURI ui-    where-    ui = reverse . dropWhile (=='@') . reverse . maybe "" uriUserInfo . uriAuthority---- | arrow for computing the path component of an URI, fails if input is not a legal URI--getPathFromURI          :: ArrowList a => a String String-getPathFromURI          = getPartFromURI uriPath---- | arrow for computing the query component of an URI, fails if input is not a legal URI--getQueryFromURI         :: ArrowList a => a String String-getQueryFromURI         = getPartFromURI uriQuery---- | arrow for computing the fragment component of an URI, fails if input is not a legal URI--getFragmentFromURI      :: ArrowList a => a String String-getFragmentFromURI      = getPartFromURI uriFragment---- | arrow for computing the path component of an URI, fails if input is not a legal URI--getPartFromURI          :: ArrowList a => (URI -> String) -> a String String-getPartFromURI sel-    = arrL (maybeToList . getPart)-      where-      getPart s = do-                  uri <- parseURIReference' s-                  return (sel uri)---- ---------------------------------------------------------------- | set the table mapping of file extensions to mime types in the system state------ Default table is defined in 'Text.XML.HXT.DOM.MimeTypeDefaults'.--- This table is used when reading loacl files, (file: protocol) to determine the mime type--setMimeTypeTable        :: MimeTypeTable -> IOStateArrow s b b-setMimeTypeTable mtt-    = changeSysParam (\ _ s -> s {xio_mimeTypes = mtt})---- | set the table mapping of file extensions to mime types by an external config file------ The config file must follow the conventions of /etc/mime.types on a debian linux system,--- that means all empty lines and all lines starting with a # are ignored. The other lines--- must consist of a mime type followed by a possible empty list of extensions.--- The list of extenstions and mime types overwrites the default list in the system state--- of the IOStateArrow--setMimeTypeTableFromFile        :: FilePath -> IOStateArrow s b b-setMimeTypeTableFromFile file-    = setMimeTypeTable $< arrIO0 ( readMimeTypeTable file)---- ------------------------------------------------------------
+ src/Text/XML/HXT/Arrow/XmlOptions.hs view
@@ -0,0 +1,254 @@+-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.Arrow.XmlOptions+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   system configuration and common options options++-}++-- ------------------------------------------------------------++module Text.XML.HXT.Arrow.XmlOptions+where++import Text.XML.HXT.DOM.Interface++import Text.XML.HXT.Arrow.XmlState.TypeDefs+import Text.XML.HXT.Arrow.XmlState.SystemConfig++import Data.Maybe++import System.Console.GetOpt++-- ------------------------------------------------------------+--++-- |+-- commonly useful options for XML input+--+-- can be used for option definition with haskell getopt+--+-- defines options: 'a_trace', 'a_proxy', 'a_use_curl', 'a_do_not_use_curl', 'a_options_curl', 'a_encoding',+-- 'a_issue_errors', 'a_do_not_issue_errors', 'a_parse_html', 'a_parse_by_mimetype', 'a_issue_warnings', 'a_do_not_issue_warnings',+-- 'a_parse_xml', 'a_validate', 'a_do_not_validate', 'a_canonicalize', 'a_do_not_canonicalize',+--- 'a_preserve_comment', 'a_do_not_preserve_comment', 'a_check_namespaces', 'a_do_not_check_namespaces',+-- 'a_remove_whitespace', 'a_do_not_remove_whitespace'++inputOptions    :: [OptDescr SysConfig]+inputOptions+    = [ Option "t"      [a_trace]                       (OptArg trc "LEVEL")                    "trace level (0-4), default 1"+      , Option "p"      [a_proxy]                       (ReqArg  withProxy            "PROXY")  "proxy for http access (e.g. \"www-cache:3128\")"+      , Option ""       [a_redirect]                    (NoArg  (withRedirect           True))  "automatically follow redirected URIs"+      , Option ""       [a_no_redirect]                 (NoArg  (withRedirect          False))  "switch off following redirected URIs"+      , Option ""       [a_default_baseuri]             (ReqArg  withDefaultBaseURI     "URI")  "default base URI, default: \"file:///<cwd>/\""+      , Option "e"      [a_encoding]                    (ReqArg  withInputEncoding  "CHARSET")  ( "default document encoding (" ++ utf8 ++ ", " ++ isoLatin1 ++ ", " ++ usAscii ++ ", ...)" )+      , Option ""       [a_mime_types]                  (ReqArg  withMimeTypeFile      "FILE")  "set mime type configuration file, e.g. \"/etc/mime.types\""+      , Option ""       [a_issue_errors]                (NoArg  (withErrors             True))  "issue all error messages on stderr (default)"+      , Option ""       [a_do_not_issue_errors]         (NoArg  (withErrors            False))  "ignore all error messages"+      , Option ""       [a_ignore_encoding_errors]      (NoArg  (withEncodingErrors    False))   "ignore encoding errors"+      , Option ""       [a_ignore_none_xml_contents]    (NoArg  (withIgnoreNoneXmlContents True)) "discards all contents of none XML/HTML documents, only the meta info remains in the doc tree"+      , Option ""       [a_accept_mimetypes]            (ReqArg  withMT           "MIMETYPES")  "only accept documents matching the given comma separated list of mimetype specs"+      , Option "H"      [a_parse_html]                  (NoArg  (withParseHTML          True))  "parse input as HTML, try to interprete everything as HTML, no validation"+      , Option "M"      [a_parse_by_mimetype]           (NoArg  (withParseByMimeType    True))  "parse dependent on mime type: text/html as HTML, text/xml and text/xhtml and others as XML, else no parse"+      , Option ""       [a_parse_xml]                   (NoArg  (withParseHTML         False))  "parse input as XML, (default)"+      , Option ""       [a_strict_input]                (NoArg  (withStrictInput        True))  "read input files strictly, this ensures closing the files correctly even if not read completely"+      , Option ""       [a_issue_warnings]              (NoArg  (withWarnings           True))  "issue warnings, when parsing HTML (default)"+      , Option "Q"      [a_do_not_issue_warnings]       (NoArg  (withWarnings          False))  "ignore warnings, when parsing HTML"+      , Option ""       [a_validate]                    (NoArg  (withValidate           True))  "document validation when parsing XML (default)"+      , Option "w"      [a_do_not_validate]             (NoArg  (withValidate          False))  "only wellformed check, no validation"+      , Option ""       [a_subst_dtd_entities]          (NoArg  (withSubstDTDEntities   True))  "entities defined in DTD are substituted when parsing XML (default)"+      , Option ""       [a_do_not_subst_dtd_entities]   (NoArg  (withSubstDTDEntities  False))  "entities defined in DTD are NOT substituted when parsing XML"+      , Option ""       [a_subst_html_entities]         (NoArg  (withSubstHTMLEntities   True)) "entities defined in XHTML are substituted when parsing XML, only in effect when prev. option is switched off"+      , Option ""       [a_do_not_subst_html_entities]  (NoArg  (withSubstHTMLEntities  False)) "only entities predefined in XML are substituted when parsing XML (default)"+      , Option ""       [a_canonicalize]                (NoArg  (withCanonicalize       True))  "canonicalize document, remove DTD, comment, transform CDATA, CharRef's, ... (default)"+      , Option "c"      [a_do_not_canonicalize]         (NoArg  (withCanonicalize      False))  "do not canonicalize document, don't remove DTD, comment, don't transform CDATA, CharRef's, ..."+      , Option "C"      [a_preserve_comment]            (NoArg  (withPreserveComment    True))  "don't remove comments during canonicalisation"+      , Option ""       [a_do_not_preserve_comment]     (NoArg  (withPreserveComment   False))  "remove comments during canonicalisation (default)"+      , Option "n"      [a_check_namespaces]            (NoArg  (withCheckNamespaces    True))  "tag tree with namespace information and check namespaces"+      , Option ""       [a_do_not_check_namespaces]     (NoArg  (withCheckNamespaces   False))  "ignore namespaces (default)"+      , Option "r"      [a_remove_whitespace]           (NoArg  (withRemoveWS           True))  "remove redundant whitespace, simplifies tree and processing"+      , Option ""       [a_do_not_remove_whitespace]    (NoArg  (withRemoveWS          False))  "don't remove redundant whitespace (default)"+      ]+    where+    withMT = withAcceptedMimeTypes . words . map (\ x -> if x == ',' then ' ' else x)+    trc = withTrace . max 0 . min 9 . (read :: String -> Int) . ('0':) . filter (`elem` "0123456789") . fromMaybe v_1++-- |+-- commonly useful options for XML output+--+-- defines options: 'a_indent', 'a_output_encoding', 'a_output_html' and others++outputOptions   :: [OptDescr SysConfig]+outputOptions+    = [ Option "f"      [a_output_file]         (ReqArg (withSysAttr a_output_file) "FILE")   "output file for resulting document (default: stdout)"+      , Option "i"      [a_indent]              (NoArg  (withIndent               True))      "indent XML output for readability"+      , Option "o"      [a_output_encoding]     (ReqArg  withOutputEncoding    "CHARSET")      ( "encoding of output (" ++ utf8 ++ ", " ++ isoLatin1 ++ ", " ++ usAscii ++ ")" )+      , Option ""       [a_output_xml]          (NoArg   withOutputXML                  )      "output of none ASCII chars as HTMl entity references"+      , Option ""       [a_output_html]         (NoArg   withOutputHTML                 )      "output of none ASCII chars as HTMl entity references"+      , Option ""       [a_output_xhtml]        (NoArg   withOutputXHTML                )      "output of HTML elements with empty content (script, ...) done in format <elem...></elem> instead of <elem/>"+      , Option ""       [a_output_plain]        (NoArg   withOutputPLAIN                )      "output of HTML elements with empty content (script, ...) done in format <elem...></elem> instead of <elem/>"+      , Option ""       [a_no_xml_pi]           (NoArg  (withXmlPi                False))      ("output without <?xml ...?> processing instruction, useful in combination with --" ++ show a_output_html)+      , Option ""       [a_no_empty_elem_for]   (ReqArg (withNoEmptyElemFor . words') "NAMES")   "output of empty elements done in format <elem...></elem> only for given list of element names"+      , Option ""       [a_add_default_dtd]     (NoArg  (withAddDefaultDTD         True))      "add the document type declaration given in the input document"+      , Option ""       [a_text_mode]           (NoArg  (withTextMode              True))      "output in text mode"+      ]+    where+    words'+        = words+          . map (\ c -> if c == ',' then ' ' else c)++-- |+-- commonly useful options+--+-- defines options: 'a_verbose', 'a_help'++generalOptions  :: [OptDescr SysConfig]+generalOptions+    = [ Option "v"      [a_verbose]             (NoArg  (withSysAttr a_verbose v_1))               "verbose output"+      , Option "h?"     [a_help]                (NoArg  (withSysAttr a_help    v_1))               "this message"+      ]++-- |+-- defines 'a_version' option++versionOptions  :: [OptDescr SysConfig]+versionOptions+    = [ Option "V"      [a_version]             (NoArg  (withSysAttr a_version v_1))               "show program version"+      ]++-- |+-- debug output options++showOptions     :: [OptDescr SysConfig]+showOptions+    = [ Option ""       [a_show_tree]           (NoArg  (withShowTree      True))          "output tree representation instead of document source"+      , Option ""       [a_show_haskell]        (NoArg  (withShowHaskell   True))          "output internal Haskell representation instead of document source"+      ]++-- ------------------------------------------------------------++a_accept_mimetypes,+ a_add_default_dtd,+ a_canonicalize,+ a_check_namespaces,+ a_collect_errors,+ a_default_baseuri,+ a_do_not_canonicalize,+ a_do_not_check_namespaces,+ a_do_not_issue_errors,+ a_do_not_issue_warnings,+ a_do_not_preserve_comment,+ a_do_not_remove_whitespace,+ a_do_not_subst_dtd_entities,+ a_do_not_subst_html_entities,+ a_do_not_validate,+ a_error,+ a_error_log,+ a_help,+ a_if_modified_since,+ a_if_unmodified_since,+ a_ignore_encoding_errors,+ a_ignore_none_xml_contents,+ a_indent,+ a_issue_errors,+ a_issue_warnings,+ a_mime_types,+ a_no_empty_elements,+ a_no_empty_elem_for,+ a_no_redirect,+ a_no_xml_pi,+ a_output_file,+ a_output_xml,+ a_output_html,+ a_output_xhtml,+ a_output_plain,+ a_parse_by_mimetype,+ a_parse_html,+ a_parse_xml,+ a_preserve_comment,+ a_proxy,+ a_redirect,+ a_remove_whitespace,+ a_show_haskell,+ a_show_tree,+ a_strict_input,+ a_subst_dtd_entities,+ a_subst_html_entities,+ a_text_mode,+ a_trace,+ a_validate,+ a_verbose      :: String++a_accept_mimetypes              = "accept-mimetypes"+a_add_default_dtd               = "add-default-dtd"+a_canonicalize                  = "canonicalize"+a_check_namespaces              = "check-namespaces"+a_collect_errors                = "collect-errors"+a_default_baseuri               = "default-base-URI"+a_do_not_canonicalize           = "do-not-canonicalize"+a_do_not_check_namespaces       = "do-not-check-namespaces"+a_do_not_issue_errors           = "do-not-issue-errors"+a_do_not_issue_warnings         = "do-not-issue-warnings"+a_do_not_preserve_comment       = "do-not-preserve-comment"+a_do_not_remove_whitespace      = "do-not-remove-whitespace"+a_do_not_subst_dtd_entities     = "do-not-subst-dtd-entities"+a_do_not_subst_html_entities    = "do-not-subst-html-entities"+a_do_not_validate               = "do-not-validate"+a_error                         = "error"+a_error_log                     = "errorLog"+a_help                          = "help"+a_if_modified_since             = "if-modified-since"+a_if_unmodified_since           = "if-unmodified-since"+a_ignore_encoding_errors        = "ignore-encoding-errors"+a_ignore_none_xml_contents      = "ignore-none-xml-contents"+a_indent                        = "indent"+a_issue_warnings                = "issue-warnings"+a_issue_errors                  = "issue-errors"+a_mime_types                    = "mimetypes"+a_no_empty_elements             = "no-empty-elements"+a_no_empty_elem_for             = "no-empty-elem-for"+a_no_redirect                   = "no-redirect"+a_no_xml_pi                     = "no-xml-pi"+a_output_file                   = "output-file"+a_output_html                   = "output-html"+a_output_xhtml                  = "output-xhtml"+a_output_xml                    = "output-xml"+a_output_plain                  = "output-plain"+a_parse_by_mimetype             = "parse-by-mimetype"+a_parse_html                    = "parse-html"+a_parse_xml                     = "parse-xml"+a_preserve_comment              = "preserve-comment"+a_proxy                         = "proxy"+a_redirect                      = "redirect"+a_remove_whitespace             = "remove-whitespace"+a_show_haskell                  = "show-haskell"+a_show_tree                     = "show-tree"+a_strict_input                  = "strict-input"+a_subst_dtd_entities            = "subst-dtd-entities"+a_subst_html_entities           = "subst-html-entities"+a_text_mode                     = "text-mode"+a_trace                         = "trace"+a_validate                      = "validate"+a_verbose                       = "verbose"++-- ------------------------------------------------------------++-- |+-- select options from a predefined list of option descriptions++selectOptions   :: [String] -> [OptDescr a] -> [OptDescr a]+selectOptions ol os+    = concat . map (\ on -> filter (\ (Option _ ons _ _) -> on `elem` ons) os) $ ol++removeOptions   :: [String] -> [OptDescr a] -> [OptDescr a]+removeOptions ol os+    = filter (\ (Option _ ons _ _) -> not . any (`elem` ol) $ ons ) os++-- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/XmlRegex.hs view
@@ -11,7 +11,7 @@     Regular Expression Matcher working on lists of XmlTrees -   It's intendet to import this module with an explicit+   It's intended to import this module with an explicit    import declaration for not spoiling the namespace    with these somewhat special arrows @@ -24,14 +24,20 @@     , mkZero     , mkUnit     , mkPrim+    , mkPrim'     , mkPrimA     , mkDot     , mkStar     , mkAlt+    , mkAlts     , mkSeq+    , mkSeqs     , mkRep     , mkRng     , mkOpt+    , mkPerm+    , mkPerms+    , mkMerge     , nullable     , delta     , matchXmlRegex@@ -43,11 +49,12 @@     ) where -import Control.Arrow.ListArrows+import           Control.Arrow.ListArrows -import Data.Maybe+import           Data.Maybe -import Text.XML.HXT.DOM.Interface+import           Text.XML.HXT.DOM.Interface+import           Text.XML.HXT.DOM.ShowXml   (xshow)  -- ------------------------------------------------------------ -- the exported regex arrows@@ -61,7 +68,7 @@ -- ('mkStar', mkRep', 'mkRng') and choice ('mkAlt', 'mkOpt')  matchRegexA             :: XmlRegex -> LA XmlTree XmlTree -> LA XmlTree XmlTrees-matchRegexA re ts       = ts >>. (\ s -> maybe [] (const [s]) . matchXmlRegex re $ s)+matchRegexA re ts       = ts >>. (\ s -> maybe [s] (const []) . matchXmlRegex re $ s)  -- | split the sequence of trees computed by the filter a into --@@ -86,13 +93,15 @@  data XmlRegex   = Zero String                 | Unit-                | Sym (XmlTree -> Bool)+                | Sym  (XmlTree -> Bool) String    -- optional external repr. of predicate                 | Dot-                | Star XmlRegex-                | Alt XmlRegex XmlRegex-                | Seq XmlRegex XmlRegex-                | Rep Int XmlRegex              -- 1 or more repetitions-                | Rng Int Int XmlRegex  -- n..m repetitions+                | Star  XmlRegex+                | Alt   XmlRegex XmlRegex+                | Seq   XmlRegex XmlRegex+                | Rep   Int      XmlRegex          -- 1 or more repetitions+                | Rng   Int Int  XmlRegex          -- n..m repetitions+                | Perm  XmlRegex XmlRegex+                | Merge XmlRegex XmlRegex  -- ------------------------------------------------------------ @@ -104,7 +113,7 @@ instance Inv XmlRegex where     inv (Zero _)        = True     inv Unit            = True-    inv (Sym p)         = p holds for some XmlTrees+    inv (Sym p _)       = p holds for some XmlTrees     inv Dot             = True     inv (Star e)        = inv e     inv (Alt e1 e2)     = inv e1 &&@@ -114,6 +123,8 @@     inv (Rep i e)       = i > 0 && inv e     inv (Rng i j e)     = (i < j || (i == j && i > 1)) &&                           inv e+    inv (Perm e1 e2)    = inv e1 &&+                          inv e2 -} -- ------------------------------------------------------------ --@@ -126,13 +137,16 @@ mkUnit          = Unit  mkPrim          :: (XmlTree -> Bool) -> XmlRegex-mkPrim          = Sym+mkPrim p        = Sym p "" +mkPrim'         :: (XmlTree -> Bool) -> String -> XmlRegex+mkPrim'         = Sym+ mkPrimA         :: LA XmlTree XmlTree -> XmlRegex mkPrimA a       = mkPrim (not . null . runLA a) -mkDot   :: XmlRegex-mkDot   = Dot+mkDot           :: XmlRegex+mkDot           = Dot  mkStar                  :: XmlRegex -> XmlRegex mkStar (Zero _)         = mkUnit                -- {}* == ()@@ -153,12 +167,20 @@ mkAlt (Zero _)      e2                  = e2                            -- {} u e2 = e2 mkAlt e1@(Star Dot) _e2                 = e1                            -- A* u e1 = A* mkAlt _e1           e2@(Star Dot)       = e2                            -- e1 u A* = A*-mkAlt (Sym p1)      (Sym p2)            = mkPrim $ \ x -> p1 x || p2 x  -- melting of predicates-mkAlt e1            e2@(Sym _)          = mkAlt e2 e1                   -- symmetry: predicates always first-mkAlt e1@(Sym _)    (Alt e2@(Sym _) e3) = mkAlt (mkAlt e1 e2) e3        -- prepare melting of predicates+mkAlt (Sym p1 e1)   (Sym p2 e2)         = mkPrim' (\ x -> p1 x || p2 x)  (e e1 e2) -- melting of predicates+                                          where+                                            e "" x2 = x2+                                            e x1 "" = x1+                                            e x1 x2 = x1 ++ "|" ++ x2+mkAlt e1            e2@(Sym _ _)        = mkAlt e2 e1                   -- symmetry: predicates always first+mkAlt e1@(Sym _ _)  (Alt e2@(Sym _ _) e3)+                                        = mkAlt (mkAlt e1 e2) e3        -- prepare melting of predicates mkAlt (Alt e1 e2)   e3                  = mkAlt e1 (mkAlt e2 e3)        -- associativity mkAlt e1 e2                             = Alt e1 e2 +mkAlts                          :: [XmlRegex] -> XmlRegex+mkAlts                          = foldr mkAlt (mkZero "")+ mkSeq                           :: XmlRegex -> XmlRegex -> XmlRegex mkSeq e1@(Zero _) _e2           = e1 mkSeq _e1         e2@(Zero _)   = e2@@ -167,6 +189,9 @@ mkSeq (Seq e1 e2) e3            = mkSeq e1 (mkSeq e2 e3) mkSeq e1 e2                     = Seq e1 e2 +mkSeqs                          :: [XmlRegex] -> XmlRegex+mkSeqs                          = foldr mkSeq mkUnit+ mkRep           :: Int -> XmlRegex -> XmlRegex mkRep 0 e                       = mkStar e mkRep _ e@(Zero _)              = e@@ -187,12 +212,30 @@ mkOpt   :: XmlRegex -> XmlRegex mkOpt   = mkRng 0 1 +mkPerm                           :: XmlRegex -> XmlRegex -> XmlRegex+mkPerm e1@(Zero _) _             = e1+mkPerm _           e2@(Zero _)   = e2+mkPerm Unit        e2            = e2+mkPerm e1          Unit          = e1+mkPerm e1          e2            = Perm e1 e2++mkPerms                          :: [XmlRegex] -> XmlRegex+mkPerms                          = foldr mkPerm mkUnit++mkMerge                          :: XmlRegex -> XmlRegex -> XmlRegex+mkMerge e1@(Zero _) _            = e1+mkMerge _           e2@(Zero _)  = e2+mkMerge Unit        e2           = e2+mkMerge e1          Unit         = e1+mkMerge e1          e2           = Merge e1 e2+ -- ------------------------------------------------------------  instance Show XmlRegex where     show (Zero s)       = "{err:" ++ s ++ "}"     show Unit           = "()"-    show (Sym _p)       = "{single tree pred}"+    show (Sym _p "")    = "<pred>"+    show (Sym _p r )    = r     show Dot            = "."     show (Star e)       = "(" ++ show e ++ ")*"     show (Alt e1 e2)    = "(" ++ show e1 ++ "|" ++ show e2 ++ ")"@@ -201,13 +244,28 @@     show (Rep i e)      = "(" ++ show e ++ "){" ++ show i ++ ",}"     show (Rng 0 1 e)    = "(" ++ show e ++ ")?"     show (Rng i j e)    = "(" ++ show e ++ "){" ++ show i ++ "," ++ show j ++ "}"+    show (Perm e1 e2)   = "(" ++ show e1 ++ show e2 ++ "|" ++ show e2 ++ show e1 ++ ")"+    show (Merge e1 e2)  = "(" ++ show e1 ++ "&" ++ show e2 ++ ")"  -- ------------------------------------------------------------ +unexpected              :: XmlTree -> String -> String+unexpected t e          = emsg e ++ (cut 80 . xshow) [t]+    where+      emsg ""           = "unexpected: "+      emsg s            = "expected: " ++ s ++ ", but got: "+      cut n s+          | null rest   = s'+          | otherwise   = s' ++ "..."+          where+            (s', rest)  = splitAt n s++-- ------------------------------------------------------------+ nullable        :: XmlRegex -> Bool nullable (Zero _)       = False nullable Unit           = True-nullable (Sym _p)       = False         -- assumption: p holds for at least one tree+nullable (Sym _p _)     = False         -- assumption: p holds for at least one tree nullable Dot            = False nullable (Star _)       = True nullable (Alt e1 e2)    = nullable e1 ||@@ -217,25 +275,34 @@ nullable (Rep _i e)     = nullable e nullable (Rng i _ e)    = i == 0 ||                           nullable e+nullable (Perm e1 e2)   = nullable e1 &&+                          nullable e2+nullable (Merge e1 e2)  = nullable e1 &&+                          nullable e2  -- ------------------------------------------------------------  delta   :: XmlRegex -> XmlTree -> XmlRegex-delta e@(Zero _)  _     = e-delta Unit        c     = mkZero $-                          "unexpected char " ++ show c-delta (Sym p)     c+delta e@(Zero _)   _    = e+delta Unit         c    = mkZero $ unexpected c ""+delta (Sym p e)    c     | p c               = mkUnit-    | otherwise         = mkZero $-                          "unexpected tree " ++ show c-delta Dot         _     = mkUnit-delta e@(Star e1) c     = mkSeq (delta e1 c) e-delta (Alt e1 e2) c     = mkAlt (delta e1 c) (delta e2 c)-delta (Seq e1 e2) c+    | otherwise         = mkZero $ unexpected c e+delta Dot          _    = mkUnit+delta e@(Star e1)  c    = mkSeq (delta e1 c) e+delta (Alt e1 e2)  c    = mkAlt (delta e1 c) (delta e2 c)+delta (Seq e1 e2)  c     | nullable e1       = mkAlt (mkSeq (delta e1 c) e2) (delta e2 c)     | otherwise         = mkSeq (delta e1 c) e2-delta (Rep i e)   c     = mkSeq (delta e c) (mkRep (i-1) e)-delta (Rng i j e) c     = mkSeq (delta e c) (mkRng ((i-1) `max` 0) (j-1) e)+delta (Rep i e)    c    = mkSeq (delta e c) (mkRep (i-1) e)+delta (Rng i j e)  c    = mkSeq (delta e c) (mkRng ((i-1) `max` 0) (j-1) e)+delta (Perm e1 e2) c    = case e1' of+                            (Zero _) -> mkPerm e1 (delta e2 c)+                            _        -> mkPerm e1' e2+                          where+                          e1' = delta e1 c+delta (Merge e1 e2) c   = mkAlt (mkMerge (delta e1 c) e2)+                                (mkMerge e1 (delta e2 c))  -- ------------------------------------------------------------
+ src/Text/XML/HXT/Arrow/XmlState.hs view
@@ -0,0 +1,162 @@+-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.Arrow.XmlState+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   the interface for the basic state maipulation functions+-}++-- ------------------------------------------------------------++module Text.XML.HXT.Arrow.XmlState+    ( -- * Data Types+      XIOState+    , XIOSysState+    , IOStateArrow+    , IOSArrow+    , SysConfig+    , SysConfigList+    ,+      -- * User State Manipulation+      getUserState+    , setUserState+    , changeUserState+    , withExtendedUserState+    , withOtherUserState+    , withoutUserState+    ,+      -- * Run IO State arrows+      runX+    ,+      -- * Global System State Configuration and Access+      configSysVars+    , setSysAttr+    , unsetSysAttr+    , getSysAttr+    , getAllSysAttrs+    , setSysAttrString+    , setSysAttrInt+    , getSysAttrInt+    , getConfigAttr+    ,+      -- * Error Handling+      clearErrStatus+    , setErrStatus+    , getErrStatus+    , setErrMsgStatus+    , setErrorMsgHandler+    , errorMsgStderr+    , errorMsgCollect+    , errorMsgStderrAndCollect+    , errorMsgIgnore+    , getErrorMessages+    , filterErrorMsg+    , issueWarn+    , issueErr+    , issueFatal+    , issueExc+    , setDocumentStatus+    , setDocumentStatusFromSystemState+    , documentStatusOk++    , -- * Tracing+      setTraceLevel+    , getTraceLevel+    , withTraceLevel+    , setTraceCmd+    , getTraceCmd+    , trace+    , traceMsg+    , traceValue+    , traceString+    , traceSource+    , traceTree+    , traceDoc++    , -- * Document Base+      setBaseURI+    , getBaseURI+    , changeBaseURI+    , setDefaultBaseURI+    , getDefaultBaseURI+    , runInLocalURIContext++    ,  -- * URI Manipulation+      expandURIString+    , expandURI+    , mkAbsURI+    , getFragmentFromURI+    , getPathFromURI+    , getPortFromURI+    , getQueryFromURI+    , getRegNameFromURI+    , getSchemeFromURI+    , getUserInfoFromURI++    , -- * Mime Type Handling+      getMimeTypeTable+    , setMimeTypeTable+    , setMimeTypeTableFromFile++    , -- * System Configuration and Options+      yes+    , no++    , withAcceptedMimeTypes+    , withAddDefaultDTD+    , withSysAttr+    , withCanonicalize+    , withCompression+    , withCheckNamespaces+    , withDefaultBaseURI+    , withStrictDeserialize+    , withEncodingErrors+    , withErrors+    , withFileMimeType+    , withIgnoreNoneXmlContents+    , withIndent+    , withInputEncoding+    , withInputOption+    , withInputOptions+    , withMimeTypeFile+    , withMimeTypeHandler+    , withNoEmptyElemFor+    , withXmlPi+    , withOutputEncoding+    , withOutputXML+    , withOutputHTML+    , withOutputXHTML+    , withOutputPLAIN+    , withParseByMimeType+    , withParseHTML+    , withPreserveComment+    , withProxy+    , withRedirect+    , withRemoveWS+    , withShowHaskell+    , withShowTree+    , withStrictInput+    , withSubstDTDEntities+    , withSubstHTMLEntities+    , withTextMode+    , withTrace+    , withValidate+    , withWarnings+    )+where++import Text.XML.HXT.Arrow.XmlState.ErrorHandling+import Text.XML.HXT.Arrow.XmlState.MimeTypeTable+import Text.XML.HXT.Arrow.XmlState.RunIOStateArrow+import Text.XML.HXT.Arrow.XmlState.SystemConfig+import Text.XML.HXT.Arrow.XmlState.TraceHandling+import Text.XML.HXT.Arrow.XmlState.TypeDefs+import Text.XML.HXT.Arrow.XmlState.URIHandling++-- ------------------------------------------------------------
+ src/Text/XML/HXT/Arrow/XmlState/ErrorHandling.hs view
@@ -0,0 +1,252 @@+-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.Arrow.XmlState.ErrorHandling+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   the basic state arrows for XML processing++   A state is needed for global processing options,+   like encoding options, document base URI, trace levels+   and error message handling++   The state is separated into a user defined state+   and a system state. The system state contains variables+   for error message handling, for tracing, for the document base+   for accessing XML documents with relative references, e.g. DTDs,+   and a global key value store. This assoc list has strings as keys+   and lists of XmlTrees as values. It is used to store arbitrary+   XML and text values, e.g. user defined global options.++   The user defined part of the store is in the default case empty, defined as ().+   It can be extended with an arbitray data type++-}++-- ------------------------------------------------------------++module Text.XML.HXT.Arrow.XmlState.ErrorHandling+where++import Control.Arrow                            -- arrow classes+import Control.Arrow.ArrowList+import Control.Arrow.ArrowIf+import Control.Arrow.ArrowTree+import Control.Arrow.ArrowIO++import Control.Exception                ( SomeException )++import Data.Maybe++import Text.XML.HXT.DOM.Interface++import Text.XML.HXT.Arrow.XmlArrow+import Text.XML.HXT.Arrow.XmlState.TypeDefs++import System.IO                        ( hPutStrLn+                                        , hFlush+                                        , stderr+                                        )++-- ------------------------------------------------------------++changeErrorStatus       :: (Int -> Int -> Int) -> IOStateArrow s Int Int+changeErrorStatus f     = chgSysVar theErrorStatus f++-- | reset global error variable++clearErrStatus          :: IOStateArrow s b b+clearErrStatus          = configSysVar $ setS theErrorStatus 0++-- | set global error variable++setErrStatus            :: IOStateArrow s Int Int+setErrStatus            = changeErrorStatus max++-- | read current global error status++getErrStatus            :: IOStateArrow s XmlTree Int+getErrStatus            = getSysVar theErrorStatus++-- ------------------------------------------------------------++-- | raise the global error status level to that of the input tree++setErrMsgStatus         :: IOStateArrow s XmlTree XmlTree+setErrMsgStatus         = perform+                          ( getErrorLevel >>> setErrStatus )++-- | set the error message handler and the flag for collecting the errors++setErrorMsgHandler      :: Bool -> (String -> IO ()) -> IOStateArrow s b b+setErrorMsgHandler c f  = configSysVar $ setS (theErrorMsgCollect .&&&. theErrorMsgHandler) (c, f)++-- | error message handler for output to stderr++sysErrorMsg             :: IOStateArrow s XmlTree XmlTree+sysErrorMsg             = perform+                          ( getErrorLevel &&& getErrorMsg+                            >>>+                            arr formatErrorMsg+                            >>>+                            getSysVar theErrorMsgHandler &&& this+                            >>>+                            arrIO (\ (h, msg) -> h msg)+                          )+    where+    formatErrorMsg (level, msg) = "\n" ++ errClass level ++ ": " ++ msg+    errClass l          = fromMaybe "fatal error" . lookup l $ msgList+        where+        msgList         = [ (c_ok,      "no error")+                          , (c_warn,    "warning")+                          , (c_err,     "error")+                          , (c_fatal,   "fatal error")+                          ]+++-- | the default error message handler: error output to stderr++errorMsgStderr          :: IOStateArrow s b b+errorMsgStderr          = setErrorMsgHandler False (\ x ->+                                                    do hPutStrLn stderr x+                                                       hFlush    stderr+                                                   )++-- | error message handler for collecting errors++errorMsgCollect         :: IOStateArrow s b b+errorMsgCollect         = setErrorMsgHandler True (const $ return ())++-- | error message handler for output to stderr and collecting++errorMsgStderrAndCollect        :: IOStateArrow s b b+errorMsgStderrAndCollect        = setErrorMsgHandler True (hPutStrLn stderr)++-- | error message handler for ignoring errors++errorMsgIgnore          :: IOStateArrow s b b+errorMsgIgnore          = setErrorMsgHandler False (const $ return ())++-- |+-- if error messages are collected by the error handler for+-- processing these messages by the calling application,+-- this arrow reads the stored messages and clears the error message store++getErrorMessages        :: IOStateArrow s b XmlTree+getErrorMessages        = getSysVar theErrorMsgList+                          >>>+                          configSysVar (setS theErrorMsgList [])+                          >>>+                          arrL reverse++addToErrorMsgList       :: IOStateArrow s XmlTree XmlTree+addToErrorMsgList       = chgSysVar+                          ( theErrorMsgCollect .&&&. theErrorMsgList )+                          ( \ e (cs, es) -> (cs, if cs then e : es else es) )++-- ------------------------------------------------------------++-- |+-- filter error messages from input trees and issue errors++filterErrorMsg          :: IOStateArrow s XmlTree XmlTree+filterErrorMsg          = ( setErrMsgStatus+                            >>>+                            sysErrorMsg+                            >>>+                            addToErrorMsgList+                            >>>+                            none+                          )+                          `when`+                          isError++-- | generate a warnig message++issueWarn               :: String -> IOStateArrow s b b+issueWarn msg           = perform (warn msg  >>> filterErrorMsg)++-- | generate an error message+issueErr                :: String -> IOStateArrow s b b+issueErr msg            = perform (err msg   >>> filterErrorMsg)++-- | generate a fatal error message, e.g. document not found++issueFatal              :: String -> IOStateArrow s b b+issueFatal msg          = perform (fatal msg >>> filterErrorMsg)++-- | Default exception handler: issue a fatal error message and fail.+--+-- The parameter can be used to specify where the error occured++issueExc                :: String -> IOStateArrow s SomeException b+issueExc m              = ( issueFatal $< arr  ((msg ++) . show) )+                          >>>+                          none+    where+    msg | null m        = "Exception: "+        | otherwise     = "Exception in " ++ m ++ ": "++-- |+-- add the error level and the module where the error occured+-- to the attributes of a document root node and remove the children when level is greater or equal to 'c_err'.+-- called by 'setDocumentStatusFromSystemState' when the system state indicates an error++setDocumentStatus       :: Int -> String -> IOStateArrow s XmlTree XmlTree+setDocumentStatus level msg+                        = ( addAttrl ( sattr a_status (show level)+                                       <+>+                                       sattr a_module msg+                                     )+                            >>>+                            ( if level >= c_err+                              then setChildren []+                              else this+                            )+                          )+                      `when`+                      isRoot++-- |+-- check whether the error level attribute in the system state+-- is set to error, in this case the children of the document root are+-- removed and the module name where the error occured and the error level are added as attributes with 'setDocumentStatus'+-- else nothing is changed++setDocumentStatusFromSystemState        :: String -> IOStateArrow s XmlTree XmlTree+setDocumentStatusFromSystemState msg+                                = setStatus $< getErrStatus+    where+    setStatus level+        | level <= c_warn       = this+        | otherwise             = setDocumentStatus level msg+++-- |+-- check whether tree is a document root and the status attribute has a value less than 'c_err'++documentStatusOk        :: ArrowXml a => a XmlTree XmlTree+documentStatusOk        = isRoot+                          >>>+                          ( (getAttrValue a_status+                             >>>+                             isA (\ v -> null v || ((read v)::Int) <= c_warn)+                            )+                            `guards`+                            this+                          )++-- ------------------------------------------------------------++errorOutputToStderr     :: String -> IO ()+errorOutputToStderr msg+                        = do+                          hPutStrLn stderr msg+                          hFlush stderr++-- ------------------------------------------------------------
+ src/Text/XML/HXT/Arrow/XmlState/MimeTypeTable.hs view
@@ -0,0 +1,60 @@+-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.Arrow.XmlState.MimeTypeTable+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   the mime type configuration functions++-}++-- ------------------------------------------------------------++module Text.XML.HXT.Arrow.XmlState.MimeTypeTable+where++import Control.Arrow                            -- arrow classes+import Control.Arrow.ArrowList+import Control.Arrow.ArrowIO++import Text.XML.HXT.DOM.Interface++import Text.XML.HXT.Arrow.XmlState.TypeDefs++-- ------------------------------------------------------------++-- | set the table mapping of file extensions to mime types in the system state+--+-- Default table is defined in 'Text.XML.HXT.DOM.MimeTypeDefaults'.+-- This table is used when reading loacl files, (file: protocol) to determine the mime type++setMimeTypeTable                :: MimeTypeTable -> IOStateArrow s b b+setMimeTypeTable mtt            = configSysVar $ setS (theMimeTypes .&&&. theMimeTypeFile) (mtt, "")++-- | set the table mapping of file extensions to mime types by an external config file+--+-- The config file must follow the conventions of /etc/mime.types on a debian linux system,+-- that means all empty lines and all lines starting with a # are ignored. The other lines+-- must consist of a mime type followed by a possible empty list of extensions.+-- The list of extenstions and mime types overwrites the default list in the system state+-- of the IOStateArrow++setMimeTypeTableFromFile        :: FilePath -> IOStateArrow s b b+setMimeTypeTableFromFile file   = configSysVar $ setS theMimeTypeFile file++-- | read the system mimetype table++getMimeTypeTable                :: IOStateArrow s b MimeTypeTable+getMimeTypeTable                = getMime $< getSysVar (theMimeTypes .&&&. theMimeTypeFile)+    where+    getMime (mtt, "")           = constA mtt+    getMime (_,  mtf)           = perform (setMimeTypeTable $< arrIO0 ( readMimeTypeTable mtf))+                                  >>>+                                  getMimeTypeTable++-- ------------------------------------------------------------
+ src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs view
@@ -0,0 +1,252 @@+-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.Arrow.XmlState.RunIOStateArrow+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   run an io state arrow+-}++-- ------------------------------------------------------------++module Text.XML.HXT.Arrow.XmlState.RunIOStateArrow+where++import Control.Arrow                            -- arrow classes+import Control.Arrow.ArrowList+import Control.Arrow.IOStateListArrow++import Data.Map                                 ( empty )+import Text.XML.HXT.DOM.Interface++import Text.XML.HXT.Arrow.XmlArrow+import Text.XML.HXT.Arrow.XmlState.ErrorHandling+import Text.XML.HXT.Arrow.XmlState.TraceHandling+import Text.XML.HXT.Arrow.XmlState.TypeDefs++-- ------------------------------------------------------------++-- |+-- apply an 'IOSArrow' to an empty root node with 'initialState' () as initial state+--+-- the main entry point for running a state arrow with IO+--+-- when running @ runX f@ an empty XML root node is applied to @f@.+-- usually @f@ will start with a constant arrow (ignoring the input), e.g. a 'Text.XML.HXT.Arrow.ReadDocument.readDocument' arrow.+--+-- for usage see examples with 'Text.XML.HXT.Arrow.WriteDocument.writeDocument'+--+-- if input has to be feed into the arrow use 'Control.Arrow.IOStateListArrow.runIOSLA' like in @ runIOSLA f emptyX inputDoc @++runX            :: IOSArrow XmlTree c -> IO [c]+runX            = runXIOState (initialState ())+++runXIOState     :: XIOState s -> IOStateArrow s XmlTree c -> IO [c]+runXIOState s0 f+    = do+      (_finalState, res) <- runIOSLA (emptyRoot >>> f) s0 undefined+      return res+    where+    emptyRoot    = root [] []+++-- | the default global state, used as initial state when running an 'IOSArrow' with 'runIOSLA' or+-- 'runX'++initialState    :: us -> XIOState us+initialState s  = XIOState { xioSysState       = initialSysState+                           , xioUserState      = s+                           }++-- ------------------------------------------------------------++initialSysState                 :: XIOSysState+initialSysState                 = XIOSys+                                  { xioSysWriter         = initialSysWriter+                                  , xioSysEnv            = initialSysEnv+                                  }++initialSysWriter                :: XIOSysWriter+initialSysWriter                = XIOwrt+                                  { xioErrorStatus       = c_ok+                                  , xioErrorMsgList      = []+                                  , xioExpatErrors       = none+                                  , xioRelaxNoOfErrors   = 0+                                  , xioRelaxDefineId     = 0+                                  , xioRelaxAttrList     = []+                                  }++initialSysEnv                   :: XIOSysEnv+initialSysEnv                   = XIOEnv+                                  { xioTraceLevel        = 0+                                  , xioTraceCmd          = traceOutputToStderr+                                  , xioErrorMsgHandler   = errorOutputToStderr+                                  , xioErrorMsgCollect   = False+                                  , xioBaseURI           = ""+                                  , xioDefaultBaseURI    = ""+                                  , xioAttrList          = []+                                  , xioInputConfig       = initialInputConfig+                                  , xioParseConfig       = initialParseConfig+                                  , xioOutputConfig      = initialOutputConfig+                                  , xioRelaxConfig       = initialRelaxConfig+                                  , xioXmlSchemaConfig   = initialXmlSchemaConfig+                                  , xioCacheConfig       = initialCacheConfig+                                  }++initialInputConfig              :: XIOInputConfig+initialInputConfig              = XIOIcgf+                                  { xioStrictInput       = False+                                  , xioEncodingErrors    = True+                                  , xioInputEncoding     = ""+                                  , xioHttpHandler       = dummyHTTPHandler+                                  , xioInputOptions      = []+                                  , xioRedirect          = False+                                  , xioProxy             = ""+                                  }++initialParseConfig              :: XIOParseConfig+initialParseConfig              = XIOPcfg+                                  { xioMimeTypes                = defaultMimeTypeTable+                                  , xioMimeTypeHandlers         = empty+                                  , xioMimeTypeFile             = ""+                                  , xioAcceptedMimeTypes        = []+                                  , xioFileMimeType             = ""+                                  , xioWarnings                 = True+                                  , xioRemoveWS                 = False+                                  , xioParseByMimeType          = False+                                  , xioParseHTML                = False+                                  , xioLowerCaseNames           = False+                                  , xioTagSoup                  = False+                                  , xioPreserveComment          = False+                                  , xioValidate                 = True+                                  , xioSubstDTDEntities         = True+                                  , xioSubstHTMLEntities        = False+                                  , xioCheckNamespaces          = False+                                  , xioCanonicalize             = True+                                  , xioIgnoreNoneXmlContents    = False+                                  , xioTagSoupParser            = dummyTagSoupParser+                                  , xioExpat                    = False+                                  , xioExpatParser              = dummyExpatParser+                                  }++initialOutputConfig             :: XIOOutputConfig+initialOutputConfig             = XIOOcfg+                                  { xioIndent                   = False+                                  , xioOutputEncoding           = ""+                                  , xioOutputFmt                = XMLoutput+                                  , xioXmlPi                    = True+                                  , xioNoEmptyElemFor           = []+                                  , xioAddDefaultDTD            = False+                                  , xioTextMode                 = False+                                  , xioShowTree                 = False+                                  , xioShowHaskell              = False+                                  }++initialRelaxConfig              :: XIORelaxConfig+initialRelaxConfig              = XIORxc+                                  { xioRelaxValidate            = False+                                  , xioRelaxSchema              = ""+                                  , xioRelaxCheckRestr          = True+                                  , xioRelaxValidateExtRef      = True+                                  , xioRelaxValidateInclude     = True+                                  , xioRelaxCollectErrors       = True+                                  , xioRelaxValidator           = dummyRelaxValidator+                                  }++initialXmlSchemaConfig          :: XIOXmlSchemaConfig+initialXmlSchemaConfig          = XIOScc+                                  { xioXmlSchemaValidate        = False+                                  , xioXmlSchemaSchema          = ""+                                  , xioXmlSchemaValidator       = dummyXmlSchemaValidator+                                  }++initialCacheConfig              :: XIOCacheConfig+initialCacheConfig              = XIOCch+                                   { xioBinaryCompression       = id+                                   , xioBinaryDeCompression     = id+                                   , xioWithCache               = False+                                   , xioCacheDir                = ""+                                   , xioDocumentAge             = 0+                                   , xioCache404Err             = False+                                   , xioCacheRead               = dummyCacheRead+                                   , xioStrictDeserialize       = False+                                   }++-- ------------------------------------------------------------++dummyHTTPHandler        :: IOSArrow XmlTree XmlTree+dummyHTTPHandler        = ( issueFatal $+                            unlines $+                            [ "HTTP handler not configured,"+                            , "please install package hxt-curl and use 'withCurl' config option"+                            , "or install package hxt-http and use 'withHTTP' config option"+                            ]+                          )+                          >>>+                          addAttr transferMessage "HTTP handler not configured"+                          >>>+                          addAttr transferStatus "999"+++dummyTagSoupParser      :: IOSArrow b b+dummyTagSoupParser      =  issueFatal $+                           unlines $+                           [ "TagSoup parser not configured,"+                           , "please install package hxt-tagsoup"+                           , " and use 'withTagSoup' parser config option from this package"+                           ]++dummyExpatParser        :: IOSArrow b b+dummyExpatParser        =  issueFatal $+                           unlines $+                           [ "Expat parser not configured,"+                           , "please install package hxt-expat"+                           , " and use 'withExpat' parser config option from this package"+                           ]++dummyRelaxValidator     :: IOSArrow b b+dummyRelaxValidator     =  issueFatal $+                           unlines $+                           [ "RelaxNG validator not configured,"+                           , "please install package hxt-relaxng"+                           , " and use 'withRelaxNG' config option from this package"+                           ]++dummyXmlSchemaValidator :: IOSArrow b b+dummyXmlSchemaValidator =  issueFatal $+                           unlines $+                           [ "XML Schema validator not configured,"+                           , "please install package hxt-xmlschema"+                           , " and use 'withXmlSchema' config option from this package"+                           ]++dummyCacheRead          :: String -> IOSArrow b b+dummyCacheRead          = const $+                          issueFatal $+                          unlines $+                          [ "Document cache not configured,"+                          , "please install package hxt-cache and use 'withCache' config option"+                          ]++-- ------------------------------------------------------------++getConfigAttr           :: String -> SysConfigList -> String+getConfigAttr n c       = lookup1 n $ tl+    where+    s                   = (foldr (>>>) id c) initialSysState+    tl                  = getS theAttrList s++-- ----------------------------------------++theSysConfigComp        :: Selector XIOSysState a -> Selector SysConfig a+theSysConfigComp sel    = S { getS = \     cf -> getS sel      (cf initialSysState)+                            , setS = \ val cf -> setS sel val . cf+                            }++-- ------------------------------------------------------------
+ src/Text/XML/HXT/Arrow/XmlState/SystemConfig.hs view
@@ -0,0 +1,273 @@+-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.Arrow.XmlState.SystemConfig+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   system configuration and common options options++-}++-- ------------------------------------------------------------++module Text.XML.HXT.Arrow.XmlState.SystemConfig+where++import Control.Arrow++import Data.Map                         ( insert )++import Text.XML.HXT.DOM.Interface++import Text.XML.HXT.Arrow.XmlState.ErrorHandling+import Text.XML.HXT.Arrow.XmlState.TypeDefs++-- ------------------------------++-- config options++-- | @withTrace level@ : system option, set the trace level, (0..4)++withTrace                       :: Int -> SysConfig+withTrace                       = setS theTraceLevel++-- | @withSysAttr key value@ : store an arbitrary key value pair in system state++withSysAttr                     :: String -> String -> SysConfig+withSysAttr n v                 = chgS theAttrList (addEntry n v)++-- | Specify the set of accepted mime types.+--+-- All contents of documents for which the mime type is not found in this list+-- are discarded.++withAcceptedMimeTypes           :: [String] -> SysConfig+withAcceptedMimeTypes           = setS theAcceptedMimeTypes++-- | Specify a content handler for documents of a given mime type++withMimeTypeHandler             :: String -> IOSArrow XmlTree XmlTree -> SysConfig+withMimeTypeHandler mt pa       = chgS theMimeTypeHandlers $ insert mt pa++-- | @withMimeTypeFile filename@ : input option,+-- set the mime type table for @file:@ documents by given file.+-- The format of this config file must be in the syntax of a debian linux \"mime.types\" config file++withMimeTypeFile                :: String -> SysConfig+withMimeTypeFile                = setS theMimeTypeFile++-- | Force a given mime type for all file contents.+--+-- The mime type for file access will then not be computed by looking into a mime.types file++withFileMimeType                :: String -> SysConfig+withFileMimeType                = setS theFileMimeType++-- | @withWarnings yes/no@ : system option, issue warnings during reading, HTML parsing and processing,+-- default is 'yes'++withWarnings                    :: Bool -> SysConfig+withWarnings                    = setS theWarnings++-- | @withErrors yes/no@ : system option for suppressing error messages, default is 'no'++withErrors                      :: Bool -> SysConfig+withErrors b                    = setS theErrorMsgHandler h+    where+    h | b                       = errorOutputToStderr+      | otherwise               = const $ return ()++-- | @withRemoveWS yes/no@ : read and write option, remove all whitespace, used for document indentation, default is 'no'++withRemoveWS                    :: Bool -> SysConfig+withRemoveWS                    = setS theRemoveWS++-- | @withPreserveComment yes/no@ : read option, preserve comments during canonicalization, default is 'no'++withPreserveComment             :: Bool -> SysConfig+withPreserveComment             = setS thePreserveComment++-- | @withParseByMimeType yes/no@  : read option, select the parser by the mime type of the document+-- (pulled out of the HTTP header).+--+-- When the mime type is set to \"text\/html\"+-- the configured HTML parser is taken, when it\'s set to+-- \"text\/xml\" or \"text\/xhtml\" the configured XML parser is taken.+-- If the mime type is something else, no further processing is performed,+-- the contents is given back to the application in form of a single text node.+-- If the default document encoding is set to isoLatin1, this even enables processing+-- of arbitray binary data.++withParseByMimeType             :: Bool -> SysConfig+withParseByMimeType             = setS theParseByMimeType++-- | @withParseHTML yes/no@: read option, use HTML parser, default is 'no' (use XML parser)++withParseHTML                   :: Bool -> SysConfig+withParseHTML                   = setS theParseHTML++-- | @withValidate yes/no@: read option, validate document against DTD, default is 'yes'++withValidate                    :: Bool -> SysConfig+withValidate                    = setS theValidate++-- | @withSubstDTDEntities yes/no@: read option, substitute general entities defined in DTD, default is 'yes'.+-- switching this option and the validate option off can lead to faster parsing, because then+-- there is no need to access the DTD++withSubstDTDEntities            :: Bool -> SysConfig+withSubstDTDEntities            = setS theSubstDTDEntities++-- | @withSubstHTMLEntities yes/no@: read option, substitute general entities defined in HTML DTD, default is 'no'.+-- switching this option on and the substDTDEntities and validate options off can lead to faster parsing+-- because there is no need to access a DTD, but still the HTML general entities are substituted++withSubstHTMLEntities            :: Bool -> SysConfig+withSubstHTMLEntities            = setS theSubstHTMLEntities++-- | @withCheckNamespaces yes/no@: read option, check namespaces, default is 'no'++withCheckNamespaces             :: Bool -> SysConfig+withCheckNamespaces             = setS theCheckNamespaces++-- | @withCanonicalize yes/no@ : read option, canonicalize document, default is 'yes'++withCanonicalize                :: Bool -> SysConfig+withCanonicalize                = setS theCanonicalize++-- | @withIgnoreNoneXmlContents yes\/no@ : input option, ignore document contents of none XML\/HTML documents.+--+-- This option can be useful for implementing crawler like applications, e.g. an URL checker.+-- In those cases net traffic can be reduced.++withIgnoreNoneXmlContents       :: Bool -> SysConfig+withIgnoreNoneXmlContents       = setS theIgnoreNoneXmlContents++-- ------------------------------------------------------------++-- | @withStrictInput yes/no@ : input option, input of file and HTTP contents is read eagerly, default is 'no'++withStrictInput                 :: Bool -> SysConfig+withStrictInput                 = setS theStrictInput++-- | @withEncodingErrors yes/no@ : input option, ignore all encoding errors, default is 'no'++withEncodingErrors              :: Bool -> SysConfig+withEncodingErrors              = setS theEncodingErrors++-- | @withInputEncoding encodingName@ : input option+--+-- Set default document encoding ('utf8', 'isoLatin1', 'usAscii', 'iso8859_2', ... , 'iso8859_16', ...).+-- Only XML, HTML and text documents are decoded,+-- default decoding for XML\/HTML is utf8, for text iso latin1 (no decoding).++withInputEncoding               :: String -> SysConfig+withInputEncoding               = setS theInputEncoding++-- | @withDefaultBaseURI URI@ , input option, set the default base URI+--+-- This option can be useful when parsing documents from stdin or contained in a string, and interpreting+-- relative URIs within the document++withDefaultBaseURI              :: String -> SysConfig+withDefaultBaseURI              = setS theDefaultBaseURI++withInputOption                 :: String -> String -> SysConfig+withInputOption n v             = chgS theInputOptions (addEntry n v)++withInputOptions                :: Attributes -> SysConfig+withInputOptions                = foldr (>>>) id . map (uncurry withInputOption)++-- | @withRedirect yes/no@ : input option, automatically follow redirected URIs, default is 'yes'++withRedirect                    :: Bool -> SysConfig+withRedirect                    = setS theRedirect++-- | @withProxy \"host:port\"@ : input option, configure a proxy for HTTP access, e.g. www-cache:3128++withProxy                       :: String -> SysConfig+withProxy                       = setS theProxy++-- ------------------------------------------------------------++-- | @withIndent yes/no@ : output option, indent document before output, default is 'no'++withIndent                      :: Bool -> SysConfig+withIndent                      = setS theIndent++-- | @withOutputEncoding encoding@ , output option,+-- default is the default input encoding or utf8, if input encoding is not set++withOutputEncoding              :: String -> SysConfig+withOutputEncoding              = setS theOutputEncoding++-- | @withOutputXML@ : output option, default writing+--+-- Default is writing XML: quote special XML chars \>,\<,\",\',& where neccessary,+-- add XML processing instruction+-- and encode document with respect to 'withOutputEncoding'++withOutputXML                   :: SysConfig+withOutputXML                   = setS theOutputFmt XMLoutput++-- | Write XHTML: quote all special XML chars, use HTML entity refs or char refs for none ASCII chars++withOutputHTML                  :: SysConfig+withOutputHTML                  = setS theOutputFmt HTMLoutput++-- | Write XML: quote only special XML chars, don't substitute chars by HTML entities,+-- and don\'t generate empty elements for HTML elements,+-- which may contain any contents, e.g. @<script src=...></script>@ instead of @<script src=... />@++withOutputXHTML                 :: SysConfig+withOutputXHTML                 = setS theOutputFmt XHTMLoutput++-- | suppreses all char and entitiy substitution++withOutputPLAIN                 :: SysConfig+withOutputPLAIN                 = setS theOutputFmt PLAINoutput++withXmlPi                       :: Bool -> SysConfig+withXmlPi                       = setS theXmlPi++withNoEmptyElemFor              :: [String] -> SysConfig+withNoEmptyElemFor              = setS theNoEmptyElemFor++withAddDefaultDTD               :: Bool -> SysConfig+withAddDefaultDTD               = setS theAddDefaultDTD++withTextMode                    :: Bool -> SysConfig+withTextMode                    = setS theTextMode++withShowTree                    :: Bool -> SysConfig+withShowTree                    = setS theShowTree++withShowHaskell                 :: Bool -> SysConfig+withShowHaskell                 = setS theShowHaskell++-- | Configure compression and decompression for binary serialization/deserialization.+-- First component is the compression function applied after serialization,+-- second the decompression applied before deserialization.++withCompression                 :: (CompressionFct, DeCompressionFct) -> SysConfig+withCompression                 = setS (theBinaryCompression .&&&. theBinaryDeCompression)++-- | Strict input for deserialization of binary data++withStrictDeserialize           :: Bool -> SysConfig+withStrictDeserialize           = setS theStrictDeserialize++-- ------------------------------------------------------------++yes                             :: Bool+yes                             = True++no                              :: Bool+no                              = False++-- ------------------------------------------------------------
+ src/Text/XML/HXT/Arrow/XmlState/TraceHandling.hs view
@@ -0,0 +1,150 @@+-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.Arrow.XmlState.TraceHandling+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   the trace arrows++-}++-- ------------------------------------------------------------++module Text.XML.HXT.Arrow.XmlState.TraceHandling+where++import Control.Arrow                            -- arrow classes+import Control.Arrow.ArrowList+import Control.Arrow.ArrowIf+import Control.Arrow.ArrowTree+import Control.Arrow.ArrowIO++import System.IO                        ( hPutStrLn+                                        , hFlush+                                        , stderr+                                        )++import Text.XML.HXT.DOM.Interface++import Text.XML.HXT.Arrow.XmlArrow+import Text.XML.HXT.Arrow.XmlState.TypeDefs+import Text.XML.HXT.Arrow.XmlState.SystemConfig++import Text.XML.HXT.Arrow.Edit          ( addHeadlineToXmlDoc+                                        , treeRepOfXmlDoc+                                        , indentDoc+                                        )++-- ------------------------------------------------------------++-- | set the global trace level++setTraceLevel           :: Int -> IOStateArrow s b b+setTraceLevel l         = configSysVar $ withTrace l++-- | read the global trace level++getTraceLevel           :: IOStateArrow s b Int+getTraceLevel           = getSysVar theTraceLevel++-- | set the global trace command. This command does the trace output++setTraceCmd             :: (Int -> String -> IO ()) -> IOStateArrow s b b+setTraceCmd c           = configSysVar $ setS theTraceCmd c++-- | acces the command for trace output++getTraceCmd             :: IOStateArrow a b (Int -> String -> IO ())+getTraceCmd             = getSysVar theTraceCmd++-- | run an arrow with a given trace level, the old trace level is restored after the arrow execution++withTraceLevel          :: Int -> IOStateArrow s b c -> IOStateArrow s b c+withTraceLevel level f  = localSysEnv $ setTraceLevel level >>> f++-- | apply a trace arrow and issue message to stderr++trace                   :: Int -> IOStateArrow s b String -> IOStateArrow s b b+trace level trc         = perform ( trc+                                    >>>+                                    ( getTraceCmd &&& this )+                                    >>>+                                    arrIO (\ (cmd, msg) -> cmd level msg)+                                  )+                          `when` ( getTraceLevel+                                   >>>+                                   isA (>= level)+                                 )++-- | trace the current value transfered in a sequence of arrows.+--+-- The value is formated by a string conversion function. This is a substitute for+-- the old and less general traceString function++traceValue              :: Int -> (b -> String) -> IOStateArrow s b b+traceValue level trc    = trace level (arr $ (('-' : "- (" ++ show level ++ ") ") ++) . trc)++-- | an old alias for 'traceValue'++traceString             :: Int -> (b -> String) -> IOStateArrow s b b+traceString             = traceValue++-- | issue a string message as trace++traceMsg                :: Int -> String -> IOStateArrow s b b+traceMsg level msg      = traceValue level (const msg)++-- | issue the source representation of a document if trace level >= 3+--+-- for better readability the source is formated with indentDoc++traceSource             :: IOStateArrow s XmlTree XmlTree+traceSource             = trace 3 $+                          xshow $+                          choiceA [ isRoot :-> ( indentDoc+                                                 >>>+                                                 getChildren+                                               )+                                  , isElem :-> ( root [] [this]+                                                 >>> indentDoc+                                                 >>> getChildren+                                                 >>> isElem+                                               )+                                  , this   :-> this+                                  ]++-- | issue the tree representation of a document if trace level >= 4+traceTree               :: IOStateArrow s XmlTree XmlTree+traceTree               = trace 4 $+                          xshow $+                          treeRepOfXmlDoc+                          >>>+                          addHeadlineToXmlDoc+                          >>>+                          getChildren++-- | trace a main computation step+-- issue a message when trace level >= 1, issue document source if level >= 3, issue tree when level is >= 4++traceDoc                :: String -> IOStateArrow s XmlTree XmlTree+traceDoc msg            = traceMsg 1 msg+                          >>>+                          traceSource+                          >>>+                          traceTree++-- ----------------------------------------------------------++traceOutputToStderr     :: Int -> String -> IO ()+traceOutputToStderr _level msg+                        = do+                          hPutStrLn stderr msg+                          hFlush stderr++-- ----------------------------------------------------------+
+ src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs view
@@ -0,0 +1,910 @@+-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.Arrow.XmlState.TypeDefs+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   the basic state arrows for XML processing++   A state is needed for global processing options,+   like encoding options, document base URI, trace levels+   and error message handling++   The state is separated into a user defined state+   and a system state. The system state contains variables+   for error message handling, for tracing, for the document base+   for accessing XML documents with relative references, e.g. DTDs,+   and a global key value store. This assoc list has strings as keys+   and lists of XmlTrees as values. It is used to store arbitrary+   XML and text values, e.g. user defined global options.++   The user defined part of the store is in the default case empty, defined as ().+   It can be extended with an arbitray data type++-}++-- ------------------------------------------------------------++module Text.XML.HXT.Arrow.XmlState.TypeDefs+    ( module Text.XML.HXT.Arrow.XmlState.TypeDefs+    , Selector(..)+    , chgS+    , idS+    , (.&&&.)+    )+where++import           Control.Arrow+import           Control.Arrow.ArrowList+import           Control.Arrow.IOStateListArrow+import           Control.DeepSeq++import           Data.ByteString.Lazy           (ByteString)+import           Data.Char                      (isDigit)+import           Data.Function.Selector         (Selector (..), chgS, idS,+                                                 (.&&&.))+import qualified Data.Map                       as M++import           Text.XML.HXT.DOM.Interface++-- ------------------------------------------------------------+{- datatypes -}++-- |+-- state datatype consists of a system state and a user state+-- the user state is not fixed++data XIOState us        = XIOState { xioSysState  :: !XIOSysState+                                   , xioUserState :: !us+                                   }++instance (NFData us) => NFData (XIOState us) where+    rnf (XIOState sys usr)      = rnf sys `seq` rnf usr++-- |+-- The arrow type for stateful arrows++type IOStateArrow s b c = IOSLA (XIOState s) b c++-- |+-- The arrow for stateful arrows with no user defined state++type IOSArrow b c       = IOStateArrow () b c++-- ------------------------------------------------------------++-- user state functions++-- | read the user defined part of the state++getUserState    :: IOStateArrow s b s+getUserState+    = IOSLA $ \ s _ ->+      return (s, [xioUserState s])++-- | change the user defined part of the state++changeUserState         :: (b -> s -> s) -> IOStateArrow s b b+changeUserState cf+    = IOSLA $ \ s v ->+      let s' = s { xioUserState = cf v (xioUserState s) }+      in return (s', [v])++-- | set the user defined part of the state++setUserState            :: IOStateArrow s s s+setUserState+    = changeUserState const++-- | extend user state+--+-- Run an arrow with an extended user state component, The old component+-- is stored together with a new one in a pair, the arrow is executed with this+-- extended state, and the augmented state component is removed form the state+-- when the arrow has finished its execution++withExtendedUserState   :: s1 -> IOStateArrow (s1, s0) b c -> IOStateArrow s0 b c+withExtendedUserState initS1 f+    = IOSLA $ \ s0 x ->+      do+      ~(finalS, res) <- runIOSLA f ( XIOState { xioSysState  =          xioSysState  s0+                                              , xioUserState = (initS1, xioUserState s0)+                                              }+                                   ) x+      return ( XIOState { xioSysState  =      xioSysState  finalS+                        , xioUserState = snd (xioUserState finalS)+                        }+             , res+             )++-- | change the type of user state+--+-- This conversion is useful, when running a state arrow with another+-- structure of the user state, e.g. with () when executing some IO arrows++withOtherUserState      :: s1 -> IOStateArrow s1 b c -> IOStateArrow s0 b c+withOtherUserState s1 f+    = IOSLA $ \ s x ->+      do+      (s', res) <- runIOSLA f ( XIOState { xioSysState  = xioSysState s+                                         , xioUserState = s1+                                         }+                              ) x+      return ( XIOState { xioSysState  = xioSysState  s'+                        , xioUserState = xioUserState s+                        }+             , res+             )++withoutUserState      :: IOSArrow b c -> IOStateArrow s0 b c+withoutUserState      = withOtherUserState ()++-- ------------------------------------------------------------++-- system state structure and acces functions++-- |+-- predefined system state data type with all components for the+-- system functions, like trace, error handling, ...++data XIOSysState        = XIOSys  { xioSysWriter :: !XIOSysWriter+                                  , xioSysEnv    :: !XIOSysEnv+                                  }++instance NFData XIOSysState where+    rnf x = seq x ()    -- all fields of interest are strict++data XIOSysWriter       = XIOwrt  { xioErrorStatus     :: !Int+                                  , xioErrorMsgList    :: !XmlTrees+                                  , xioExpatErrors     ::  IOSArrow XmlTree XmlTree+                                  , xioRelaxNoOfErrors :: !Int+                                  , xioRelaxDefineId   :: !Int+                                  , xioRelaxAttrList   ::  AssocList String XmlTrees+                                  }++data XIOSysEnv          = XIOEnv  { xioTraceLevel      :: !Int+                                  , xioTraceCmd        ::  Int -> String -> IO ()+                                  , xioErrorMsgHandler ::  String -> IO ()+                                  , xioErrorMsgCollect :: !Bool+                                  , xioBaseURI         :: !String+                                  , xioDefaultBaseURI  :: !String+                                  , xioAttrList        :: !Attributes+                                  , xioInputConfig     :: !XIOInputConfig+                                  , xioParseConfig     :: !XIOParseConfig+                                  , xioOutputConfig    :: !XIOOutputConfig+                                  , xioRelaxConfig     :: !XIORelaxConfig+                                  , xioXmlSchemaConfig :: !XIOXmlSchemaConfig+                                  , xioCacheConfig     :: !XIOCacheConfig+                                  }++data XIOInputConfig     = XIOIcgf { xioStrictInput    :: !Bool+                                  , xioEncodingErrors :: !Bool+                                  , xioInputEncoding  ::  String+                                  , xioHttpHandler    ::  IOSArrow XmlTree XmlTree+                                  , xioInputOptions   :: !Attributes+                                  , xioRedirect       :: !Bool+                                  , xioProxy          ::  String+                                  }++data XIOParseConfig     = XIOPcfg { xioMimeTypes             ::  MimeTypeTable+                                  , xioMimeTypeHandlers      ::  MimeTypeHandlers+                                  , xioMimeTypeFile          ::  String+                                  , xioAcceptedMimeTypes     ::  [String]+                                  , xioFileMimeType          ::  String+                                  , xioWarnings              :: !Bool+                                  , xioRemoveWS              :: !Bool+                                  , xioParseByMimeType       :: !Bool+                                  , xioParseHTML             :: !Bool+                                  , xioLowerCaseNames        :: !Bool+                                  , xioPreserveComment       :: !Bool+                                  , xioValidate              :: !Bool+                                  , xioSubstDTDEntities      :: !Bool+                                  , xioSubstHTMLEntities     :: !Bool+                                  , xioCheckNamespaces       :: !Bool+                                  , xioCanonicalize          :: !Bool+                                  , xioIgnoreNoneXmlContents :: !Bool+                                  , xioTagSoup               :: !Bool+                                  , xioTagSoupParser         ::  IOSArrow XmlTree XmlTree+                                  , xioExpat                 :: !Bool+                                  , xioExpatParser           ::  IOSArrow XmlTree XmlTree+                                  }++data XIOOutputConfig    = XIOOcfg { xioIndent         :: !Bool+                                  , xioOutputEncoding :: !String+                                  , xioOutputFmt      :: !XIOXoutConfig+                                  , xioXmlPi          :: !Bool+                                  , xioNoEmptyElemFor :: ![String]+                                  , xioAddDefaultDTD  :: !Bool+                                  , xioTextMode       :: !Bool+                                  , xioShowTree       :: !Bool+                                  , xioShowHaskell    :: !Bool+                                  }+data XIOXoutConfig      = XMLoutput | XHTMLoutput | HTMLoutput | PLAINoutput+                          deriving (Eq)++data XIORelaxConfig     = XIORxc  { xioRelaxValidate        :: !Bool+                                  , xioRelaxSchema          ::  String+                                  , xioRelaxCheckRestr      :: !Bool+                                  , xioRelaxValidateExtRef  :: !Bool+                                  , xioRelaxValidateInclude :: !Bool+                                  , xioRelaxCollectErrors   :: !Bool+                                  , xioRelaxValidator       ::  IOSArrow XmlTree XmlTree+                                  }++data XIOXmlSchemaConfig = XIOScc  { xioXmlSchemaValidate  :: !Bool+                                  , xioXmlSchemaSchema    ::  String+                                  , xioXmlSchemaValidator ::  IOSArrow XmlTree XmlTree+                                  }++data XIOCacheConfig     = XIOCch  { xioBinaryCompression   ::  CompressionFct+                                  , xioBinaryDeCompression ::  DeCompressionFct+                                  , xioWithCache           :: !Bool+                                  , xioCacheDir            :: !String+                                  , xioDocumentAge         :: !Int+                                  , xioCache404Err         :: !Bool+                                  , xioCacheRead           ::  String -> IOSArrow XmlTree XmlTree+                                  , xioStrictDeserialize   :: !Bool+                                  }++type MimeTypeHandlers   = M.Map String (IOSArrow XmlTree XmlTree)++type CompressionFct     = ByteString -> ByteString+type DeCompressionFct   = ByteString -> ByteString++type SysConfig          = XIOSysState -> XIOSysState+type SysConfigList      = [SysConfig]++-- ----------------------------------------++theSysState                     :: Selector (XIOState us) XIOSysState+theSysState                     = S { getS = xioSysState+                                    , setS = \ x s -> s { xioSysState = x}+                                    }++theUserState                    :: Selector (XIOState us) us+theUserState                    = S { getS = xioUserState+                                    , setS = \ x s -> s { xioUserState = x}+                                    }++-- ----------------------------------------++theSysWriter                    :: Selector XIOSysState XIOSysWriter+theSysWriter                    = S { getS = xioSysWriter+                                    , setS = \ x s -> s { xioSysWriter = x}+                                    }++theErrorStatus                  :: Selector XIOSysState Int+theErrorStatus                  = theSysWriter+                                  >>>+                                  S { getS = xioErrorStatus+                                    , setS = \ x s -> s { xioErrorStatus = x }+                                    }++theErrorMsgList                 :: Selector XIOSysState XmlTrees+theErrorMsgList                 = theSysWriter+                                  >>>+                                  S { getS = xioErrorMsgList+                                    , setS = \ x s -> s { xioErrorMsgList = x }+                                    }++theRelaxNoOfErrors              :: Selector XIOSysState Int+theRelaxNoOfErrors              = theSysWriter+                                  >>>+                                  S { getS = xioRelaxNoOfErrors+                                    , setS = \ x s -> s { xioRelaxNoOfErrors = x}+                                    }++theRelaxDefineId                :: Selector XIOSysState Int+theRelaxDefineId                = theSysWriter+                                  >>>+                                  S { getS = xioRelaxDefineId+                                    , setS = \ x s -> s { xioRelaxDefineId = x}+                                    }++theRelaxAttrList                :: Selector XIOSysState (AssocList String XmlTrees)+theRelaxAttrList                = theSysWriter+                                  >>>+                                  S { getS = xioRelaxAttrList+                                    , setS = \ x s -> s { xioRelaxAttrList = x}+                                    }++-- ----------------------------------------++theSysEnv                       :: Selector XIOSysState XIOSysEnv+theSysEnv                       = S { getS = xioSysEnv+                                    , setS = \ x s -> s { xioSysEnv = x}+                                    }++theInputConfig                  :: Selector XIOSysState XIOInputConfig+theInputConfig                  = theSysEnv+                                  >>>+                                  S { getS = xioInputConfig+                                    , setS = \ x s -> s { xioInputConfig = x}+                                    }++theStrictInput                  :: Selector XIOSysState Bool+theStrictInput                  = theInputConfig+                                  >>>+                                  S { getS = xioStrictInput+                                    , setS = \ x s -> s { xioStrictInput = x}+                                    }++theEncodingErrors               :: Selector XIOSysState Bool+theEncodingErrors               = theInputConfig+                                  >>>+                                  S { getS = xioEncodingErrors+                                    , setS = \ x s -> s { xioEncodingErrors = x}+                                    }++theInputEncoding                :: Selector XIOSysState String+theInputEncoding                = theInputConfig+                                  >>>+                                  S { getS = xioInputEncoding+                                    , setS = \ x s -> s { xioInputEncoding = x}+                                    }++theHttpHandler                  :: Selector XIOSysState (IOSArrow XmlTree XmlTree)+theHttpHandler                  = theInputConfig+                                  >>>+                                  S { getS = xioHttpHandler+                                    , setS = \ x s -> s { xioHttpHandler = x}+                                    }++theInputOptions                 :: Selector XIOSysState Attributes+theInputOptions                 = theInputConfig+                                  >>>+                                  S { getS = xioInputOptions+                                    , setS = \ x s -> s { xioInputOptions = x}+                                    }++theRedirect                     :: Selector XIOSysState Bool+theRedirect                     = theInputConfig+                                  >>>+                                  S { getS = xioRedirect+                                    , setS = \ x s -> s { xioRedirect = x}+                                    }++theProxy                        :: Selector XIOSysState String+theProxy                        = theInputConfig+                                  >>>+                                  S { getS = xioProxy+                                    , setS = \ x s -> s { xioProxy = x}+                                    }++-- ----------------------------------------++theOutputConfig                 :: Selector XIOSysState XIOOutputConfig+theOutputConfig                 = theSysEnv+                                  >>>+                                  S { getS = xioOutputConfig+                                    , setS = \ x s -> s { xioOutputConfig = x}+                                    }++theIndent                       :: Selector XIOSysState Bool+theIndent                       = theOutputConfig+                                  >>>+                                  S { getS = xioIndent+                                    , setS = \ x s -> s { xioIndent = x}+                                    }++theOutputEncoding               :: Selector XIOSysState String+theOutputEncoding               = theOutputConfig+                                  >>>+                                  S { getS = xioOutputEncoding+                                    , setS = \ x s -> s { xioOutputEncoding = x}+                                    }++theOutputFmt                    :: Selector XIOSysState XIOXoutConfig+theOutputFmt                    = theOutputConfig+                                  >>>+                                  S { getS = xioOutputFmt+                                    , setS = \ x s -> s { xioOutputFmt = x}+                                    }++theXmlPi                        :: Selector XIOSysState Bool+theXmlPi                        = theOutputConfig+                                  >>>+                                  S { getS = xioXmlPi+                                    , setS = \ x s -> s { xioXmlPi = x}+                                    }++theNoEmptyElemFor               :: Selector XIOSysState [String]+theNoEmptyElemFor               = theOutputConfig+                                  >>>+                                  S { getS = xioNoEmptyElemFor+                                    , setS = \ x s -> s { xioNoEmptyElemFor = x}+                                    }++theAddDefaultDTD                :: Selector XIOSysState Bool+theAddDefaultDTD                = theOutputConfig+                                  >>>+                                  S { getS = xioAddDefaultDTD+                                    , setS = \ x s -> s { xioAddDefaultDTD = x}+                                    }++theTextMode                     :: Selector XIOSysState Bool+theTextMode                     = theOutputConfig+                                  >>>+                                  S { getS = xioTextMode+                                    , setS = \ x s -> s { xioTextMode = x}+                                    }++theShowTree                     :: Selector XIOSysState Bool+theShowTree                     = theOutputConfig+                                  >>>+                                  S { getS = xioShowTree+                                    , setS = \ x s -> s { xioShowTree = x}+                                    }++theShowHaskell                  :: Selector XIOSysState Bool+theShowHaskell                  = theOutputConfig+                                  >>>+                                  S { getS = xioShowHaskell+                                    , setS = \ x s -> s { xioShowHaskell = x}+                                    }++-- ----------------------------------------++theRelaxConfig                  :: Selector XIOSysState XIORelaxConfig+theRelaxConfig                  = theSysEnv+                                  >>>+                                  S { getS = xioRelaxConfig+                                    , setS = \ x s -> s { xioRelaxConfig = x}+                                    }++theRelaxValidate                :: Selector XIOSysState Bool+theRelaxValidate                = theRelaxConfig+                                  >>>+                                  S { getS = xioRelaxValidate+                                    , setS = \ x s -> s { xioRelaxValidate = x}+                                    }++theRelaxSchema                  :: Selector XIOSysState String+theRelaxSchema                  = theRelaxConfig+                                  >>>+                                  S { getS = xioRelaxSchema+                                    , setS = \ x s -> s { xioRelaxSchema = x}+                                    }++theRelaxCheckRestr              :: Selector XIOSysState Bool+theRelaxCheckRestr              = theRelaxConfig+                                  >>>+                                  S { getS = xioRelaxCheckRestr+                                    , setS = \ x s -> s { xioRelaxCheckRestr = x}+                                    }++theRelaxValidateExtRef          :: Selector XIOSysState Bool+theRelaxValidateExtRef          = theRelaxConfig+                                  >>>+                                  S { getS = xioRelaxValidateExtRef+                                    , setS = \ x s -> s { xioRelaxValidateExtRef = x}+                                    }++theRelaxValidateInclude         :: Selector XIOSysState Bool+theRelaxValidateInclude         = theRelaxConfig+                                  >>>+                                  S { getS = xioRelaxValidateInclude+                                    , setS = \ x s -> s { xioRelaxValidateInclude = x}+                                    }++theRelaxCollectErrors           :: Selector XIOSysState Bool+theRelaxCollectErrors           = theRelaxConfig+                                  >>>+                                  S { getS = xioRelaxCollectErrors+                                    , setS = \ x s -> s { xioRelaxCollectErrors = x}+                                    }++theRelaxValidator               :: Selector XIOSysState (IOSArrow XmlTree XmlTree)+theRelaxValidator               = theRelaxConfig+                                  >>>+                                  S { getS = xioRelaxValidator+                                    , setS = \ x s -> s { xioRelaxValidator = x}+                                    }++-- ----------------------------------------++theXmlSchemaConfig              :: Selector XIOSysState XIOXmlSchemaConfig+theXmlSchemaConfig              = theSysEnv+                                  >>>+                                  S { getS = xioXmlSchemaConfig+                                    , setS = \ x s -> s { xioXmlSchemaConfig = x}+                                    }++theXmlSchemaValidate            :: Selector XIOSysState Bool+theXmlSchemaValidate            = theXmlSchemaConfig+                                  >>>+                                  S { getS = xioXmlSchemaValidate+                                    , setS = \ x s -> s { xioXmlSchemaValidate = x}+                                    }++theXmlSchemaSchema              :: Selector XIOSysState String+theXmlSchemaSchema              = theXmlSchemaConfig+                                  >>>+                                  S { getS = xioXmlSchemaSchema+                                    , setS = \ x s -> s { xioXmlSchemaSchema = x}+                                    }++theXmlSchemaValidator           :: Selector XIOSysState (IOSArrow XmlTree XmlTree)+theXmlSchemaValidator           = theXmlSchemaConfig+                                  >>>+                                  S { getS = xioXmlSchemaValidator+                                    , setS = \ x s -> s { xioXmlSchemaValidator = x}+                                    }++-- ----------------------------------------++theParseConfig                  :: Selector XIOSysState XIOParseConfig+theParseConfig                  = theSysEnv+                                  >>>+                                  S { getS = xioParseConfig+                                    , setS = \ x s -> s { xioParseConfig = x}+                                    }++theErrorMsgHandler              :: Selector XIOSysState (String -> IO ())+theErrorMsgHandler              = theSysEnv+                                  >>>+                                  S { getS = xioErrorMsgHandler+                                    , setS = \ x s -> s { xioErrorMsgHandler = x }+                                    }++theErrorMsgCollect              :: Selector XIOSysState Bool+theErrorMsgCollect              = theSysEnv+                                  >>>+                                  S { getS = xioErrorMsgCollect+                                    , setS = \ x s -> s { xioErrorMsgCollect = x }+                                    }++theBaseURI                      :: Selector XIOSysState String+theBaseURI                      = theSysEnv+                                  >>>+                                  S { getS = xioBaseURI+                                    , setS = \ x s -> s { xioBaseURI = x }+                                    }++theDefaultBaseURI               :: Selector XIOSysState String+theDefaultBaseURI               = theSysEnv+                                  >>>+                                  S { getS = xioDefaultBaseURI+                                    , setS = \ x s -> s { xioDefaultBaseURI = x }+                                    }++theTraceLevel                   :: Selector XIOSysState Int+theTraceLevel                   = theSysEnv+                                  >>>+                                  S { getS = xioTraceLevel+                                    , setS = \ x s -> s { xioTraceLevel = x }+                                    }++theTraceCmd                     :: Selector XIOSysState (Int -> String -> IO ())+theTraceCmd                     = theSysEnv+                                  >>>+                                  S { getS = xioTraceCmd+                                    , setS = \ x s -> s { xioTraceCmd = x }+                                    }++theTrace                        :: Selector XIOSysState (Int, Int -> String -> IO ())+theTrace                        = theTraceLevel .&&&. theTraceCmd++theAttrList                     :: Selector XIOSysState Attributes+theAttrList                     = theSysEnv+                                  >>>+                                  S { getS = xioAttrList+                                    , setS = \ x s -> s { xioAttrList = x }+                                    }++theMimeTypes                    :: Selector XIOSysState MimeTypeTable+theMimeTypes                    = theParseConfig+                                  >>>+                                  S { getS = xioMimeTypes+                                    , setS = \ x s -> s { xioMimeTypes = x }+                                    }++theMimeTypeHandlers             :: Selector XIOSysState MimeTypeHandlers+theMimeTypeHandlers             = theParseConfig+                                  >>>+                                  S { getS = xioMimeTypeHandlers+                                    , setS = \ x s -> s { xioMimeTypeHandlers = x }+                                    }++theMimeTypeFile                 :: Selector XIOSysState String+theMimeTypeFile                 = theParseConfig+                                  >>>+                                  S { getS = xioMimeTypeFile+                                    , setS = \ x s -> s { xioMimeTypeFile = x }+                                    }++theAcceptedMimeTypes            :: Selector XIOSysState [String]+theAcceptedMimeTypes            = theParseConfig+                                  >>>+                                  S { getS = xioAcceptedMimeTypes+                                    , setS = \ x s -> s { xioAcceptedMimeTypes = x }+                                    }++theFileMimeType                 :: Selector XIOSysState String+theFileMimeType                 = theParseConfig+                                  >>>+                                  S { getS = xioFileMimeType+                                    , setS = \ x s -> s { xioFileMimeType = x }+                                    }++theWarnings                     :: Selector XIOSysState Bool+theWarnings                     = theParseConfig+                                  >>>+                                  S { getS = xioWarnings+                                    , setS = \ x s -> s { xioWarnings = x }+                                    }++theRemoveWS                     :: Selector XIOSysState Bool+theRemoveWS                     = theParseConfig+                                  >>>+                                  S { getS = xioRemoveWS+                                    , setS = \ x s -> s { xioRemoveWS = x }+                                    }++thePreserveComment              :: Selector XIOSysState Bool+thePreserveComment              = theParseConfig+                                  >>>+                                  S { getS = xioPreserveComment+                                    , setS = \ x s -> s { xioPreserveComment = x }+                                    }++theParseByMimeType              :: Selector XIOSysState Bool+theParseByMimeType              = theParseConfig+                                  >>>+                                  S { getS = xioParseByMimeType+                                    , setS = \ x s -> s { xioParseByMimeType = x }+                                    }++theParseHTML                    :: Selector XIOSysState Bool+theParseHTML                    = theParseConfig+                                  >>>+                                  S { getS = xioParseHTML+                                    , setS = \ x s -> s { xioParseHTML = x }+                                    }++theLowerCaseNames               :: Selector XIOSysState Bool+theLowerCaseNames               = theParseConfig+                                  >>>+                                  S { getS = xioLowerCaseNames+                                    , setS = \ x s -> s { xioLowerCaseNames = x }+                                    }++theValidate                     :: Selector XIOSysState Bool+theValidate                     = theParseConfig+                                  >>>+                                  S { getS = xioValidate+                                    , setS = \ x s -> s { xioValidate = x }+                                    }++theSubstDTDEntities            :: Selector XIOSysState Bool+theSubstDTDEntities            = theParseConfig+                                  >>>+                                  S { getS = xioSubstDTDEntities+                                    , setS = \ x s -> s { xioSubstDTDEntities = x }+                                    }++theSubstHTMLEntities            :: Selector XIOSysState Bool+theSubstHTMLEntities            = theParseConfig+                                  >>>+                                  S { getS = xioSubstHTMLEntities+                                    , setS = \ x s -> s { xioSubstHTMLEntities = x }+                                    }++theCheckNamespaces              :: Selector XIOSysState Bool+theCheckNamespaces              = theParseConfig+                                  >>>+                                  S { getS = xioCheckNamespaces+                                    , setS = \ x s -> s { xioCheckNamespaces = x }+                                    }++theCanonicalize                 :: Selector XIOSysState Bool+theCanonicalize                 = theParseConfig+                                  >>>+                                  S { getS = xioCanonicalize+                                    , setS = \ x s -> s { xioCanonicalize = x }+                                    }++theIgnoreNoneXmlContents        :: Selector XIOSysState Bool+theIgnoreNoneXmlContents        = theParseConfig+                                  >>>+                                  S { getS = xioIgnoreNoneXmlContents+                                    , setS = \ x s -> s { xioIgnoreNoneXmlContents = x }+                                    }++theTagSoup                      :: Selector XIOSysState Bool+theTagSoup                      = theParseConfig+                                  >>>+                                  S { getS = xioTagSoup+                                    , setS = \ x s -> s { xioTagSoup = x }+                                    }++theTagSoupParser                :: Selector XIOSysState (IOSArrow XmlTree XmlTree)+theTagSoupParser                = theParseConfig+                                  >>>+                                  S { getS = xioTagSoupParser+                                    , setS = \ x s -> s { xioTagSoupParser = x }+                                    }++theExpat                        :: Selector XIOSysState Bool+theExpat                        = theParseConfig+                                  >>>+                                  S { getS = xioExpat+                                    , setS = \ x s -> s { xioExpat = x }+                                    }++theExpatParser                  :: Selector XIOSysState (IOSArrow XmlTree XmlTree)+theExpatParser                  = theParseConfig+                                  >>>+                                  S { getS = xioExpatParser+                                    , setS = \ x s -> s { xioExpatParser = x }+                                    }++theExpatErrors                  :: Selector XIOSysState (IOSArrow XmlTree XmlTree)+theExpatErrors                  = theSysWriter+                                  >>>+                                  S { getS = xioExpatErrors+                                    , setS = \ x s -> s { xioExpatErrors = x }+                                    }++-- ----------------------------------------++theCacheConfig                  :: Selector XIOSysState XIOCacheConfig+theCacheConfig                  = theSysEnv+                                  >>>+                                  S { getS = xioCacheConfig+                                    , setS = \ x s -> s { xioCacheConfig = x}+                                    }++theBinaryCompression            :: Selector XIOSysState (ByteString -> ByteString)+theBinaryCompression            = theCacheConfig+                                  >>>+                                  S { getS = xioBinaryCompression+                                    , setS = \ x s -> s { xioBinaryCompression = x}+                                    }++theBinaryDeCompression          :: Selector XIOSysState (ByteString -> ByteString)+theBinaryDeCompression          = theCacheConfig+                                  >>>+                                  S { getS = xioBinaryDeCompression+                                    , setS = \ x s -> s { xioBinaryDeCompression = x}+                                    }++theWithCache                    :: Selector XIOSysState Bool+theWithCache                    = theCacheConfig+                                  >>>+                                  S { getS = xioWithCache+                                    , setS = \ x s -> s { xioWithCache = x}+                                    }++theCacheDir                     :: Selector XIOSysState String+theCacheDir                     = theCacheConfig+                                  >>>+                                  S { getS = xioCacheDir+                                    , setS = \ x s -> s { xioCacheDir = x}+                                    }++theDocumentAge                  :: Selector XIOSysState Int+theDocumentAge                  = theCacheConfig+                                  >>>+                                  S { getS = xioDocumentAge+                                    , setS = \ x s -> s { xioDocumentAge = x}+                                    }++theCache404Err                  :: Selector XIOSysState Bool+theCache404Err                  = theCacheConfig+                                  >>>+                                  S { getS = xioCache404Err+                                    , setS = \ x s -> s { xioCache404Err = x}+                                    }++theCacheRead                    :: Selector XIOSysState (String -> IOSArrow XmlTree XmlTree)+theCacheRead                    = theCacheConfig+                                  >>>+                                  S { getS = xioCacheRead+                                    , setS = \ x s -> s { xioCacheRead = x}+                                    }++theStrictDeserialize            :: Selector XIOSysState Bool+theStrictDeserialize            = theCacheConfig+                                  >>>+                                  S { getS = xioStrictDeserialize+                                    , setS = \ x s -> s { xioStrictDeserialize = x}+                                    }++-- ------------------------------------------------------------++getSysVar                       :: Selector XIOSysState c -> IOStateArrow s b c+getSysVar sel                   = IOSLA $ \ s _x ->+                                  return (s, (:[]) . getS (theSysState >>> sel) $ s)++setSysVar                       :: Selector XIOSysState c -> IOStateArrow s c c+setSysVar sel                   = (\ v -> configSysVar $ setS sel v) $< this++chgSysVar                       :: Selector XIOSysState c -> (b -> c -> c) -> IOStateArrow s b b+chgSysVar sel op                = (\ v -> configSysVar $ chgS sel (op v)) $< this++configSysVar                    :: SysConfig -> IOStateArrow s c c+configSysVar cf                 = IOSLA $ \ s v ->+                                  return (chgS theSysState cf s, [v])++configSysVars                   :: SysConfigList -> IOStateArrow s c c+configSysVars cfs               = configSysVar $ foldr (>>>) id $ cfs++localSysVar                     :: Selector XIOSysState c -> IOStateArrow s a b -> IOStateArrow s a b+localSysVar sel f               = IOSLA $ \ s0 v ->+                                  let sel' = theSysState >>> sel in+                                  let c0   = getS sel' s0 in+                                  do+                                  (s1, res) <- runIOSLA f s0 v+                                  return (setS sel' c0 s1, res)++localSysEnv                     :: IOStateArrow s a b -> IOStateArrow s a b+localSysEnv                     = localSysVar theSysEnv++incrSysVar                      :: Selector XIOSysState Int -> IOStateArrow s a Int+incrSysVar cnt                  = getSysVar cnt+                                  >>>+                                  arr (+1)+                                  >>>+                                  setSysVar cnt+                                  >>>+                                  arr (\ x -> x - 1)++-- ------------------------------++-- | store a string in global state under a given attribute name++setSysAttr              :: String -> IOStateArrow s String String+setSysAttr n            = chgSysVar theAttrList (addEntry n)++-- | remove an entry in global state, arrow input remains unchanged++unsetSysAttr            :: String -> IOStateArrow s b b+unsetSysAttr n            = configSysVar $ chgS theAttrList (delEntry n)++-- | read an attribute value from global state++getSysAttr                :: String -> IOStateArrow s b String+getSysAttr n              = getSysVar theAttrList+                          >>^+                          lookup1 n++-- | read all attributes from global state++getAllSysAttrs            :: IOStateArrow s b Attributes+getAllSysAttrs            = getSysVar theAttrList+++setSysAttrString        :: String -> String -> IOStateArrow s b b+setSysAttrString n v    = perform ( constA v+                                    >>>+                                    setSysAttr n+                                  )++-- | store an int value in global state++setSysAttrInt           :: String -> Int -> IOStateArrow s b b+setSysAttrInt n v       = setSysAttrString n (show v)++-- | read an int value from global state+--+-- > getSysAttrInt 0 myIntAttr++getSysAttrInt           :: Int -> String -> IOStateArrow s b Int+getSysAttrInt def n     = getSysAttr n+                          >>^+                          toInt def++toInt                   :: Int -> String -> Int+toInt def s+    | not (null s)+      &&+      all isDigit s     = read s+    | otherwise         = def++-- ------------------------------------------------------------
+ src/Text/XML/HXT/Arrow/XmlState/URIHandling.hs view
@@ -0,0 +1,240 @@+-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.Arrow.XmlState.URIHandling+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   the basic state arrows for URI handling++-}++-- ------------------------------------------------------------++module Text.XML.HXT.Arrow.XmlState.URIHandling+where++import Control.Arrow                            -- arrow classes+import Control.Arrow.ArrowList+import Control.Arrow.ArrowIf++import Control.Arrow.ArrowIO++import Control.Monad                    ( mzero+                                        , mplus )++import Text.XML.HXT.Arrow.XmlArrow+import Text.XML.HXT.Arrow.XmlState.TypeDefs+import Text.XML.HXT.Arrow.XmlState.TraceHandling++import Data.Maybe++import Network.URI                      ( URI+                                        , escapeURIChar+                                        , isUnescapedInURI+                                        , nonStrictRelativeTo+                                        , parseURIReference+                                        , uriAuthority+                                        , uriFragment+                                        , uriPath+                                        , uriPort+                                        , uriQuery+                                        , uriRegName+                                        , uriScheme+                                        , uriUserInfo+                                        )++import System.Directory                 ( getCurrentDirectory )++-- ------------------------------------------------------------++-- | set the base URI of a document, used e.g. for reading includes, e.g. external entities,+-- the input must be an absolute URI++setBaseURI              :: IOStateArrow s String String+setBaseURI              = setSysVar theBaseURI+                          >>>+                          traceValue 2 (("setBaseURI: new base URI is " ++) . show)++-- | read the base URI from the globale state++getBaseURI              :: IOStateArrow s b String+getBaseURI              = getSysVar theBaseURI+                          >>>+                          ( ( getDefaultBaseURI+                              >>>+                              setBaseURI+                              >>>+                              getBaseURI+                            )+                            `when`+                            isA null                                -- set and get it, if not yet done+                          )++-- | change the base URI with a possibly relative URI, can be used for+-- evaluating the xml:base attribute. Returns the new absolute base URI.+-- Fails, if input is not parsable with parseURIReference+--+-- see also: 'setBaseURI', 'mkAbsURI'++changeBaseURI           :: IOStateArrow s String String+changeBaseURI           = mkAbsURI >>> setBaseURI++-- | set the default base URI, if parameter is null, the system base (@ file:\/\/\/\<cwd\>\/ @) is used,+-- else the parameter, must be called before any document is read++setDefaultBaseURI       :: String -> IOStateArrow s b String+setDefaultBaseURI base  = ( if null base+                            then arrIO getDir+                            else constA base+                          )+                          >>>+                          setSysVar theDefaultBaseURI+                          >>>+                          traceValue 2 (("setDefaultBaseURI: new default base URI is " ++) . show)+    where+    getDir _            = do+                          cwd <- getCurrentDirectory+                          return ("file://" ++ normalize cwd ++ "/")++    -- under Windows getCurrentDirectory returns something like: "c:\path\to\file"+    -- backslaches are not allowed in URIs and paths must start with a /+    -- so this is transformed into "/c:/path/to/file"++    normalize wd'@(d : ':' : _)+        | d `elem` ['A'..'Z']+          ||+          d `elem` ['a'..'z']+                        = '/' : concatMap win32ToUriChar wd'+    normalize wd'       = concatMap escapeNonUriChar wd'++    win32ToUriChar '\\' = "/"+    win32ToUriChar c    = escapeNonUriChar c++    escapeNonUriChar c  = escapeURIChar isUnescapedInURI c   -- from Network.URI+++-- | get the default base URI++getDefaultBaseURI       :: IOStateArrow s b String+getDefaultBaseURI       = getSysVar theDefaultBaseURI            -- read default uri in system  state+                          >>>+                          ( ( setDefaultBaseURI ""                  -- set the default uri in system state+                              >>>+                              getDefaultBaseURI+                            )+                            `when` isA null+                          )                                         -- when uri not yet set++-- ------------------------------------------------------------++-- | remember base uri, run an arrow and restore the base URI, used with external entity substitution++runInLocalURIContext    :: IOStateArrow s b c -> IOStateArrow s b c+runInLocalURIContext f  = localSysVar theBaseURI f++-- ----------------------------------------------------------++-- | parse a URI reference, in case of a failure,+-- try to escape unescaped chars, convert backslashes to slashes for windows paths,+-- and try parsing again++parseURIReference'      :: String -> Maybe URI+parseURIReference' uri+    = parseURIReference uri+      `mplus`+      ( if unesc+        then parseURIReference uri'+        else mzero+      )+    where+    unesc       = not . all isUnescapedInURI $ uri++    escape '\\' = "/"+    escape c    = escapeURIChar isUnescapedInURI c++    uri'        = concatMap escape uri++-- | compute the absolut URI for a given URI and a base URI++expandURIString :: String -> String -> Maybe String+expandURIString uri base+    = do+      base' <- parseURIReference' base+      uri'  <- parseURIReference' uri+      --  abs' <- nonStrictRelativeTo uri' base'+      let abs' =  nonStrictRelativeTo uri' base'+      return $ show abs'++-- | arrow variant of 'expandURIString', fails if 'expandURIString' returns Nothing++expandURI               :: ArrowXml a => a (String, String) String+expandURI+    = arrL (maybeToList . uncurry expandURIString)++-- | arrow for expanding an input URI into an absolute URI using global base URI, fails if input is not a legal URI++mkAbsURI                :: IOStateArrow s String String+mkAbsURI+    = ( this &&& getBaseURI ) >>> expandURI++-- | arrow for selecting the scheme (protocol) of the URI, fails if input is not a legal URI.+--+-- See Network.URI for URI components++getSchemeFromURI        :: ArrowList a => a String String+getSchemeFromURI        = getPartFromURI scheme+    where+    scheme = init . uriScheme++-- | arrow for selecting the registered name (host) of the URI, fails if input is not a legal URI++getRegNameFromURI       :: ArrowList a => a String String+getRegNameFromURI       = getPartFromURI host+    where+    host = maybe "" uriRegName . uriAuthority++-- | arrow for selecting the port number of the URI without leading \':\', fails if input is not a legal URI++getPortFromURI          :: ArrowList a => a String String+getPortFromURI          = getPartFromURI port+    where+    port = dropWhile (==':') . maybe "" uriPort . uriAuthority++-- | arrow for selecting the user info of the URI without trailing \'\@\', fails if input is not a legal URI++getUserInfoFromURI              :: ArrowList a => a String String+getUserInfoFromURI              = getPartFromURI ui+    where+    ui = reverse . dropWhile (=='@') . reverse . maybe "" uriUserInfo . uriAuthority++-- | arrow for computing the path component of an URI, fails if input is not a legal URI++getPathFromURI          :: ArrowList a => a String String+getPathFromURI          = getPartFromURI uriPath++-- | arrow for computing the query component of an URI, fails if input is not a legal URI++getQueryFromURI         :: ArrowList a => a String String+getQueryFromURI         = getPartFromURI uriQuery++-- | arrow for computing the fragment component of an URI, fails if input is not a legal URI++getFragmentFromURI      :: ArrowList a => a String String+getFragmentFromURI      = getPartFromURI uriFragment++-- | arrow for computing the path component of an URI, fails if input is not a legal URI++getPartFromURI          :: ArrowList a => (URI -> String) -> a String String+getPartFromURI sel+    = arrL (maybeToList . getPart)+      where+      getPart s = do+                  uri <- parseURIReference' s+                  return (sel uri)++-- ------------------------------------------------------------
+ src/Text/XML/HXT/Core.hs view
@@ -0,0 +1,69 @@+-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.Core+   Copyright  : Copyright (C) 2006-2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   The HXT arrow interface++   The application programming interface to the arrow modules of the Haskell XML Toolbox.+   This module exports all important arrows for input, output, parsing, validating and transforming XML.+   It also exports all basic datatypes and functions of the toolbox.++-}++-- ------------------------------------------------------------++module Text.XML.HXT.Core+    ( module Control.Arrow.ListArrows++    , module Text.XML.HXT.DOM.Interface++    , module Text.XML.HXT.Arrow.XmlArrow+    , module Text.XML.HXT.Arrow.XmlState++    , module Text.XML.HXT.Arrow.DocumentInput+    , module Text.XML.HXT.Arrow.DocumentOutput+    , module Text.XML.HXT.Arrow.Edit+    , module Text.XML.HXT.Arrow.GeneralEntitySubstitution+    , module Text.XML.HXT.Arrow.Namespace+    , module Text.XML.HXT.Arrow.Pickle+    , module Text.XML.HXT.Arrow.ProcessDocument+    , module Text.XML.HXT.Arrow.ReadDocument+    , module Text.XML.HXT.Arrow.WriteDocument+    , module Text.XML.HXT.Arrow.Binary+    , module Text.XML.HXT.Arrow.XmlOptions++    , module Text.XML.HXT.Version+    )+where++import Control.Arrow.ListArrows                 -- arrow classes++import Data.Atom ()                             -- import this explicitly++import Text.XML.HXT.DOM.Interface++import Text.XML.HXT.Arrow.DocumentInput+import Text.XML.HXT.Arrow.DocumentOutput+import Text.XML.HXT.Arrow.Edit+import Text.XML.HXT.Arrow.GeneralEntitySubstitution+import Text.XML.HXT.Arrow.Namespace+import Text.XML.HXT.Arrow.Pickle+import Text.XML.HXT.Arrow.ProcessDocument+import Text.XML.HXT.Arrow.ReadDocument+import Text.XML.HXT.Arrow.WriteDocument+import Text.XML.HXT.Arrow.XmlArrow+import Text.XML.HXT.Arrow.XmlOptions+import Text.XML.HXT.Arrow.XmlState+import Text.XML.HXT.Arrow.XmlRegex ()           -- import this explicitly+import Text.XML.HXT.Arrow.Binary++import Text.XML.HXT.Version++-- ------------------------------------------------------------
src/Text/XML/HXT/DOM/FormatXmlTree.hs view
@@ -21,12 +21,12 @@     ) where +import Data.Maybe+ import Text.XML.HXT.DOM.Interface import Text.XML.HXT.DOM.ShowXml import Text.XML.HXT.DOM.XmlNode -import Data.Maybe- -- ------------------------------------------------------------  @@ -49,7 +49,7 @@     where  showName        :: XNode -> String-showName        = maybe "" showQn . getName+showName        = maybe "" show . getName  showAtts        :: XNode -> String showAtts        = concatMap showAl . fromMaybe [] . getAttrl@@ -57,18 +57,9 @@ showAl          :: XmlTree -> String showAl t        -- (NTree (XAttr an) av)     | isAttr t-        = "\n|   " ++ (maybe "" showQn . getName $ t) ++ "=" ++ show (xshow . getChildren $ t)+        = "\n|   " ++ (maybe "" show . getName $ t) ++ "=" ++ show (xshow . getChildren $ t)     | otherwise         = show t--showQn          :: QName -> String-showQn n-    | null ns-        = show $ qualifiedName n-    | otherwise-        = show $ "{" ++ ns ++ "}" ++ qualifiedName n-    where-    ns = namespaceUri n  -- ------------------------------------------------------------
src/Text/XML/HXT/DOM/Interface.hs view
@@ -21,16 +21,16 @@     ( module Text.XML.HXT.DOM.XmlKeywords     , module Text.XML.HXT.DOM.TypeDefs     , module Text.XML.HXT.DOM.Util-    , module Text.XML.HXT.DOM.XmlOptions     , module Text.XML.HXT.DOM.MimeTypes+    , module Data.String.EncodingNames     ) where  import Text.XML.HXT.DOM.XmlKeywords             -- constants import Text.XML.HXT.DOM.TypeDefs                -- XML Tree types import Text.XML.HXT.DOM.Util-import Text.XML.HXT.DOM.XmlOptions              -- predefined options import Text.XML.HXT.DOM.MimeTypes               -- mime types related stuff +import Data.String.EncodingNames                -- char encoding names for readDocument  -- ------------------------------------------------------------
− src/Text/XML/HXT/DOM/IsoLatinTables.hs 
@@ -1,719 +0,0 @@-module Text.XML.HXT.DOM.IsoLatinTables-where--iso_8859_2      :: [(Char, Char)]-iso_8859_2-    = [ ('\161', '\260' )-      , ('\162', '\728' )-      , ('\163', '\321' )-      , ('\165', '\317' )-      , ('\166', '\346' )-      , ('\169', '\352' )-      , ('\170', '\350' )-      , ('\171', '\356' )-      , ('\172', '\377' )-      , ('\174', '\381' )-      , ('\175', '\379' )-      , ('\177', '\261' )-      , ('\178', '\731' )-      , ('\179', '\322' )-      , ('\181', '\318' )-      , ('\182', '\347' )-      , ('\183', '\711' )-      , ('\185', '\353' )-      , ('\186', '\351' )-      , ('\187', '\357' )-      , ('\188', '\378' )-      , ('\189', '\733' )-      , ('\190', '\382' )-      , ('\191', '\380' )-      , ('\192', '\340' )-      , ('\195', '\258' )-      , ('\197', '\313' )-      , ('\198', '\262' )-      , ('\200', '\268' )-      , ('\202', '\280' )-      , ('\204', '\282' )-      , ('\207', '\270' )-      , ('\208', '\272' )-      , ('\209', '\323' )-      , ('\210', '\327' )-      , ('\213', '\336' )-      , ('\216', '\344' )-      , ('\217', '\366' )-      , ('\219', '\368' )-      , ('\222', '\354' )-      , ('\224', '\341' )-      , ('\227', '\259' )-      , ('\229', '\314' )-      , ('\230', '\263' )-      , ('\232', '\269' )-      , ('\234', '\281' )-      , ('\236', '\283' )-      , ('\239', '\271' )-      , ('\240', '\273' )-      , ('\241', '\324' )-      , ('\242', '\328' )-      , ('\245', '\337' )-      , ('\248', '\345' )-      , ('\249', '\367' )-      , ('\251', '\369' )-      , ('\254', '\355' )-      , ('\255', '\729' )-      ]--iso_8859_3      :: [(Char, Char)]-iso_8859_3-    = [ ('\161', '\294' )-      , ('\162', '\728' )-      , ('\166', '\292' )-      , ('\169', '\304' )-      , ('\170', '\350' )-      , ('\171', '\286' )-      , ('\172', '\308' )-      , ('\175', '\379' )-      , ('\177', '\295' )-      , ('\182', '\293' )-      , ('\185', '\305' )-      , ('\186', '\351' )-      , ('\187', '\287' )-      , ('\188', '\309' )-      , ('\191', '\380' )-      , ('\197', '\266' )-      , ('\198', '\264' )-      , ('\213', '\288' )-      , ('\216', '\284' )-      , ('\221', '\364' )-      , ('\222', '\348' )-      , ('\229', '\267' )-      , ('\230', '\265' )-      , ('\245', '\289' )-      , ('\248', '\285' )-      , ('\253', '\365' )-      , ('\254', '\349' )-      , ('\255', '\729' )-      ]--iso_8859_4      :: [(Char, Char)]-iso_8859_4-    = [ ('\161', '\260' )-      , ('\162', '\312' )-      , ('\163', '\342' )-      , ('\165', '\296' )-      , ('\166', '\315' )-      , ('\169', '\352' )-      , ('\170', '\274' )-      , ('\171', '\290' )-      , ('\172', '\358' )-      , ('\174', '\381' )-      , ('\177', '\261' )-      , ('\178', '\731' )-      , ('\179', '\343' )-      , ('\181', '\297' )-      , ('\182', '\316' )-      , ('\183', '\711' )-      , ('\185', '\353' )-      , ('\186', '\275' )-      , ('\187', '\291' )-      , ('\188', '\359' )-      , ('\189', '\330' )-      , ('\190', '\382' )-      , ('\191', '\331' )-      , ('\192', '\256' )-      , ('\199', '\302' )-      , ('\200', '\268' )-      , ('\202', '\280' )-      , ('\204', '\278' )-      , ('\207', '\298' )-      , ('\208', '\272' )-      , ('\209', '\325' )-      , ('\210', '\332' )-      , ('\211', '\310' )-      , ('\217', '\370' )-      , ('\221', '\360' )-      , ('\222', '\362' )-      , ('\224', '\257' )-      , ('\231', '\303' )-      , ('\232', '\269' )-      , ('\234', '\281' )-      , ('\236', '\279' )-      , ('\239', '\299' )-      , ('\240', '\273' )-      , ('\241', '\326' )-      , ('\242', '\333' )-      , ('\243', '\311' )-      , ('\249', '\371' )-      , ('\253', '\361' )-      , ('\254', '\363' )-      , ('\255', '\729' )-      ]--iso_8859_5      :: [(Char, Char)]-iso_8859_5-    = [ ('\161', '\1025' )-      , ('\162', '\1026' )-      , ('\163', '\1027' )-      , ('\164', '\1028' )-      , ('\165', '\1029' )-      , ('\166', '\1030' )-      , ('\167', '\1031' )-      , ('\168', '\1032' )-      , ('\169', '\1033' )-      , ('\170', '\1034' )-      , ('\171', '\1035' )-      , ('\172', '\1036' )-      , ('\174', '\1038' )-      , ('\175', '\1039' )-      , ('\176', '\1040' )-      , ('\177', '\1041' )-      , ('\178', '\1042' )-      , ('\179', '\1043' )-      , ('\180', '\1044' )-      , ('\181', '\1045' )-      , ('\182', '\1046' )-      , ('\183', '\1047' )-      , ('\184', '\1048' )-      , ('\185', '\1049' )-      , ('\186', '\1050' )-      , ('\187', '\1051' )-      , ('\188', '\1052' )-      , ('\189', '\1053' )-      , ('\190', '\1054' )-      , ('\191', '\1055' )-      , ('\192', '\1056' )-      , ('\193', '\1057' )-      , ('\194', '\1058' )-      , ('\195', '\1059' )-      , ('\196', '\1060' )-      , ('\197', '\1061' )-      , ('\198', '\1062' )-      , ('\199', '\1063' )-      , ('\200', '\1064' )-      , ('\201', '\1065' )-      , ('\202', '\1066' )-      , ('\203', '\1067' )-      , ('\204', '\1068' )-      , ('\205', '\1069' )-      , ('\206', '\1070' )-      , ('\207', '\1071' )-      , ('\208', '\1072' )-      , ('\209', '\1073' )-      , ('\210', '\1074' )-      , ('\211', '\1075' )-      , ('\212', '\1076' )-      , ('\213', '\1077' )-      , ('\214', '\1078' )-      , ('\215', '\1079' )-      , ('\216', '\1080' )-      , ('\217', '\1081' )-      , ('\218', '\1082' )-      , ('\219', '\1083' )-      , ('\220', '\1084' )-      , ('\221', '\1085' )-      , ('\222', '\1086' )-      , ('\223', '\1087' )-      , ('\224', '\1088' )-      , ('\225', '\1089' )-      , ('\226', '\1090' )-      , ('\227', '\1091' )-      , ('\228', '\1092' )-      , ('\229', '\1093' )-      , ('\230', '\1094' )-      , ('\231', '\1095' )-      , ('\232', '\1096' )-      , ('\233', '\1097' )-      , ('\234', '\1098' )-      , ('\235', '\1099' )-      , ('\236', '\1100' )-      , ('\237', '\1101' )-      , ('\238', '\1102' )-      , ('\239', '\1103' )-      , ('\240', '\8470' )-      , ('\241', '\1105' )-      , ('\242', '\1106' )-      , ('\243', '\1107' )-      , ('\244', '\1108' )-      , ('\245', '\1109' )-      , ('\246', '\1110' )-      , ('\247', '\1111' )-      , ('\248', '\1112' )-      , ('\249', '\1113' )-      , ('\250', '\1114' )-      , ('\251', '\1115' )-      , ('\252', '\1116' )-      , ('\253', '\167' )-      , ('\254', '\1118' )-      , ('\255', '\1119' )-      ]--iso_8859_6      :: [(Char, Char)]-iso_8859_6-    = [ ('\172', '\1548' )-      , ('\187', '\1563' )-      , ('\191', '\1567' )-      , ('\193', '\1569' )-      , ('\194', '\1570' )-      , ('\195', '\1571' )-      , ('\196', '\1572' )-      , ('\197', '\1573' )-      , ('\198', '\1574' )-      , ('\199', '\1575' )-      , ('\200', '\1576' )-      , ('\201', '\1577' )-      , ('\202', '\1578' )-      , ('\203', '\1579' )-      , ('\204', '\1580' )-      , ('\205', '\1581' )-      , ('\206', '\1582' )-      , ('\207', '\1583' )-      , ('\208', '\1584' )-      , ('\209', '\1585' )-      , ('\210', '\1586' )-      , ('\211', '\1587' )-      , ('\212', '\1588' )-      , ('\213', '\1589' )-      , ('\214', '\1590' )-      , ('\215', '\1591' )-      , ('\216', '\1592' )-      , ('\217', '\1593' )-      , ('\218', '\1594' )-      , ('\224', '\1600' )-      , ('\225', '\1601' )-      , ('\226', '\1602' )-      , ('\227', '\1603' )-      , ('\228', '\1604' )-      , ('\229', '\1605' )-      , ('\230', '\1606' )-      , ('\231', '\1607' )-      , ('\232', '\1608' )-      , ('\233', '\1609' )-      , ('\234', '\1610' )-      , ('\235', '\1611' )-      , ('\236', '\1612' )-      , ('\237', '\1613' )-      , ('\238', '\1614' )-      , ('\239', '\1615' )-      , ('\240', '\1616' )-      , ('\241', '\1617' )-      , ('\242', '\1618' )-      ]--iso_8859_7      :: [(Char, Char)]-iso_8859_7-    = [ ('\161', '\8216' )-      , ('\162', '\8217' )-      , ('\164', '\8364' )-      , ('\165', '\8367' )-      , ('\170', '\890' )-      , ('\175', '\8213' )-      , ('\180', '\900' )-      , ('\181', '\901' )-      , ('\182', '\902' )-      , ('\184', '\904' )-      , ('\185', '\905' )-      , ('\186', '\906' )-      , ('\188', '\908' )-      , ('\190', '\910' )-      , ('\191', '\911' )-      , ('\192', '\912' )-      , ('\193', '\913' )-      , ('\194', '\914' )-      , ('\195', '\915' )-      , ('\196', '\916' )-      , ('\197', '\917' )-      , ('\198', '\918' )-      , ('\199', '\919' )-      , ('\200', '\920' )-      , ('\201', '\921' )-      , ('\202', '\922' )-      , ('\203', '\923' )-      , ('\204', '\924' )-      , ('\205', '\925' )-      , ('\206', '\926' )-      , ('\207', '\927' )-      , ('\208', '\928' )-      , ('\209', '\929' )-      , ('\211', '\931' )-      , ('\212', '\932' )-      , ('\213', '\933' )-      , ('\214', '\934' )-      , ('\215', '\935' )-      , ('\216', '\936' )-      , ('\217', '\937' )-      , ('\218', '\938' )-      , ('\219', '\939' )-      , ('\220', '\940' )-      , ('\221', '\941' )-      , ('\222', '\942' )-      , ('\223', '\943' )-      , ('\224', '\944' )-      , ('\225', '\945' )-      , ('\226', '\946' )-      , ('\227', '\947' )-      , ('\228', '\948' )-      , ('\229', '\949' )-      , ('\230', '\950' )-      , ('\231', '\951' )-      , ('\232', '\952' )-      , ('\233', '\953' )-      , ('\234', '\954' )-      , ('\235', '\955' )-      , ('\236', '\956' )-      , ('\237', '\957' )-      , ('\238', '\958' )-      , ('\239', '\959' )-      , ('\240', '\960' )-      , ('\241', '\961' )-      , ('\242', '\962' )-      , ('\243', '\963' )-      , ('\244', '\964' )-      , ('\245', '\965' )-      , ('\246', '\966' )-      , ('\247', '\967' )-      , ('\248', '\968' )-      , ('\249', '\969' )-      , ('\250', '\970' )-      , ('\251', '\971' )-      , ('\252', '\972' )-      , ('\253', '\973' )-      , ('\254', '\974' )-      ]--iso_8859_8      :: [(Char, Char)]-iso_8859_8-    = [ ('\170', '\215' )-      , ('\186', '\247' )-      , ('\223', '\8215' )-      , ('\224', '\1488' )-      , ('\225', '\1489' )-      , ('\226', '\1490' )-      , ('\227', '\1491' )-      , ('\228', '\1492' )-      , ('\229', '\1493' )-      , ('\230', '\1494' )-      , ('\231', '\1495' )-      , ('\232', '\1496' )-      , ('\233', '\1497' )-      , ('\234', '\1498' )-      , ('\235', '\1499' )-      , ('\236', '\1500' )-      , ('\237', '\1501' )-      , ('\238', '\1502' )-      , ('\239', '\1503' )-      , ('\240', '\1504' )-      , ('\241', '\1505' )-      , ('\242', '\1506' )-      , ('\243', '\1507' )-      , ('\244', '\1508' )-      , ('\245', '\1509' )-      , ('\246', '\1510' )-      , ('\247', '\1511' )-      , ('\248', '\1512' )-      , ('\249', '\1513' )-      , ('\250', '\1514' )-      , ('\253', '\8206' )-      , ('\254', '\8207' )-      ]--iso_8859_9      :: [(Char, Char)]-iso_8859_9-    = [ ('\208', '\286' )-      , ('\221', '\304' )-      , ('\222', '\350' )-      , ('\240', '\287' )-      , ('\253', '\305' )-      , ('\254', '\351' )-      ]--iso_8859_10     :: [(Char, Char)]-iso_8859_10-    = [ ('\161', '\260' )-      , ('\162', '\274' )-      , ('\163', '\290' )-      , ('\164', '\298' )-      , ('\165', '\296' )-      , ('\166', '\310' )-      , ('\168', '\315' )-      , ('\169', '\272' )-      , ('\170', '\352' )-      , ('\171', '\358' )-      , ('\172', '\381' )-      , ('\174', '\362' )-      , ('\175', '\330' )-      , ('\177', '\261' )-      , ('\178', '\275' )-      , ('\179', '\291' )-      , ('\180', '\299' )-      , ('\181', '\297' )-      , ('\182', '\311' )-      , ('\184', '\316' )-      , ('\185', '\273' )-      , ('\186', '\353' )-      , ('\187', '\359' )-      , ('\188', '\382' )-      , ('\189', '\8213' )-      , ('\190', '\363' )-      , ('\191', '\331' )-      , ('\192', '\256' )-      , ('\199', '\302' )-      , ('\200', '\268' )-      , ('\202', '\280' )-      , ('\204', '\278' )-      , ('\209', '\325' )-      , ('\210', '\332' )-      , ('\215', '\360' )-      , ('\217', '\370' )-      , ('\224', '\257' )-      , ('\231', '\303' )-      , ('\232', '\269' )-      , ('\234', '\281' )-      , ('\236', '\279' )-      , ('\241', '\326' )-      , ('\242', '\333' )-      , ('\247', '\361' )-      , ('\249', '\371' )-      , ('\255', '\312' )-      ]--iso_8859_11     :: [(Char, Char)]-iso_8859_11-    = [ ('\161', '\3585' )-      , ('\162', '\3586' )-      , ('\163', '\3587' )-      , ('\164', '\3588' )-      , ('\165', '\3589' )-      , ('\166', '\3590' )-      , ('\167', '\3591' )-      , ('\168', '\3592' )-      , ('\169', '\3593' )-      , ('\170', '\3594' )-      , ('\171', '\3595' )-      , ('\172', '\3596' )-      , ('\173', '\3597' )-      , ('\174', '\3598' )-      , ('\175', '\3599' )-      , ('\176', '\3600' )-      , ('\177', '\3601' )-      , ('\178', '\3602' )-      , ('\179', '\3603' )-      , ('\180', '\3604' )-      , ('\181', '\3605' )-      , ('\182', '\3606' )-      , ('\183', '\3607' )-      , ('\184', '\3608' )-      , ('\185', '\3609' )-      , ('\186', '\3610' )-      , ('\187', '\3611' )-      , ('\188', '\3612' )-      , ('\189', '\3613' )-      , ('\190', '\3614' )-      , ('\191', '\3615' )-      , ('\192', '\3616' )-      , ('\193', '\3617' )-      , ('\194', '\3618' )-      , ('\195', '\3619' )-      , ('\196', '\3620' )-      , ('\197', '\3621' )-      , ('\198', '\3622' )-      , ('\199', '\3623' )-      , ('\200', '\3624' )-      , ('\201', '\3625' )-      , ('\202', '\3626' )-      , ('\203', '\3627' )-      , ('\204', '\3628' )-      , ('\205', '\3629' )-      , ('\206', '\3630' )-      , ('\207', '\3631' )-      , ('\208', '\3632' )-      , ('\209', '\3633' )-      , ('\210', '\3634' )-      , ('\211', '\3635' )-      , ('\212', '\3636' )-      , ('\213', '\3637' )-      , ('\214', '\3638' )-      , ('\215', '\3639' )-      , ('\216', '\3640' )-      , ('\217', '\3641' )-      , ('\218', '\3642' )-      , ('\223', '\3647' )-      , ('\224', '\3648' )-      , ('\225', '\3649' )-      , ('\226', '\3650' )-      , ('\227', '\3651' )-      , ('\228', '\3652' )-      , ('\229', '\3653' )-      , ('\230', '\3654' )-      , ('\231', '\3655' )-      , ('\232', '\3656' )-      , ('\233', '\3657' )-      , ('\234', '\3658' )-      , ('\235', '\3659' )-      , ('\236', '\3660' )-      , ('\237', '\3661' )-      , ('\238', '\3662' )-      , ('\239', '\3663' )-      , ('\240', '\3664' )-      , ('\241', '\3665' )-      , ('\242', '\3666' )-      , ('\243', '\3667' )-      , ('\244', '\3668' )-      , ('\245', '\3669' )-      , ('\246', '\3670' )-      , ('\247', '\3671' )-      , ('\248', '\3672' )-      , ('\249', '\3673' )-      , ('\250', '\3674' )-      , ('\251', '\3675' )-      ]--iso_8859_13     :: [(Char, Char)]-iso_8859_13-    = [ ('\161', '\8221' )-      , ('\165', '\8222' )-      , ('\168', '\216' )-      , ('\170', '\342' )-      , ('\175', '\198' )-      , ('\180', '\8220' )-      , ('\184', '\248' )-      , ('\186', '\343' )-      , ('\191', '\230' )-      , ('\192', '\260' )-      , ('\193', '\302' )-      , ('\194', '\256' )-      , ('\195', '\262' )-      , ('\198', '\280' )-      , ('\199', '\274' )-      , ('\200', '\268' )-      , ('\202', '\377' )-      , ('\203', '\278' )-      , ('\204', '\290' )-      , ('\205', '\310' )-      , ('\206', '\298' )-      , ('\207', '\315' )-      , ('\208', '\352' )-      , ('\209', '\323' )-      , ('\210', '\325' )-      , ('\212', '\332' )-      , ('\216', '\370' )-      , ('\217', '\321' )-      , ('\218', '\346' )-      , ('\219', '\362' )-      , ('\221', '\379' )-      , ('\222', '\381' )-      , ('\224', '\261' )-      , ('\225', '\303' )-      , ('\226', '\257' )-      , ('\227', '\263' )-      , ('\230', '\281' )-      , ('\231', '\275' )-      , ('\232', '\269' )-      , ('\234', '\378' )-      , ('\235', '\279' )-      , ('\236', '\291' )-      , ('\237', '\311' )-      , ('\238', '\299' )-      , ('\239', '\316' )-      , ('\240', '\353' )-      , ('\241', '\324' )-      , ('\242', '\326' )-      , ('\244', '\333' )-      , ('\248', '\371' )-      , ('\249', '\322' )-      , ('\250', '\347' )-      , ('\251', '\363' )-      , ('\253', '\380' )-      , ('\254', '\382' )-      , ('\255', '\8217' )-      ]--iso_8859_14     :: [(Char, Char)]-iso_8859_14-    = [ ('\161', '\7682' )-      , ('\162', '\7683' )-      , ('\164', '\266' )-      , ('\165', '\267' )-      , ('\166', '\7690' )-      , ('\168', '\7808' )-      , ('\170', '\7810' )-      , ('\171', '\7691' )-      , ('\172', '\7922' )-      , ('\175', '\376' )-      , ('\176', '\7710' )-      , ('\177', '\7711' )-      , ('\178', '\288' )-      , ('\179', '\289' )-      , ('\180', '\7744' )-      , ('\181', '\7745' )-      , ('\183', '\7766' )-      , ('\184', '\7809' )-      , ('\185', '\7767' )-      , ('\186', '\7811' )-      , ('\187', '\7776' )-      , ('\188', '\7923' )-      , ('\189', '\7812' )-      , ('\190', '\7813' )-      , ('\191', '\7777' )-      , ('\208', '\372' )-      , ('\215', '\7786' )-      , ('\222', '\374' )-      , ('\240', '\373' )-      , ('\247', '\7787' )-      , ('\254', '\375' )-      ]--iso_8859_15     :: [(Char, Char)]-iso_8859_15-    = [ ('\164', '\8364' )-      , ('\166', '\352' )-      , ('\168', '\353' )-      , ('\180', '\381' )-      , ('\184', '\382' )-      , ('\188', '\338' )-      , ('\189', '\339' )-      , ('\190', '\376' )-      ]--iso_8859_16     :: [(Char, Char)]-iso_8859_16-    = [ ('\161', '\260' )-      , ('\162', '\261' )-      , ('\163', '\321' )-      , ('\164', '\8364' )-      , ('\165', '\8222' )-      , ('\166', '\352' )-      , ('\168', '\353' )-      , ('\170', '\536' )-      , ('\172', '\377' )-      , ('\174', '\378' )-      , ('\175', '\379' )-      , ('\178', '\268' )-      , ('\179', '\322' )-      , ('\180', '\381' )-      , ('\181', '\8221' )-      , ('\184', '\382' )-      , ('\185', '\269' )-      , ('\186', '\537' )-      , ('\188', '\338' )-      , ('\189', '\339' )-      , ('\190', '\376' )-      , ('\191', '\380' )-      , ('\195', '\258' )-      , ('\197', '\262' )-      , ('\208', '\272' )-      , ('\209', '\323' )-      , ('\213', '\336' )-      , ('\215', '\346' )-      , ('\216', '\368' )-      , ('\221', '\280' )-      , ('\222', '\538' )-      , ('\227', '\259' )-      , ('\229', '\263' )-      , ('\240', '\273' )-      , ('\241', '\324' )-      , ('\245', '\337' )-      , ('\247', '\347' )-      , ('\248', '\369' )-      , ('\253', '\281' )-      , ('\254', '\539' )-      ]-
src/Text/XML/HXT/DOM/MimeTypes.hs view
@@ -47,6 +47,7 @@  text_html,  text_pdf,  text_plain,+ text_xdtd,  text_xml,  text_xml_external_parsed_entity        :: String @@ -58,6 +59,7 @@ text_html                               = "text/html" text_pdf                                = "text/pdf" text_plain                              = "text/plain"+text_xdtd                               = "text/x-dtd" text_xml                                = "text/xml" text_xml_external_parsed_entity         = "text/xml-external-parsed-entity" @@ -74,6 +76,7 @@                                                      , application_xml_dtd                                                      , text_xml                                                      , text_xml_external_parsed_entity+                                                     , text_xdtd                                                      ]                                             ||                                             "+xml" `isSuffixOf` t               -- application/mathml+xml
src/Text/XML/HXT/DOM/QualifiedName.hs view
@@ -4,14 +4,14 @@  {- |    Module     : Text.XML.HXT.DOM.QualifiedName-   Copyright  : Copyright (C) 2008 Uwe Schmidt+   Copyright  : Copyright (C) 2011 Uwe Schmidt    License    : MIT     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)    Stability  : stable    Portability: portable -   The core data types of the HXT DOM.+   The types and functions for qualified names  -} @@ -19,7 +19,7 @@  module Text.XML.HXT.DOM.QualifiedName     ( QName-    , XName+    , XName(unXN)     , NsEnv      , mkQName@@ -39,6 +39,7 @@     , newXName     , nullXName     , isNullXName+    , newQName      , mkQName'     , namePrefix'@@ -50,6 +51,7 @@     , setNamespaceUri'      , qualifiedName+    , qualifiedName'     , universalName     , universalUri     , buildUniversalName@@ -80,28 +82,27 @@ import           Debug.Trace  -} -import           Control.Arrow                  ( (***) )+import           Control.Arrow                     ((***)) -import           Control.Concurrent.MVar import           Control.DeepSeq+import           Control.FlatSeq  import           Data.AssocList-import           Data.Char                      ( toLower )-import           Data.List                      ( isPrefixOf )-import qualified Data.Map               as M+import           Data.Binary+import           Data.Char                         (toLower)+import           Data.IORef+import           Data.List                         (isPrefixOf)+import qualified Data.Map                          as M import           Data.Typeable -import           System.IO.Unsafe               ( unsafePerformIO )+import           System.IO.Unsafe                  (unsafePerformIO) -import           Text.XML.HXT.DOM.XmlKeywords   ( a_xml-                                                , a_xmlns-                                                , xmlNamespace-                                                , xmlnsNamespace-                                                )+import           Text.XML.HXT.DOM.XmlKeywords      (a_xml, a_xmlns,+                                                    xmlNamespace,+                                                    xmlnsNamespace) -import           Text.XML.HXT.DOM.Unicode       ( isXmlNCNameStartChar-                                                , isXmlNCNameChar-                                                )+import           Data.Char.Properties.XMLCharProps (isXmlNCNameChar,+                                                    isXmlNCNameStartChar)  -- ----------------------------------------------------------------------------- @@ -109,9 +110,46 @@ -- Names are always reduced to normal form, and they are stored internally in a name cache -- for sharing equal names by the same data structure -type XName      = Atom+data XName                      = XN { _idXN :: !Int        -- for optimization of equality test, see Eq instance+                                     ,  unXN ::   String+                                     }+                                  deriving (Typeable) +instance Eq XName where+    (XN id1 _) == (XN id2 _)    = id1 == id2++instance Ord XName where+    compare (XN _ n1) (XN _ n2) = compare n1 n2+{-+instance Read XName where+    readsPrec p str             = [ (newXName x, y) | (x, y) <- readsPrec p str ]++instance Show XName where+    show (XN _ s)               = show s+-}+instance NFData XName where+    rnf (XN _ s)                = rnf s++instance WNFData XName where+    rwnf (XN _ s)               = rnf s++instance Binary XName where+    put (XN _ s)                = put s+    get                         = do+                                  s <- get+                                  return $! newXName s++-----------------------------------------------------------------------------+ -- |+-- Type for the namespace association list, used when propagating namespaces by+-- modifying the 'QName' values in a tree++type NsEnv              = AssocList XName XName++-----------------------------------------------------------------------------++-- | -- Namespace support for element and attribute names. -- -- A qualified name consists of a name prefix, a local name@@ -120,107 +158,90 @@ -- When dealing with namespaces, the document tree must be processed by 'Text.XML.HXT.Arrow.Namespace.propagateNamespaces' -- to split names of structure \"prefix:localPart\" and label the name with the apropriate namespace uri -data QName      = LP ! XName-                | PX ! XName ! QName-                | NS ! XName ! QName-             deriving (Ord, Show, Read, Typeable)---- |--- Type for the namespace association list, used when propagating namespaces by--- modifying the 'QName' values in a tree--type NsEnv = AssocList XName XName+data QName      = QN { localPart'    :: !XName+                     , namePrefix'   :: !XName+                     , namespaceUri' :: !XName+                     }+             deriving (Typeable)  -- -----------------------------------------------------------------------------  -- | Two QNames are equal if (1. case) namespaces are both empty and the qualified names -- (prefix:localpart) are the same or (2. case) namespaces are set and namespaces and--- local parts both are equal+-- local parts are equal  instance Eq QName where-    (LP lp1)     == (LP lp2)            = lp1 == lp2-    (PX px1 qn1) == (PX px2 qn2)        = px1 == px2 && qn1== qn2-    (NS ns1 qn1) == (NS ns2 qn2)        = ns1 == ns2 && localPart' qn1 == localPart' qn2-    n1@(PX _ _)  == n2@(LP _)           = qualifiedName n1 == qualifiedName n2-    n1@(LP _)    == n2@(PX _ _)         = qualifiedName n1 == qualifiedName n2-    _            == _                   = False---- the 4. and 5. rule are only neccessary when someone--- uses XML names not in a systematical way--- and does things like "mkName("x:y") == mkPrefixLocalPart("x","y")--instance NFData QName where---- -------------------------------------------------------------------------------newXName                :: String -> XName-newXName                = newAtom+    (QN lp1 px1 ns1) == (QN lp2 px2 ns2)+        | ns1 /= ns2            = False                 -- namespaces are set and differ+        | not (isNullXName ns1) = lp1 == lp2            -- namespaces are set and are equal: local parts must be equal+        | otherwise             = lp1 == lp2            -- no namespaces are set: local parts must be equal+                                  &&                    -- and prefixes are not set or they are equal+                                  px1 == px2 -isNullXName             :: XName -> Bool-isNullXName             = (== nullXName)+instance Ord QName where+  compare (QN lp1 px1 ns1) (QN lp2 px2 ns2)+      | isNullXName ns1 && isNullXName ns2              -- no namespaces set: px is significant+          = compare (px1, lp1) (px2, lp2)+      | otherwise                                       -- namespace aware cmp: ns is significant, px is irrelevant+          = compare (lp1, ns1) (lp2, ns2) -nullXName               :: XName-nullXName               = newXName ""+instance NFData  QName where+    rnf x = seq x () --- | access name prefix+instance WNFData QName -namePrefix'             :: QName -> XName-namePrefix' (LP _)      = nullXName-namePrefix' (PX px _)   = px-namePrefix' (NS _ n)    = namePrefix' n+instance Show QName where+    show = showQN --- | access local part+-- ----------------------------------------------------------------------------- -localPart'              :: QName -> XName-localPart' (LP lp)      = lp-localPart' (PX _ n)     = localPart' n-localPart' (NS _ n)     = localPart' n+instance Binary QName where+    put (QN lp px ns)   = put (unXN px) >>+                          put (unXN lp) >>+                          put (unXN ns)+    get                 = do+                          px <- get+                          lp <- get+                          ns <- get+                          return $! newNsName lp px ns+                          --     ^^+                          -- strict apply !!!+                          -- build the QNames strict, else the name sharing optimization will not be in effect --- | access namespace uri+-- ----------------------------------------------------------------------------- -namespaceUri'           :: QName -> XName-namespaceUri' (NS ns _) = ns-namespaceUri' _         = nullXName+isNullXName             :: XName -> Bool+isNullXName             = (== nullXName)+{-# INLINE isNullXName #-}  namePrefix              :: QName -> String-namePrefix              = show . namePrefix'+namePrefix              = unXN . namePrefix'+{-# INLINE namePrefix #-}  localPart               :: QName -> String-localPart               = show . localPart'+localPart               = unXN . localPart'+{-# INLINE localPart #-}  namespaceUri            :: QName -> String-namespaceUri            = show . namespaceUri'+namespaceUri            = unXN . namespaceUri'+{-# INLINE namespaceUri #-}  -- ------------------------------------------------------------  -- | set name prefix -setNamespaceUri'                :: XName -> QName -> QName-setNamespaceUri' ns (NS _ n)    = if isNullXName ns-                                  then n-                                  else NS ns n-setNamespaceUri' ns n           = if isNullXName ns-                                  then n-                                  else NS ns n+setNamespaceUri'                        :: XName -> QName -> QName+setNamespaceUri' ns (QN lp px _ns)      = newQName lp px ns  -- | set local part -setLocalPart'                   :: XName -> QName -> QName-setLocalPart' lp (LP _)         = LP lp-setLocalPart' lp (PX px n)      = PX px (setLocalPart' lp n)-setLocalPart' lp (NS ns n)      = NS ns (setLocalPart' lp n)+setLocalPart'                           :: XName -> QName -> QName+setLocalPart' lp (QN _lp px ns)         = newQName lp px ns  -- | set name prefix -setNamePrefix'                  :: XName -> QName -> QName-setNamePrefix' px (PX _ n)      = if px == nullXName-                                  then n-                                  else PX px n-setNamePrefix' px n@(LP _)      = if px == nullXName-                                  then n-                                  else PX px n-setNamePrefix' px (NS ns n)     = NS ns (setNamePrefix' px n)-+setNamePrefix'                          :: XName -> QName -> QName+setNamePrefix' px (QN lp _px ns)        = newQName lp px ns  -- ------------------------------------------------------------ @@ -228,10 +249,17 @@ -- builds the full name \"prefix:localPart\", if prefix is not null, else the local part is the result  qualifiedName                   :: QName -> String-qualifiedName (LP lp)           = show lp-qualifiedName (PX px n)         = show px ++ (':' : qualifiedName n)-qualifiedName (NS _ n)          = qualifiedName n+qualifiedName (QN lp px _ns)+    | isNullXName px            = unXN lp+    | otherwise                 = unXN px ++ (':' : unXN lp) +-- | functional list version of qualifiedName used in xshow++qualifiedName'                   :: QName -> String -> String+qualifiedName' (QN lp px _ns)+    | isNullXName px            = (unXN lp ++)+    | otherwise                 = (unXN px ++) . (':' :) . (unXN lp ++)+ -- | -- builds the \"universal\" name, that is the namespace uri surrounded with \"{\" and \"}\" followed by the local part -- (specialisation of 'buildUniversalName')@@ -252,21 +280,24 @@ -- namespace uri and local part are combined with the combining function given by the first parameter  buildUniversalName              :: (String -> String -> String) -> QName -> String-buildUniversalName bf (NS ns n) = show ns `bf` localPart n-buildUniversalName _  n         = localPart n+buildUniversalName bf n@(QN _lp _px ns)+    | isNullXName ns            = localPart n+    | otherwise                 = unXN ns `bf` localPart n +showQN                          :: QName -> String+showQN n+    | null ns                   = show $ qualifiedName n+    | otherwise                 = show $ "{" ++ ns ++ "}" ++ qualifiedName n+    where+    ns = namespaceUri n+ -- ------------------------------------------------------------ -- -- internal XName functions  mkQName'                        :: XName -> XName -> XName -> QName-mkQName' px lp ns-    | isNullXName ns            =       px_lp-    | otherwise                 = NS ns px_lp-    where-    px_lp-        | isNullXName px        = LP lp-        | otherwise             = PX px (LP lp)+mkQName' px lp ns               = newQName lp px ns+{-# DEPRECATED mkQName' "use newQName instead with lp px ns param seq " #-}  -- ------------------------------------------------------------ @@ -277,10 +308,8 @@  mkPrefixLocalPart               :: String -> String -> QName mkPrefixLocalPart px lp-    | null px                   =                  n1-    | otherwise                 = PX (newXName px) n1-    where-    n1 = LP (newXName lp)+    | null px                   = newLpName lp+    | otherwise                 = newPxName lp px  -- | -- constructs a simple, namespace unaware name.@@ -293,10 +322,10 @@     | (':' `elem` n)       &&       not (null px)                     -- more restrictive: isWellformedQualifiedName n-                                = mkPrefixLocalPart px lp-    | otherwise                 = mkPrefixLocalPart "" n+                                = newPxName lp px+    | otherwise                 = newLpName n     where-    (px, (_:lp)) = span (/= ':') n+    (px, (_ : lp)) = span (/= ':') n  -- | -- constructs a complete qualified name with 'namePrefix', 'localPart' and 'namespaceUri'.@@ -306,10 +335,8 @@  mkQName                         :: String -> String -> String -> QName mkQName px lp ns-    | null ns                   =                  n1-    | otherwise                 = NS (newXName ns) n1-    where-    n1 = mkPrefixLocalPart px lp+    | null ns                   = mkPrefixLocalPart px lp+    | otherwise                 = newNsName lp px ns  -- ------------------------------------------------------------ @@ -318,6 +345,7 @@  mkSNsName                       :: String -> QName mkSNsName                       = mkName+{-# DEPRECATED mkSNsName "use mkName instead" #-}  -- | -- constructs a simple, namespace aware name, with prefix:localPart as first parameter,@@ -325,10 +353,18 @@ -- -- see also 'mkName', 'mkPrefixLocalPart' -mkNsName                        :: String -> String -> QName+{-+mkNsName                          :: String -> String -> QName+mkNsName n ns                     = trace ("mkNsName: " ++ show n ++ " " ++ show ns) (mkNsName' n ns)+-}++mkNsName                          :: String -> String -> QName mkNsName n ns-    | null ns                   =                   mkName n-    | otherwise                 = NS (newXName ns) (mkName n)+    | null ns                   = qn+    | otherwise                 = setNamespaceUri' ns' qn+    where+    qn                          = mkName n+    ns'                         = newXName ns  -- ------------------------------------------------------------ @@ -374,27 +410,8 @@ -- see 'isWellformedQName' and 'isWellformedQualifiedName' for error checking.  setNamespace                    :: NsEnv -> QName -> QName-setNamespace env n@(PX px _)    = attachNS env px        n              -- none empty prefix found-setNamespace env n@(LP _)       = attachNS env nullXName n              -- use default namespace uri-setNamespace env (NS _ n)       = setNamespace env n--attachNS                        :: NsEnv -> XName -> QName -> QName-attachNS env px n1              = maybe n1 (\ ns -> NS ns n1) . lookup px $ env--xmlnsNamespaceXName             :: XName-xmlnsNamespaceXName             = newXName xmlnsNamespace--xmlnsXName                      :: XName-xmlnsXName                      = newXName a_xmlns--xmlnsQN                         :: QName-xmlnsQN                         = NS xmlnsNamespaceXName (LP xmlnsXName)--xmlNamespaceXName               :: XName-xmlNamespaceXName               = newXName xmlNamespace--xmlXName                        :: XName-xmlXName                        = newXName a_xml+setNamespace env n@(QN lp px _ns)+                                = maybe n (\ ns -> newQName lp px ns) . lookup px $ env  -- ----------------------------------------------------------------------------- --@@ -426,11 +443,13 @@ -- predicate is used in filter 'valdateNamespaces'.  isWellformedQName               :: QName -> Bool-isWellformedQName (LP lp)       = isNCName . show $ lp                          -- rule [8] XML Namespaces-isWellformedQName (PX px n)     = (isNCName . show) px                          -- rule [7] XML Namespaces+isWellformedQName (QN lp px _ns)+                                = (isNCName . unXN) lp                          -- rule [8] XML Namespaces                                   &&-                                  isWellformedQName n-isWellformedQName (NS _ n)      = isWellformedQName n+                                  ( isNullXName px+                                    ||+                                    (isNCName . unXN) px                        -- rule [7] XML Namespaces+                                  )  -- | -- test whether an attribute name is a namesapce declaration name.@@ -440,47 +459,44 @@ -- predicate is used in filter 'valdateNamespaces'.  isWellformedNSDecl              :: QName -> Bool-isWellformedNSDecl n            = not (isNameSpaceName n)+isWellformedNSDecl n+                                = not (isNameSpaceName n)                                   ||                                   isWellformedNameSpaceName n  -- | -- test for a namespace name to be well formed -isWellformedNameSpaceName               :: QName -> Bool-isWellformedNameSpaceName (LP lp)       = lp == xmlnsXName-isWellformedNameSpaceName (PX px n)     = px == xmlnsXName-                                          &&-                                          not (null lp')-                                          &&-                                          not (a_xml `isPrefixOf` lp')-                                          where-                                          lp' = localPart n-isWellformedNameSpaceName (NS _ n)      = isWellformedNSDecl n+isWellformedNameSpaceName       :: QName -> Bool+isWellformedNameSpaceName n@(QN lp px _ns)+    | isNullXName px            = lp == xmlnsXName+    | otherwise                 = px == xmlnsXName+                                  &&+                                  not (null lp')+                                  &&+                                  not (a_xml `isPrefixOf` lp')+    where+    lp'                         = localPart n + -- | -- test whether a name is a namespace declaration attribute name -isNameSpaceName                 :: QName -> Bool-isNameSpaceName (LP lp)         = lp == xmlnsXName-isNameSpaceName (PX px _)       = px == xmlnsXName-isNameSpaceName (NS _  n)       = isNameSpaceName n+isNameSpaceName                         :: QName -> Bool+isNameSpaceName (QN lp px _ns)+    | isNullXName px                    = lp == xmlnsXName+    | otherwise                         = px == xmlnsXName  -- | -- -- predicate is used in filter 'valdateNamespaces'. -isDeclaredNamespace             :: QName -> Bool-isDeclaredNamespace (NS ns n)   = isNS ns        n-isDeclaredNamespace        n    = isNS nullXName n--isNS                            :: XName -> QName -> Bool-isNS _  (LP _)                  = True                          -- no namespace used-isNS ns (PX px _)-    | px == xmlnsXName          = ns == xmlnsNamespaceXName     -- "xmlns" has a predefined namespace uri-    | px == xmlXName            = ns == xmlNamespaceXName       -- "xml" has a predefiend namespace"-    | otherwise                 = ns /= nullXName               -- namespace values are not empty-isNS ns (NS _ n)                = isNS ns n                     -- this does not occur, but warning is prevented+isDeclaredNamespace                     :: QName -> Bool+isDeclaredNamespace (QN _lp px ns)+    | isNullXName px                    = True                          -- no namespace used+    | px == xmlnsXName                  = ns == xmlnsNamespaceXName     -- "xmlns" has a predefined namespace uri+    | px == xmlXName                    = ns == xmlNamespaceXName       -- "xml" has a predefiend namespace"+    | otherwise                         = not (isNullXName ns)          -- namespace values are not empty  -- ----------------------------------------------------------------------------- @@ -489,50 +505,129 @@  -- ----------------------------------------------------------------------------- --- the name cache, same implementation strategy as in Data.Atom,--- but conversion to and from ByteString prevented+-- the name and string cache -type Atoms      = M.Map String String+data NameCache          = NC { _newXN   :: !Int                                       -- next free name id+                             , _xnCache :: !(M.Map String XName)+                             , _qnCache :: !(M.Map (XName, XName, XName) QName)       -- we need another type than QName+                             }                                                          -- for the key because of the unusable+                                                                                        -- Eq instance of QName+type ChangeNameCache r  = NameCache -> (NameCache, r) -newtype Atom    = A String-                  deriving (Eq, Ord, Typeable)+-- ------------------------------------------------------------ +-- | the internal cache for QNames (and name strings)++theNameCache            :: IORef NameCache+theNameCache            = unsafePerformIO (newIORef $ initialCache)+{-# NOINLINE theNameCache #-}++initialXNames           :: [XName]++nullXName+ , xmlnsNamespaceXName+ , xmlnsXName+ , xmlNamespaceXName+ , xmlXName             :: XName++initialXNames@[+   nullXName+ , xmlnsNamespaceXName+ , xmlnsXName+ , xmlNamespaceXName+ , xmlXName+ ]                      = zipWith XN [0..] $+                          [ ""+                          , xmlnsNamespace+                          , a_xmlns+                          , xmlNamespace+                          , a_xml+                          ]++initialQNames           :: [QName]++xmlnsQN                 :: QName++initialQNames@[xmlnsQN] = [QN xmlnsXName nullXName xmlnsNamespaceXName]++initialCache            :: NameCache+initialCache            = NC+                          (length initialXNames)+                          (M.fromList $ map (\ xn -> (unXN xn, xn)) initialXNames)+                          (M.fromList $ map (\ qn@(QN lp px ns) -> ((lp, px, ns), qn)) initialQNames)+ -- ------------------------------------------------------------ --- | the internal cache for the strings+changeNameCache         :: NFData r => ChangeNameCache r -> r+changeNameCache action  = unsafePerformIO changeNameCache'+    where+    action' c =+      let r = action c+      in+       fst r `seq` r    -- eval name cache to whnf -theAtoms        :: MVar Atoms-theAtoms        = unsafePerformIO (newMVar M.empty)-{-# NOINLINE theAtoms #-}+    changeNameCache' =+      do+      -- putStrLn "modify cache"+      res <- atomicModifyIORef theNameCache action'+      -- putStrLn "cache modified"+      return res --- | insert a bytestring into the atom cache+{-# NOINLINE changeNameCache #-} -insertAtom      :: String -> Atoms -> (Atoms, Atom)-insertAtom s m  = maybe (M.insert {- (trace (show s) s) -} s s m, deepseq s (A s))-                        (\ s' -> (m, A s'))-                  .-                  M.lookup s $ m+newXName'               :: String -> ChangeNameCache XName+newXName' n c@(NC nxn xm qm)+                        = case M.lookup n xm of+                          Just xn       -> (c, xn)+                          Nothing       -> let nxn' = nxn + 1 in+                                           let xn   = (XN nxn n) in+                                           let xm'  = M.insert n xn xm in+                                           -- trace ("newXName: XN " ++ show nxn ++ " " ++ show n) $+                                           rnf xn `seq` (NC nxn' xm' qm, xn) --- | creation of an @Atom@ from a @String@+newQName'               :: XName -> XName -> XName -> ChangeNameCache QName+newQName' lp px ns c@(NC nxn xm qm)+                        = case M.lookup q' qm of+                          Just qn       -> -- trace ("oldQName: " ++ show qn) $                 -- log evaluation sequence+                                           (c, qn)+                          Nothing       -> let qm'  = M.insert q' q qm in+                                           -- trace ("newQName: " ++ show q) $                  -- log insertion of a new QName+                                           q `seq` (NC nxn xm qm', q)+    where+    q'                  = (lp, px, ns)+    q                   = QN lp px ns -newAtom         :: String -> Atom-newAtom         = unsafePerformIO . newAtom'-{-# NOINLINE newAtom #-}+andThen                 :: ChangeNameCache r1 ->+                           (r1 -> ChangeNameCache r2) -> ChangeNameCache r2+andThen a1 a2 c0        = let (c1, r1) = a1 c0 in+                          (a2 r1) c1 --- | The internal operation running in the IO monad-newAtom'        :: String -> IO Atom-newAtom' s      = do-                  m <- takeMVar theAtoms-                  let (m', a) = insertAtom s m-                  putMVar theAtoms m'-                  return a+newXName                :: String -> XName+newXName n              = changeNameCache $+                          newXName' n -instance Read Atom where-    readsPrec p str = [ (newAtom x, y) | (x, y) <- readsPrec p str ]+newQName                :: XName -> XName -> XName -> QName+newQName lp px ns       = lp `seq` px `seq` ns `seq`            -- XNames must be evaluated, else MVar blocks+                          ( changeNameCache $+                            newQName' lp px ns+                          ) -instance Show Atom where-    show (A s)  = s+newLpName               :: String -> QName+newLpName lp            = changeNameCache $+                          newXName' lp `andThen` \ lp' ->+                          newQName' lp' nullXName nullXName -instance NFData Atom where+newPxName               :: String -> String -> QName+newPxName lp px         = changeNameCache $+                          newXName' lp `andThen` \ lp' ->+                          newXName' px `andThen` \ px' ->+                          newQName' lp' px' nullXName++newNsName               :: String -> String -> String -> QName+newNsName lp px ns      = changeNameCache $+                          newXName' lp `andThen` \ lp' ->+                          newXName' px `andThen` \ px' ->+                          newXName' ns `andThen` \ ns' ->+                          newQName' lp' px' ns'  -----------------------------------------------------------------------------
src/Text/XML/HXT/DOM/ShowXml.hs view
@@ -17,389 +17,441 @@  module Text.XML.HXT.DOM.ShowXml     ( xshow-    , showElemType+    , xshowBlob+    , xshow'+    , xshow''     ) where -import Data.Maybe-import Data.Tree.NTree.TypeDefs+import           Prelude                      hiding (showChar, showString) -import Text.XML.HXT.DOM.TypeDefs                -- XML Tree types-import Text.XML.HXT.DOM.XmlKeywords-import Text.XML.HXT.DOM.XmlNode                 ( mkDTDElem-                                                , getDTDAttrl-                                                )+import           Data.Maybe+import           Data.Tree.Class+import           Data.Tree.NTree.TypeDefs +import           Text.XML.HXT.DOM.TypeDefs+import           Text.XML.HXT.DOM.XmlKeywords+import           Text.XML.HXT.DOM.XmlNode     (getDTDAttrl, mkDTDElem)+import           Text.Regex.XMLSchema.Generic(sed)+ -- ----------------------------------------------------------------------------- -- -- the toString conversion functions  -- |--- convert the result of a filter into a string+-- convert a list of trees into a string -- -- see also : 'xmlTreesToText' for filter version, 'Text.XML.HXT.Parser.XmlParsec.xread' for the inverse operation -xshow   :: XmlTrees -> String+xshow                           :: XmlTrees -> String xshow [(NTree (XText s) _)]     = s                     -- special case optimisation-xshow ts                        = showXmlTrees ts ""+xshow [(NTree (XBlob b) _)]     = blobToString b        -- special case optimisation+xshow ts                        = showXmlTrees showString showString ts "" --- ------------------------------------------------------------+-- | convert an XML tree into a binary large object (a bytestring) -showXmlTree             :: XmlTree  -> String -> String+xshowBlob                       :: XmlTrees -> Blob+xshowBlob [(NTree (XBlob b) _)] = b                     -- special case optimisation+xshowBlob [(NTree (XText s) _)] = stringToBlob s        -- special case optimisation+xshowBlob ts                    = stringToBlob $ xshow ts -showXmlTree (NTree (XText s) _)-    = showString s+-- |+-- convert a list of trees into a blob.+--+-- Apply a quoting function for XML quoting of content,+-- a 2. quoting funtion for attribute values+-- and an encoding function after tree conversion -showXmlTree (NTree (XCharRef i) _)-    = showString "&#" . showString (show i) . showChar ';'+xshow'                          :: (Char -> StringFct) ->+                                   (Char -> StringFct) ->+                                   (Char -> StringFct) ->+                                   XmlTrees -> Blob+xshow' cquot aquot enc ts       = stringToBlob $ (concatMap' enc (showTrees ts "")) ""+    where+    showTrees                   = showXmlTrees (concatMap' cquot) (concatMap' aquot) -showXmlTree (NTree (XEntityRef r) _)-    = showString "&" . showString r . showChar ';'+xshow''                         :: (Char -> StringFct) ->+                                   (Char -> StringFct) ->+                                   XmlTrees -> String+xshow'' cquot aquot ts          = showTrees ts ""+    where+    showTrees                   = showXmlTrees (concatMap' cquot) (concatMap' aquot) -showXmlTree (NTree (XCmt c) _)-    = showString "<!--" . showString c . showString "-->"+-- ------------------------------------------------------------ -showXmlTree (NTree (XCdata d) _)-    = showString "<![CDATA[" . showString d . showString "]]>"+type StringFct          = String -> String -showXmlTree (NTree (XPi n al) _)-    = showString "<?"-      .-      showQName n-      .-      (foldr (.) id . map showPiAttr) al-      .-      showString "?>"+-- ------------------------------------------------------------++showXmlTrees                    :: (String -> StringFct) ->+                                   (String -> StringFct) ->+                                   XmlTrees -> StringFct+showXmlTrees cf af+    = showTrees       where-      showPiAttr        :: XmlTree -> String -> String-      showPiAttr a@(NTree (XAttr an) cs)-          | qualifiedName an == a_value-              = showBlank . showXmlTrees cs-          | otherwise-              = showXmlTree a-      showPiAttr _-          = id -showXmlTree (NTree (XTag t al) [])-    = showLt . showQName t . showXmlTrees al . showSlash . showGt+      -- ------------------------------------------------------------ -showXmlTree (NTree (XTag t al) cs)-    = showLt . showQName t . showXmlTrees al . showGt-      . showXmlTrees cs-      . showLt . showSlash . showQName t . showGt+      showTrees                 :: XmlTrees -> StringFct+      showTrees                 = foldr (.) id . map showXmlTree+      {-# INLINE showTrees #-} -showXmlTree (NTree (XDTD de al) cs)-    = showXmlDTD de al cs+      showTrees'                :: XmlTrees -> StringFct+      showTrees'                = foldr (\ x y -> x . showNL . y) id . map showXmlTree+      {-# INLINE showTrees' #-} -showXmlTree (NTree (XAttr an) cs)-    = showBlank . showQName an . showEq . showQuoteString (xshow cs)+      -- ------------------------------------------------------------ -showXmlTree (NTree (XError l e) _)-    = showString "<!-- ERROR (" . shows l . showString "):\n" . showString e . showString "\n-->"+      showXmlTree             :: XmlTree  -> StringFct+      showXmlTree (NTree (XText s) _)                         -- common cases first+                                = cf s --- ------------------------------------------------------------+      showXmlTree (NTree (XTag t al) [])+                                = showLt . showQName t . showTrees al . showSlash . showGt -showXmlTrees            :: XmlTrees -> String -> String-showXmlTrees            = foldr (.) id . map showXmlTree+      showXmlTree (NTree (XTag t al) cs)+                                = showLt . showQName t . showTrees al . showGt+                                  . showTrees cs+                                  . showLt . showSlash . showQName t . showGt -showXmlTrees'           :: XmlTrees -> String -> String-showXmlTrees'           = foldr (\ x y -> x . showNL . y) id . map showXmlTree+      showXmlTree (NTree (XAttr an) cs)+                                = showBlank+                                  . showQName an+                                  . showEq+                                  . showQuot+                                  . af (xshow cs)+                                  . showQuot --- ------------------------------------------------------------+      showXmlTree (NTree (XBlob b) _)+                                = cf . blobToString $ b -showQName               :: QName -> String -> String-showQName-    = showString . qualifiedName+      showXmlTree (NTree (XCharRef i) _)+                                = showString "&#" . showString (show i) . showChar ';' --- ------------------------------------------------------------+      showXmlTree (NTree (XEntityRef r) _)+                                = showString "&" . showString r . showChar ';' -showQuoteString         :: String -> String -> String-showQuoteString s-    | '\"' `elem` s-        = showApos . showString s . showApos-    | otherwise-        = showQuot . showString s . showQuot+      showXmlTree (NTree (XCmt c) _)+                                = showString "<!--" . showString c . showString "-->" +      showXmlTree (NTree (XCdata d) _)+                                = showString "<![CDATA[" . showString d' . showString "]]>"+                                  where+                                    -- quote "]]>" in CDATA contents+                                    d' = sed (const "]]&gt;") "\\]\\]>" d --- ------------------------------------------------------------+      showXmlTree (NTree (XPi n al) _)+                                = showString "<?"+                                  . showQName n+                                  . (foldr (.) id . map showPiAttr) al+                                  . showString "?>"+                                  where+                                  showPiAttr        :: XmlTree -> StringFct+                                  showPiAttr a@(NTree (XAttr an) cs)+                                      | qualifiedName an == a_value+                                          -- <?some-pi ... ?>+                                          -- no XML quoting of PI value+                                          = showBlank . showXmlTrees showString showString cs+                                      | otherwise+                                          -- <?xml version="..." ... ?>+                                          = showXmlTree a+                                  showPiAttr a+                                      = showXmlTree a -- id -showAttr        :: String -> Attributes -> String -> String-showAttr k al-    = showString (fromMaybe "" . lookup k $ al)+      showXmlTree (NTree (XDTD de al) cs)+                                = showXmlDTD de al cs --- ------------------------------------------------------------+      showXmlTree (NTree (XError l e) _)+                                = showString "<!-- ERROR ("+                                  . shows l+                                  . showString "):\n"+                                  . showString e+                                  . showString "\n-->" -showPEAttr      :: Attributes -> String -> String-showPEAttr al-    = showPE (lookup a_peref al)-      where-      showPE (Just pe) = showChar '%' . showString pe . showChar ';'-      showPE Nothing   = id+      -- ------------------------------------------------------------ --- ------------------------------------------------------------+      showXmlDTD              :: DTDElem -> Attributes -> XmlTrees -> StringFct -showExternalId  :: Attributes -> String -> String-showExternalId al-    = id2Str (lookup k_system al) (lookup k_public al)-      where-      id2Str Nothing  Nothing  = id-      id2Str (Just s) Nothing  = showBlank . showString k_system . showBlank . showQuoteString s-      id2Str Nothing  (Just p) = showBlank . showString k_public . showBlank . showQuoteString p-      id2Str (Just s) (Just p) = showBlank . showString k_public . showBlank . showQuoteString p . showBlank . showQuoteString s+      showXmlDTD DOCTYPE al cs  = showString "<!DOCTYPE "+                                  . showAttr a_name al+                                  . showExternalId al+                                  . showInternalDTD cs+                                  . showString ">"+                                  where+                                  showInternalDTD [] = id+                                  showInternalDTD ds = showString " [\n"+                                                       . showTrees' ds+                                                       . showChar ']' --- ------------------------------------------------------------+      showXmlDTD ELEMENT al cs  = showString "<!ELEMENT "+                                  . showAttr a_name al+                                  . showBlank+                                  . showElemType (lookup1 a_type al) cs+                                  . showString " >" -showNData       :: Attributes -> String -> String-showNData al-    = nd2Str (lookup k_ndata al)-      where-      nd2Str Nothing    = id-      nd2Str (Just v)   = showBlank . showString k_ndata . showBlank . showString v+      showXmlDTD ATTLIST al cs  = showString "<!ATTLIST "+                                  . ( if isNothing . lookup a_name $ al+                                      then+                                      showTrees cs+                                      else+                                      showAttr a_name al+                                      . showBlank+                                      . ( case lookup a_value al of+                                          Nothing -> ( showPEAttr+                                                       . fromMaybe [] . getDTDAttrl+                                                       . head+                                                     ) cs+                                          Just a  -> ( showString a+                                                       . showAttrType (lookup1 a_type al)+                                                       . showAttrKind (lookup1 a_kind al)+                                                     )+                                        )+                                    )+                                  . showString " >"+                                  where+                                  showAttrType t+                                      | t == k_peref+                                          = showBlank . showPEAttr al+                                      | t == k_enumeration+                                          = showAttrEnum+                                      | t == k_notation+                                          = showBlank . showString k_notation . showAttrEnum+                                      | otherwise+                                          = showBlank . showString t --- ------------------------------------------------------------+                                  showAttrEnum+                                      = showString " ("+                                        . foldr1+                                              (\ s1 s2 -> s1 . showString " | " .  s2)+                                              (map (getEnum . fromMaybe [] . getDTDAttrl) cs)+                                        . showString ")"+                                        where+                                        getEnum     :: Attributes -> StringFct+                                        getEnum l = showAttr a_name l . showPEAttr l -showXmlDTD              :: DTDElem -> Attributes -> XmlTrees -> String -> String+                                  showAttrKind k+                                      | k == k_default+                                          = showBlank+                                            . showQuoteString (lookup1 a_default al)+                                      | k == k_fixed+                                          = showBlank+                                            . showString k_fixed+                                            . showBlank+                                            . showQuoteString (lookup1 a_default al)+                                      | k == ""+                                          = id+                                      | otherwise+                                          = showBlank+                                            . showString k -showXmlDTD DOCTYPE al cs-    = showString "<!DOCTYPE "-      .-      showAttr a_name al-      .-      showExternalId al-      .-      showInternalDTD cs-      .-      showString ">"-      where-      showInternalDTD [] = id-      showInternalDTD ds = showString " [\n" . showXmlTrees' ds . showChar ']'+      showXmlDTD NOTATION al _cs+                                = showString "<!NOTATION "+                                  . showAttr a_name al+                                  . showExternalId al+                                  . showString " >" -showXmlDTD ELEMENT al cs-    = showString "<!ELEMENT "-      .-      showAttr a_name al-      .-      showBlank-      .-      showElemType (lookup1 a_type al) cs-      .-      showString " >"+      showXmlDTD PENTITY al cs  = showEntity "% " al cs -showXmlDTD ATTLIST al cs-    = showString "<!ATTLIST "-      .-      ( if isNothing . lookup a_name $ al-        then-        showXmlTrees cs-        else-        showAttr a_name al-        .-        showBlank-        .-        ( case lookup a_value al of-          Nothing -> ( showPEAttr-                       . fromMaybe [] . getDTDAttrl-                       . head-                     ) cs-          Just a  -> ( showString a-                       .-                       showAttrType (lookup1 a_type al)-                       .-                       showAttrKind (lookup1 a_kind al)-                     )-        )-      )-      .-      showString " >"-      where-      showAttrType t-          | t == k_peref-              = showBlank . showPEAttr al-          | t == k_enumeration-              = showAttrEnum-          | t == k_notation-              = showBlank . showString k_notation . showAttrEnum-          | otherwise-              = showBlank . showString t+      showXmlDTD ENTITY al cs   = showEntity "" al cs -      showAttrEnum-          = showString " ("-            .-            foldr1 (\ s1 s2 -> s1 . showString " | " .  s2) (map (getEnum . fromMaybe [] . getDTDAttrl) cs)-            .-            showString ")"-            where-            getEnum     :: Attributes -> String -> String-            getEnum l = showAttr a_name l . showPEAttr l+      showXmlDTD PEREF al _cs   = showPEAttr al -      showAttrKind k-          | k == k_default-              = showBlank . showQuoteString (lookup1 a_default al)-          | k == k_fixed-              = showBlank . showString k_fixed-                .-                showBlank . showQuoteString (lookup1 a_default al)-          | k == ""-              = id-          | otherwise-              = showBlank . showString k+      showXmlDTD CONDSECT _ (c1 : cs)+                                = showString "<![ "+                                  . showXmlTree c1+                                  . showString " [\n"+                                  . showTrees cs+                                  . showString "]]>" -showXmlDTD NOTATION al _cs-    = showString "<!NOTATION "-      .-      showAttr a_name al-      .-      showExternalId al-      .-      showString " >"+      showXmlDTD CONTENT al cs  = showContent (mkDTDElem CONTENT al cs) -showXmlDTD PENTITY al cs-    = showEntity "% " al cs+      showXmlDTD NAME al _cs    = showAttr a_name al -showXmlDTD ENTITY al cs-    = showEntity "" al cs+      showXmlDTD de al _cs      = showString "NOT YET IMPLEMETED: "+                                  . showString (show de)+                                  . showBlank+                                  . showString (show al)+                                  . showString " [...]\n" -showXmlDTD PEREF al _cs-    = showPEAttr al+      -- ------------------------------------------------------------ -showXmlDTD CONDSECT _ (c1 : cs)-    = showString "<![ "-      .-      showXmlTree c1-      .-      showString " [\n"-      .-      showXmlTrees cs-      .-      showString "]]>"+      showEntity                :: String -> Attributes -> XmlTrees -> StringFct+      showEntity kind al cs     = showString "<!ENTITY "+                                  . showString kind+                                  . showAttr a_name al+                                  . showExternalId al+                                  . showNData al+                                  . showEntityValue cs+                                  . showString " >" -showXmlDTD CONTENT al cs-    = showContent (mkDTDElem CONTENT al cs) -showXmlDTD NAME al _cs-    = showAttr a_name al+      showEntityValue           :: XmlTrees -> StringFct+      showEntityValue []        = id+      showEntityValue cs        = showBlank+                                  . showQuot+                                  . af (xshow cs)+                                  . showQuot -showXmlDTD de al _cs-    = showString "NOT YET IMPLEMETED: " . showString (show de) . showBlank . showString (show al) . showString " [...]\n"+      -- ------------------------------------------------------------ --- ------------------------------------------------------------+      showContent               :: XmlTree -> StringFct+      showContent (NTree (XDTD de al) cs)+                                = cont2String de+                                  where+                                  cont2String           :: DTDElem -> StringFct+                                  cont2String NAME      = showAttr a_name al+                                  cont2String PEREF     = showPEAttr al+                                  cont2String CONTENT   = showLpar+                                                          . foldr1+                                                                (combine (lookup1 a_kind al))+                                                                (map showContent cs)+                                                          . showRpar+                                                          . showAttr a_modifier al+                                  cont2String n         = error ("cont2string " ++ show n ++ " is undefined")+                                  combine k s1 s2       = s1+                                                          . showString ( if k == v_seq+                                                                         then ", "+                                                                         else " | "+                                                                       )+                                                          . s2 -showElemType    :: String -> XmlTrees -> String -> String-showElemType t cs-    | t == v_pcdata-        = showLpar . showString v_pcdata . showRpar+      showContent n             = showXmlTree n -    | t == v_mixed && (not . null) cs-        = showLpar-          .-          showString v_pcdata-          .-          ( foldr (.) id . map (mixedContent . selAttrl . getNode) ) cs1-          .-          showRpar-          .-          showAttr a_modifier al1-    | t == v_mixed                              -- incorrect tree, e.g. after erronius pe substitution-        = showLpar-          .-          showRpar-    | t == v_children && (not . null) cs-        = showContent (head cs)-    | t == v_children-        = showLpar-          . showRpar-    | t == k_peref-        = foldr (.) id . map showContent $ cs-    | otherwise-        = showString t-    where-    [(NTree (XDTD CONTENT al1) cs1)] = cs+      -- ------------------------------------------------------------ -    mixedContent :: Attributes -> String -> String-    mixedContent l-        = showString " | " . showAttr a_name l . showPEAttr l+      showElemType              :: String -> XmlTrees -> StringFct+      showElemType t cs+          | t == v_pcdata       = showLpar . showString v_pcdata . showRpar+          | t == v_mixed+            &&+            (not . null) cs     = showLpar+                                  . showString v_pcdata+                                  . ( foldr (.) id+                                      . map (mixedContent . selAttrl . getNode)+                                    ) cs1+                                  . showRpar+                                  . showAttr a_modifier al1+          | t == v_mixed                              -- incorrect tree, e.g. after erronius pe substitution+                                = showLpar+                                  . showRpar+          | t == v_children+            &&+            (not . null) cs     = showContent (head cs)+          | t == v_children     = showLpar+                                  . showRpar+          | t == k_peref        = foldr (.) id+                                  . map showContent $ cs+          | otherwise           = showString t+          where+          [(NTree (XDTD CONTENT al1) cs1)] = cs -    selAttrl (XDTD _ as) = as-    selAttrl (XText tex) = [(a_name, tex)]-    selAttrl _           = []+          mixedContent          :: Attributes -> StringFct+          mixedContent l        = showString " | " . showAttr a_name l . showPEAttr l +          selAttrl (XDTD _ as)  = as+          selAttrl (XText tex)  = [(a_name, tex)]+          selAttrl _            = []+ -- ------------------------------------------------------------ -showContent     :: XmlTree -> String -> String-showContent (NTree (XDTD de al) cs)-    = cont2String de-      where-      cont2String       :: DTDElem -> String -> String-      cont2String NAME-          = showAttr a_name al-      cont2String PEREF-          = showPEAttr al-      cont2String CONTENT-          = showLpar-            .-            foldr1 (combine (lookup1 a_kind al)) (map showContent cs)-            .-            showRpar-            .-            showAttr a_modifier al-      cont2String n-          = error ("cont2string " ++ show n ++ " is undefined")-      combine k s1 s2-          = s1-            .-            showString ( if k == v_seq-                         then ", "-                         else " | "-                       )-            .-            s2+showQName                       :: QName -> StringFct+showQName                       = qualifiedName'+{-# INLINE showQName #-} -showContent n-    = showXmlTree n+-- ------------------------------------------------------------ +showQuoteString                 :: String -> StringFct+showQuoteString s               = showQuot . showString s . showQuot+ -- ------------------------------------------------------------ -showEntity      :: String -> Attributes -> XmlTrees -> String -> String+showAttr                        :: String -> Attributes -> StringFct+showAttr k al                   = showString (fromMaybe "" . lookup k $ al) -showEntity kind al cs-    = showString "<!ENTITY "-      .-      showString kind-      .-      showAttr a_name al-      .-      showExternalId al-      .-      showNData al-      .-      showEntityValue cs-      .-      showString " >"+-- ------------------------------------------------------------ +showPEAttr                      :: Attributes -> StringFct+showPEAttr al                   = showPE (lookup a_peref al)+    where+    showPE (Just pe)            = showChar '%'+                                  . showString pe+                                  . showChar ';'+    showPE Nothing              = id+ -- ------------------------------------------------------------ -showEntityValue :: XmlTrees -> String -> String+showExternalId                  :: Attributes -> StringFct+showExternalId al               = id2Str (lookup k_system al) (lookup k_public al)+    where+    id2Str Nothing  Nothing     = id+    id2Str (Just s) Nothing     = showBlank+                                  . showString k_system+                                  . showBlank+                                  . showQuoteString s+    id2Str Nothing  (Just p)    = showBlank+                                  . showString k_public+                                  . showBlank+                                  . showQuoteString p+    id2Str (Just s) (Just p)    = showBlank+                                  . showString k_public+                                  . showBlank+                                  . showQuoteString p+                                  . showBlank+                                  . showQuoteString s -showEntityValue []-    = id+-- ------------------------------------------------------------ -showEntityValue cs-    = showBlank . showQuoteString (xshow cs)+showNData                       :: Attributes -> StringFct+showNData al                    = nd2Str (lookup k_ndata al)+    where+    nd2Str Nothing              = id+    nd2Str (Just v)             = showBlank+                                  . showString k_ndata+                                  . showBlank+                                  . showString v  -- ------------------------------------------------------------  showBlank,-  showEq, showLt, showGt, showSlash, showApos, showQuot, showLpar, showRpar, showNL :: String -> String+  showEq, showLt, showGt, showSlash, showQuot, showLpar, showRpar, showNL :: StringFct  showBlank       = showChar ' '+{-# INLINE showBlank #-}+ showEq          = showChar '='+{-# INLINE showEq #-}+ showLt          = showChar '<'+{-# INLINE showLt #-}+ showGt          = showChar '>'+{-# INLINE showGt #-}+ showSlash       = showChar '/'-showApos        = showChar '\''+{-# INLINE showSlash #-}+ showQuot        = showChar '\"'+{-# INLINE showQuot #-}+ showLpar        = showChar '('+{-# INLINE showLpar #-}+ showRpar        = showChar ')'+{-# INLINE showRpar #-}+ showNL          = showChar '\n'+{-# INLINE showNL #-}++showChar        :: Char -> StringFct+showChar        = (:)+{-# INLINE showChar #-}++showString      :: String -> StringFct+showString      = (++)+{-# INLINE showString #-}++concatMap'      :: (Char -> StringFct) -> String -> StringFct+concatMap' f    = foldr (\ x r -> f x . r) id+{-# INLINE concatMap' #-}  -- -----------------------------------------------------------------------------
src/Text/XML/HXT/DOM/TypeDefs.hs view
@@ -4,7 +4,7 @@  {- |    Module     : Text.XML.HXT.DOM.TypeDefs-   Copyright  : Copyright (C) 2008 Uwe Schmidt+   Copyright  : Copyright (C) 2008-2010 Uwe Schmidt    License    : MIT     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)@@ -25,59 +25,133 @@  where -import Control.DeepSeq+import           Control.DeepSeq+import           Control.FlatSeq -import Data.AssocList-import Data.Tree.NTree.TypeDefs-import Data.Typeable+import           Data.AssocList -import Text.XML.HXT.DOM.QualifiedName+import           Data.Binary+import qualified Data.ByteString.Lazy            as BS+import qualified Data.ByteString.Lazy.Char8      as CS +import           Data.Tree.NTree.TypeDefs+import           Data.Tree.NTree.Zipper.TypeDefs++import           Data.Typeable++import           Text.XML.HXT.DOM.QualifiedName+ -- ----------------------------------------------------------------------------- -- -- Basic types for xml tree and filters --- | Node of xml tree representation+-- | Rose tree with XML nodes (XNode)  type XmlTree    = NTree    XNode --- | List of nodes of xml tree representation+-- | List of rose trees with XML nodes  type XmlTrees   = NTrees   XNode +-- | Navigatable rose tree with XML nodes++type XmlNavTree = NTZipper XNode++-- | List of navigatable rose trees with XML nodes++type XmlNavTrees = [NTZipper XNode]+ -- ----------------------------------------------------------------------------- -- -- XNode  -- | Represents elements -data XNode      = XText           String                        -- ^ ordinary text                              (leaf)-                | XCharRef        Int                           -- ^ character reference                        (leaf)-                | XEntityRef      String                        -- ^ entity reference                           (leaf)-                | XCmt            String                        -- ^ comment                                    (leaf)-                | XCdata          String                        -- ^ CDATA section                              (leaf)-                | XPi             QName XmlTrees                -- ^ Processing Instr with qualified name       (leaf)+data XNode      = XText           String                        -- ^ ordinary text                                       (leaf)+                | XBlob           Blob                          -- ^ text represented more space efficient as bytestring (leaf)+                | XCharRef        Int                           -- ^ character reference                                 (leaf)+                | XEntityRef      String                        -- ^ entity reference                                    (leaf)+                | XCmt            String                        -- ^ comment                                             (leaf)+                | XCdata          String                        -- ^ CDATA section                                       (leaf)+                | XPi             QName XmlTrees                -- ^ Processing Instr with qualified name                (leaf)                                                                 --   with list of attributes.-                                                                --   If tag name is xml, attributs are \"version\", \"encoding\", \"standalone\",+                                                                --   If tag name is xml, attributes are \"version\", \"encoding\", \"standalone\",                                                                 --   else attribute list is empty, content is a text child node                 | XTag            QName XmlTrees                -- ^ tag with qualified name and list of attributes (inner node or leaf)                 | XDTD            DTDElem  Attributes           -- ^ DTD element with assoc list for dtd element features                 | XAttr           QName                         -- ^ attribute with qualified name, the attribute value is stored in children                 | XError          Int  String                   -- ^ error message with level and text-                  deriving (Eq, Ord, Show, Read, Typeable)+                  deriving (Eq, Show, Typeable)  instance NFData XNode where     rnf (XText s)               = rnf s+    rnf (XTag qn cs)            = rnf qn `seq` rnf cs+    rnf (XAttr qn)              = rnf qn     rnf (XCharRef i)            = rnf i     rnf (XEntityRef n)          = rnf n     rnf (XCmt c)                = rnf c     rnf (XCdata s)              = rnf s     rnf (XPi qn ts)             = rnf qn `seq` rnf ts-    rnf (XTag qn cs)            = rnf qn `seq` rnf cs     rnf (XDTD de al)            = rnf de `seq` rnf al-    rnf (XAttr qn)              = rnf qn+    rnf (XBlob b)               = BS.length b `seq` ()     rnf (XError n e)            = rnf n  `seq` rnf e +instance WNFData XNode where+    rwnf (XText s)              = rwnf s+    rwnf (XTag qn cs)           = rwnf qn `seq` rwnf cs+    rwnf (XAttr qn)             = rwnf qn+    rwnf (XCharRef i)           = i `seq` ()+    rwnf (XEntityRef n)         = rwnf n+    rwnf (XCmt c)               = rwnf c+    rwnf (XCdata s)             = rwnf s+    rwnf (XPi qn ts)            = rwnf qn `seq` rwnf ts+    rwnf (XDTD de al)           = rwnf de `seq` rwnfAttributes al+    rwnf (XBlob _b)             = () -- BS.length b `seq` () -- lazy bytestrings are not evaluated+    rwnf (XError n e)           = n `seq` rwnf e++-- | Evaluate an assoc list of strings+rwnfAttributes                  :: Attributes -> ()+rwnfAttributes [] = ()+rwnfAttributes ((k, v) : as)    = rwnf k `seq` rwnf v `seq` rwnfAttributes as+++instance Binary XNode where+    put (XText s)               = put ( 0::Word8) >> put s+    put (XTag qn cs)            = put ( 6::Word8) >> put qn >> put cs+    put (XAttr qn)              = put ( 8::Word8) >> put qn+    put (XCharRef i)            = put ( 1::Word8) >> put i+    put (XEntityRef n)          = put ( 2::Word8) >> put n+    put (XCmt c)                = put ( 3::Word8) >> put c+    put (XCdata s)              = put ( 4::Word8) >> put s+    put (XPi qn ts)             = put ( 5::Word8) >> put qn >> put ts+    put (XDTD de al)            = put ( 7::Word8) >> put de >> put al+    put (XError n e)            = put ( 9::Word8) >> put n  >> put e+    put (XBlob b)               = put (10::Word8) >> put b++    get                         = do+                                  tag <- getWord8+                                  case tag of+                                    0  -> get >>= return . XText+                                    1  -> get >>= return . XCharRef+                                    2  -> get >>= return . XEntityRef+                                    3  -> get >>= return . XCmt+                                    4  -> get >>= return . XCdata+                                    5  -> do+                                          qn <- get+                                          get >>= return . XPi qn+                                    6  -> do+                                          qn <- get+                                          get >>= return . XTag qn+                                    7  -> do+                                          de <- get+                                          get >>= return . XDTD de+                                    8  -> get >>= return . XAttr+                                    9  -> do+                                          n <- get+                                          get >>= return . XError n+                                    10 -> get >>= return . XBlob+                                    _  -> error "XNode.get: error while decoding XNode"+ -- ----------------------------------------------------------------------------- -- -- DTDElem@@ -120,9 +194,31 @@                   deriving (Eq, Ord, Enum, Show, Read, Typeable)  instance NFData DTDElem+    where rnf x = seq x () +instance WNFData DTDElem++instance Binary DTDElem where+    put de = put ((toEnum . fromEnum $ de)::Word8)         -- DTDElem is not yet instance of Enum+    get    = do tag <- getWord8+                return $! (toEnum . fromEnum $ tag)+ -- ----------------------------------------------------------------------------- +-- | Binary large object implemented as a lazy bytestring++type Blob       = BS.ByteString++blobToString    :: Blob -> String+blobToString    = CS.unpack+{-# INLINE blobToString #-}++stringToBlob    :: String -> Blob+stringToBlob    = CS.pack+{-# INLINE stringToBlob #-}++-- -----------------------------------------------------------------------------+ -- | Attribute list -- -- used for storing option lists and features of DTD parts@@ -157,9 +253,9 @@ -- such that the selected nodes can be processed or selected later in -- processing a document tree -data XmlNodeSet = XNS { thisNode        :: Bool         -- ^ is this node part of the set ?-                      , attrNodes       :: [QName]      -- ^ the set of attribute nodes-                      , childNodes      :: ChildNodes   -- ^ the set of child nodes, a list of pairs of index and node set+data XmlNodeSet = XNS { thisNode   :: Bool         -- ^ is this node part of the set ?+                      , attrNodes  :: [QName]      -- ^ the set of attribute nodes+                      , childNodes :: ChildNodes   -- ^ the set of child nodes, a list of pairs of index and node set                       }                   deriving (Eq, Show, Typeable)
− src/Text/XML/HXT/DOM/UTF8Decoding.hs 
@@ -1,52 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.DOM.UTF8Decoding-   Copyright  : Copyright (C) 2005 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : stable-   Portability: portable--   Interface for Data.Char.UTF8 funtions---}---- --------------------------------------------------------------module Text.XML.HXT.DOM.UTF8Decoding (-   decodeUtf8,-   decodeUtf8EmbedErrors,-   decodeUtf8IgnoreErrors,-   )-where--import qualified Data.Char.UTF8 as UTF8-import Data.Word (Word8)---- | calls 'Data.Char.UTF8.decode' for parsing and decoding UTF-8--decodeUtf8      :: String -> (String, [String])-decodeUtf8 str-    = (res, map (uncurry toErrStr) errs)-    where-    (res, errs) = UTF8.decode . stringToByteString $ str--decodeUtf8IgnoreErrors  :: String -> String-decodeUtf8IgnoreErrors-    = fst . decodeUtf8--decodeUtf8EmbedErrors   :: String -> [Either String Char]-decodeUtf8EmbedErrors str-    = map (either (Left . uncurry toErrStr) Right) $-      UTF8.decodeEmbedErrors $ stringToByteString $ str--stringToByteString :: String -> [Word8]-stringToByteString = map (toEnum . fromEnum)--toErrStr :: UTF8.Error -> Int -> String-toErrStr err pos-        = " at input position " ++ show pos ++ ": " ++ show err---- ------------------------------------------------------------
− src/Text/XML/HXT/DOM/Unicode.hs 
@@ -1,1105 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.DOM.Unicode-   Copyright  : Copyright (C) 2005-2008 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : experimental-   Portability: portable--   Unicode and UTF-8 Conversion Functions---}---- --------------------------------------------------------------module Text.XML.HXT.DOM.Unicode-    (-     -- * Unicode Type declarations-     Unicode,-     UString,-     UTF8Char,-     UTF8String,-     UStringWithErrors,-     DecodingFct,-     DecodingFctEmbedErrors,--      -- * XML char predicates--      isXmlChar-    , isXmlLatin1Char-    , isXmlSpaceChar-    , isXml11SpaceChar-    , isXmlNameChar-    , isXmlNameStartChar-    , isXmlNCNameChar-    , isXmlNCNameStartChar-    , isXmlPubidChar-    , isXmlLetter-    , isXmlBaseChar-    , isXmlIdeographicChar-    , isXmlCombiningChar-    , isXmlDigit-    , isXmlExtender-    , isXmlControlOrPermanentlyUndefined--      -- * UTF-8 and Unicode conversion functions-    , utf8ToUnicode-    , utf8ToUnicodeEmbedErrors-    , latin1ToUnicode-    , ucs2ToUnicode-    , ucs2BigEndianToUnicode-    , ucs2LittleEndianToUnicode-    , utf16beToUnicode-    , utf16leToUnicode--    , unicodeCharToUtf8--    , unicodeToUtf8-    , unicodeToXmlEntity-    , unicodeToLatin1-    , unicodeRemoveNoneAscii-    , unicodeRemoveNoneLatin1--    , intToCharRef-    , intToCharRefHex--    , getDecodingFct-    , getDecodingFctEmbedErrors-    , getOutputEncodingFct--    , normalizeNL-    , guessEncoding-    )-where--import Data.Char( toUpper )--import Text.XML.HXT.DOM.Util ( swap, partitionEither )--import Text.XML.HXT.DOM.IsoLatinTables-import Text.XML.HXT.DOM.UTF8Decoding    ( decodeUtf8, decodeUtf8EmbedErrors )-import Text.XML.HXT.DOM.Util            ( intToHexString )-import Text.XML.HXT.DOM.XmlKeywords---- ---------------------------------------------------------------- | Unicode is represented as the Char type---   Precondition for this is the support of Unicode character range---   in the compiler (e.g. ghc but not hugs)--type Unicode    = Char---- | the type for Unicode strings--type UString    = [Unicode]---- | UTF-8 charachters are represented by the Char type--type UTF8Char   = Char---- | UTF-8 strings are implemented as Haskell strings--type UTF8String = String---- | Decoding function with a pair containing the result string and a list of decoding errors as result--type DecodingFct = String -> (UString, [String])--type UStringWithErrors = [Either String Char]---- | Decoding function where decoding errors are interleaved with decoded characters--type DecodingFctEmbedErrors = String -> UStringWithErrors---- ------------------------------------------------------------------ Unicode predicates---- |--- test for a legal 1 byte XML char--is1ByteXmlChar          :: Unicode -> Bool-is1ByteXmlChar c-    = c < '\x80'-      && ( c >= ' '-           ||-           c == '\n'-           ||-           c == '\t'-           ||-           c == '\r'-         )---- |--- test for a legal latin1 XML char--isXmlLatin1Char         :: Unicode -> Bool-isXmlLatin1Char i-    = is1ByteXmlChar i-      ||-      (i >= '\x80' && i <= '\xff')---- ---------------------------------------------------------------- |--- conversion from Unicode strings (UString) to UTF8 encoded strings.--unicodeToUtf8           :: UString -> UTF8String-unicodeToUtf8           = concatMap unicodeCharToUtf8---- |--- conversion from Unicode (Char) to a UTF8 encoded string.--unicodeCharToUtf8       :: Unicode -> UTF8String-unicodeCharToUtf8 c-    | i >= 0          && i <= 0x0000007F        -- 1 byte UTF8 (7 bits)-        = [ toEnum i ]-    | i >= 0x00000080 && i <= 0x000007FF        -- 2 byte UTF8 (5 + 6 bits)-        = [ toEnum (0xC0 + i `div` 0x40)-          , toEnum (0x80 + i                  `mod` 0x40)-          ]-    | i >= 0x00000800 && i <= 0x0000FFFF        -- 3 byte UTF8 (4 + 6 + 6 bits)-        = [ toEnum (0xE0 +  i `div`   0x1000)-          , toEnum (0x80 + (i `div`     0x40) `mod` 0x40)-          , toEnum (0x80 +  i                 `mod` 0x40)-          ]-    | i >= 0x00010000 && i <= 0x001FFFFF        -- 4 byte UTF8 (3 + 6 + 6 + 6 bits)-        = [ toEnum (0xF0 +  i `div`    0x40000)-          , toEnum (0x80 + (i `div`     0x1000) `mod` 0x40)-          , toEnum (0x80 + (i `div`       0x40) `mod` 0x40)-          , toEnum (0x80 +  i                   `mod` 0x40)-          ]-    | i >= 0x00200000 && i <= 0x03FFFFFF        -- 5 byte UTF8 (2 + 6 + 6 + 6 + 6 bits)-        = [ toEnum (0xF8 +  i `div`  0x1000000)-          , toEnum (0x80 + (i `div`    0x40000) `mod` 0x40)-          , toEnum (0x80 + (i `div`     0x1000) `mod` 0x40)-          , toEnum (0x80 + (i `div`       0x40) `mod` 0x40)-          , toEnum (0x80 +  i                   `mod` 0x40)-          ]-    | i >= 0x04000000 && i <= 0x7FFFFFFF        -- 6 byte UTF8 (1 + 6 + 6 + 6 + 6 + 6 bits)-        = [ toEnum (0xFC +  i `div` 0x40000000)-          , toEnum (0x80 + (i `div`  0x1000000) `mod` 0x40)-          , toEnum (0x80 + (i `div`    0x40000) `mod` 0x40)-          , toEnum (0x80 + (i `div`     0x1000) `mod` 0x40)-          , toEnum (0x80 + (i `div`       0x40) `mod` 0x40)-          , toEnum (0x80 +  i                   `mod` 0x40)-          ]-    | otherwise                                 -- other values not supported-        = error ("unicodeCharToUtf8: illegal integer argument " ++ show i)-    where-    i = fromEnum c---- ---------------------------------------------------------------- |--- checking for valid XML characters--isXmlChar               :: Unicode -> Bool-isXmlChar c-    = isInList c-      [ ('\x0009', '\x000A')-      , ('\x000D', '\x000D')-      , ('\x0020', '\xD7FF')-      , ('\xE000', '\xFFFD')-      , ('\x10000', '\x10FFFF')-      ]---- |--- checking for XML space character: \\\n, \\\r, \\\t and \" \"--isXmlSpaceChar          :: Unicode -> Bool-isXmlSpaceChar c-    = c `elem` ['\x20', '\x09', '\x0D', '\x0A']---- |--- checking for XML1.1 space character: additional space 0x85 and 0x2028------ see also : 'isXmlSpaceChar'--isXml11SpaceChar                :: Unicode -> Bool-isXml11SpaceChar c-    = c `elem` ['\x20', '\x09', '\x0D', '\x0A', '\x85', '\x2028']---- |--- checking for XML name character--isXmlNameChar           :: Unicode -> Bool-isXmlNameChar c-    = isXmlLetter c-      ||-      isXmlDigit c-      ||-      (c == '\x2D' || c == '\x2E')              -- '-' | '.'-      ||-      (c == '\x3A' || c == '\x5F')              -- Letter | ':' | '_'-      ||-      isXmlCombiningChar c-      ||-      isXmlExtender c---- |--- checking for XML name start character------ see also : 'isXmlNameChar'--isXmlNameStartChar              :: Unicode -> Bool-isXmlNameStartChar c-    = isXmlLetter c-      ||-      (c == '\x3A' || c == '\x5F')              -- Letter | ':' | '_'---- |--- checking for XML NCName character: no \":\" allowed------ see also : 'isXmlNameChar'--isXmlNCNameChar                 :: Unicode -> Bool-isXmlNCNameChar c-    = c /= '\x3A'-      &&-      isXmlNameChar c---- |--- checking for XML NCName start character: no \":\" allowed------ see also : 'isXmlNameChar', 'isXmlNCNameChar'--isXmlNCNameStartChar            :: Unicode -> Bool-isXmlNCNameStartChar c-    = c /= '\x3A'-      &&-      isXmlNameStartChar c---- |--- checking for XML public id character--isXmlPubidChar          :: Unicode -> Bool-isXmlPubidChar c-    = isInList c [ ('0', '9')-                 , ('A', 'Z')-                 , ('a', 'z')-                 ]-      ||-      ( c `elem` " \r\n-'()+,./:=?;!*#@$_%" )---- |--- checking for XML letter--isXmlLetter             :: Unicode -> Bool-isXmlLetter c-    = isXmlBaseChar c-      ||-      isXmlIdeographicChar c---- |--- checking for XML base charater--isXmlBaseChar           :: Unicode -> Bool-isXmlBaseChar c-    = isInList c-      [ ('\x0041', '\x005A')-      , ('\x0061', '\x007A')-      , ('\x00C0', '\x00D6')-      , ('\x00D8', '\x00F6')-      , ('\x00F8', '\x0131')-      , ('\x0134', '\x013E')-      , ('\x0141', '\x0148')-      , ('\x014A', '\x017E')-      , ('\x0180', '\x01C3')-      , ('\x01CD', '\x01F0')-      , ('\x01F4', '\x01F5')-      , ('\x01FA', '\x0217')-      , ('\x0250', '\x02A8')-      , ('\x02BB', '\x02C1')-      , ('\x0386', '\x0386')-      , ('\x0388', '\x038A')-      , ('\x038C', '\x038C')-      , ('\x038E', '\x03A1')-      , ('\x03A3', '\x03CE')-      , ('\x03D0', '\x03D6')-      , ('\x03DA', '\x03DA')-      , ('\x03DC', '\x03DC')-      , ('\x03DE', '\x03DE')-      , ('\x03E0', '\x03E0')-      , ('\x03E2', '\x03F3')-      , ('\x0401', '\x040C')-      , ('\x040E', '\x044F')-      , ('\x0451', '\x045C')-      , ('\x045E', '\x0481')-      , ('\x0490', '\x04C4')-      , ('\x04C7', '\x04C8')-      , ('\x04CB', '\x04CC')-      , ('\x04D0', '\x04EB')-      , ('\x04EE', '\x04F5')-      , ('\x04F8', '\x04F9')-      , ('\x0531', '\x0556')-      , ('\x0559', '\x0559')-      , ('\x0561', '\x0586')-      , ('\x05D0', '\x05EA')-      , ('\x05F0', '\x05F2')-      , ('\x0621', '\x063A')-      , ('\x0641', '\x064A')-      , ('\x0671', '\x06B7')-      , ('\x06BA', '\x06BE')-      , ('\x06C0', '\x06CE')-      , ('\x06D0', '\x06D3')-      , ('\x06D5', '\x06D5')-      , ('\x06E5', '\x06E6')-      , ('\x0905', '\x0939')-      , ('\x093D', '\x093D')-      , ('\x0958', '\x0961')-      , ('\x0985', '\x098C')-      , ('\x098F', '\x0990')-      , ('\x0993', '\x09A8')-      , ('\x09AA', '\x09B0')-      , ('\x09B2', '\x09B2')-      , ('\x09B6', '\x09B9')-      , ('\x09DC', '\x09DD')-      , ('\x09DF', '\x09E1')-      , ('\x09F0', '\x09F1')-      , ('\x0A05', '\x0A0A')-      , ('\x0A0F', '\x0A10')-      , ('\x0A13', '\x0A28')-      , ('\x0A2A', '\x0A30')-      , ('\x0A32', '\x0A33')-      , ('\x0A35', '\x0A36')-      , ('\x0A38', '\x0A39')-      , ('\x0A59', '\x0A5C')-      , ('\x0A5E', '\x0A5E')-      , ('\x0A72', '\x0A74')-      , ('\x0A85', '\x0A8B')-      , ('\x0A8D', '\x0A8D')-      , ('\x0A8F', '\x0A91')-      , ('\x0A93', '\x0AA8')-      , ('\x0AAA', '\x0AB0')-      , ('\x0AB2', '\x0AB3')-      , ('\x0AB5', '\x0AB9')-      , ('\x0ABD', '\x0ABD')-      , ('\x0AE0', '\x0AE0')-      , ('\x0B05', '\x0B0C')-      , ('\x0B0F', '\x0B10')-      , ('\x0B13', '\x0B28')-      , ('\x0B2A', '\x0B30')-      , ('\x0B32', '\x0B33')-      , ('\x0B36', '\x0B39')-      , ('\x0B3D', '\x0B3D')-      , ('\x0B5C', '\x0B5D')-      , ('\x0B5F', '\x0B61')-      , ('\x0B85', '\x0B8A')-      , ('\x0B8E', '\x0B90')-      , ('\x0B92', '\x0B95')-      , ('\x0B99', '\x0B9A')-      , ('\x0B9C', '\x0B9C')-      , ('\x0B9E', '\x0B9F')-      , ('\x0BA3', '\x0BA4')-      , ('\x0BA8', '\x0BAA')-      , ('\x0BAE', '\x0BB5')-      , ('\x0BB7', '\x0BB9')-      , ('\x0C05', '\x0C0C')-      , ('\x0C0E', '\x0C10')-      , ('\x0C12', '\x0C28')-      , ('\x0C2A', '\x0C33')-      , ('\x0C35', '\x0C39')-      , ('\x0C60', '\x0C61')-      , ('\x0C85', '\x0C8C')-      , ('\x0C8E', '\x0C90')-      , ('\x0C92', '\x0CA8')-      , ('\x0CAA', '\x0CB3')-      , ('\x0CB5', '\x0CB9')-      , ('\x0CDE', '\x0CDE')-      , ('\x0CE0', '\x0CE1')-      , ('\x0D05', '\x0D0C')-      , ('\x0D0E', '\x0D10')-      , ('\x0D12', '\x0D28')-      , ('\x0D2A', '\x0D39')-      , ('\x0D60', '\x0D61')-      , ('\x0E01', '\x0E2E')-      , ('\x0E30', '\x0E30')-      , ('\x0E32', '\x0E33')-      , ('\x0E40', '\x0E45')-      , ('\x0E81', '\x0E82')-      , ('\x0E84', '\x0E84')-      , ('\x0E87', '\x0E88')-      , ('\x0E8A', '\x0E8A')-      , ('\x0E8D', '\x0E8D')-      , ('\x0E94', '\x0E97')-      , ('\x0E99', '\x0E9F')-      , ('\x0EA1', '\x0EA3')-      , ('\x0EA5', '\x0EA5')-      , ('\x0EA7', '\x0EA7')-      , ('\x0EAA', '\x0EAB')-      , ('\x0EAD', '\x0EAE')-      , ('\x0EB0', '\x0EB0')-      , ('\x0EB2', '\x0EB3')-      , ('\x0EBD', '\x0EBD')-      , ('\x0EC0', '\x0EC4')-      , ('\x0F40', '\x0F47')-      , ('\x0F49', '\x0F69')-      , ('\x10A0', '\x10C5')-      , ('\x10D0', '\x10F6')-      , ('\x1100', '\x1100')-      , ('\x1102', '\x1103')-      , ('\x1105', '\x1107')-      , ('\x1109', '\x1109')-      , ('\x110B', '\x110C')-      , ('\x110E', '\x1112')-      , ('\x113C', '\x113C')-      , ('\x113E', '\x113E')-      , ('\x1140', '\x1140')-      , ('\x114C', '\x114C')-      , ('\x114E', '\x114E')-      , ('\x1150', '\x1150')-      , ('\x1154', '\x1155')-      , ('\x1159', '\x1159')-      , ('\x115F', '\x1161')-      , ('\x1163', '\x1163')-      , ('\x1165', '\x1165')-      , ('\x1167', '\x1167')-      , ('\x1169', '\x1169')-      , ('\x116D', '\x116E')-      , ('\x1172', '\x1173')-      , ('\x1175', '\x1175')-      , ('\x119E', '\x119E')-      , ('\x11A8', '\x11A8')-      , ('\x11AB', '\x11AB')-      , ('\x11AE', '\x11AF')-      , ('\x11B7', '\x11B8')-      , ('\x11BA', '\x11BA')-      , ('\x11BC', '\x11C2')-      , ('\x11EB', '\x11EB')-      , ('\x11F0', '\x11F0')-      , ('\x11F9', '\x11F9')-      , ('\x1E00', '\x1E9B')-      , ('\x1EA0', '\x1EF9')-      , ('\x1F00', '\x1F15')-      , ('\x1F18', '\x1F1D')-      , ('\x1F20', '\x1F45')-      , ('\x1F48', '\x1F4D')-      , ('\x1F50', '\x1F57')-      , ('\x1F59', '\x1F59')-      , ('\x1F5B', '\x1F5B')-      , ('\x1F5D', '\x1F5D')-      , ('\x1F5F', '\x1F7D')-      , ('\x1F80', '\x1FB4')-      , ('\x1FB6', '\x1FBC')-      , ('\x1FBE', '\x1FBE')-      , ('\x1FC2', '\x1FC4')-      , ('\x1FC6', '\x1FCC')-      , ('\x1FD0', '\x1FD3')-      , ('\x1FD6', '\x1FDB')-      , ('\x1FE0', '\x1FEC')-      , ('\x1FF2', '\x1FF4')-      , ('\x1FF6', '\x1FFC')-      , ('\x2126', '\x2126')-      , ('\x212A', '\x212B')-      , ('\x212E', '\x212E')-      , ('\x2180', '\x2182')-      , ('\x3041', '\x3094')-      , ('\x30A1', '\x30FA')-      , ('\x3105', '\x312C')-      , ('\xAC00', '\xD7A3')-      ]---- |--- checking for XML ideographic charater--isXmlIdeographicChar    :: Unicode -> Bool-isXmlIdeographicChar c-    = isInList c-      [ ('\x3007', '\x3007')-      , ('\x3021', '\x3029')-      , ('\x4E00', '\x9FA5')-      ]---- |--- checking for XML combining charater--isXmlCombiningChar      :: Unicode -> Bool-isXmlCombiningChar c-    = isInList c-      [ ('\x0300', '\x0345')-      , ('\x0360', '\x0361')-      , ('\x0483', '\x0486')-      , ('\x0591', '\x05A1')-      , ('\x05A3', '\x05B9')-      , ('\x05BB', '\x05BD')-      , ('\x05BF', '\x05BF')-      , ('\x05C1', '\x05C2')-      , ('\x05C4', '\x05C4')-      , ('\x064B', '\x0652')-      , ('\x0670', '\x0670')-      , ('\x06D6', '\x06DC')-      , ('\x06DD', '\x06DF')-      , ('\x06E0', '\x06E4')-      , ('\x06E7', '\x06E8')-      , ('\x06EA', '\x06ED')-      , ('\x0901', '\x0903')-      , ('\x093C', '\x093C')-      , ('\x093E', '\x094C')-      , ('\x094D', '\x094D')-      , ('\x0951', '\x0954')-      , ('\x0962', '\x0963')-      , ('\x0981', '\x0983')-      , ('\x09BC', '\x09BC')-      , ('\x09BE', '\x09BE')-      , ('\x09BF', '\x09BF')-      , ('\x09C0', '\x09C4')-      , ('\x09C7', '\x09C8')-      , ('\x09CB', '\x09CD')-      , ('\x09D7', '\x09D7')-      , ('\x09E2', '\x09E3')-      , ('\x0A02', '\x0A02')-      , ('\x0A3C', '\x0A3C')-      , ('\x0A3E', '\x0A3E')-      , ('\x0A3F', '\x0A3F')-      , ('\x0A40', '\x0A42')-      , ('\x0A47', '\x0A48')-      , ('\x0A4B', '\x0A4D')-      , ('\x0A70', '\x0A71')-      , ('\x0A81', '\x0A83')-      , ('\x0ABC', '\x0ABC')-      , ('\x0ABE', '\x0AC5')-      , ('\x0AC7', '\x0AC9')-      , ('\x0ACB', '\x0ACD')-      , ('\x0B01', '\x0B03')-      , ('\x0B3C', '\x0B3C')-      , ('\x0B3E', '\x0B43')-      , ('\x0B47', '\x0B48')-      , ('\x0B4B', '\x0B4D')-      , ('\x0B56', '\x0B57')-      , ('\x0B82', '\x0B83')-      , ('\x0BBE', '\x0BC2')-      , ('\x0BC6', '\x0BC8')-      , ('\x0BCA', '\x0BCD')-      , ('\x0BD7', '\x0BD7')-      , ('\x0C01', '\x0C03')-      , ('\x0C3E', '\x0C44')-      , ('\x0C46', '\x0C48')-      , ('\x0C4A', '\x0C4D')-      , ('\x0C55', '\x0C56')-      , ('\x0C82', '\x0C83')-      , ('\x0CBE', '\x0CC4')-      , ('\x0CC6', '\x0CC8')-      , ('\x0CCA', '\x0CCD')-      , ('\x0CD5', '\x0CD6')-      , ('\x0D02', '\x0D03')-      , ('\x0D3E', '\x0D43')-      , ('\x0D46', '\x0D48')-      , ('\x0D4A', '\x0D4D')-      , ('\x0D57', '\x0D57')-      , ('\x0E31', '\x0E31')-      , ('\x0E34', '\x0E3A')-      , ('\x0E47', '\x0E4E')-      , ('\x0EB1', '\x0EB1')-      , ('\x0EB4', '\x0EB9')-      , ('\x0EBB', '\x0EBC')-      , ('\x0EC8', '\x0ECD')-      , ('\x0F18', '\x0F19')-      , ('\x0F35', '\x0F35')-      , ('\x0F37', '\x0F37')-      , ('\x0F39', '\x0F39')-      , ('\x0F3E', '\x0F3E')-      , ('\x0F3F', '\x0F3F')-      , ('\x0F71', '\x0F84')-      , ('\x0F86', '\x0F8B')-      , ('\x0F90', '\x0F95')-      , ('\x0F97', '\x0F97')-      , ('\x0F99', '\x0FAD')-      , ('\x0FB1', '\x0FB7')-      , ('\x0FB9', '\x0FB9')-      , ('\x20D0', '\x20DC')-      , ('\x20E1', '\x20E1')-      , ('\x302A', '\x302F')-      , ('\x3099', '\x3099')-      , ('\x309A', '\x309A')-      ]---- |--- checking for XML digit--isXmlDigit              :: Unicode -> Bool-isXmlDigit c-    = isInList c-      [ ('\x0030', '\x0039')-      , ('\x0660', '\x0669')-      , ('\x06F0', '\x06F9')-      , ('\x0966', '\x096F')-      , ('\x09E6', '\x09EF')-      , ('\x0A66', '\x0A6F')-      , ('\x0AE6', '\x0AEF')-      , ('\x0B66', '\x0B6F')-      , ('\x0BE7', '\x0BEF')-      , ('\x0C66', '\x0C6F')-      , ('\x0CE6', '\x0CEF')-      , ('\x0D66', '\x0D6F')-      , ('\x0E50', '\x0E59')-      , ('\x0ED0', '\x0ED9')-      , ('\x0F20', '\x0F29')-      ]---- |--- checking for XML extender--isXmlExtender           :: Unicode -> Bool-isXmlExtender c-    = isInList c-      [ ('\x00B7', '\x00B7')-      , ('\x02D0', '\x02D0')-      , ('\x02D1', '\x02D1')-      , ('\x0387', '\x0387')-      , ('\x0640', '\x0640')-      , ('\x0E46', '\x0E46')-      , ('\x0EC6', '\x0EC6')-      , ('\x3005', '\x3005')-      , ('\x3031', '\x3035')-      , ('\x309D', '\x309E')-      , ('\x30FC', '\x30FE')-      ]---- |--- checking for XML control or permanently discouraged char------ see Errata to XML1.0 (http:\/\/www.w3.org\/XML\/xml-V10-2e-errata) No 46------ Document authors are encouraged to avoid "compatibility characters",--- as defined in section 6.8 of [Unicode] (see also D21 in section 3.6 of [Unicode3]).--- The characters defined in the following ranges are also discouraged.--- They are either control characters or permanently undefined Unicode characters:---isXmlControlOrPermanentlyUndefined      :: Unicode -> Bool-isXmlControlOrPermanentlyUndefined c-    = isInList c-      [ ('\x7F', '\x84')-      , ('\x86', '\x9F')-      , ('\xFDD0', '\xFDDF')-      , ('\x1FFFE', '\x1FFFF')-      , ('\x2FFFE', '\x2FFFF')-      , ('\x3FFFE', '\x3FFFF')-      , ('\x4FFFE', '\x4FFFF')-      , ('\x5FFFE', '\x5FFFF')-      , ('\x6FFFE', '\x6FFFF')-      , ('\x7FFFE', '\x7FFFF')-      , ('\x8FFFE', '\x8FFFF')-      , ('\x9FFFE', '\x9FFFF')-      , ('\xAFFFE', '\xAFFFF')-      , ('\xBFFFE', '\xBFFFF')-      , ('\xCFFFE', '\xCFFFF')-      , ('\xDFFFE', '\xDFFFF')-      , ('\xEFFFE', '\xEFFFF')-      , ('\xFFFFE', '\xFFFFF')-      , ('\x10FFFE', '\x10FFFF')-      ]---- --------------------------------------------------------------isInList        :: Unicode -> [(Unicode, Unicode)] -> Bool-isInList i =-   foldr (\(lb, ub) b -> i >= lb && (i <= ub || b)) False-   {- The expression (i>=lb && i<=ub) || b would work more generally,-      but in a sorted list, the above one aborts the computation as early as possible. -}--{--isInList'       :: Unicode -> [(Unicode, Unicode)] -> Bool-isInList' i ((lb, ub) : l)-    | i <  lb   = False-    | i <= ub   = True-    | otherwise = isInList' i l--isInList' _ []-    = False--{- works, but is not so fast -}-isInList''      :: Unicode -> [(Unicode, Unicode)] -> Bool-isInList'' i = any (flip isInRange i)---- move to an Utility module?-isInRange       :: Ord a => (a,a) -> a -> Bool-isInRange (l,r) x = l<=x && x<=r--propIsInList :: Bool-propIsInList =-   all-     (\c -> let dict = [ ('\x0041', '\x005A'), ('\x0061', '\x007A') ]-                b0 = isInList c dict-                b1 = isInList' c dict-                b2 = isInList'' c dict-            in  b0 == b1 && b0 == b2)-     ['\x00'..'\x100']--}---- ---------------------------------------------------------------- |--- code conversion from latin1 to Unicode--latin1ToUnicode :: String -> UString-latin1ToUnicode = id--latinToUnicode  :: [(Char, Char)] -> String -> UString-latinToUnicode tt-    = map charToUni-    where-    charToUni c =-       foldr (\(src,dst) r ->-          case compare c src of-             EQ -> dst-             LT -> c {- not found in table -}-             GT -> r) c tt---- | conversion from ASCII to unicode with check for legal ASCII char set------ Structure of decoding function copied from 'Data.Char.UTF8.decode'.--decodeAscii     :: DecodingFct-decodeAscii-    = swap . partitionEither . decodeAsciiEmbedErrors--decodeAsciiEmbedErrors  :: String -> UStringWithErrors-decodeAsciiEmbedErrors str-    = map (\(c,pos) -> if isValid c-                         then Right c-                         else Left (toErrStr c pos)) posStr-    where-    posStr = zip str [(0::Int)..]-    toErrStr errChr pos-        = " at input position " ++ show pos ++ ": none ASCII char " ++ show errChr-    isValid x = x < '\x80'---- |--- UCS-2 big endian to Unicode conversion--ucs2BigEndianToUnicode  :: String -> UString--ucs2BigEndianToUnicode (b : l : r)-    = toEnum (fromEnum b * 256 + fromEnum l) : ucs2BigEndianToUnicode r--ucs2BigEndianToUnicode []-    = []--ucs2BigEndianToUnicode _-    = []                                -- error "illegal UCS-2 byte input sequence with odd length"-                                        -- is ignored (garbage in, garbage out)---- ---------------------------------------------------------------- |--- UCS-2 little endian to Unicode conversion--ucs2LittleEndianToUnicode       :: String -> UString--ucs2LittleEndianToUnicode (l : b : r)-    = toEnum (fromEnum b * 256 + fromEnum l) : ucs2LittleEndianToUnicode r--ucs2LittleEndianToUnicode []-    = []--ucs2LittleEndianToUnicode [_]-    = []                                -- error "illegal UCS-2 byte input sequence with odd length"-                                        -- is ignored---- ---------------------------------------------------------------- |--- UCS-2 to UTF-8 conversion with byte order mark analysis--ucs2ToUnicode           :: String -> UString--ucs2ToUnicode ('\xFE':'\xFF':s)         -- 2 byte mark for big endian encoding-    = ucs2BigEndianToUnicode s--ucs2ToUnicode ('\xFF':'\xFE':s)         -- 2 byte mark for little endian encoding-    = ucs2LittleEndianToUnicode s--ucs2ToUnicode s-    = ucs2BigEndianToUnicode s          -- default: big endian---- ---------------------------------------------------------------- |--- UTF-8 to Unicode conversion with deletion of leading byte order mark, as described in XML standard F.1--utf8ToUnicode           :: DecodingFct--utf8ToUnicode ('\xEF':'\xBB':'\xBF':s)  -- remove byte order mark ( XML standard F.1 )-    = decodeUtf8 s--utf8ToUnicode s-    = decodeUtf8 s--utf8ToUnicodeEmbedErrors        :: DecodingFctEmbedErrors--utf8ToUnicodeEmbedErrors ('\xEF':'\xBB':'\xBF':s)       -- remove byte order mark ( XML standard F.1 )-    = decodeUtf8EmbedErrors s--utf8ToUnicodeEmbedErrors s-    = decodeUtf8EmbedErrors s---- ---------------------------------------------------------------- |--- UTF-16 big endian to UTF-8 conversion with removal of byte order mark--utf16beToUnicode                :: String -> UString--utf16beToUnicode ('\xFE':'\xFF':s)              -- remove byte order mark-    = ucs2BigEndianToUnicode s--utf16beToUnicode s-    = ucs2BigEndianToUnicode s---- ---------------------------------------------------------------- |--- UTF-16 little endian to UTF-8 conversion with removal of byte order mark--utf16leToUnicode                :: String -> UString--utf16leToUnicode ('\xFF':'\xFE':s)              -- remove byte order mark-    = ucs2LittleEndianToUnicode s--utf16leToUnicode s-    = ucs2LittleEndianToUnicode s----- ---------------------------------------------------------------- |--- substitute all Unicode characters, that are not legal 1-byte--- UTF-8 XML characters by a character reference.------ This function can be used to translate all text nodes and--- attribute values into pure ascii.------ see also : 'unicodeToLatin1'--unicodeToXmlEntity      :: UString -> String-unicodeToXmlEntity-    = escape is1ByteXmlChar (intToCharRef . fromEnum)---- |--- substitute all Unicode characters, that are not legal latin1--- UTF-8 XML characters by a character reference.------ This function can be used to translate all text nodes and--- attribute values into ISO latin1.------ see also : 'unicodeToXmlEntity'--unicodeToLatin1 :: UString -> String-unicodeToLatin1-    = escape isXmlLatin1Char (intToCharRef . fromEnum)----- |--- substitute selected characters--- The @check@ function returns 'True' whenever a character needs to substitution--- The function @esc@ computes a substitute.-escape :: (Unicode -> Bool) -> (Unicode -> String) -> UString -> String-escape check esc =-    concatMap (\uc -> if check uc then [uc] else esc uc)---- |--- removes all non ascii chars, may be used to transform--- a document into a pure ascii representation by removing--- all non ascii chars from tag and attibute names------ see also : 'unicodeRemoveNoneLatin1', 'unicodeToXmlEntity'--unicodeRemoveNoneAscii  :: UString -> String-unicodeRemoveNoneAscii-    = filter is1ByteXmlChar---- |--- removes all non latin1 chars, may be used to transform--- a document into a pure ascii representation by removing--- all non ascii chars from tag and attibute names------ see also : 'unicodeRemoveNoneAscii', 'unicodeToLatin1'--unicodeRemoveNoneLatin1 :: UString -> String-unicodeRemoveNoneLatin1-    = filter isXmlLatin1Char---- ---------------------------------------------------------------- |--- convert an Unicode into a XML character reference.------ see also : 'intToCharRefHex'--intToCharRef            :: Int -> String-intToCharRef i-    = "&#" ++ show i ++ ";"---- |--- convert an Unicode into a XML hexadecimal character reference.------ see also: 'intToCharRef'--intToCharRefHex         :: Int -> String-intToCharRefHex i-    = "&#x" ++ h2 ++ ";"-      where-      h1 = intToHexString i-      h2 = if length h1 `mod` 2 == 1-           then '0': h1-           else h1---- ------------------------------------------------------------------ | White Space (XML Standard 2.3) and--- end of line handling (2.11)------ \#x0D and \#x0D\#x0A are mapped to \#x0A--normalizeNL     :: String -> String-normalizeNL ('\r' : '\n' : rest)        = '\n' : normalizeNL rest-normalizeNL ('\r' : rest)               = '\n' : normalizeNL rest-normalizeNL (c : rest)                  = c    : normalizeNL rest-normalizeNL []                          = []----- ---------------------------------------------------------------- |--- the table of supported character encoding schemes and the associated--- conversion functions into Unicode:q--{--This table could be derived from decodingTableEither,-but this way it is certainly more efficient.--}--decodingTable   :: [(String, DecodingFct)]-decodingTable-    = [ (utf8,          utf8ToUnicode                           )-      , (isoLatin1,     liftDecFct latin1ToUnicode              )-      , (usAscii,       decodeAscii                             )-      , (ucs2,          liftDecFct ucs2ToUnicode                )-      , (utf16,         liftDecFct ucs2ToUnicode                )-      , (utf16be,       liftDecFct utf16beToUnicode             )-      , (utf16le,       liftDecFct utf16leToUnicode             )-      , (iso8859_2,     liftDecFct (latinToUnicode iso_8859_2)  )-      , (iso8859_3,     liftDecFct (latinToUnicode iso_8859_3)  )-      , (iso8859_4,     liftDecFct (latinToUnicode iso_8859_4)  )-      , (iso8859_5,     liftDecFct (latinToUnicode iso_8859_5)  )-      , (iso8859_6,     liftDecFct (latinToUnicode iso_8859_6)  )-      , (iso8859_7,     liftDecFct (latinToUnicode iso_8859_7)  )-      , (iso8859_8,     liftDecFct (latinToUnicode iso_8859_8)  )-      , (iso8859_9,     liftDecFct (latinToUnicode iso_8859_9)  )-      , (iso8859_10,    liftDecFct (latinToUnicode iso_8859_10) )-      , (iso8859_11,    liftDecFct (latinToUnicode iso_8859_11) )-      , (iso8859_13,    liftDecFct (latinToUnicode iso_8859_13) )-      , (iso8859_14,    liftDecFct (latinToUnicode iso_8859_14) )-      , (iso8859_15,    liftDecFct (latinToUnicode iso_8859_15) )-      , (iso8859_16,    liftDecFct (latinToUnicode iso_8859_16) )-      , (unicodeString, liftDecFct id                           )-      , ("",            liftDecFct id                           )       -- default-      ]-    where-    liftDecFct df = \ s -> (df s, [])---- |--- the lookup function for selecting the decoding function--getDecodingFct          :: String -> Maybe DecodingFct-getDecodingFct enc-    = lookup (map toUpper enc) decodingTable----- |--- Similar to 'decodingTable' but it embeds errors--- in the string of decoded characters.--decodingTableEmbedErrors        :: [(String, DecodingFctEmbedErrors)]-decodingTableEmbedErrors-    = [ (utf8,          utf8ToUnicodeEmbedErrors                )-      , (isoLatin1,     liftDecFct latin1ToUnicode              )-      , (usAscii,       decodeAsciiEmbedErrors                  )-      , (ucs2,          liftDecFct ucs2ToUnicode                )-      , (utf16,         liftDecFct ucs2ToUnicode                )-      , (utf16be,       liftDecFct utf16beToUnicode             )-      , (utf16le,       liftDecFct utf16leToUnicode             )-      , (iso8859_2,     liftDecFct (latinToUnicode iso_8859_2)  )-      , (iso8859_3,     liftDecFct (latinToUnicode iso_8859_3)  )-      , (iso8859_4,     liftDecFct (latinToUnicode iso_8859_4)  )-      , (iso8859_5,     liftDecFct (latinToUnicode iso_8859_5)  )-      , (iso8859_6,     liftDecFct (latinToUnicode iso_8859_6)  )-      , (iso8859_7,     liftDecFct (latinToUnicode iso_8859_7)  )-      , (iso8859_8,     liftDecFct (latinToUnicode iso_8859_8)  )-      , (iso8859_9,     liftDecFct (latinToUnicode iso_8859_9)  )-      , (iso8859_10,    liftDecFct (latinToUnicode iso_8859_10) )-      , (iso8859_11,    liftDecFct (latinToUnicode iso_8859_11) )-      , (iso8859_13,    liftDecFct (latinToUnicode iso_8859_13) )-      , (iso8859_14,    liftDecFct (latinToUnicode iso_8859_14) )-      , (iso8859_15,    liftDecFct (latinToUnicode iso_8859_15) )-      , (iso8859_16,    liftDecFct (latinToUnicode iso_8859_16) )-      , (unicodeString, liftDecFct id                           )-      , ("",            liftDecFct id                           )       -- default-      ]-    where-    liftDecFct df = map Right . df---- |--- the lookup function for selecting the decoding function--getDecodingFctEmbedErrors       :: String -> Maybe DecodingFctEmbedErrors-getDecodingFctEmbedErrors enc-    = lookup (map toUpper enc) decodingTableEmbedErrors------ |--- the table of supported output encoding schemes and the associated--- conversion functions from Unicode--outputEncodingTable     :: [(String, (UString -> String))]-outputEncodingTable-    = [ (utf8,          unicodeToUtf8           )-      , (isoLatin1,     unicodeToLatin1         )-      , (usAscii,       unicodeToXmlEntity      )-      , (ucs2,          ucs2ToUnicode           )-      , (unicodeString, id                      )-      , ("",            unicodeToUtf8           )       -- default-      ]---- |--- the lookup function for selecting the encoding function--getOutputEncodingFct            :: String -> Maybe (String -> UString)-getOutputEncodingFct enc-    = lookup (map toUpper enc) outputEncodingTable---- -----------------------------------------------------------------guessEncoding           :: String -> String--guessEncoding ('\xFF':'\xFE':'\x00':'\x00':_)   = "UCS-4LE"             -- with byte order mark-guessEncoding ('\xFF':'\xFE':_)                 = "UTF-16LE"            -- with byte order mark--guessEncoding ('\xFE':'\xFF':'\x00':'\x00':_)   = "UCS-4-3421"          -- with byte order mark-guessEncoding ('\xFE':'\xFF':_)                 = "UTF-16BE"            -- with byte order mark--guessEncoding ('\xEF':'\xBB':'\xBF':_)          = utf8                  -- with byte order mark--guessEncoding ('\x00':'\x00':'\xFE':'\xFF':_)   = "UCS-4BE"             -- with byte order mark-guessEncoding ('\x00':'\x00':'\xFF':'\xFE':_)   = "UCS-4-2143"          -- with byte order mark--guessEncoding ('\x00':'\x00':'\x00':'\x3C':_)   = "UCS-4BE"             -- "<" of "<?xml"-guessEncoding ('\x3C':'\x00':'\x00':'\x00':_)   = "UCS-4LE"             -- "<" of "<?xml"-guessEncoding ('\x00':'\x00':'\x3C':'\x00':_)   = "UCS-4-2143"          -- "<" of "<?xml"-guessEncoding ('\x00':'\x3C':'\x00':'\x00':_)   = "UCS-4-3412"          -- "<" of "<?xml"--guessEncoding ('\x00':'\x3C':'\x00':'\x3F':_)   = "UTF-16BE"            -- "<?" of "<?xml"-guessEncoding ('\x3C':'\x00':'\x3F':'\x00':_)   = "UTF-16LE"            -- "<?" of "<?xml"--guessEncoding ('\x4C':'\x6F':'\xA7':'\x94':_)   = "EBCDIC"              -- "<?xm" of "<?xml"--guessEncoding _                                 = ""                    -- no guess---- ------------------------------------------------------------
src/Text/XML/HXT/DOM/XmlKeywords.hs view
@@ -26,73 +26,23 @@ t_xml,                          -- tag names  t_root         :: String -a_accept_mimetypes,- a_add_default_dtd,- a_canonicalize,- a_default,                     -- attribute names- a_check_namespaces,+a_default,                     -- attribute names  a_contentLength,- a_collect_errors,  a_column,- a_default_baseuri,- a_do_not_canonicalize,- a_do_not_check_namespaces,- a_do_not_issue_errors,- a_do_not_issue_warnings,- a_do_not_preserve_comment,- a_do_not_remove_whitespace,- a_do_not_use_curl,- a_do_not_validate,  a_encoding,- a_error,- a_error_log,- a_help,- a_if_modified_since,- a_ignore_encoding_errors,- a_ignore_none_xml_contents,- a_indent,- a_issue_errors,- a_issue_warnings,  a_kind,  a_line,- a_mime_types,  a_module,  a_modifier,  a_name,- a_no_empty_elements,- a_no_empty_elem_for,- a_no_redirect,- a_no_xml_pi,- a_options_curl,  a_output_encoding,- a_output_file,- a_output_xml,- a_output_html,- a_output_xhtml,- a_parse_by_mimetype,- a_parse_html,- a_parse_xml,  a_peref,- a_preserve_comment,- a_propagate_errors,- a_proxy,- a_remove_whitespace,- a_redirect,- a_show_haskell,- a_show_tree,  a_source,  a_status,  a_standalone,- a_strict_input,- a_tagsoup,- a_text_mode,- a_trace,  a_type,- a_use_curl,  a_url,- a_validate,  a_value,- a_verbose,  a_version,  a_xml,  a_xmlns        :: String@@ -143,73 +93,23 @@ t_xml           = "xml" t_root          = "/"           -- name of root node tag -a_accept_mimetypes              = "accept-mimetypes"-a_add_default_dtd               = "add-default-dtd"-a_canonicalize                  = "canonicalize"-a_check_namespaces              = "check-namespaces"-a_collect_errors                = "collect-errors" a_column                        = "column" a_contentLength                 = "Content-Length" a_default                       = "default"-a_default_baseuri               = "default-base-URI"-a_do_not_canonicalize           = "do-not-canonicalize"-a_do_not_check_namespaces       = "do-not-check-namespaces"-a_do_not_issue_errors           = "do-not-issue-errors"-a_do_not_issue_warnings         = "do-not-issue-warnings"-a_do_not_preserve_comment       = "do-not-preserve-comment"-a_do_not_remove_whitespace      = "do-not-remove-whitespace"-a_do_not_use_curl               = "do-not-use-curl"-a_do_not_validate               = "do-not-validate" a_encoding                      = "encoding"-a_error                         = "error"-a_error_log                     = "errorLog"-a_help                          = "help"-a_if_modified_since             = "if-modified-since"-a_ignore_encoding_errors        = "ignore-encoding-errors"-a_ignore_none_xml_contents      = "ignore-none-xml-contents"-a_indent                        = "indent"-a_issue_warnings                = "issue-warnings"-a_issue_errors                  = "issue-errors" a_kind                          = "kind" a_line                          = "line"-a_mime_types                    = "mimetypes" a_module                        = "module" a_modifier                      = "modifier" a_name                          = "name"-a_no_empty_elements             = "no-empty-elements"-a_no_empty_elem_for             = "no-empty-elem-for"-a_no_redirect                   = "no-redirect"-a_no_xml_pi                     = "no-xml-pi"-a_options_curl                  = "options-curl"-a_output_file                   = "output-file" a_output_encoding               = "output-encoding"-a_output_html                   = "output-html"-a_output_xhtml                  = "output-xhtml"-a_output_xml                    = "output-xml"-a_parse_by_mimetype             = "parse-by-mimetype"-a_parse_html                    = "parse-html"-a_parse_xml                     = "parse-xml" a_peref                         = k_peref-a_preserve_comment              = "preserve-comment"-a_propagate_errors              = "propagate-errors"-a_proxy                         = "proxy"-a_redirect                      = "redirect"-a_remove_whitespace             = "remove-whitespace"-a_show_haskell                  = "show-haskell"-a_show_tree                     = "show-tree" a_source                        = "source" a_standalone                    = "standalone" a_status                        = "status"-a_strict_input                  = "strict-input"-a_tagsoup                       = "tagsoup"-a_text_mode                     = "text-mode"-a_trace                         = "trace" a_type                          = "type" a_url                           = "url"-a_use_curl                      = "use-curl"-a_validate                      = "validate" a_value                         = "value"-a_verbose                       = "verbose" a_version                       = "version" a_xml                           = "xml" a_xmlns                         = "xmlns"@@ -301,40 +201,6 @@  -- ------------------------------------------------------------ ----- encoding names--isoLatin1-  , iso8859_1, iso8859_2, iso8859_3, iso8859_4, iso8859_5-  , iso8859_6, iso8859_7, iso8859_8, iso8859_9, iso8859_10-  , iso8859_11, iso8859_13, iso8859_14, iso8859_15, iso8859_16-  , usAscii, ucs2, utf8, utf16, utf16be, utf16le, unicodeString :: String--isoLatin1       = iso8859_1-iso8859_1       = "ISO-8859-1"-iso8859_2       = "ISO-8859-2"-iso8859_3       = "ISO-8859-3"-iso8859_4       = "ISO-8859-4"-iso8859_5       = "ISO-8859-5"-iso8859_6       = "ISO-8859-6"-iso8859_7       = "ISO-8859-7"-iso8859_8       = "ISO-8859-8"-iso8859_9       = "ISO-8859-9"-iso8859_10      = "ISO-8859-10"-iso8859_11      = "ISO-8859-11"-iso8859_13      = "ISO-8859-13"-iso8859_14      = "ISO-8859-14"-iso8859_15      = "ISO-8859-15"-iso8859_16      = "ISO-8859-16"-usAscii         = "US-ASCII"-ucs2            = "ISO-10646-UCS-2"-utf8            = "UTF-8"-utf16           = "UTF-16"-utf16be         = "UTF-16BE"-utf16le         = "UTF-16LE"-unicodeString   = "UNICODE"---- --------------------------------------------------------------- -- known namespaces  -- |@@ -352,28 +218,5 @@ -- | Relax NG namespace relaxNamespace  :: String relaxNamespace  = "http://relaxng.org/ns/structure/1.0"---- --------------------------------------------------------------- option for Relax NG--a_relax_schema,- a_do_not_check_restrictions,- a_check_restrictions,- a_do_not_validate_externalRef,- a_validate_externalRef,- a_do_not_validate_include,- a_validate_include,- a_output_changes,- a_do_not_collect_errors :: String--a_relax_schema                = "relax-schema"-a_do_not_check_restrictions   = "do-not-check-restrictions"-a_check_restrictions          = "check-restrictions"-a_do_not_validate_externalRef = "do-not-validate-externalRef"-a_validate_externalRef        = "validate-externalRef"-a_do_not_validate_include     = "do-not-validate-include"-a_validate_include            = "validate-include"-a_output_changes              = "output-pattern-transformations"-a_do_not_collect_errors       = "do-not-collect-errors"  -- ------------------------------------------------------------
src/Text/XML/HXT/DOM/XmlNode.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-}+ -- ------------------------------------------------------------  {- |@@ -25,15 +27,21 @@  module Text.XML.HXT.DOM.XmlNode     ( module Text.XML.HXT.DOM.XmlNode+    , module Data.Tree.Class     , module Data.Tree.NTree.TypeDefs     ) where  import Control.Monad+import Control.FlatSeq +import Data.Function            ( on )+import Data.Maybe               ( fromMaybe+                                , fromJust+                                )+import Data.Tree.Class import Data.Tree.NTree.TypeDefs -import Data.Maybe  import Text.XML.HXT.DOM.Interface @@ -41,6 +49,7 @@     -- discriminating predicates      isText              :: a -> Bool+    isBlob              :: a -> Bool     isCharRef           :: a -> Bool     isEntityRef         :: a -> Bool     isCmt               :: a -> Bool@@ -55,6 +64,7 @@     -- constructor functions for leave nodes      mkText              :: String -> a+    mkBlob              :: Blob   -> a     mkCharRef           :: Int    -> a     mkEntityRef         :: String -> a     mkCmt               :: String -> a@@ -65,6 +75,7 @@     -- selectors      getText             :: a -> Maybe String+    getBlob             :: a -> Maybe Blob     getCharRef          :: a -> Maybe Int     getEntityRef        :: a -> Maybe String     getCmt              :: a -> Maybe String@@ -92,6 +103,7 @@     -- "modifier" functions      changeText          :: (String   -> String)   -> a -> a+    changeBlob          :: (Blob     -> Blob)     -> a -> a     changeCmt           :: (String   -> String)   -> a -> a     changeName          :: (QName    -> QName)    -> a -> a     changeElemName      :: (QName    -> QName)    -> a -> a@@ -101,6 +113,7 @@     changeDTDAttrl      :: (Attributes -> Attributes) -> a -> a      setText             :: String   -> a -> a+    setBlob             :: Blob     -> a -> a     setCmt              :: String   -> a -> a     setName             :: QName    -> a -> a     setElemName         :: QName    -> a -> a@@ -112,45 +125,58 @@     -- default implementations      getName n           = getElemName n `mplus` getAttrName n `mplus` getPiName n-    getQualifiedName n  = getName n >>= \ n' -> return (qualifiedName n')-    getUniversalName n  = getName n >>= \ n' -> return (universalName n')-    getUniversalUri n   = getName n >>= \ n' -> return (universalUri n')-    getLocalPart n      = getName n >>= \ n' -> return (localPart n')-    getNamePrefix n     = getName n >>= \ n' -> return (namePrefix n')-    getNamespaceUri n   = getName n >>= \ n' -> return (namespaceUri n')+    getQualifiedName n  = getName n >>= return . qualifiedName+    getUniversalName n  = getName n >>= return . universalName+    getUniversalUri n   = getName n >>= return . universalUri+    getLocalPart n      = getName n >>= return . localPart+    getNamePrefix n     = getName n >>= return . namePrefix+    getNamespaceUri n   = getName n >>= return . namespaceUri -    setText t           = changeText     (const t)-    setCmt c            = changeCmt      (const c)-    setName n           = changeName     (const n)-    setElemName n       = changeElemName (const n)-    setElemAttrl al     = changeAttrl    (const al)-    setAttrName n       = changeAttrName (const n)-    setPiName   n       = changePiName   (const n)-    setDTDAttrl al      = changeDTDAttrl (const al)+    setText             = changeText     . const+    setBlob             = changeBlob     . const+    setCmt              = changeCmt      . const+    setName             = changeName     . const+    setElemName         = changeElemName . const+    setElemAttrl        = changeAttrl    . const+    setAttrName         = changeAttrName . const+    setPiName           = changePiName   . const+    setDTDAttrl         = changeDTDAttrl . const  -- XNode and XmlTree are instances of XmlNode  instance XmlNode XNode where     isText (XText _)            = True+    isText (XBlob _)            = True     isText _                    = False+    {-# INLINE isText #-} +    isBlob (XBlob _)            = True+    isBlob _                    = False+    {-# INLINE isBlob #-}+     isCharRef (XCharRef _)      = True     isCharRef _                 = False+    {-# INLINE isCharRef #-}      isEntityRef (XEntityRef _)  = True     isEntityRef _               = False+    {-# INLINE isEntityRef #-}      isCmt (XCmt _)              = True     isCmt _                     = False+    {-# INLINE isCmt #-}      isCdata (XCdata _)          = True     isCdata _                   = False+    {-# INLINE isCdata #-}      isPi (XPi _ _)              = True     isPi _                      = False+    {-# INLINE isPi #-}      isElem (XTag _ _)           = True     isElem _                    = False+    {-# INLINE isElem #-}      isRoot t                    = isElem t                                   &&@@ -158,155 +184,253 @@      isDTD (XDTD _ _)            = True     isDTD _                     = False+    {-# INLINE isDTD #-}      isAttr (XAttr _)            = True     isAttr _                    = False+    {-# INLINE isAttr #-}      isError (XError _ _)        = True     isError _                   = False+    {-# INLINE isError #-}  -    mkText t                    = XText t-    mkCharRef c                 = XCharRef c-    mkEntityRef e               = XEntityRef e-    mkCmt c                     = XCmt c-    mkCdata d                   = XCdata d-    mkPi n c                    = XPi n (if null c then [] else [mkAttr (mkName a_value) c])-    mkError l msg               = XError l msg+    mkText                      = XText+    {-# INLINE mkText #-}+    mkBlob                      = XBlob+    {-# INLINE mkBlob #-}+    mkCharRef                   = XCharRef+    {-# INLINE mkCharRef #-}+    mkEntityRef                 = XEntityRef+    {-# INLINE mkEntityRef #-}+    mkCmt                       = XCmt+    {-# INLINE mkCmt #-}+    mkCdata                     = XCdata+    {-# INLINE mkCdata #-}+    mkPi                        = XPi+    {-# INLINE mkPi #-} +    mkError                     = XError+    {-# INLINE mkError #-} -    getText (XText t)           = Just t++    getText (XText t)           = Just   t+    getText (XBlob b)           = Just . blobToString $ b     getText _                   = Nothing+    {-# INLINE getText #-} +    getBlob (XBlob b)           = Just b+    getBlob _                   = Nothing+    {-# INLINE getBlob #-}+     getCharRef (XCharRef c)     = Just c     getCharRef _                = Nothing+    {-# INLINE getCharRef #-}      getEntityRef (XEntityRef e) = Just e     getEntityRef _              = Nothing+    {-# INLINE getEntityRef #-}      getCmt (XCmt c)             = Just c     getCmt _                    = Nothing+    {-# INLINE getCmt #-}      getCdata (XCdata d)         = Just d     getCdata _                  = Nothing+    {-# INLINE getCdata #-}      getPiName (XPi n _)         = Just n     getPiName _                 = Nothing+    {-# INLINE getPiName #-}      getPiContent (XPi _ c)      = Just c     getPiContent _              = Nothing+    {-# INLINE getPiContent #-}      getElemName (XTag n _)      = Just n     getElemName _               = Nothing+    {-# INLINE getElemName #-}      getAttrl (XTag _ al)        = Just al     getAttrl (XPi  _ al)        = Just al     getAttrl _                  = Nothing+    {-# INLINE getAttrl #-}      getDTDPart (XDTD p _)       = Just p     getDTDPart _                = Nothing+    {-# INLINE getDTDPart #-}      getDTDAttrl (XDTD _ al)     = Just al     getDTDAttrl _               = Nothing+    {-# INLINE getDTDAttrl #-}      getAttrName (XAttr n)       = Just n     getAttrName _               = Nothing+    {-# INLINE getAttrName #-}      getErrorLevel (XError l _)  = Just l     getErrorLevel _             = Nothing+    {-# INLINE getErrorLevel #-}      getErrorMsg (XError _ m)    = Just m     getErrorMsg _               = Nothing+    {-# INLINE getErrorMsg #-} -    changeText cf (XText t)             = XText (cf t)+    changeText cf (XText t)             = XText . cf $ t+    changeText cf (XBlob b)             = XText . cf . blobToString $ b     changeText _ _                      = error "changeText undefined"+    {-# INLINE changeText #-} -    changeCmt cf (XCmt c)               = XCmt (cf c)+    changeBlob cf (XBlob b)             = XBlob . cf $ b+    changeBlob _ _                      = error "changeBlob undefined"+    {-# INLINE changeBlob #-}++    changeCmt cf (XCmt c)               = XCmt  . cf $ c     changeCmt _ _                       = error "changeCmt undefined"+    {-# INLINE changeCmt #-} -    changeName cf (XTag n al)           = XTag (cf n) al-    changeName cf (XAttr n)             = XAttr (cf n)-    changeName cf (XPi n al)            = XPi (cf n) al+    changeName cf (XTag n al)           = XTag   (cf n) al+    changeName cf (XAttr n)             = XAttr . cf $ n+    changeName cf (XPi n al)            = XPi    (cf n) al     changeName _ _                      = error "changeName undefined"+    {-# INLINE changeName #-} -    changeElemName cf (XTag n al)       = XTag (cf n) al+    changeElemName cf (XTag n al)       = XTag   (cf n) al     changeElemName _ _                  = error "changeElemName undefined"+    {-# INLINE changeElemName #-}      changeAttrl cf (XTag n al)          = XTag n (cf al)     changeAttrl cf (XPi  n al)          = XPi  n (cf al)     changeAttrl _ _                     = error "changeAttrl undefined"+    {-# INLINE changeAttrl #-} -    changeAttrName cf (XAttr n)         = XAttr (cf n)+    changeAttrName cf (XAttr n)         = XAttr . cf $ n     changeAttrName _ _                  = error "changeAttrName undefined"+    {-# INLINE changeAttrName #-} -    changePiName cf (XPi n al)          = XPi (cf n) al-    changePiName _ _                    = error "changeAttrName undefined"+    changePiName cf (XPi n al)          = XPi    (cf n) al+    changePiName _ _                    = error "changePiName undefined"+    {-# INLINE changePiName #-}      changeDTDAttrl cf (XDTD p al)       = XDTD p (cf al)     changeDTDAttrl _ _                  = error "changeDTDAttrl undefined"+    {-# INLINE changeDTDAttrl #-}  mkElementNode   :: QName -> XmlTrees -> XNode mkElementNode   = XTag+{-# INLINE mkElementNode #-}  mkAttrNode      :: QName -> XNode mkAttrNode      = XAttr+{-# INLINE mkAttrNode #-}  mkDTDNode       :: DTDElem -> Attributes -> XNode mkDTDNode       = XDTD+{-# INLINE mkDTDNode #-} -instance XmlNode a => XmlNode (NTree a) where+instance (XmlNode a, Tree t) => XmlNode (t a) where     isText              = isText      . getNode+    {-# INLINE isText #-}+    isBlob              = isBlob      . getNode+    {-# INLINE isBlob #-}     isCharRef           = isCharRef   . getNode+    {-# INLINE isCharRef #-}     isEntityRef         = isEntityRef . getNode+    {-# INLINE isEntityRef #-}     isCmt               = isCmt       . getNode+    {-# INLINE isCmt #-}     isCdata             = isCdata     . getNode+    {-# INLINE isCdata #-}     isPi                = isPi        . getNode+    {-# INLINE isPi #-}     isElem              = isElem      . getNode+    {-# INLINE isElem #-}     isRoot              = isRoot      . getNode+    {-# INLINE isRoot #-}     isDTD               = isDTD       . getNode+    {-# INLINE isDTD #-}     isAttr              = isAttr      . getNode+    {-# INLINE isAttr #-}     isError             = isError     . getNode+    {-# INLINE isError #-}      mkText              = mkLeaf . mkText+    {-# INLINE mkText #-}+    mkBlob              = mkLeaf . mkBlob+    {-# INLINE mkBlob #-}     mkCharRef           = mkLeaf . mkCharRef+    {-# INLINE mkCharRef #-}     mkEntityRef         = mkLeaf . mkEntityRef+    {-# INLINE mkEntityRef #-}     mkCmt               = mkLeaf . mkCmt+    {-# INLINE mkCmt #-}     mkCdata             = mkLeaf . mkCdata+    {-# INLINE mkCdata #-}     mkPi n              = mkLeaf . mkPi n+    {-# INLINE mkPi #-}     mkError l           = mkLeaf . mkError l+    {-# INLINE mkError #-}      getText             = getText       . getNode+    {-# INLINE getText #-}+    getBlob             = getBlob       . getNode+    {-# INLINE getBlob #-}     getCharRef          = getCharRef    . getNode+    {-# INLINE getCharRef #-}     getEntityRef        = getEntityRef  . getNode+    {-# INLINE getEntityRef #-}     getCmt              = getCmt        . getNode+    {-# INLINE getCmt #-}     getCdata            = getCdata      . getNode+    {-# INLINE getCdata #-}     getPiName           = getPiName     . getNode+    {-# INLINE getPiName #-}     getPiContent        = getPiContent  . getNode+    {-# INLINE getPiContent #-}     getElemName         = getElemName   . getNode+    {-# INLINE getElemName #-}     getAttrl            = getAttrl      . getNode+    {-# INLINE getAttrl #-}     getDTDPart          = getDTDPart    . getNode+    {-# INLINE getDTDPart #-}     getDTDAttrl         = getDTDAttrl   . getNode+    {-# INLINE getDTDAttrl #-}     getAttrName         = getAttrName   . getNode+    {-# INLINE getAttrName #-}     getErrorLevel       = getErrorLevel . getNode+    {-# INLINE getErrorLevel #-}     getErrorMsg         = getErrorMsg   . getNode+    {-# INLINE getErrorMsg #-} -    changeText cf       = changeNode (changeText cf)-    changeCmt cf        = changeNode (changeCmt  cf)-    changeName cf       = changeNode (changeName cf)-    changeElemName cf   = changeNode (changeElemName cf)-    changeAttrl cf      = changeNode (changeAttrl cf)-    changeAttrName cf   = changeNode (changeAttrName cf)-    changePiName cf     = changeNode (changePiName cf)-    changeDTDAttrl cf   = changeNode (changeDTDAttrl cf)+    changeText          = changeNode . changeText+    {-# INLINE changeText #-}+    changeBlob          = changeNode . changeBlob+    {-# INLINE changeBlob #-}+    changeCmt           = changeNode . changeCmt+    {-# INLINE changeCmt #-}+    changeName          = changeNode . changeName+    {-# INLINE changeName #-}+    changeElemName      = changeNode . changeElemName+    {-# INLINE changeElemName #-}+    changeAttrl         = changeNode . changeAttrl+    {-# INLINE changeAttrl #-}+    changeAttrName      = changeNode . changeAttrName+    {-# INLINE changeAttrName #-}+    changePiName        = changeNode . changePiName+    {-# INLINE changePiName #-}+    changeDTDAttrl      = changeNode . changeDTDAttrl+    {-# INLINE changeDTDAttrl #-}  mkElement       :: QName -> XmlTrees -> XmlTrees -> XmlTree mkElement n al  = mkTree (mkElementNode n al)+{-# INLINE mkElement #-}  mkRoot          :: XmlTrees -> XmlTrees -> XmlTree mkRoot al       = mkTree (mkElementNode (mkName t_root) al)  mkAttr          :: QName -> XmlTrees -> XmlTree mkAttr n        = mkTree (mkAttrNode n)+{-# INLINE mkAttr #-}  mkDTDElem       :: DTDElem -> Attributes -> XmlTrees -> XmlTree mkDTDElem e al  = mkTree (mkDTDNode e al)@@ -329,5 +453,82 @@  mergeAttrl      :: XmlTrees -> XmlTrees -> XmlTrees mergeAttrl      = foldr addAttr++-- ------------------------------------------------------------++-- | weak normalform versions of constructors++mkElement'              :: QName -> XmlTrees -> XmlTrees -> XmlTree+mkElement' n al cl      = id $!! mkElement n al cl+{-# INLINE mkElement' #-}++mkRoot'                 :: XmlTrees -> XmlTrees -> XmlTree+mkRoot' al cl           = id $!! mkRoot al cl+{-# INLINE mkRoot' #-}++mkAttr'                 :: QName -> XmlTrees -> XmlTree+mkAttr' n av            = id $!! mkAttr n av+{-# INLINE mkAttr' #-}++mkText'                 :: String -> XmlTree+mkText' t               = id $!! mkText t+{-# INLINE mkText' #-}++mkCharRef'              :: Int    -> XmlTree+mkCharRef' i            = id $!! mkCharRef i+{-# INLINE mkCharRef' #-}++mkEntityRef'            :: String -> XmlTree+mkEntityRef' n          = id $!! mkEntityRef n+{-# INLINE mkEntityRef' #-}++mkCmt'                  :: String -> XmlTree+mkCmt' c                = id $!! mkCmt c+{-# INLINE mkCmt' #-}++mkCdata'                :: String -> XmlTree+mkCdata' d              = id $!! mkCdata d+{-# INLINE mkCdata' #-}++mkPi'                   :: QName  -> XmlTrees -> XmlTree+mkPi' n v               = id $!! mkPi n v+{-# INLINE mkPi' #-}++mkError'                :: Int -> String   -> XmlTree+mkError' l m            = id $!! mkError l m+{-# INLINE mkError' #-}++mkDTDElem'              :: DTDElem -> Attributes -> XmlTrees -> XmlTree+mkDTDElem' e al cl      = id $!! mkDTDElem e al cl+{-# INLINE mkDTDElem' #-}++-- ------------------------------------------------------------++toText :: XmlTree -> XmlTree+toText t+    | isCharRef t+        = mkText+          . (:[]) . toEnum+          . fromJust+          . getCharRef+          $ t+    | isCdata t+        = mkText+          . fromJust+          . getCdata+          $ t+    | otherwise+        = t++concText :: XmlTree -> XmlTree -> XmlTrees+concText t1 t2+    | isText t1 && isText t2+        = (:[]) . mkText $ fromJust (getText t1) ++ fromJust (getText t2)+    | otherwise+        = [t1, t2]++mergeText :: XmlTree -> XmlTree -> XmlTrees+mergeText+    = concText `on` toText  -- ------------------------------------------------------------
− src/Text/XML/HXT/DOM/XmlOptions.hs 
@@ -1,188 +0,0 @@--- |--- Common useful options------ Version : $Id: XmlOptions.hs,v 1.1 2006/11/09 20:27:42 hxml Exp $--------module Text.XML.HXT.DOM.XmlOptions-    ( inputOptions-    , relaxOptions-    , outputOptions-    , generalOptions-    , versionOptions-    , showOptions--    , selectOptions-    , removeOptions-    , optionIsSet-    , isTrueValue-    )-where--import Text.XML.HXT.DOM.XmlKeywords-import Text.XML.HXT.DOM.TypeDefs--import Data.Maybe--import System.Console.GetOpt---- ------------------------------------------------------------------- |--- commonly useful options for XML input------ can be used for option definition with haskell getopt------ defines options: 'a_trace', 'a_proxy', 'a_use_curl', 'a_do_not_use_curl', 'a_options_curl', 'a_encoding',--- 'a_issue_errors', 'a_do_not_issue_errors', 'a_parse_html', 'a_parse_by_mimetype', 'a_tagsoup' 'a_issue_warnings', 'a_do_not_issue_warnings',--- 'a_parse_xml', 'a_validate', 'a_do_not_validate', 'a_canonicalize', 'a_do_not_canonicalize',---- 'a_preserve_comment', 'a_do_not_preserve_comment', 'a_check_namespaces', 'a_do_not_check_namespaces',--- 'a_remove_whitespace', 'a_do_not_remove_whitespace'--inputOptions    :: [OptDescr (String, String)]-inputOptions-    = [ Option "t"      [a_trace]                       (OptArg trc "LEVEL")                    "trace level (0-4), default 1"-      , Option "p"      [a_proxy]                       (ReqArg (att a_proxy)         "PROXY")  "proxy for http access (e.g. \"www-cache:3128\")"-      , Option ""       [a_redirect]                    (NoArg  (att a_redirect          v_1))  "automatically follow redirected URIs"-      , Option ""       [a_no_redirect]                 (NoArg  (att a_redirect          v_0))  "switch off following redirected URIs"-      , Option ""       [a_use_curl]                    (NoArg  (att a_use_curl          v_1))  "obsolete, since hxt-8.1 HTTP access is always done with curl bindings"-      , Option ""       [a_do_not_use_curl]             (NoArg  (att a_use_curl          v_0))  "obsolete, since hxt-8.1 HTTP access is always done with curl bindings"-      , Option ""       [a_options_curl]                (ReqArg (att a_options_curl)    "STR")  "additional curl options, e.g. for timeout, ..."-      , Option ""       [a_default_baseuri]             (ReqArg (att transferURI)       "URI")  "default base URI, default: \"file:///<cwd>/\""-      , Option "e"      [a_encoding]                    (ReqArg (att a_encoding)    "CHARSET")  ( "default document encoding (" ++ utf8 ++ ", " ++ isoLatin1 ++ ", " ++ usAscii ++ ", ...)" )-      , Option ""       [a_mime_types]                  (ReqArg (att a_mime_types)     "FILE")  "set mime type configuration file, e.g. \"/etc/mime.types\""-      , Option ""       [a_issue_errors]                (NoArg  (att a_issue_errors      v_1))  "issue all errorr messages on stderr (default)"-      , Option ""       [a_do_not_issue_errors]         (NoArg  (att a_issue_errors      v_0))  "ignore all error messages"-      , Option ""       [a_ignore_encoding_errors]      (NoArg  (att a_ignore_encoding_errors v_1))   "ignore encoding errors"-      , Option ""       [a_ignore_none_xml_contents]    (NoArg  (att a_ignore_none_xml_contents v_1)) "discards all contents of none XML/HTML documents, only the meta info remains in the doc tree"-      , Option ""       [a_accept_mimetypes]            (ReqArg (att a_accept_mimetypes) "MIMETYPES") "only accept documents matching the given list of mimetype specs"-      , Option "H"      [a_parse_html]                  (NoArg  (att a_parse_html        v_1))  "parse input as HTML, try to interprete everything as HTML, no validation"-      , Option "M"      [a_parse_by_mimetype]           (NoArg  (att a_parse_by_mimetype v_1))  "parse dependent on mime type: text/html as HTML, text/xml and text/xhtml and others as XML, else no parse"-      , Option ""       [a_parse_xml]                   (NoArg  (att a_parse_html        v_0))  "parse input as XML, (default)"-      , Option ""       [a_strict_input]                (NoArg  (att a_strict_input      v_1))  "read input files strictly, this ensures closing the files correctly even if not read completely"-      , Option "T"      [a_tagsoup]                     (NoArg  (att a_tagsoup           v_1))  "lazy tagsoup parser, for HTML and XML, no DTD, no validation, no PIs, only XHTML entityrefs"-      , Option ""       [a_issue_warnings]              (NoArg  (att a_issue_warnings    v_1))  "issue warnings, when parsing HTML (default)"-      , Option "Q"      [a_do_not_issue_warnings]       (NoArg  (att a_issue_warnings    v_0))  "ignore warnings, when parsing HTML"-      , Option ""       [a_validate]                    (NoArg  (att a_validate          v_1))  "document validation when parsing XML (default)"-      , Option "w"      [a_do_not_validate]             (NoArg  (att a_validate          v_0))  "only wellformed check, no validation"-      , Option ""       [a_canonicalize]                (NoArg  (att a_canonicalize      v_1))  "canonicalize document, remove DTD, comment, transform CDATA, CharRef's, ... (default)"-      , Option "c"      [a_do_not_canonicalize]         (NoArg  (att a_canonicalize      v_0))  "do not canonicalize document, don't remove DTD, comment, don't transform CDATA, CharRef's, ..."-      , Option "C"      [a_preserve_comment]            (NoArg  (att a_preserve_comment  v_1))  "don't remove comments during canonicalisation"-      , Option ""       [a_do_not_preserve_comment]     (NoArg  (att a_preserve_comment  v_0))  "remove comments during canonicalisation (default)"-      , Option "n"      [a_check_namespaces]            (NoArg  (att a_check_namespaces  v_1))  "tag tree with namespace information and check namespaces"-      , Option ""       [a_do_not_check_namespaces]     (NoArg  (att a_check_namespaces  v_0))  "ignore namespaces (default)"-      , Option "r"      [a_remove_whitespace]           (NoArg  (att a_remove_whitespace v_1))  "remove redundant whitespace, simplifies tree and processing"-      , Option ""       [a_do_not_remove_whitespace]    (NoArg  (att a_remove_whitespace v_0))  "don't remove redundant whitespace (default)"-      ]-    where-    att n v     = (n, v)-    trc = att a_trace . show . max 0 . min 9 . (read :: String -> Int) . ('0':) . filter (`elem` "0123456789") . fromMaybe v_1----- | available Relax NG validation options------ defines options--- 'a_check_restrictions', 'a_validate_externalRef', 'a_validate_include', 'a_do_not_check_restrictions',--- 'a_do_not_validate_externalRef', 'a_do_not_validate_include'--relaxOptions :: [OptDescr (String, String)]-relaxOptions-    = [ Option "X" [a_relax_schema]                     (ReqArg (att a_relax_schema) "SCHEMA")  "validation with Relax NG, SCHEMA is the URI for the Relax NG schema"-      , Option ""  [a_check_restrictions]               (NoArg (a_check_restrictions,    v_1))  "check Relax NG schema restrictions during schema simplification (default)"-      , Option ""  [a_do_not_check_restrictions]        (NoArg (a_check_restrictions,    v_0))  "do not check Relax NG schema restrictions"-      , Option ""  [a_validate_externalRef]             (NoArg (a_validate_externalRef,  v_1))  "validate a Relax NG schema referenced by a externalRef-Pattern (default)"-      , Option ""  [a_do_not_validate_externalRef]      (NoArg (a_validate_externalRef,  v_0))  "do not validate a Relax NG schema referenced by an externalRef-Pattern"-      , Option ""  [a_validate_include]                 (NoArg (a_validate_include,      v_1))  "validate a Relax NG schema referenced by an include-Pattern (default)"-      , Option ""  [a_do_not_validate_include]          (NoArg (a_validate_include,      v_0))   "do not validate a Relax NG schema referenced by an include-Pattern"-        {--      , Option ""  [a_output_changes]                   (NoArg (a_output_changes,        v_1))  "output Pattern transformations in case of an error"-      , Option ""  [a_do_not_collect_errors]            (NoArg (a_do_not_collect_errors, v_1))  "stop Relax NG simplification after the first error has occurred"-        -}-      ]-    where-    att n v     = (n, v)---- |--- commonly useful options for XML output------ defines options: 'a_indent', 'a_output_encoding', 'a_output_file', 'a_output_html'--outputOptions   :: [OptDescr (String, String)]-outputOptions-    = [ Option "i"      [a_indent]              (NoArg  (att a_indent                v_1))      "indent XML output for readability"-      , Option "o"      [a_output_encoding]     (ReqArg (att a_output_encoding) "CHARSET")      ( "encoding of output (" ++ utf8 ++ ", " ++ isoLatin1 ++ ", " ++ usAscii ++ ")" )-      , Option "f"      [a_output_file]         (ReqArg (att a_output_file)        "FILE")      "output file for resulting document (default: stdout)"-      , Option ""       [a_output_html]         (NoArg  (att a_output_html           v_1))      "output of none ASCII chars as HTMl entity references"-      , Option ""       [a_no_xml_pi]           (NoArg  (att a_no_xml_pi             v_1))      ("output without <?xml ...?> processing instruction, useful in combination with --" ++ show a_output_html)-      , Option ""       [a_output_xhtml]        (NoArg  (att a_output_xhtml          v_1))      "output of HTML elements with empty content (script, ...) done in format <elem...></elem> instead of <elem/>"-      , Option ""       [a_no_empty_elem_for]   (ReqArg (att a_no_empty_elem_for) "NAMES")      "output of empty elements done in format <elem...></elem> only for given list of element names"-      , Option ""       [a_no_empty_elements]   (NoArg  (att a_no_empty_elements     v_1))      "output of empty elements done in format <elem...></elem> instead of <elem/>"-      , Option ""       [a_add_default_dtd]     (NoArg  (att a_add_default_dtd       v_1))      "add the document type declaration given in the input document"-      , Option ""       [a_text_mode]           (NoArg  (att a_text_mode             v_1))      "output in text mode"-      ]-    where-    att n v     = (n, v)---- |--- commonly useful options------ defines options: 'a_verbose', 'a_help'--generalOptions  :: [OptDescr (String, String)]-generalOptions-    = [ Option "v"      [a_verbose]             (NoArg  (a_verbose, v_1))               "verbose output"-      , Option "h?"     [a_help]                (NoArg  (a_help,    v_1))               "this message"-      ]---- |--- defines 'a_version' option--versionOptions  :: [OptDescr (String, String)]-versionOptions-    = [ Option "V"      [a_version]             (NoArg  (a_version, v_1))               "show program version"-      ]---- |--- debug output options--showOptions     :: [OptDescr (String, String)]-showOptions-    = [ Option ""       [a_show_tree]           (NoArg  (a_show_tree,    v_1))          "output tree representation instead of document source"-      , Option ""       [a_show_haskell]        (NoArg  (a_show_haskell, v_1))          "output internal Haskell representation instead of document source"-      ]---- ---------------------------------------------------------------- |--- select options from a predefined list of option desciptions--selectOptions   :: [String] -> [OptDescr (String, String)] -> [OptDescr (String, String)]-selectOptions ol os-    = concat . map (\ on -> filter (\ (Option _ ons _ _) -> on `elem` ons) os) $ ol--removeOptions   :: [String] -> [OptDescr (String, String)] -> [OptDescr (String, String)]-removeOptions ol os-    = filter (\ (Option _ ons _ _) -> not . any (`elem` ol) $ ons ) os---- |--- check whether an option is set------ reads the value of an attribute, usually applied to a document root node,--- and checks if the value represents True. The following strings are interpreted--- as true: \"1\", \"True\", \"true\", \"yes\", \"Yes\".--optionIsSet     :: String -> Attributes -> Bool-optionIsSet n   = isTrueValue . lookupDef "" n---- | check whether a string represents True------ definition:------ > isTrueValue        = (`elem` ["1", "True", "true", "Yes", "yes"])--isTrueValue     :: String -> Bool-isTrueValue     = (`elem` ["1", "True", "true", "Yes", "yes"])---- ------------------------------------------------------------
src/Text/XML/HXT/DTDValidation/DTDValidation.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts #-}+ -- ------------------------------------------------------------  {- |@@ -36,8 +38,8 @@     ) where -import Text.XML.HXT.DTDValidation.TypeDefs-import Text.XML.HXT.DTDValidation.AttributeValueValidation+import           Text.XML.HXT.DTDValidation.AttributeValueValidation+import           Text.XML.HXT.DTDValidation.TypeDefs  -- | -- Validate a DTD.
src/Text/XML/HXT/DTDValidation/DocTransformation.hs view
@@ -42,6 +42,7 @@ import Data.Maybe import Data.List import Data.Ord+import qualified Data.Map as M  -- ------------------------------------------------------------ @@ -49,8 +50,7 @@ -- Lookup-table which maps element names to their transformation functions. The -- transformation functions are XmlArrows. -type TransEnvTable      = [TransEnv]-type TransEnv           = (ElemName, TransFct)+type TransEnvTable      = M.Map ElemName TransFct type ElemName           = String type TransFct           = XmlArrow @@ -81,18 +81,15 @@  traverseTree :: TransEnvTable -> XmlArrow traverseTree transEnv-    = processTopDown-      ( ( (transFct $< getName)-          >>>-          processChildren (traverseTree transEnv)-        )-       `when`-       isElem-      )+    = processTopDown ( (transFct $< getName)+                       `when`+                       isElem+                     )     where     transFct            :: String -> XmlArrow-    transFct name       = fromMaybe this . lookup name $ transEnv+    transFct name       = fromMaybe this . M.lookup name $ transEnv + -- | -- Build all transformation functions. --@@ -102,7 +99,8 @@  buildAllTransformationFunctions :: XmlTrees -> TransEnvTable buildAllTransformationFunctions dtdNodes-    = (t_root, this)+    = M.fromList $+      (t_root, this)       :       concatMap (buildTransformationFunctions dtdNodes) dtdNodes @@ -116,7 +114,7 @@ -- --    - returns : entry for the lookup-table -buildTransformationFunctions :: XmlTrees -> XmlTree -> [TransEnv]+buildTransformationFunctions :: XmlTrees -> XmlTree -> [(ElemName, TransFct)]  buildTransformationFunctions dtdPart dn     | isDTDElementNode dn       = [(name, transFct)]
src/Text/XML/HXT/DTDValidation/RE.hs view
@@ -48,6 +48,8 @@   ) where +import           Data.List (foldl')+ -- | -- Data type for regular expressions. @@ -61,7 +63,7 @@         | RE_OPT (RE a)         --' L(e?)  = L(e) `union` { [] }         | RE_SEQ (RE a) (RE a)  --' L(e,f) = { x ++ y | x <- L(e), y <- L(f) }         | RE_ALT (RE a) (RE a)  --' L(e|f) = L(e) `union` L(f)-        deriving (Show, Eq)+        deriving (Show, Eq, Ord)   @@ -128,10 +130,11 @@ -- but without this simplification the runtime can increase exponentally -- when computing deltas, e.g. for a** or (a|b*)* which is the same as (a|b)* -rem_rep                 :: RE a -> RE a-rem_rep (RE_ALT e1 e2)  = RE_ALT (rem_rep e1) (rem_rep e2)-rem_rep (RE_REP e1)     = rem_rep e1-rem_rep e1              = e1+rem_rep                     :: RE a -> RE a+rem_rep (RE_ALT RE_UNIT e2) = e2+rem_rep (RE_ALT e1 e2)      = RE_ALT (rem_rep e1) (rem_rep e2)+rem_rep (RE_REP e1)         = rem_rep e1+rem_rep e1                  = e1   -- |@@ -144,7 +147,9 @@ re_plus                 :: RE a -> RE a re_plus RE_UNIT         = RE_UNIT re_plus (RE_ZERO m)     = RE_ZERO m-re_plus e               = RE_PLUS e+re_plus e+    | nullable e        = re_rep e            -- nullable e => e+ == e*+    | otherwise         = re_seq e (re_rep e)   -- |@@ -154,11 +159,10 @@ -- --    - returns : new regular expression -re_opt                  :: RE a -> RE a+re_opt                  :: (Ord a) => RE a -> RE a re_opt RE_UNIT          = RE_UNIT re_opt (RE_ZERO _)      = RE_UNIT-re_opt e                = RE_OPT e-+re_opt e                = re_alt RE_UNIT e  -- | -- Constructs a sequence (,) of two regular expressions@@ -169,12 +173,13 @@ -- --    - returns : new regular expression -re_seq                  :: RE a -> RE a -> RE a-re_seq (RE_ZERO m) _    = RE_ZERO m-re_seq RE_UNIT f        = f-re_seq _ (RE_ZERO m)    = RE_ZERO m-re_seq e RE_UNIT        = e-re_seq e f              = RE_SEQ e f+re_seq                                 :: RE a -> RE a -> RE a+re_seq e1@(RE_ZERO _)   _              = e1                         -- simplification+re_seq RE_UNIT          e2             = e2                         -- simplification+re_seq _                e2@(RE_ZERO _) = e2                         -- simplification+re_seq e1               RE_UNIT        = e1                         -- simplification+re_seq (RE_SEQ e11 e12) e2             = re_seq e11 (re_seq e12 e2) -- right assoc.+re_seq e1               e2             = RE_SEQ e1 e2   -- |@@ -186,10 +191,18 @@ -- --    - returns : new regular expression -re_alt                  :: RE a -> RE a -> RE a-re_alt (RE_ZERO _) f    = f-re_alt e (RE_ZERO _)    = e-re_alt e f              = RE_ALT e f+re_alt                                      :: (Ord a) => RE a -> RE a -> RE a+re_alt (RE_ZERO _)      e2                  = e2+re_alt e1               (RE_ZERO _)         = e1+re_alt (RE_ALT e11 e12) e2                  = re_alt e11 (re_alt e12 e2)  -- is right assoc+re_alt e1               e2@(RE_ALT e21 e22)+    | e1 == e21                             = e2             -- duplicates removed, the effective rule+    | e1 >  e21                             = re_alt e21 (re_alt e1 e22)  -- sort alternatives+    | otherwise                             = RE_ALT e1 e2+re_alt e1               e2+    | e1 == e2                              = e2             -- simplification, the effective rule+    | e1 >  e2                              = re_alt e2 e1   -- sort alts for unique repr.+    | otherwise                             = RE_ALT e1 e2   @@ -208,7 +221,7 @@ --    - returns : true if regular expression matches the empty sequence, --                otherwise false -nullable                ::  (Show a) => RE a -> Bool+nullable                ::  RE a -> Bool nullable (RE_ZERO _)    = False nullable RE_UNIT        = True nullable (RE_SYM _)     = False@@ -231,7 +244,7 @@ -- --    - returns : the derived regular expression -delta :: (Eq a, Show a) => RE a -> a -> RE a+delta :: (Ord a, Show a) => RE a -> a -> RE a delta re x = case re of         RE_ZERO _               -> re                                   -- re_zero m         RE_UNIT                 -> re_zero ("Symbol " ++ show x ++ " unexpected.")@@ -257,8 +270,8 @@ -- --    - returns : the derived regular expression -matches :: (Eq a, Show a) => RE a -> [a] -> RE a-matches e = foldl delta e+matches :: (Ord a, Show a) => RE a -> [a] -> RE a+matches e = foldl' delta e   -- |@@ -273,7 +286,7 @@ --    - returns : empty String if input matched the regular expression, otherwise --               an error message is returned -checkRE :: (Show a) => RE a -> String+checkRE :: (Eq a, Show a) => RE a -> String checkRE (RE_UNIT)       = "" checkRE (RE_ZERO m)     = m checkRE re@@ -293,11 +306,11 @@ -- --    - returns : the string representation of the regular expression -printRE :: (Show a) => RE a -> String+printRE :: (Eq a, Show a) => RE a -> String printRE re'     = "( " ++ printRE1 re' ++ " )"       where-      printRE1 :: (Show a) => RE a -> String+      -- printRE1 :: (Eq a, Show a) => RE a -> String       printRE1 re = case re of           RE_ZERO m                             -> "ERROR: " ++ m           RE_UNIT                               -> ""@@ -312,11 +325,16 @@           RE_OPT e               | isSingle e                      -> printRE1 e ++ "?"               | otherwise                       -> "(" ++ printRE1 e ++ ")?"+          RE_SEQ e1 (RE_REP e2)+              | e1 == e2                        -> printRE1 (RE_PLUS e1)+          RE_SEQ e1 (RE_SEQ (RE_REP e2) e3)+              | e1 == e2                        -> printRE1 (RE_SEQ (RE_PLUS e1) e3)           RE_SEQ e f               | isAlt e  && not (isAlt f)       -> "(" ++ printRE1 e ++ ") , " ++ printRE1 f               | not (isAlt e) && isAlt f        -> printRE1 e ++ " , (" ++ printRE1 f ++ ")"               | isAlt e  && isAlt f             -> "(" ++ printRE1 e ++ ") , (" ++ printRE1 f ++ ")"               | otherwise                       -> printRE1 e ++ " , " ++ printRE1 f+          RE_ALT RE_UNIT f                      -> printRE1 (RE_OPT f)           RE_ALT e f               | isSeq e  && not (isSeq f)       -> "(" ++ printRE1 e ++ ") | " ++ printRE1 f               | not (isSeq e) && isSeq f        -> printRE1 e ++ " | (" ++ printRE1 f ++ ")"@@ -331,11 +349,14 @@       isSingle _              = False  -      isSeq :: RE a -> Bool+      isSeq :: (Eq a) => RE a -> Bool+      isSeq (RE_SEQ e1 (RE_REP e2))+          | e1 == e2          = False  -- is transformed back into RE_PLUS       isSeq (RE_SEQ _ _)      = True       isSeq _                 = False         isAlt :: RE a -> Bool+      isAlt (RE_ALT RE_UNIT _)= False  -- is transformed back into a RE_OPT       isAlt (RE_ALT _ _)      = True       isAlt _                 = False
src/Text/XML/HXT/DTDValidation/Validation.hs view
@@ -26,6 +26,7 @@  module Text.XML.HXT.DTDValidation.Validation     ( getDTDSubset+    , generalEntitiesDefined     , validate     , validateDTD     , validateDoc@@ -35,12 +36,12 @@  where -import Text.XML.HXT.DTDValidation.TypeDefs+import           Text.XML.HXT.DTDValidation.TypeDefs -import qualified Text.XML.HXT.DTDValidation.DTDValidation     as DTDValidation+import qualified Text.XML.HXT.DTDValidation.DocTransformation as DocTransformation import qualified Text.XML.HXT.DTDValidation.DocValidation     as DocValidation+import qualified Text.XML.HXT.DTDValidation.DTDValidation     as DTDValidation import qualified Text.XML.HXT.DTDValidation.IdValidation      as IdValidation-import qualified Text.XML.HXT.DTDValidation.DocTransformation as DocTransformation  -- | -- Main validation filter. Check if the DTD and the document are valid.@@ -126,5 +127,9 @@                           >>>                           ( filterA $ isDTDDoctype >>> getDTDAttrl >>> isA (hasEntry a_name) ) +generalEntitiesDefined  :: XmlArrow+generalEntitiesDefined  = getDTDSubset+                          >>>+                          deep isDTDEntity  -- ------------------------------------------------------------
src/Text/XML/HXT/DTDValidation/XmlRE.hs view
@@ -36,17 +36,17 @@     ) where --- import Debug.Trace(trace)+-- import           Debug.Trace                         (trace) -import Text.XML.HXT.DTDValidation.RE hiding (matches)+import           Data.List                           (foldl') -import Text.XML.HXT.DTDValidation.TypeDefs-import Text.XML.HXT.Arrow.Edit-    ( removeComment-    , removeWhiteSpace-    )-import qualified Text.XML.HXT.DOM.XmlNode as XN+import           Text.XML.HXT.DTDValidation.RE       hiding (matches) +import           Text.XML.HXT.Arrow.Edit             (removeComment,+                                                      removeWhiteSpace)+import qualified Text.XML.HXT.DOM.XmlNode            as XN+import           Text.XML.HXT.DTDValidation.TypeDefs+ -- | -- Derives a regular expression with respect to a list of elements. --@@ -58,7 +58,7 @@  matches :: RE String -> XmlTrees -> RE String matches re list-    = foldl delta re (removeUnimportantStuff $$ list)+    = foldl' delta re (removeUnimportantStuff $$ list)       where       removeUnimportantStuff :: XmlArrow       removeUnimportantStuff = processBottomUp (removeWhiteSpace >>> removeComment)
src/Text/XML/HXT/IO/GetFILE.hs view
@@ -22,39 +22,30 @@  where -import qualified Data.ByteString        as B-import qualified Data.ByteString.Char8  as C+import           Control.Exception      ( try ) -import           Network.URI            ( unEscapeString-                                        )+import qualified Data.ByteString.Lazy   as B -import           System.IO              ( IOMode(..)-                                        , openBinaryFile-                                          -- , getContents  is defined in the prelude-                                        , hGetContents+import           Network.URI            ( unEscapeString                                         )- import           System.IO.Error        ( ioeGetErrorString-                                        , try                                         )- import           System.Directory       ( doesFileExist-                                        , getPermissions-                                        , readable+                                        -- , getPermissions+                                        -- , readable                                         ) import           Text.XML.HXT.DOM.XmlKeywords  -- ------------------------------------------------------------ -getStdinCont            :: Bool -> IO (Either ([(String, String)], String)-                                              String)+getStdinCont            :: Bool -> IO (Either ([(String, String)], String) B.ByteString) getStdinCont strictInput     = do-      c <- try ( if strictInput-                 then do-                      cb <- B.getContents-                      return  (C.unpack cb)-                 else getContents+      c <- try ( do+                 cb <- B.getContents+                 if strictInput+                    then B.length cb `seq` return cb+                    else                   return cb                )       return (either readErr Right c)     where@@ -68,26 +59,24 @@           msg = "stdin read error: " ++ es           es  = ioeGetErrorString e -getCont         :: Bool -> String -> IO (Either ([(String, String)], String)-                                                String)+getCont         :: Bool -> String -> IO (Either ([(String, String)], String) B.ByteString) getCont strictInput source     = do                        -- preliminary       source'' <- checkFile source'       case source'' of            Nothing -> return $ fileErr "file not found"            Just fn -> do-                      perm <- getPermissions fn-                      if not (readable perm)+                      -- perm <- getPermissions fn  -- getPermission may fail+                      -- if not (readable perm)+                      if False                          then return $ fileErr "file not readable"                          else do                               c <- try $+                                   do+                                   cb <- B.readFile fn                                    if strictInput-                                      then do-                                           cb <- B.readFile fn-                                           return (C.unpack cb)-                                      else do-                                           h <- openBinaryFile fn ReadMode-                                           hGetContents h+                                      then B.length `seq` return cb+                                      else                return cb                               return (either readErr Right c)     where     source' = drivePath $ source
− src/Text/XML/HXT/IO/GetHTTPLibCurl.hs 
@@ -1,310 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.IO.GetHTTPLibCurl-   Copyright  : Copyright (C) 2008 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : stable-   Portability: portable--   GET for http access with libcurl---}---- --------------------------------------------------------------module Text.XML.HXT.IO.GetHTTPLibCurl-    ( getCont-    )--where--import Control.Arrow                    ( first-                                        , (>>>)-                                        )-import Control.Concurrent.MVar-import Control.Monad                    ( when )--import qualified Data.ByteString        as B-import qualified Data.ByteString.Char8  as C--import Data.Char                        ( isDigit-                                        , isSpace-                                        )-import Data.List                        ( isPrefixOf )--import Network.Curl--import System.IO-import System.IO.Unsafe                 ( unsafePerformIO )--import Text.ParserCombinators.Parsec    ( parse )--import Text.XML.HXT.DOM.Util            ( stringToLower )-import Text.XML.HXT.DOM.XmlKeywords-import Text.XML.HXT.DOM.XmlOptions      ( isTrueValue )--import Text.XML.HXT.Parser.ProtocolHandlerUtil-                                        ( parseContentType )-import Text.XML.HXT.Version---- ------------------------------------------------------------------ the global flag for initializing curl in the 1. call--isInitCurl      :: MVar Bool-isInitCurl      = unsafePerformIO $ newMVar False--{-# NOINLINE isInitCurl #-}--initCurl        :: IO ()-initCurl-    = do-      i <- takeMVar isInitCurl-      when (not i) ( do-                     _ <- curl_global_init 3-                     return ()-                   )-      putMVar isInitCurl True---- ---------------------------------------------------------------- The curl lib is not thread save--curlResource    :: MVar ()-curlResource    = unsafePerformIO $ newMVar ()--{-# NOINLINE curlResource #-}--requestCurl     :: IO ()-requestCurl     = takeMVar curlResource--releaseCurl     :: IO ()-releaseCurl     = putMVar curlResource ()---- ------------------------------------------------------------------- the http protocol handler implemented by calling libcurl--- (<http://curl.haxx.se/>)--- via the curl binding--- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/curl>--- This function tries to support mostly all curl options concerning HTTP requests.--- The naming convetion is as follows: A curl option must be prefixed by the string--- \"curl\" and then written exactly as described in the curl man page--- (<http://curl.haxx.se/docs/manpage.html>).------ Example:------ > getCont [("curl--user-agent","My first HXT app"),("curl-e","http://the.referer.url/")] "http://..."------ will set the user agent and the referer URL for this request.--getCont         :: [(String, String)] -> String -> IO (Either ([(String, String)], String)-                                                              ([(String, String)], String))-getCont options uri-    = do-      initCurl-      requestCurl-      resp <- curlGetResponse_ uri curlOptions-      let resp' = evalResponse resp-      resp' `seq`-            releaseCurl-      -- dumpResponse-      return resp'-    where-    _dumpResponse r-        = do-          hPutStrLn stderr $ show $ respCurlCode   r-          hPutStrLn stderr $ show $ respStatus     r-          hPutStrLn stderr $        respStatusLine r-          hPutStrLn stderr $ show $ respHeaders    r-          hPutStrLn stderr $        respBody       r--    curlOptions-        = defaultOptions ++ concatMap (uncurry copt) options ++ standardOptions--    defaultOptions                                              -- these options may be overwritten-        = [ CurlUserAgent ("hxt/" ++ hxt_version ++ " via libcurl")-          , CurlFollowLocation True-          ]--    standardOptions                                             -- these options can't be overwritten-        = [ CurlFailOnError    False-          , CurlHeader         False-          , CurlNoProgress     True-          ]-    evalResponse r-        | rc /= CurlOK-            = Left ( [ mkH transferStatus    "999"-                     , mkH transferMessage $ "curl library rc: " ++ show rc-                     ]-                   , "curl library error when requesting URI "-                     ++ show uri-                     ++ ": (curl return code=" ++ show rc ++ ") "-                   )-        | rs < 200 && rs >= 300-            = Left ( contentT rsh ++ headers-                   , "http error when accessing URI "-                     ++ show uri-                     ++ ": "-                     ++ show rsl-                   )-        | otherwise-            = B.length body-              `seq`-              Right ( contentT rsh ++ headers-                    , C.unpack body-                    )-        where-        body :: B.ByteString-        body = respBody r--        mkH x y = (x, dropWhile isSpace y)--        headers-            = map (\ (k, v) -> mkH (httpPrefix ++ stringToLower k) v) rsh-              ++-              statusLine (words rsl)--        contentT-            = map (first stringToLower)                 -- all header names to lowercase-              >>>-              filter ((== "content-type") . fst)        -- select content-type header-              >>>-              reverse                                   -- when libcurl is called with automatic redirects, there are more than one content-type headers-              >>>-              take 1                                    -- take the last one, (if at leat one is found)-              >>>-              map snd                                   -- select content-type value-              >>>-              map ( either (const []) id-                    . parse parseContentType ""         -- parse the content-type for mimetype and charset-                  )-              >>>-              concat--        statusLine (vers : _code : msg)                 -- the status line of the curl response can be an old one, e.g. in the case of a redirect,-            = [ mkH transferVersion   vers              -- so the return code is taken from the status field, which is contains the last status-              , mkH transferMessage $ unwords msg-              , mkH transferStatus  $ show rs-              ]-        statusLine _-            = []--        rc  = respCurlCode    r-        rs  = respStatus      r-        rsl = respStatusLine  r-        rsh = respHeaders     r---- --------------------------------------------------------------copt    :: String -> String -> [CurlOption]-copt k v-    | "curl" `isPrefixOf` k-        = opt2copt (drop 4 k) v--    | k `elem` [a_proxy, a_redirect]-        = opt2copt k v--    | k == a_options_curl-        = curlOptionString v--    | otherwise-        = []--opt2copt        :: String -> String -> [CurlOption]-opt2copt k v-    | k `elem` ["-A", "--user-agent"]   = [CurlUserAgent v]-    | k `elem` ["-b", "--cookie"]       = [CurlCookie v]-    | k == "--connect-timeout"-      &&-      isIntArg v                        = [CurlConnectTimeout      $ read    v]-    | k == "--crlf"                     = [CurlCRLF                $ isTrue  v]-    | k `elem` ["-d", "--data"]         = [CurlPostFields          $ lines   v]-    | k `elem` ["-e", "--referer"]      = [CurlReferer                       v]-    | k `elem` ["-H", "--header"]       = [CurlHttpHeaders         $ lines   v]-    | k == "--ignore-content-length"    = [CurlIgnoreContentLength $ isTrue  v]-    | k `elem` ["-I", "--head"]         = [CurlNoBody              $ isTrue  v]-    | k `elem` ["-L", "--location", a_redirect]-                                        = [CurlFollowLocation      $ isTrue  v]-    | k == "--max-filesize"-      &&-      isIntArg v                        = [CurlMaxFileSizeLarge    $ read    v]-    | k `elem` ["-m", "--max-time"]-      &&-      isIntArg v                        = [CurlTimeoutMS           $ read    v]-    | k `elem` ["-n", "--netrc"]        = [CurlNetrcFile                     v]-    | k `elem` ["--ssl-verify-peer"]    = [CurlSSLVerifyPeer $ read v]-    | k `elem` ["-R", "--remote-time"]  = [CurlFiletime            $ isTrue  v]-    | k `elem` ["-u", "--user"]         = [CurlUserPwd                       v]-    | k `elem` ["-U", "--proxy-user"]   = [CurlProxyUserPwd                  v]-    | k `elem` ["-x", "--proxy", a_proxy]-                                        =  proxyOptions-    | k `elem` ["-X", "--request"]      = [CurlCustomRequest                 v]-    | k `elem` ["-y", "--speed-time"]-      &&-      isIntArg v                        = [CurlLowSpeedTime        $ read    v]-    | k `elem` ["-Y", "--speed-limit"]-      &&-      isIntArg v                        = [CurlLowSpeed            $ read    v]-    | k `elem` ["-z", "--time-cond", a_if_modified_since]-                                        =  ifModifiedOptions--    | k == a_if_modified_since          = [CurlHttpHeaders         $ ["If-Modified-Since: " ++ v] ]-                                        -- CurlTimeValue seems to be buggy, therefore this workaround-    | k == "--max-redirs"-      &&-      isIntArg v                        = [CurlMaxRedirs           $ read    v]-    | k `elem` ["-0", "--http1.0"]      = [CurlHttpVersion       HttpVersion10]-    | otherwise                         = []-    where-    ifModifiedOptions-        | "-" `isPrefixOf` v-          &&-          isIntArg v'                   = [CurlTimeCondition TimeCondIfUnmodSince-                                          ,CurlTimeValue           $ read   v'-                                          ]-        | isIntArg v                    = [CurlTimeCondition TimeCondIfModSince-                                          ,CurlTimeValue           $ read   v'-                                          ]-        | otherwise                     = []-        where-        v' = tail v--    proxyOptions-        = [ CurlProxyPort pport-          , CurlProxy     phost-          ]-        where-        pport-            | isIntArg ppp      = read v-            | otherwise         = 1080-        (phost, pp)             = span (/=':') v-        ppp                     = drop 1 pp----isTrue          :: String -> Bool-isTrue s        = null s || isTrueValue s--isIntArg        :: String -> Bool-isIntArg s      = not (null s) && all isDigit s--curlOptionString        :: String -> [CurlOption]-curlOptionString-    = concatMap (uncurry copt) . opts . words-    where-    opts l-        | null l                        = []-        | not ("-" `isPrefixOf` k)      = opts l1               -- k not an option: ignore-        | null l1                       = opts (k:"":l1)        -- last option-        | "-" `isPrefixOf` v            = (k, "") : opts (v:l)  -- k option without arg-        | otherwise                     = (k, v) : opts l2      -- k with value-        where-        (k:l1) = l-        (v:l2) = l1---- ------------------------------------------------------------
src/Text/XML/HXT/Parser/HtmlParsec.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP                #-}+ -- ------------------------------------------------------------  {- |@@ -33,94 +35,108 @@  where -import Text.XML.HXT.DOM.Interface--import Text.XML.HXT.DOM.XmlNode-    ( mkText-    , mkError-    , mkCmt-    , mkElement-    , mkAttr-    , mkDTDElem-    )--import Text.ParserCombinators.Parsec-    ( Parser-    , SourcePos-    , anyChar-    , between-    , char-    , eof-    , getPosition-    , many-    , noneOf-    , option-    , parse-    , satisfy-    , string-    , try-    , (<|>)-    )--import Text.XML.HXT.Parser.XmlTokenParser-    ( allBut-    , dq-    , eq-    , gt-    , name-    , pubidLiteral-    , skipS-    , skipS0-    , sq-    , systemLiteral--    , singleCharsT-    , referenceT-    )--import Text.XML.HXT.Parser.XmlParsec-    ( cDSect-    , charData'-    , misc-    , parseXmlText-    , pI-    , xMLDecl'-    )+#if MIN_VERSION_base(4,8,2)+#else+import Control.Applicative                      ((<$>))+#endif -import Text.XML.HXT.Parser.XmlCharParser-    ( xmlChar-    )+import Data.Char                                ( toLower+                                                , toUpper+                                                )+import Data.Char.Properties.XMLCharProps        ( isXmlChar+                                                )+import Data.Maybe                               ( fromMaybe+                                                , fromJust+                                                )+import qualified Data.Map                       as M -import Data.Maybe-    ( fromMaybe-    )+import Text.ParserCombinators.Parsec            ( SourcePos+                                                , anyChar+                                                , between+                                                -- , char+                                                , eof+                                                , getPosition+                                                , many+                                                , many1+                                                , noneOf+                                                , option+                                                , runParser+                                                , satisfy+                                                , string+                                                , try+                                                , (<|>)+                                                ) -import Data.Char-    ( toLower-    , toUpper-    )+import Text.XML.HXT.DOM.Interface+import Text.XML.HXT.DOM.XmlNode                 ( mkText'+                                                , mkError'+                                                , mkCdata'+                                                , mkCmt'+                                                , mkCharRef'+                                                , mkElement'+                                                , mkAttr'+                                                , mkDTDElem'+                                                , mkPi'+                                                , isEntityRef+                                                , getEntityRef+                                                )+import Text.XML.HXT.Parser.XmlTokenParser       ( allBut+                                                , amp+                                                , dq+                                                , eq+                                                , gt+                                                , lt+                                                , name+                                                , pubidLiteral+                                                , skipS+                                                , skipS0+                                                , sPace+                                                , sq+                                                , systemLiteral+                                                , checkString+                                                , singleCharsT+                                                , referenceT+                                                , mergeTextNodes+                                                )+import Text.XML.HXT.Parser.XmlParsec            ( misc+                                                , parseXmlText+                                                , xMLDecl'+                                                )+import Text.XML.HXT.Parser.XmlCharParser        ( xmlChar+                                                , SimpleXParser+                                                , withNormNewline+                                                )+import Text.XML.HXT.Parser.XhtmlEntities        ( xhtmlEntities+                                                )  -- ------------------------------------------------------------ -parseHtmlText   :: String -> XmlTree -> XmlTrees-parseHtmlText loc t-    = parseXmlText htmlDocument loc $ t+parseHtmlText           :: String -> XmlTree -> XmlTrees+parseHtmlText loc t     = parseXmlText htmlDocument (withNormNewline ()) loc $ t  -- ------------------------------------------------------------ -parseHtmlFromString     :: Parser XmlTrees -> String -> String -> XmlTrees+parseHtmlFromString     :: SimpleXParser XmlTrees -> String -> String -> XmlTrees parseHtmlFromString parser loc-    = either ((:[]) . mkError c_err . (++ "\n") . show) id . parse parser loc+    = either ((:[]) . mkError' c_err . (++ "\n") . show) id . runParser parser (withNormNewline ()) loc  parseHtmlDocument       :: String -> String -> XmlTrees parseHtmlDocument       = parseHtmlFromString htmlDocument  parseHtmlContent        :: String -> XmlTrees-parseHtmlContent        = parseHtmlFromString htmlContent "text"+parseHtmlContent        = parseHtmlFromString htmlContent "string"  -- ------------------------------------------------------------ -htmlDocument    :: Parser XmlTrees+type Context    = (XmlTreeFl, OpenTags)++type XmlTreeFl  = XmlTrees -> XmlTrees++type OpenTags   = [(String, XmlTrees, XmlTreeFl)]++-- ------------------------------------------------------------++htmlDocument    :: SimpleXParser XmlTrees htmlDocument     = do       pl <- htmlProlog@@ -128,7 +144,7 @@       eof       return (pl ++ el) -htmlProlog      :: Parser XmlTrees+htmlProlog      :: SimpleXParser XmlTrees htmlProlog     = do       xml <- option []@@ -136,8 +152,8 @@                <|>                ( do                  pos <- getPosition-                 _ <- try (string "<?")-                 return $ [mkError c_warn (show pos ++ " wrong XML declaration")]+                 checkString "<?"+                 return $ [mkError' c_warn (show pos ++ " wrong XML declaration")]                )              )       misc1   <- many misc@@ -146,15 +162,15 @@                    <|>                    ( do                      pos <- getPosition-                     _ <- try (upperCaseString "<!DOCTYPE")-                     return $ [mkError c_warn (show pos ++ " HTML DOCTYPE declaration ignored")]+                     upperCaseString "<!DOCTYPE"+                     return $ [mkError' c_warn (show pos ++ " HTML DOCTYPE declaration ignored")]                    )                  )       return (xml ++ misc1 ++ dtdPart) -doctypedecl     :: Parser XmlTrees+doctypedecl     :: SimpleXParser XmlTrees doctypedecl-    = between (try $ upperCaseString "<!DOCTYPE") (char '>')+    = between (upperCaseString "<!DOCTYPE") gt       ( do         skipS         n <- name@@ -163,13 +179,13 @@                   option [] externalID                 )         skipS0-        return [mkDTDElem DOCTYPE ((a_name, n) : exId) []]+        return [mkDTDElem' DOCTYPE ((a_name, n) : exId) []]       ) -externalID      :: Parser Attributes+externalID      :: SimpleXParser Attributes externalID     = do-      _ <- try (upperCaseString k_public)+      upperCaseString k_public       skipS       pl <- pubidLiteral       sl <- option "" $ try ( do@@ -178,45 +194,49 @@                             )       return $ (k_public, pl) : if null sl then [] else [(k_system, sl)] -htmlContent     :: Parser XmlTrees+htmlContent     :: SimpleXParser XmlTrees htmlContent+    = mergeTextNodes <$> htmlContent'++htmlContent'    :: SimpleXParser XmlTrees+htmlContent'     = option []       ( do-        context <- hContent ([], [])+        context <- hContent (id, [])         pos     <- getPosition         return $ closeTags pos context       )       where-      closeTags _ (body, [])-          = reverse body+      closeTags _pos (body, [])+          = body []       closeTags pos' (body, ((tn, al, body1) : restOpen))-          = closeTags pos' (addHtmlWarn (show pos' ++ ": no closing tag found for \"<" ++ tn ++ " ...>\"")-                            .-                            addHtmlTag tn al body-                            $-                            (body1, restOpen)-                           )+          = closeTags pos'+                      ( addHtmlWarn (show pos' ++ ": no closing tag found for \"<" ++ tn ++ " ...>\"")+                        .+                        addHtmlTag tn al body+                        $+                        (body1, restOpen)+                      ) -type OpenTags   = [(String, XmlTrees, XmlTrees)]-type Context    = (XmlTrees, OpenTags)+-- ------------------------------------------------------------ -hElement        :: Context -> Parser Context+hElement        :: Context -> SimpleXParser Context hElement context     = ( do         t <- hSimpleData-        return (addHtmlElems [t] context)+        return (addHtmlElem t context)       )       <|>-      hOpenTag context-      <|>       hCloseTag context       <|>+      hOpenTag context+      <|>       ( do                      -- wrong tag, take it as text         pos <- getPosition         c   <- xmlChar         return ( addHtmlWarn (show pos ++ " markup char " ++ show c ++ " not allowed in this context")                  .-                 addHtmlElems [mkText [c]]+                 addHtmlElem (mkText' [c])                  $                  context                )@@ -235,54 +255,57 @@       )  -hSimpleData     :: Parser XmlTree+hSimpleData     :: SimpleXParser XmlTree hSimpleData-    = charData'+    = charData''       <|>-      try referenceT+      hReference'       <|>-      try hComment+      hComment       <|>-      try pI+      hpI       <|>-      try cDSect+      hcDSect+    where+    charData''+        = do+          t <- many1 (satisfy (\ x -> isXmlChar x && not (x == '<' || x == '&')))+          return (mkText' t) -hCloseTag       :: Context -> Parser Context+hCloseTag       :: Context -> SimpleXParser Context hCloseTag context     = do-      n <- try ( do-                 _ <- string "</"-                 lowerCaseName-               )+      checkString "</"+      n <- lowerCaseName       skipS0       pos <- getPosition       checkSymbol gt ("closing > in tag \"</" ++ n ++ "\" expected") (closeTag pos n context) -hOpenTag        :: Context -> Parser Context+hOpenTag        :: Context -> SimpleXParser Context hOpenTag context     = ( do-        pos <- getPosition         e   <- hOpenTagStart-        hOpenTagRest pos e context+        hOpenTagRest e context       ) -hOpenTagStart   :: Parser (String, XmlTrees)+hOpenTagStart   :: SimpleXParser ((SourcePos, String), XmlTrees) hOpenTagStart     = do-      n <- try ( do-                 _ <- char '<'-                 n <- lowerCaseName-                 return n-               )+      np <- try ( do+                  lt+                  pos <- getPosition+                  n <- lowerCaseName+                  return (pos, n)+                )       skipS0       as <- hAttrList-      return (n, as)+      return (np, as) -hOpenTagRest    :: SourcePos -> (String, XmlTrees) -> Context -> Parser Context-hOpenTagRest pos (tn, al) context+hOpenTagRest    :: ((SourcePos, String), XmlTrees) -> Context -> SimpleXParser Context+hOpenTagRest ((pos, tn), al) context     = ( do-        _ <- try $ string "/>"-        return (addHtmlTag tn al [] context)+        checkString "/>"+        return (addHtmlTag tn al id context)       )       <|>       ( do@@ -290,13 +313,13 @@         return ( let context2 = closePrevTag pos tn context1                  in                  ( if isEmptyHtmlTag tn-                   then addHtmlTag tn al []+                   then addHtmlTag tn al id                    else openTag tn al                  ) context2                )       ) -hAttrList       :: Parser XmlTrees+hAttrList       :: SimpleXParser XmlTrees hAttrList     = many (try hAttribute)       where@@ -305,18 +328,14 @@             n <- lowerCaseName             v <- hAttrValue             skipS0-            return $ mkAttr (mkName n) v+            return $ mkAttr' (mkName n) v -hAttrValue      :: Parser XmlTrees+hAttrValue      :: SimpleXParser XmlTrees hAttrValue     = option []-      ( try ( do-              eq-              hAttrValue'-            )-      )+      ( eq >> hAttrValue' ) -hAttrValue'     :: Parser XmlTrees+hAttrValue'     :: SimpleXParser XmlTrees hAttrValue'     = try ( between dq dq (hAttrValue'' "&\"") )       <|>@@ -324,76 +343,157 @@       <|>       ( do                      -- HTML allows unquoted attribute values         cs <- many (noneOf " \r\t\n>\"\'")-        return [mkText cs]+        return [mkText' cs]       ) -hAttrValue''    :: String -> Parser XmlTrees+hAttrValue''    :: String -> SimpleXParser XmlTrees hAttrValue'' notAllowed     = many ( hReference' <|> singleCharsT notAllowed) -hReference'     :: Parser XmlTree+hReference'     :: SimpleXParser XmlTree hReference'-    = try referenceT+    = try hReferenceT       <|>       ( do-        _ <- char '&'-        return (mkText "&")+        amp+        return (mkText' "&")       ) -hContent        :: Context -> Parser Context+hReferenceT     :: SimpleXParser XmlTree+hReferenceT+    = do+      r <- referenceT+      return ( if isEntityRef r+               then substRef  r+               else r+             )+    where+    -- optimization: HTML entity refs are substituted by char refs, so a later entity ref substituion isn't required+    substRef r+        = case (lookup en xhtmlEntities) of+          Just i        -> mkCharRef' i+          Nothing       -> r                            -- not found: the entity ref remains as it is+                                                        -- this is also done in the XML parser+{- alternative def+          Nothing       -> mkText' ("&" ++ en ++ ";")   -- not found: the entity ref is taken as text+-}+        where+        en = fromJust . getEntityRef $ r++hContent        :: Context -> SimpleXParser Context hContent context     = option context-      ( do-        context1 <- hElement context-        hContent context1+      ( hElement context+        >>=+        hContent       ) +-- ------------------------------------------------------------+ -- hComment allows "--" in comments -- comment from XML spec does not -hComment                :: Parser XmlTree+hComment                :: SimpleXParser XmlTree hComment     = do-      c <- between (try $ string "<!--") (string "-->") (allBut many "-->")-      return (mkCmt c)+      checkString "<!--"+      pos <- getPosition+      c <- allBut many "-->"+      closeCmt pos c+    where+    closeCmt pos c+        = ( do+            checkString "-->"+            return (mkCmt' c)+          )+          <|>+          ( return $+            mkError' c_warn (show pos ++ " no closing comment sequence \"-->\" found")+          ) -checkSymbol     :: Parser a -> String -> Context -> Parser Context-checkSymbol p msg context+-- ------------------------------------------------------------++hpI             :: SimpleXParser XmlTree+hpI = checkString "<?"+      >>+      ( try ( do+              n <- name+              p <- sPace >> allBut many "?>"+              string "?>" >>+                     return (mkPi' (mkName n) [mkAttr' (mkName a_value) [mkText' p]])+            )+        <|>+        ( do+          pos <- getPosition+          return $+            mkError' c_warn (show pos ++ " illegal PI found")+        )+      )++-- ------------------------------------------------------------++hcDSect        :: SimpleXParser XmlTree+hcDSect     = do+      checkString "<![CDATA["       pos <- getPosition-      option (addHtmlWarn (show pos ++ " " ++ msg) context)-       ( do-         _ <- try p-         return context-       )+      t <- allBut many "]]>"+      closeCD pos t+    where+    closeCD pos t+        = ( do+            checkString "]]>"+            return (mkCdata' t)+          )+          <|>+          ( return $+            mkError' c_warn (show pos ++ " no closing CDATA sequence \"]]>\" found")+          ) -lowerCaseName   :: Parser String+-- ------------------------------------------------------------++checkSymbol     :: SimpleXParser () -> String -> Context -> SimpleXParser Context+checkSymbol p msg context+    = ( p+        >>+        return context+      )+      <|>+      ( do+        pos <- getPosition+        return $ addHtmlWarn (show pos ++ " " ++ msg) context+      )++lowerCaseName   :: SimpleXParser String lowerCaseName     = do       n <- name       return (map toLower n) -upperCaseString :: String -> Parser String-upperCaseString-    = sequence . map (\ c -> satisfy (( == c) . toUpper))+upperCaseString :: String -> SimpleXParser ()+upperCaseString s+    = try (sequence (map (\ c -> satisfy (( == c) . toUpper)) s)) >> return ()  -- ------------------------------------------------------------ -addHtmlTag      :: String -> XmlTrees -> XmlTrees -> Context -> Context-addHtmlTag tn al body (body1, openTags)-    = ([mkElement (mkName tn) al (reverse body)] ++ body1, openTags)+addHtmlTag      :: String -> XmlTrees -> XmlTreeFl -> Context -> Context+addHtmlTag tn al body context+    = e `seq`+      addHtmlElem e context+    where+    e = mkElement' (mkName tn) al (body [])  addHtmlWarn     :: String -> Context -> Context addHtmlWarn msg-    = addHtmlElems [mkError c_warn msg]+    = addHtmlElem (mkError' c_warn msg) -addHtmlElems    :: XmlTrees -> Context -> Context-addHtmlElems elems (body, openTags)-    = (reverse elems ++ body, openTags)+addHtmlElem    :: XmlTree -> Context -> Context+addHtmlElem elem' (body, openTags)+    = (body . (elem' :), openTags)  openTag         :: String -> XmlTrees -> Context -> Context openTag tn al (body, openTags)-    = ([], (tn, al, body) : openTags)+    = (id, (tn, al, body) : openTags)  closeTag        :: SourcePos -> String -> Context -> Context closeTag pos n context@@ -402,7 +502,7 @@     | otherwise         = addHtmlWarn (show pos ++ " no opening tag found for </" ++ n ++ ">")           .-          addHtmlTag n [] []+          addHtmlTag n [] id           $           context     where@@ -427,7 +527,7 @@ closePrevTag _pos _n context@(_body, [])     = context closePrevTag pos n context@(body, (n1, al1, body1) : restOpen)-    | n `closes` n1+    | n `closesHtmlTag` n1         = closePrevTag pos n           ( addHtmlWarn (show pos ++ " tag \"<" ++ n1 ++ " ...>\" implicitly closed by opening tag \"<" ++ n ++ " ...>\"")             .@@ -461,6 +561,7 @@       , "meta"       , "param"       ]+{-# INLINE emptyHtmlTags #-}  isInnerHtmlTagOf        :: String -> String -> Bool n `isInnerHtmlTagOf` tn@@ -487,11 +588,52 @@         ]       ) -closesHtmlTag-  , closes :: String -> String -> Bool+-- a bit more efficient implementation of closes +closesHtmlTag   :: String -> String -> Bool+closesHtmlTag t t2+    = fromMaybe False . fmap ($ t) . M.lookup t2 $ closedByTable+{-# INLINE closesHtmlTag #-}++closedByTable   :: M.Map String (String -> Bool)+closedByTable+    = M.fromList $+      [ ("a",   (== "a"))+      , ("li",  (== "li" ))+      , ("th",  (`elem` ["th", "td", "tr"] ))+      , ("td",  (`elem` ["th", "td", "tr"] ))+      , ("tr",  (== "tr"))+      , ("dt",  (`elem` ["dt", "dd"] ))+      , ("dd",  (`elem` ["dt", "dd"] ))+      , ("p",   (`elem` ["hr"+                        , "h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))+      , ("colgroup",    (`elem` ["colgroup", "thead", "tfoot", "tbody"] ))+      , ("form",        (`elem` ["form"] ))+      , ("label",       (`elem` ["label"] ))+      , ("map",         (`elem` ["map"] ))+      , ("option",      const True)+      , ("script",      const True)+      , ("style",       const True)+      , ("textarea",    const True)+      , ("title",       const True)+      , ("select",      ( /= "option"))+      , ("thead",       (`elem` ["tfoot","tbody"] ))+      , ("tbody",       (== "tbody" ))+      , ("tfoot",       (== "tbody" ))+      , ("h1",  (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))+      , ("h2",  (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))+      , ("h3",  (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))+      , ("h4",  (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))+      , ("h5",  (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))+      , ("h6",  (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))+      ]++{-+closesHtmlTag :: String -> String -> Bool closesHtmlTag   = closes +closes :: String -> String -> Bool+ "a"     `closes` "a"                                    = True "li"    `closes` "li"                                   = True "th"    `closes`  t    | t `elem` ["th","td"]           = True@@ -533,5 +675,6 @@                                 ,"p"                    -- not "div"                                 ]                       = True _       `closes` _                                      = False+-}  -- ------------------------------------------------------------
− src/Text/XML/HXT/Parser/TagSoup.hs 
@@ -1,495 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.Parser.TagSoup-   Copyright  : Copyright (C) 2005-2008 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : experimental-   Portability: portable--   lazy HTML and simpe XML parser implemented with tagsoup-   parsing is done with a very simple monadic top down parser---}---- --------------------------------------------------------------module Text.XML.HXT.Parser.TagSoup-    ( parseHtmlTagSoup-    )-where---- --------------------------------------------------------------import Data.Char (toLower)-import Data.Maybe--import Text.HTML.TagSoup-import Text.HTML.TagSoup.Entity         ( lookupNumericEntity-                                        )-import Text.XML.HXT.DOM.Unicode         ( isXmlSpaceChar-                                        )-import Text.XML.HXT.Parser.HtmlParsec   ( isEmptyHtmlTag-                                        , isInnerHtmlTagOf-                                        , closesHtmlTag-                                        )-import Text.XML.HXT.Parser.XhtmlEntities-import Text.XML.HXT.DOM.Interface       ( XmlTrees-                                        , QName-                                        , NsEnv-                                        , toNsEnv-                                        , newXName-                                        , nullXName-                                        , mkQName'-                                        , mkName-                                        , isWellformedQualifiedName-                                        , c_warn-                                        , a_xml-                                        , a_xmlns-                                        , xmlNamespace-                                        , xmlnsNamespace-                                        )-import Text.XML.HXT.DOM.XmlNode         ( isElem-                                        , mkError-                                        , mkCmt-                                        , mkText-                                        , mkElement-                                        , mkAttr-                                        )---- -------------------------------------------- The name table contains the id map. All element and attribute names are stored--- the first time they are ecountered, and later always this name is used,--- not a string built by the parser.--type STag               = Tag String--type Tags               = [STag]--type Context            = ([String], NsEnv)--type State              = Tags--newtype Parser a        = P { parse :: State -> (a, State)}--instance Monad Parser where-    return x    = P $ \ ts -> (x, ts)-    p >>= f     = P $ \ ts -> let-                              (res, ts') = parse p ts-                              in-                              parse (f res) ts'--runParser       :: Parser a -> Tags -> a-runParser p ts  = fst . parse p $ ts---- ------------------------------------------cond            :: Parser Bool -> Parser a -> Parser a -> Parser a-cond c t e      = do-                  p <- c-                  if p then t else e--lookAhead       :: (STag -> Bool) -> Parser Bool-lookAhead p     = P $ \ s -> (not (null s) && p (head s), s)---- ------------------------------------------- primitive look ahead tests--isEof           :: Parser Bool-isEof           = P $ \ s -> (null s, s)--isText          :: Parser Bool-isText          = lookAhead is-                  where-                  is (TagText _) = True-                  is _           = False--isCmt           :: Parser Bool-isCmt           = lookAhead is-                  where-                  is (TagComment _) = True-                  is _              = False--isWarn          :: Parser Bool-isWarn          = lookAhead is-                  where-                  is (TagWarning _) = True-                  is _              = False--isPos           :: Parser Bool-isPos           = lookAhead is-                  where-                  is (TagPosition _ _) = True-                  is _           = False--isCls           :: Parser Bool-isCls           = lookAhead is-                  where-                  is (TagClose _) = True-                  is _            = False--isOpn           :: Parser Bool-isOpn           = lookAhead is-                  where-                  is (TagOpen _ _) = True-                  is _             = False---- ------------------------------------------- primitive symbol parsers--getTag          :: Parser STag-getTag          = P $ \ (t1:ts1) -> (t1, ts1)--getSym          :: (STag -> a) -> Parser a-getSym f        = do-                  t <- getTag-                  return (f t)--getText         :: Parser String-getText         = getSym sym-                  where-                  sym (TagText t)       = t-                  sym _                 = undefined--getCmt          :: Parser String-getCmt          = getSym sym-                  where-                  sym (TagComment c)    = c-                  sym _                 = undefined--getWarn         :: Parser String-getWarn         = getSym sym-                  where-                  sym (TagWarning w)    = w-                  sym _                 = undefined--getPos          :: Parser (Int, Int)-getPos          = getSym sym-                  where-                  sym (TagPosition l c) = (l, c)-                  sym _                 = undefined--getCls          :: Parser String-getCls          = getSym sym-                  where-                  sym (TagClose n)      = n-                  sym _                 = undefined--getOpn          :: Parser (String, [(String,String)])-getOpn          = getSym sym-                  where-                  sym (TagOpen n al)    = (n, al)-                  sym _                 = undefined---- ------------------------------------------- pushback parsers for inserting missing tags--pushBack        :: STag -> Parser ()-pushBack t      = P $ \ ts -> ((), t:ts)--insCls          :: String -> Parser ()-insCls n        = pushBack (TagClose n)--insOpn          :: String -> [(String, String)] -> Parser ()-insOpn n al     = pushBack (TagOpen n al)---- ------------------------------------------mkQN            :: Bool -> Bool -> NsEnv -> String -> Parser QName-mkQN withNamespaces isAttr env s-    | withNamespaces-        = return qn1-    | otherwise-        = return qn0-    where-    qn1-        | isAttr && isSimpleName        = s'-        | isSimpleName                  = mkQName' nullXName (newXName s) (nsUri nullXName)-        | isWellformedQualifiedName s   = mkQName' px'        lp'         (nsUri px')-        | otherwise                     = s'-    qn0                                 = s'--    nsUri x                             = fromMaybe nullXName . lookup x $ env-    isSimpleName                        = all (/= ':') s-    (px, (_ : lp))                      = span(/= ':') s-    px'                                 = newXName px-    lp'                                 = newXName lp-    s'                                  = mkName   s--extendNsEnv     :: Bool -> [(String, String)] -> NsEnv -> NsEnv-extendNsEnv withNamespaces al1 env-    | withNamespaces-        = toNsEnv (concatMap (uncurry addNs) al1) ++ env-    | otherwise-        = env-    where-    addNs n v-        | px == a_xmlns-          &&-          (null lp || (not . null . tail $ lp))-            = [(drop 1 lp, v)]-        | otherwise-            = []-        where-        (px, lp) = span (/= ':') n---- -------------------------------------------- own entity lookup to prevent problems with &amp; and tagsoup hack for IE--lookupEntity    :: Bool -> Bool -> (String, Bool) -> Tags-lookupEntity withWarnings _asHtml (e0@('#':e), withSemicolon)-    = case lookupNumericEntity e of-      Just c  -> (TagText [c])-		 : missingSemi-      Nothing -> ( TagText $ "&" ++ e0 ++ [';' | withSemicolon])-		 : if withWarnings-                   then (TagWarning $ "illegal char reference: &" ++ e ++ ";")-		        : missingSemi-		   else []-    where-    missingSemi-	| withWarnings-	  &&-	  not withSemicolon = [TagWarning $ "missing \";\" at end of char reference: &" ++ e]-        | otherwise         = []--lookupEntity withWarnings asHtml (e, withSemicolon)-    = case (lookup e entities) of-      Just x  -> (TagText [toEnum x])-		 : missingSemi-      Nothing -> (TagText $ "&" ++ e ++ [';' | withSemicolon])-		 : if withWarnings-                   then (TagWarning $ "Unknown entity reference: &" ++ e ++ ";")-			: missingSemi-		   else []-    where-    entities-        | asHtml    = xhtmlEntities-        | otherwise = xhtmlEntities -- xmlEntities (TODO: xhtml is xml and html)-    missingSemi-	| withWarnings-	  &&-	  not withSemicolon = [TagWarning $ "missing \";\" at end of entity reference: &" ++ e]-        | otherwise         = []--lookupEntityAttr        :: Bool -> Bool -> (String, Bool) -> (String, Tags)-lookupEntityAttr withWarnings asHtml (e, b)-    | null r    = (s,                   r)-    | otherwise = ("&" ++ s ++ [';' | b], r)-    where-    (TagText s) : r = lookupEntity withWarnings asHtml (e, b)---- -----------------------------------------{--        entityData x = case lookupEntity y of-            Just y -> [TagText $ fromChar y]-            Nothing -> [TagText $ fromString $ "&" ++ y ++ ";"-                       ,TagWarning $ fromString $ "Unknown entity: " ++ y]-            where y = toString x--        entityAttrib (x,b) = case lookupEntity y of-            Just y -> (fromChar y, [])-            Nothing -> (fromString $ "&" ++ y ++ [';'|b], [TagWarning $ fromString $ "Unknown entity: " ++ y])-            where y = toString x--}--- -------------------------------------------- |--- Turns all element and attribute names to lower case--- even !DOCTYPE stuff. But this is discarded when parsing the tagsoup--lowerCaseNames :: Tags -> Tags-lowerCaseNames-    = map f-    where-    f (TagOpen name attrs)-        = TagOpen (nameToLower name) (map attrToLower attrs)-    f (TagClose name)-        = TagClose (nameToLower name)-    f a = a-    nameToLower          = map toLower-    attrToLower (an, av) = (nameToLower an, av)---- ------------------------------------------- the main parser--parseHtmlTagSoup        :: Bool -> Bool -> Bool -> Bool -> Bool -> String -> String -> XmlTrees-parseHtmlTagSoup withNamespaces withWarnings withComment removeWhiteSpace asHtml doc-    = ( docRootElem-        . runParser (buildCont initContext)-        . ( if asHtml-            then lowerCaseNames-            else id-          )-        . tagsoupParse-      )-    where-    tagsoupParse        :: String -> Tags-    tagsoupParse        = parseTagsOptions tagsoupOptions--    tagsoupOptions      :: ParseOptions String-    tagsoupOptions      = parseOptions' { optTagWarning   = withWarnings-                                        , optEntityData   = lookupEntity     withWarnings asHtml-                                        , optEntityAttrib = lookupEntityAttr withWarnings asHtml-                                        }-                          where-                          parseOptions' :: ParseOptions String-                          parseOptions' = parseOptions--    -- This is essential for lazy parsing:-    -- the call of "take 1" stops parsing, when the first element is detected-    -- no check on end of input sequence is required to build this (0- or 1-element list)-    -- so eof is never checked unneccessarily--    docRootElem-        = take 1 . filter isElem--    initContext         = ( []-                          , toNsEnv $-                            [ (a_xml,   xmlNamespace)-                            , (a_xmlns, xmlnsNamespace)-                            ]-                          )--    wrap                = (:[])--    warn-        | withWarnings  = wrap . mkError c_warn . show . (doc ++) . (" " ++)-        | otherwise     = const []-    cmt-        | withComment   = wrap . mkCmt-        | otherwise     = const []-    txt-        | removeWhiteSpace-                        = \ t ->-                          if all isXmlSpaceChar t-                          then []-                          else wrap . mkText $ t-        | otherwise     = wrap . mkText--    isEmptyElem-        | asHtml        = isEmptyHtmlTag-        | otherwise     = const False--    isInnerElem-        | asHtml        = isInnerHtmlTagOf-        | otherwise     = const (const False)--    closesElem-        | asHtml        = \ ns n1 ->-                          not (null ns)-                          &&-                          n1 `closesHtmlTag` (head ns)-        | otherwise     = const (const False)--    buildCont   :: Context -> Parser XmlTrees-    buildCont ns-        = cond isText ( do-                        t <- getText-                        rl <- buildCont ns-                        return (txt t ++ rl)-                      )-          ( cond isOpn ( do-                         (n,al) <- getOpn-                         openTag ns n al-                       )-            ( cond isCls ( do-                           n <- getCls-                           closeTag ns n-                         )-              ( cond isCmt ( do-                             c <- getCmt-                             rl <- buildCont ns-                             return (cmt c ++ rl)-                           )-                ( cond isWarn ( do-                                w <- getWarn-                                rl <- buildCont ns-                                return (warn w ++ rl)-                              )-                  ( cond isPos ( do-                                 _ <- getPos-                                 buildCont ns-                               )-                    ( cond isEof ( do-                                   _ <- isEof-                                   closeAll ns-                                 )-                      ( return (warn "parse error in tagsoup tree construction")-                      )-                    )-                  )-                )-              )-            )-          )-        where-        closeTag                :: Context -> String -> Parser XmlTrees-        closeTag ((n':_), _) n1-            | n' == n1          = return []                     -- a normal closing tag-                                                                -- all other cases try to repair wrong html-        closeTag ns'@((n':_), _) n1                             -- n1 closes n implicitly-            | n' `isInnerElem` n1                               -- e.g. <td>...</tr>-                                = do-                                  insCls n1                     -- pushback </n1>-                                  insCls n'                     -- insert a </n'>-                                  buildCont ns'                 -- try again-        closeTag ns' n1-            | isEmptyElem n1    = buildCont ns'                 -- ignore a redundant closing tag for empty element-        closeTag ns'@((n':ns1'), _) n1                          -- insert a missing closing tag-            | n1 `elem` ns1'    = do-                                  insCls n1-                                  insCls n'-                                  rl <- buildCont ns'-                                  return ( warn ("closing tag " ++ show n' ++-                                                 " expected, but " ++ show n1 ++ " found")-                                           ++ rl-                                         )-        closeTag ns' n1                                         -- ignore a wrong closing tag-                                = do-                                  rl <- buildCont ns'-                                  return ( warn ("no opening tag for closing tag " ++ show n1)-                                           ++ rl-                                         )--        openTag                 :: Context -> String -> [(String, String)] -> Parser XmlTrees-        openTag cx'@(ns',env') n1 al1-            | isPiDT n1         = buildCont cx'-            | isEmptyElem n1-                                = do-                                  qn <- mkElemQN nenv n1-                                  al <- mkAttrs al1-                                  rl <- buildCont cx'-                                  return (mkElement qn al [] : rl)-            | closesElem ns' n1 = do-                                  insOpn n1 al1-                                  insCls (head ns')-                                  buildCont cx'-            | otherwise         = do-                                  qn <- mkElemQN nenv n1-                                  al <- mkAttrs al1-                                  cs <- buildCont ((n1 : ns'), nenv)-                                  rl <- buildCont cx'-                                  return (mkElement qn al cs : rl)-            where-            nenv                = extendNsEnv withNamespaces al1 env'-            mkElemQN            = mkQN withNamespaces False-            mkAttrQN            = mkQN withNamespaces True-            isPiDT ('?':_)      = True-            isPiDT ('!':_)      = True-            isPiDT _            = False-            mkAttrs             = mapM (uncurry mkA)-            mkA an av           = do-                                  qan <- mkAttrQN nenv an-                                  return (mkAttr qan (wrap . mkText $ av))--        closeAll                :: ([String], NsEnv) -> Parser XmlTrees-        closeAll (ns',_)        = return (concatMap wrn ns')-                                  where-                                  wrn = warn . ("insert missing closing tag " ++) . show---- ------------------------------------------------------------
src/Text/XML/HXT/Parser/XmlCharParser.hs view
@@ -1,23 +1,65 @@--- |--- UTF-8 character parser and simple XML token parsers------ Version : $Id: XmlCharParser.hs,v 1.2 2005/05/31 16:01:12 hxml Exp $+-- ------------------------------------------------------------ +{- |+   Module     : Text.XML.HXT.Parser.XmlCharParser+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   UTF-8 character parser and simple XML token parsers+-}++-- ------------------------------------------------------------+ module Text.XML.HXT.Parser.XmlCharParser-    ( xmlChar                   -- xml char parsers+    ( XParser+    , SimpleXParser+    , XPState(..)+    , withNormNewline+    , withoutNormNewline++    , xmlChar                   -- xml char parsers     , xmlNameChar     , xmlNameStartChar     , xmlNCNameChar     , xmlNCNameStartChar     , xmlLetter     , xmlSpaceChar+    , xmlCRLFChar     ) where -import Text.XML.HXT.DOM.Unicode-import Text.ParserCombinators.Parsec+import           Data.Char.Properties.XMLCharProps (isXmlCharCR, isXmlLetter,+                                                    isXmlNCNameChar,+                                                    isXmlNCNameStartChar,+                                                    isXmlNameChar,+                                                    isXmlNameStartChar,+                                                    isXmlSpaceCharCR) +import           Data.String.Unicode++import           Text.ParserCombinators.Parsec+ -- ------------------------------------------------------------++type XParser s a        = GenParser Char (XPState s) a+type SimpleXParser a    = XParser () a++data XPState s          = XPState+    { xps_normalizeNewline :: !Bool+    , xps_userState        ::  s+    }++withNormNewline         :: a -> XPState a+withNormNewline x       = XPState True x++withoutNormNewline      :: a -> XPState a+withoutNormNewline x    = XPState False x++-- ------------------------------------------------------------ -- -- Char (2.2) --@@ -25,50 +67,76 @@ -- | -- parse a single Unicode character -xmlChar                 :: GenParser Char state Unicode-xmlChar                 = satisfy isXmlChar <?> "legal XML character"+xmlChar                 :: XParser s Unicode+xmlChar                 = ( satisfy isXmlCharCR+                            <|>+                            xmlCRLFChar+                          )+                          <?> "legal XML character"+{-# INLINE xmlChar #-}  -- | -- parse a XML name character -xmlNameChar             :: GenParser Char state Unicode+xmlNameChar             :: XParser s Unicode xmlNameChar             = satisfy isXmlNameChar <?> "legal XML name character"+{-# INLINE xmlNameChar #-}  -- | -- parse a XML name start character -xmlNameStartChar        :: GenParser Char state Unicode+xmlNameStartChar        :: XParser s Unicode xmlNameStartChar        = satisfy isXmlNameStartChar <?> "legal XML name start character"+{-# INLINE xmlNameStartChar #-}  -- | -- parse a XML NCName character -xmlNCNameChar           :: GenParser Char state Unicode+xmlNCNameChar           :: XParser s Unicode xmlNCNameChar           = satisfy isXmlNCNameChar <?> "legal XML NCName character"+{-# INLINE xmlNCNameChar #-}  -- | -- parse a XML NCName start character -xmlNCNameStartChar      :: GenParser Char state Unicode+xmlNCNameStartChar      :: XParser s Unicode xmlNCNameStartChar      = satisfy isXmlNCNameStartChar <?> "legal XML NCName start character"+{-# INLINE xmlNCNameStartChar #-}  -- | -- parse a XML letter character -xmlLetter               :: GenParser Char state Unicode+xmlLetter               :: XParser s Unicode xmlLetter               = satisfy isXmlLetter <?> "legal XML letter"+{-# INLINE xmlLetter #-}  -- | -- White Space (2.3) --+-- end of line handling (2.11) will be done before or with 'xmlCRLFChar' parser++xmlSpaceChar            :: XParser s Char+xmlSpaceChar            = ( satisfy isXmlSpaceCharCR+                            <|>+                            xmlCRLFChar+                          )+                          <?> "white space"+{-# INLINE xmlSpaceChar #-}++-- |+-- White Space Normalization+-- -- end of line handling (2.11) -- \#x0D and \#x0D\#x0A are mapped to \#x0A--- is done in XmlInput before parsing--- otherwise \#x0D in internal parsing, e.g. for entities would normalize,--- would be transformed -xmlSpaceChar            :: GenParser Char state Char-xmlSpaceChar            = satisfy isXmlSpaceChar <?> "white space"+xmlCRLFChar            :: XParser s Char+xmlCRLFChar            = ( do+                           _ <- char '\r'+                           s <- getState+                           if xps_normalizeNewline s+                              then option '\n' (char '\n')+                              else return '\r'+                         )+                         <?> "newline"  -- -------------------------------------------------------------
src/Text/XML/HXT/Parser/XmlDTDParser.hs view
@@ -33,27 +33,33 @@  import Text.XML.HXT.DOM.Interface -- import Text.XML.HXT.DOM.ShowXml     ( xshow     )-import Text.XML.HXT.DOM.XmlNode-    ( mkDTDElem-    , mkText-    , mkError-    , isText-    , isDTD-    , getText-    , getDTDPart-    , getDTDAttrl-    , getChildren-    , setChildren-    )+import Text.XML.HXT.DOM.XmlNode                        ( mkDTDElem'+                                                       , mkText'+                                                       , mkError'+                                                       , isText+                                                       , isDTD+                                                       , getText+                                                       , getDTDPart+                                                       , getDTDAttrl+                                                       , getChildren+                                                       , setChildren+                                                       ) import qualified Text.XML.HXT.Parser.XmlTokenParser    as XT-import qualified Text.XML.HXT.Parser.XmlCharParser     as XC ( xmlSpaceChar )-import qualified Text.XML.HXT.Parser.XmlDTDTokenParser as XD ( dtdToken ) +import           Text.XML.HXT.Parser.XmlCharParser     ( XParser+                                                       , XPState(..)+                                                       , withoutNormNewline+                                                       )++import qualified Text.XML.HXT.Parser.XmlCharParser     as XC+                                                       ( xmlSpaceChar )++import qualified Text.XML.HXT.Parser.XmlDTDTokenParser as XD+                                                       ( dtdToken )+ ----------------------------------------------------------- -- -- all parsers dealing with whitespace will be redefined@@ -61,21 +67,25 @@  type LocalState = (Int, [(Int, String, SourcePos)]) -type SParser a  = GenParser Char LocalState a+type SParser a  = XParser LocalState a -initialLocalState       :: SourcePos -> LocalState-initialLocalState p     = (0, [(0, sourceName p, p)])+initialState    :: SourcePos -> XPState LocalState+initialState p  = withoutNormNewline (0, [(0, sourceName p, p)]) +updateLocalState :: (LocalState -> LocalState) -> SParser ()+updateLocalState upd+                = updateState $ \ xps -> xps { xps_userState = upd $ xps_userState xps }+ pushPar         :: String -> SParser () pushPar n       = do                   p <- getPosition-                  updateState (\ (i, s) -> (i+1, (i+1, n, p) : s))+                  updateLocalState (\ (i, s) -> (i+1, (i+1, n, p) : s))                   setPosition ( newPos (sourceName p ++ " (line " ++ show (sourceLine p) ++ ", column " ++ show (sourceColumn p) ++ ") in content of parameter entity ref %" ++ n ++ ";") 1 1)  popPar          :: SParser () popPar          = do                   oldPos <- getPos-                  updateState pop+                  updateLocalState pop                   setPosition oldPos                 where                 pop (i, [(_, s, p)]) = (i+1, [(i+1, s, p)])     -- if param entity substitution is correctly implemented, this case does not occur@@ -84,12 +94,14 @@  getParNo        :: SParser Int getParNo        = do-                  (_i, (top, _n, _p) : _s) <- getState+                  s <- getState+                  let (_i, (top, _n, _p) : _s) = xps_userState s                   return top  getPos          :: SParser SourcePos getPos          = do-                  (_i, (_top, _n, p) : _s) <- getState+                  s <- getState+                  let (_i, (_top, _n, p) : _s) = xps_userState s                   return p  delPE   :: SParser ()@@ -129,8 +141,8 @@ -- ------------------------------------------------------------  xmlSpaceChar    :: SParser ()-xmlSpaceChar    = ( do-                    _ <- XC.xmlSpaceChar+xmlSpaceChar    = ( XC.xmlSpaceChar+                    >>                     return ()                   )                   <|>@@ -141,27 +153,27 @@  skipS           :: SParser () skipS-    = do-      skipMany1 xmlSpaceChar+    = skipMany1 xmlSpaceChar+      >>       return ()  skipS0          :: SParser () skipS0-    = do-      skipMany xmlSpaceChar+    = skipMany xmlSpaceChar+      >>       return ()  name            :: SParser XmlTree name     = do       n <- XT.name-      return (mkDTDElem NAME [(a_name, n)] [])+      return (mkDTDElem' NAME [(a_name, n)] [])  nmtoken         :: SParser XmlTree nmtoken     = do       n <- XT.nmtoken-      return (mkDTDElem NAME [(a_name, n)] [])+      return (mkDTDElem' NAME [(a_name, n)] [])  -- ------------------------------------------------------------ --@@ -179,7 +191,7 @@       skipS       (al, cl) <- contentspec       skipS0-      return [mkDTDElem ELEMENT ((a_name, n) : al) cl]+      return [mkDTDElem' ELEMENT ((a_name, n) : al) cl]  contentspec     :: SParser (Attributes, XmlTrees) contentspec@@ -206,7 +218,7 @@     = ( do         (al, cl) <- choiceOrSeq         modifier <- optOrRep-        return ([(a_type, v_children)], [mkDTDElem CONTENT (modifier ++ al) cl])+        return ([(a_type, v_children)], [mkDTDElem' CONTENT (modifier ++ al) cl])       )       <?> "element content" @@ -261,14 +273,14 @@         m <- optOrRep         return ( case m of                  [(_, "")] -> n-                 _         -> mkDTDElem CONTENT (m ++ [(a_kind, v_seq)]) [n]+                 _         -> mkDTDElem' CONTENT (m ++ [(a_kind, v_seq)]) [n]                )       )       <|>       ( do         (al, cl) <- choiceOrSeq         m <- optOrRep-        return (mkDTDElem CONTENT (m ++ al) cl)+        return (mkDTDElem' CONTENT (m ++ al) cl)       )  -- ------------------------------------------------------------@@ -296,7 +308,7 @@           else do                _ <- char '*' <?> "closing parent for mixed content (\")*\")"                return ( [ (a_type, v_mixed) ]-                      , [ mkDTDElem CONTENT [ (a_modifier, "*")+                      , [ mkDTDElem' CONTENT [ (a_modifier, "*")                                              , (a_kind, v_choice)                                              ] nl                         ]@@ -322,7 +334,7 @@       return (map (mkDTree n) al)     where     mkDTree n' (al, cl)-        = mkDTDElem ATTLIST ((a_name, n') : al) cl+        = mkDTDElem' ATTLIST ((a_name, n') : al) cl  attDef          :: SParser (Attributes, XmlTrees) attDef@@ -426,7 +438,7 @@       skipS       (al, cl) <- entityDef       skipS0-      return [mkDTDElem ENTITY ((a_name, n) : al) cl]+      return [mkDTDElem' ENTITY ((a_name, n) : al) cl]  entityDef               :: SParser (Attributes, XmlTrees) entityDef@@ -450,7 +462,7 @@       skipS       (al, cs) <- peDef       skipS0-      return [mkDTDElem PENTITY ((a_name, n) : al) cs]+      return [mkDTDElem' PENTITY ((a_name, n) : al) cs]  peDef                   :: SParser (Attributes, XmlTrees) peDef@@ -460,7 +472,7 @@       al <- externalID       return (al, []) -entityValue     :: GenParser Char state (Attributes, XmlTrees)+entityValue     :: XParser s (Attributes, XmlTrees) entityValue     = do       v <- XT.entityValueT@@ -520,7 +532,7 @@                publicID              )       skipS0-      return [mkDTDElem NOTATION ((a_name, n) : eid) []]+      return [mkDTDElem' NOTATION ((a_name, n) : eid) []]  publicID                :: SParser Attributes publicID@@ -540,7 +552,7 @@       skipS0       let n' = stringToUpper n       if n' `elem` [k_include, k_ignore]-         then return [mkText  n']+         then return [mkText'  n']          else fail $ "INCLUDE or IGNORE expected in conditional section"  -- ------------------------------------------------------------@@ -579,13 +591,13 @@ parseXmlDTDEntityValue t        -- (NTree (XDTD PEREF al) cl)     | isDTDPEref t         = ( either-            ( (:[]) . mkError c_err . (++ "\n") . show )+            ( (:[]) . mkError' c_err . (++ "\n") . show )             ( \cl' -> if null cl'-                         then [mkText ""]+                         then [mkText' ""]                          else cl'             )             .-            parse parser source+            runParser parser (withoutNormNewline ()) source           ) input     | otherwise         = []@@ -608,10 +620,10 @@         = ( (:[])             .             either-               ( mkError c_err . (++ "\n") . show )+               ( mkError' c_err . (++ "\n") . show )                ( flip setChildren $ t ) -- \ cl' -> setChildren cl' t)             .-            parse parser source+            runParser parser (withoutNormNewline ()) source           ) input     | otherwise         = []@@ -640,9 +652,9 @@ parseXmlDTDdecl :: XmlTree -> XmlTrees parseXmlDTDdecl t       -- (NTree (XDTD dtdElem al) cl)     | isDTD t-        = ( either ((:[]) . mkError c_err . (++ "\n") . show) id+        = ( either ((:[]) . mkError' c_err . (++ "\n") . show) id             .-            runParser parser (initialLocalState pos) source+            runParser parser (initialState pos) source           ) input     | otherwise         = []
src/Text/XML/HXT/Parser/XmlDTDTokenParser.hs view
@@ -8,7 +8,6 @@    Maintainer : Uwe Schmidt (uwe@fh-wedel.de)    Stability  : experimental    Portability: portable-   Version    : $Id: XmlDTDTokenParser.hs,v 1.4 2005/09/02 17:09:39 hxml Exp $     Parsec parser for tokenizing DTD declarations for ELEMENT, ATTLIST, ENTITY and NOTATION @@ -21,24 +20,25 @@ import           Text.ParserCombinators.Parsec  import           Text.XML.HXT.DOM.Interface-import           Text.XML.HXT.DOM.XmlNode               ( mkDTDElem-                                                        , mkText+import           Text.XML.HXT.DOM.XmlNode               ( mkDTDElem'+                                                        , mkText'                                                         ) import qualified Text.XML.HXT.Parser.XmlTokenParser     as XT+import           Text.XML.HXT.Parser.XmlCharParser      ( XParser )  -- ------------------------------------------------------------ -- -- DTD declaration tokenizer -dtdDeclTokenizer        :: GenParser Char state XmlTree+dtdDeclTokenizer        :: XParser s XmlTree dtdDeclTokenizer     = do       (dcl, al) <- dtdDeclStart       content <- many1 dtdToken       dtdDeclEnd-      return $! mkDTDElem dcl al content+      return $ mkDTDElem' dcl al content -dtdDeclStart :: GenParser Char state (DTDElem, Attributes)+dtdDeclStart :: XParser s (DTDElem, Attributes) dtdDeclStart     = foldr1 (<|>) $       map (uncurry dtdStart) $@@ -48,7 +48,7 @@               , ("NOTATION", NOTATION)               ]     where-    dtdStart    :: String -> DTDElem -> GenParser Char state (DTDElem, Attributes)+    dtdStart    :: String -> DTDElem -> XParser s (DTDElem, Attributes)     dtdStart dcl element         = try ( do                 _ <- string "<!"@@ -61,45 +61,45 @@                        )               ) -dtdDeclEnd      :: GenParser Char state ()+dtdDeclEnd      :: XParser s () dtdDeclEnd     = do       _ <- XT.gt       return () -dtdToken        :: GenParser Char state XmlTree+dtdToken        :: XParser s XmlTree dtdToken     = dtdChars       <|>-      attrValue+      entityValue       <|>       try peReference           -- first try parameter entity ref %xxx;       <|>       percent                   -- else % may be indicator for parameter entity declaration       <?> "DTD token" -peReference     :: GenParser Char state XmlTree+peReference     :: XParser s XmlTree peReference     = do       r <- XT.peReference-      return $! (mkDTDElem PEREF [(a_peref, r)] [])+      return $! (mkDTDElem' PEREF [(a_peref, r)] []) -attrValue       :: GenParser Char state XmlTree-attrValue+entityValue       :: XParser s XmlTree+entityValue     = do-      v <- XT.attrValue-      return $! mkText v+      v <- XT.entityValue+      return $ mkText' v -dtdChars        :: GenParser Char state XmlTree+dtdChars        :: XParser s XmlTree dtdChars     = do       v <- many1 (XT.singleChar "%\"'<>[]")             -- everything except string constants, < and >, [ and ] (for cond sections)-      return $! mkText v                                -- all illegal chars will be detected later during declaration parsing+      return $ mkText' v                                -- all illegal chars will be detected later during declaration parsing -percent         :: GenParser Char state XmlTree+percent         :: XParser s XmlTree percent     = do       c <- char '%'-      return $! mkText [c]+      return $ mkText' [c]  -- ------------------------------------------------------------
src/Text/XML/HXT/Parser/XmlParsec.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP                #-}+ -- ------------------------------------------------------------  {- |@@ -8,7 +10,6 @@    Maintainer : Uwe Schmidt (uwe@fh-wedel.de)    Stability  : experimental    Portability: portable-   Version    : $Id: XmlParsec.hs,v 1.14 2005/09/02 17:09:39 hxml Exp $     Xml Parsec parser with pure filter interface @@ -38,15 +39,17 @@     , textDecl     , encodingDecl     , xread+    , xreadDoc -    , parseXmlAttrValue     , parseXmlContent     , parseXmlDocEncodingSpec     , parseXmlDocument     , parseXmlDTDPart     , parseXmlEncodingSpec     , parseXmlEntityEncodingSpec-    , parseXmlGeneralEntityValue+    , parseXmlEntityValueAsAttrValue+    , parseXmlEntityValueAsContent+     , parseXmlPart     , parseXmlText @@ -57,103 +60,105 @@     ) where -import Text.ParserCombinators.Parsec-    ( GenParser-    , Parser-    , parse-    , (<?>), (<|>)-    , char-    , string-    , eof-    , between-    , many, many1-    , option-    , try-    , unexpected-    , getPosition-    , getInput-    , sourceName-    )+#if MIN_VERSION_base(4,8,2)+#else+import           Control.Applicative                   ((<$>))+#endif -import Text.XML.HXT.DOM.ShowXml-    ( xshow-    )+import           Text.ParserCombinators.Parsec         (between, char, eof,+                                                        getInput, getPosition,+                                                        many, many1,+                                                        notFollowedBy, option,+                                                        runParser, sourceName,+                                                        string, try, unexpected,+                                                        (<?>), (<|>)) -import Text.XML.HXT.DOM.Interface+import           Text.XML.HXT.DOM.Interface+import           Text.XML.HXT.DOM.ShowXml              (xshow)+import           Text.XML.HXT.DOM.XmlNode              (changeAttrl,+                                                        getAttrName, getAttrl,+                                                        getChildren, getText,+                                                        isRoot, isText,+                                                        mergeAttrl, mkAttr',+                                                        mkCdata', mkCmt',+                                                        mkDTDElem', mkElement',+                                                        mkError', mkPi',+                                                        mkRoot', mkText')+import           Text.XML.HXT.Parser.XmlCharParser     (SimpleXParser, XPState,+                                                        XParser,+                                                        withNormNewline,+                                                        withoutNormNewline,+                                                        xmlChar)+import qualified Text.XML.HXT.Parser.XmlDTDTokenParser as XD+import qualified Text.XML.HXT.Parser.XmlTokenParser    as XT -import Text.XML.HXT.DOM.XmlNode-    ( mkElement-    , mkAttr-    , mkRoot-    , mkDTDElem-    , mkText-    , mkCmt-    , mkCdata-    , mkError-    , mkPi-    , isText-    , isRoot-    , getText-    , getChildren-    , getAttrl-    , getAttrName-    , changeAttrl-    , mergeAttrl-    )+import           Control.FlatSeq -import Text.XML.HXT.Parser.XmlCharParser-    ( xmlChar-    )-import qualified Text.XML.HXT.Parser.XmlTokenParser     as XT-import qualified Text.XML.HXT.Parser.XmlDTDTokenParser  as XD+import           Data.Char                             (toLower)+import           Data.Maybe -import Data.Char        (toLower)-import Data.Maybe+-- import Debug.Trace  -- ------------------------------------------------------------ -- -- Character Data (2.4) -charData                :: GenParser Char state XmlTrees+charData                :: XParser s XmlTrees charData     = many (charData' <|> XT.referenceT) -charData'               :: GenParser Char state XmlTree+charData'               :: XParser s XmlTree charData'-    = try ( do-            t <- XT.allBut1 many1 (\ c -> not (c `elem` "<&")) "]]>"-            return (mkText $! t)-          )+    =  do+       t <- XT.allBut1 many1 (\ c -> not (c `elem` "<&")) "]]>"+       return (mkText' t)  -- ------------------------------------------------------------ -- -- Comments (2.5) -comment         :: GenParser Char state XmlTree-+comment         :: XParser s XmlTree comment+    = comment'' $ XT.checkString "<!--"++-- the leading <! is already parsed++comment'        :: XParser s XmlTree+comment'+    = comment'' (string "--" >> return ())++comment''       :: XParser s () -> XParser s XmlTree+comment'' op     = ( do-        c <- between (try $ string "<!--") (string "-->") (XT.allBut many "--")-        return (mkCmt $! c)+        c <- between op (string ("-->")) (XT.allBut many "--")+        return (mkCmt' c)       ) <?> "comment"  -- ------------------------------------------------------------ -- -- Processing Instructions -pI              :: GenParser Char state XmlTree-pI-    = between (try $ string "<?") (string "?>")+pI             :: XParser s XmlTree+pI = pI'' $ XT.checkString "<?"++-- the leading < is already parsed++pI'             :: XParser s XmlTree+pI' = pI'' (char '?' >> return ())++pI''             :: XParser s () -> XParser s XmlTree+pI'' op+    = between op (string "?>")       ( do         n <- pITarget-        p <- option "" (do-                        _ <- XT.sPace+        p <- option "" (XT.sPace+                        >>                         XT.allBut many "?>"                        )-        return $ mkPi (mkName n) [mkAttr (mkName a_value) [mkText p]]+        return (mkPi' (mkName n) [mkAttr' (mkName a_value) [mkText' p]])       ) <?> "processing instruction"       where-      pITarget  :: GenParser Char state String+      pITarget  :: XParser s String       pITarget = ( do                    n <- XT.name                    if map toLower n == t_xml@@ -165,28 +170,38 @@ -- -- CDATA Sections (2.7) -cDSect          :: GenParser Char state XmlTree-+cDSect          :: XParser s XmlTree cDSect+    = cDSect'' $ XT.checkString "<![CDATA["++-- the leading <! is already parsed, no try neccessary++cDSect'         :: XParser s XmlTree+cDSect'+    = cDSect'' (string "[CDATA[" >> return ())++cDSect''        :: XParser s () -> XParser s XmlTree+cDSect'' op     = do-      t <- between ( try $ string "<![CDATA[") (string "]]>") (XT.allBut many "]]>")-      return (mkCdata $! t)+      t <- between op (string "]]>") (XT.allBut many "]]>")+      return (mkCdata' t)       <?> "CDATA section"  -- ------------------------------------------------------------ -- -- Document (2.1) and Prolog (2.8) -document        :: GenParser Char state XmlTree+document        :: XParser s XmlTree document     = do       pos <- getPosition       dl <- document'-      return $ mkRoot [ mkAttr (mkName a_source) [mkText (sourceName pos)]-                      , mkAttr (mkName a_status) [mkText (show c_ok)]+      return (mkRoot' [ mkAttr' (mkName a_source) [mkText' (sourceName pos)]+                      , mkAttr' (mkName a_status) [mkText' (show c_ok)]                       ] dl+             ) -document'       :: GenParser Char state XmlTrees+document'       :: XParser s XmlTrees document'     = do       pl <- prolog@@ -195,7 +210,7 @@       eof       return (pl ++ [el] ++ ml) -prolog          :: GenParser Char state XmlTrees+prolog          :: XParser s XmlTrees prolog     = do       xml     <- option [] xMLDecl'@@ -204,7 +219,7 @@       misc2   <- many misc       return (xml ++ misc1 ++ dtdPart ++ misc2) -xMLDecl         :: GenParser Char state XmlTrees+xMLDecl         :: XParser s XmlTrees xMLDecl     = between (try $ string "<?xml") (string "?>")       ( do@@ -216,32 +231,34 @@       )       <?> "xml declaration" -xMLDecl'        :: GenParser Char state XmlTrees+xMLDecl'        :: XParser s XmlTrees xMLDecl'     = do       al <- xMLDecl-      return [mkPi (mkName t_xml) al]+      return [mkPi' (mkName t_xml) al] -xMLDecl''       :: GenParser Char state XmlTree+xMLDecl''       :: XParser s XmlTree xMLDecl''     = do       al     <- option [] (try xMLDecl)-      return (mkRoot al [])+      return (mkRoot' al []) -versionInfo     :: GenParser Char state XmlTrees+versionInfo     :: XParser s XmlTrees versionInfo     = ( do-        _ <- try ( do-                   XT.skipS-                   XT.keyword a_version-                 )+        try ( XT.skipS+              >>+              XT.keyword a_version+              >>+              return ()+            )         XT.eq         vi <- XT.quoted XT.versionNum-        return [mkAttr (mkName a_version) [mkText vi]]+        return [mkAttr' (mkName a_version) [mkText' vi]]       )       <?> "version info (with quoted version number)" -misc            :: GenParser Char state XmlTree+misc            :: XParser s XmlTree misc     = comment       <|>@@ -249,7 +266,7 @@       <|>       ( ( do           ws <- XT.sPace-          return (mkText ws)+          return (mkText' ws)         ) <?> ""       ) @@ -257,7 +274,7 @@ -- -- Document Type definition (2.8) -doctypedecl     :: GenParser Char state XmlTrees+doctypedecl     :: XParser s XmlTrees doctypedecl     = between (try $ string "<!DOCTYPE") (char '>')       ( do@@ -275,10 +292,10 @@                     XT.skipS0                     return m                   )-        return [mkDTDElem DOCTYPE ((a_name, n) : exId) markup]+        return [mkDTDElem' DOCTYPE ((a_name, n) : exId) markup]       ) -markupOrDeclSep :: GenParser Char state XmlTrees+markupOrDeclSep :: XParser s XmlTrees markupOrDeclSep     = ( do         ll <- many ( markupdecl@@ -290,7 +307,7 @@         return (concat ll)       ) -declSep         :: GenParser Char state XmlTrees+declSep         :: XParser s XmlTrees declSep     = XT.mkList XT.peReferenceT       <|>@@ -299,7 +316,7 @@         return []       ) -markupdecl      :: GenParser Char state XmlTrees+markupdecl      :: XParser s XmlTrees markupdecl     = XT.mkList       ( pI@@ -313,41 +330,44 @@ -- -- Standalone Document Declaration (2.9) -sDDecl          :: GenParser Char state XmlTrees+sDDecl          :: XParser s XmlTrees sDDecl     = do-      _ <- try (do-                XT.skipS-                XT.keyword a_standalone-               )+      try ( XT.skipS+            >>+            XT.keyword a_standalone+            >>+            return ()+          )       XT.eq       sd <- XT.quoted (XT.keywords [v_yes, v_no])-      return [mkAttr (mkName a_standalone) [mkText sd]]+      return [mkAttr' (mkName a_standalone) [mkText' sd]]  -- ------------------------------------------------------------ -- -- element, tags and content (3, 3.1) -element         :: GenParser Char state XmlTree+element         :: XParser s XmlTree element+    = char '<'+      >>+      element'++element'         :: XParser s XmlTree+element'     = ( do         e <- elementStart-        elementRest e+        rwnf e `seq` elementRest e              -- evaluate name and attribute list before parsing contents       ) <?> "element" -elementStart            :: GenParser Char state (String, [(String, XmlTrees)])++elementStart            :: XParser s (QName, XmlTrees) elementStart     = do-      n <- ( try ( do-                   _ <- char '<'-                   n <- XT.name-                   return n-                 )-             <?> "start tag"-           )-      ass <- attrList+      n  <- XT.name+      al <- attrList       XT.skipS0-      return (n, ass)+      return (mkName n, al)       where       attrList           = option [] ( do@@ -358,49 +378,53 @@           = option [] ( do                         a1 <- attribute                         al <- attrList-                        let (n, _v) = a1-                        if isJust . lookup n $ al-                          then unexpected ("attribute name " ++ show n ++ " occurs twice in attribute list")+                        let n = fromJust . getAttrName $ a1+                        if n `elem` map (fromJust . getAttrName) al+                          then unexpected+                               ( "attribute name " +++                                 show (qualifiedName n) +++                                 " occurs twice in attribute list"+                               )                           else return (a1 : al)                       ) -elementRest     :: (String, [(String, XmlTrees)]) -> GenParser Char state XmlTree+elementRest     :: (QName, XmlTrees) -> XParser s XmlTree elementRest (n, al)     = ( do-        _ <- try $ string "/>"-        return $! (mkElement (mkName n) (map (mkA $!) al) [])+        XT.checkString "/>"+        return $ mkElement' n al []       )       <|>       ( do-        _ <- XT.gt+        XT.gt         c <- content         eTag n-        return $! (mkElement (mkName n) (map (mkA $!) al) $! c)+        return $ mkElement' n al c       )       <?> "proper attribute list followed by \"/>\" or \">\""-    where-    mkA (n', ts') = mkAttr (mkName n') ts' -eTag            :: String -> GenParser Char state ()+eTag            :: QName -> XParser s () eTag n'     = do-      _ <- try ( string "</" ) <?> ""+      XT.checkString "</" <?> ""       n <- XT.name       XT.skipS0-      _ <- XT.gt-      if n == n'+      XT.gt+      if n == qualifiedName n'          then return ()-         else unexpected ("illegal end tag </" ++ n ++ "> found, </" ++ n' ++ "> expected")+         else unexpected ("illegal end tag </" ++ n ++ "> found, </" ++ qualifiedName n' ++ "> expected") -attribute       :: GenParser Char state (String, XmlTrees)+attribute       :: XParser s XmlTree attribute     = do       n <- XT.name       XT.eq       v <- XT.attrValueT-      return (n, v)+      return $ mkAttr' (mkName n) v -content         :: GenParser Char state XmlTrees+{- this parser corresponds to the XML spec but it's inefficent because of more than 1 char lookahead++content         :: XParser s XmlTrees content     = do       c1 <- charData@@ -418,11 +442,47 @@               return (l : c)             )       return (c1 ++ concat cl)+-} -contentWithTextDecl     :: GenParser Char state XmlTrees+-- this simpler content parser does not need more than a single lookahead+-- so no try parsers (inefficient) are neccessary++content         :: XParser s XmlTrees+content+    = XT.mergeTextNodes <$>+      many+      ( ( do            -- parse markup but no closing tags+          try ( XT.lt+                >>+                notFollowedBy (char '/')+                >>+                return ()+              )+          markup+        )+        <|>+        charData'+        <|>+        XT.referenceT+      )+    where+    markup+        = element'+          <|>+          pI'+          <|>+          ( char '!'+            >>+            ( comment'+              <|>+              cDSect'+            )+          )++contentWithTextDecl     :: XParser s XmlTrees contentWithTextDecl-    = do-      _ <- option [] textDecl+    = option [] textDecl+      >>       content  -- ------------------------------------------------------------@@ -433,25 +493,25 @@ -- first the whole content is detected, -- and then, after PE substitution include sections are parsed again -conditionalSect         :: GenParser Char state XmlTree+conditionalSect         :: XParser s XmlTree conditionalSect     = do-      _ <- try $ string "<!["+      XT.checkString "<!["       cs <- many XD.dtdToken       _ <- char '['       sect <- condSectCont-      return (mkDTDElem CONDSECT [(a_value, sect)] cs)+      return (mkDTDElem' CONDSECT [(a_value, sect)] cs)     where -    condSectCont        :: GenParser Char state String+    condSectCont        :: XParser s String     condSectCont-        = ( do-            _ <- try $ string "]]>"+        = ( XT.checkString "]]>"+            >>             return ""           )           <|>           ( do-            _ <- try $ string "<!["+            XT.checkString "<!["             cs1 <- condSectCont             cs2 <- condSectCont             return ("<![" ++ cs1 ++ "]]>" ++ cs2)@@ -467,7 +527,7 @@ -- -- External Entities (4.2.2) -externalID      :: GenParser Char state Attributes+externalID      :: XParser s Attributes externalID     = ( do         _ <- XT.keyword k_system@@ -491,7 +551,7 @@ -- -- Text Declaration (4.3.1) -textDecl        :: GenParser Char state XmlTrees+textDecl        :: XParser s XmlTrees textDecl     = between (try $ string "<?xml") (string "?>")       ( do@@ -503,26 +563,28 @@       <?> "text declaration"  -textDecl''      :: GenParser Char state XmlTree+textDecl''      :: XParser s XmlTree textDecl''     = do       al    <- option [] (try textDecl)-      return (mkRoot al [])+      return (mkRoot' al [])  -- ------------------------------------------------------------ -- -- Encoding Declaration (4.3.3) -encodingDecl    :: GenParser Char state XmlTrees+encodingDecl    :: XParser s XmlTrees encodingDecl     = do-      _ <- try ( do-                 XT.skipS-                 XT.keyword a_encoding-               )+      try ( XT.skipS+            >>+            XT.keyword a_encoding+            >>+            return ()+          )       XT.eq       ed <- XT.quoted XT.encName-      return [mkAttr (mkName a_encoding) [mkText ed]]+      return [mkAttr' (mkName a_encoding) [mkText' ed]]  -- ------------------------------------------------------------ --@@ -535,18 +597,25 @@ -- -- the string parameter is parsed with the XML content parser. -- result is the list of trees or in case of an error a single element list with the--- error message as node. No entity or character subtitution is done.+-- error message as node. No entity or character subtitution is done here,+-- but the XML parser can do this for the predefined XML or the char references for performance reasons -- -- see also: 'parseXmlContent'  xread                   :: String -> XmlTrees-xread str-    = parseXmlFromString parser loc str+xread                   = xread' content         -- take the content parser for parsing the string++xreadDoc                :: String -> XmlTrees+xreadDoc                = xread' document'       -- take the document' parser for parsing the string++xread'                   :: XParser () XmlTrees -> String -> XmlTrees+xread' content' str+    = parseXmlFromString parser (withNormNewline ()) loc str     where     loc = "string: " ++ show (if length str > 40 then take 40 str ++ "..." else str)     parser = do-             res <- content             -- take the content parser for parsing the string-             eof                        -- and test on everything consumed+             res <- content'+             eof                        -- test on everything consumed              return res  -- |@@ -560,16 +629,16 @@ -- a more general version of 'parseXmlContent'. -- The parser to be used and the context are extra parameter -parseXmlText            :: Parser XmlTrees -> String -> XmlTree -> XmlTrees-parseXmlText p loc      = parseXmlFromString p loc . xshow . (:[])+parseXmlText            :: SimpleXParser XmlTrees -> XPState () -> String -> XmlTree -> XmlTrees+parseXmlText p s0 loc   = parseXmlFromString p s0 loc . xshow . (:[])  parseXmlDocument        :: String -> String -> XmlTrees-parseXmlDocument        = parseXmlFromString document'-+parseXmlDocument        = parseXmlFromString document' (withNormNewline ()) -parseXmlFromString      :: Parser XmlTrees -> String -> String -> XmlTrees-parseXmlFromString parser loc-    = either ((:[]) . mkError c_err . (++ "\n") . show) id . parse parser loc+parseXmlFromString      :: SimpleXParser XmlTrees -> XPState () -> String -> String -> XmlTrees+parseXmlFromString parser s0 loc+    = either ((:[]) . mkError' c_err . (++ "\n") . show) id+      . runParser parser s0 loc  -- ------------------------------------------------------------ --@@ -577,17 +646,17 @@ removeEncodingSpec      :: XmlTree -> XmlTrees removeEncodingSpec t     | isText t-        = ( either ((:[]) . mkError c_err . (++ "\n") . show) ((:[]) . mkText)-            . parse parser "remove encoding spec"+        = ( either ((:[]) . mkError' c_err . (++ "\n") . show) ((:[]) . mkText')+            . runParser parser (withNormNewline ()) "remove encoding spec"             . fromMaybe ""             . getText           ) t     | otherwise         = [t]     where-    parser :: Parser String-    parser = do-             _ <- option [] textDecl+    parser :: XParser s String+    parser = option [] textDecl+             >>              getInput  -- ------------------------------------------------------------@@ -595,13 +664,14 @@ -- | -- general parser for parsing arbitray parts of a XML document -parseXmlPart    :: Parser XmlTrees -> String -> String -> XmlTree -> XmlTrees+parseXmlPart    :: SimpleXParser XmlTrees -> String -> String -> XmlTree -> XmlTrees parseXmlPart parser expected context t-    = parseXmlText ( do-                     res <- parser-                     eof <?> expected-                     return res-                   ) context+    = parseXmlText+      ( do+        res <- parser+        eof <?> expected+        return res+      ) (withoutNormNewline ()) context       $ t  -- ------------------------------------------------------------@@ -618,17 +688,17 @@ -- | -- Parser for general entites -parseXmlGeneralEntityValue      :: String -> XmlTree -> XmlTrees-parseXmlGeneralEntityValue+parseXmlEntityValueAsContent      :: String -> XmlTree -> XmlTrees+parseXmlEntityValueAsContent     = parseXmlPart content "general entity value"  -- ------------------------------------------------------------  -- |--- Parser for attribute values+-- Parser for entity substitution within attribute values -parseXmlAttrValue       :: String -> XmlTree -> XmlTrees-parseXmlAttrValue+parseXmlEntityValueAsAttrValue       :: String -> XmlTree -> XmlTrees+parseXmlEntityValueAsAttrValue     = parseXmlPart (XT.attrValueT' "<&") "attribute value"  -- ------------------------------------------------------------@@ -664,7 +734,7 @@ --                        in case of a valid encoding spec --                        else the unchanged tree -parseXmlEncodingSpec    :: Parser XmlTree -> XmlTree -> XmlTrees+parseXmlEncodingSpec    :: SimpleXParser XmlTree -> XmlTree -> XmlTrees parseXmlEncodingSpec encDecl x     = (:[]) .       ( if isRoot x@@ -673,14 +743,24 @@       ) $ x     where     parseEncSpec r-        = case ( parse encDecl source . xshow . getChildren $ r ) of+        = case ( runParser encDecl (withNormNewline ()) source+                 . xshow+                 . getChildren+                 $ r+               ) of           Right t               -> changeAttrl (mergeAttrl . fromMaybe [] . getAttrl $ t) r           Left _               -> r         where         -- arrow \"getAttrValue a_source\" programmed on the tree level (oops!)-        source = xshow . concat . map getChildren . filter ((== a_source) . maybe "" qualifiedName . getAttrName) . fromMaybe [] . getAttrl $ r+        source = xshow+                 . concat+                 . map getChildren+                 . filter ((== a_source)+                 . maybe "" qualifiedName . getAttrName)+                 . fromMaybe []+                 . getAttrl $ r  parseXmlEntityEncodingSpec      :: XmlTree -> XmlTrees parseXmlEntityEncodingSpec      = parseXmlEncodingSpec textDecl''
src/Text/XML/HXT/Parser/XmlTokenParser.hs view
@@ -1,14 +1,15 @@+{-# LANGUAGE CPP                #-}+ -- ------------------------------------------------------------  {- |    Module     : Text.XML.HXT.Parser.XmlTokenParser-   Copyright  : Copyright (C) 2005 Uwe Schmidt+   Copyright  : Copyright (C) 2010 Uwe Schmidt    License    : MIT     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : experimental+   Stability  : stable    Portability: portable-   Version    : $Id: XmlTokenParser.hs,v 1.3 2005/09/02 17:09:39 hxml Exp $     Parsec parser for XML tokens @@ -19,10 +20,13 @@ module Text.XML.HXT.Parser.XmlTokenParser     ( allBut     , allBut1+    , amp     , asciiLetter+    , attrChar     , attrValue     , bar     , charRef+    , checkString     , comma     , dq     , encName@@ -76,33 +80,41 @@     , peReferenceT      , singleCharsT++    , mergeTextNodes     ) where -import Text.ParserCombinators.Parsec+#if MIN_VERSION_base(4,8,2)+#else+import Control.Applicative                      ((<$>))+#endif -import Text.XML.HXT.DOM.Interface -import Text.XML.HXT.DOM.XmlNode-    ( mkDTDElem-    , mkText-    , mkCharRef-    , mkEntityRef-    )+import Data.Char.Properties.XMLCharProps        ( isXmlChar+                                                , isXmlCharCR+                                                )+import Data.String.Unicode                      ( intToCharRef+                                                , intToCharRefHex+                                                ) -import Text.XML.HXT.DOM.Unicode-    ( isXmlChar-    , intToCharRef-    , intToCharRefHex-    )+import Text.ParserCombinators.Parsec -import Text.XML.HXT.Parser.XmlCharParser-    ( xmlNameChar-    , xmlNameStartChar-    , xmlNCNameChar-    , xmlNCNameStartChar-    , xmlSpaceChar-    )+import Text.XML.HXT.DOM.Interface+import Text.XML.HXT.DOM.XmlNode                 ( mkDTDElem'+                                                , mkText'+                                                , mkCharRef'+                                                , mkEntityRef'+                                                , mergeText+                                                )+import Text.XML.HXT.Parser.XmlCharParser        ( xmlNameChar+                                                , xmlNameStartChar+                                                , xmlNCNameChar+                                                , xmlNCNameStartChar+                                                , xmlSpaceChar+                                                , xmlCRLFChar+                                                , XParser+                                                )  -- ------------------------------------------------------------ --@@ -112,19 +124,19 @@  -- ------------------------------------------------------------ -sPace           :: GenParser Char state String+sPace           :: XParser s String sPace     = many1 xmlSpaceChar -sPace0          :: GenParser Char state String+sPace0          :: XParser s String sPace0     = many xmlSpaceChar -skipS           :: GenParser Char state ()+skipS           :: XParser s () skipS     = skipMany1 xmlSpaceChar -skipS0          :: GenParser Char state ()+skipS0          :: XParser s () skipS0     = skipMany xmlSpaceChar @@ -132,55 +144,53 @@ -- -- Names and Tokens (2.3) -asciiLetter             :: GenParser Char state Char+asciiLetter             :: XParser s Char asciiLetter     = satisfy (\ c -> ( c >= 'A' && c <= 'Z' ||                         c >= 'a' && c <= 'z' )               )       <?> "ASCII letter" -name            :: GenParser Char state String+name            :: XParser s String name-    = try ( do-            s1 <- xmlNameStartChar-            sl <- many xmlNameChar-            return (s1 : sl)-          )+    = do+      s1 <- xmlNameStartChar+      sl <- many xmlNameChar+      return (s1 : sl)       <?> "Name"  -- Namespaces in XML: Rules [4-5] NCName: -ncName          :: GenParser Char state String+ncName          :: XParser s String ncName-    = try ( do-            s1 <- xmlNCNameStartChar-            sl <- many xmlNCNameChar-            return (s1 : sl)-          )+    = do+      s1 <- xmlNCNameStartChar+      sl <- many xmlNCNameChar+      return (s1 : sl)       <?> "NCName"  -- Namespaces in XML: Rules [6-8] QName: -qName           :: GenParser Char state (String, String)+qName           :: XParser s (String, String) qName     = do       s1 <- ncName-      s2 <- option "" ( do-                        _ <- char ':'-                        ncName-                      )-      return ( if null s2 then (s2, s1) else (s1, s2) )+      s2 <- option "" (char ':' >> ncName)+      return ( if null s2+               then (s2, s1)+               else (s1, s2)+             ) -nmtoken         :: GenParser Char state String+nmtoken         :: XParser s String nmtoken     = try (many1 xmlNameChar)       <?> "Nmtoken" -names           :: GenParser Char state [String]+names           :: XParser s [String] names     = sepBy1 name sPace -nmtokens        :: GenParser Char state [String]+nmtokens        :: XParser s [String] nmtokens     = sepBy1 nmtoken sPace @@ -188,27 +198,38 @@ -- -- Literals (2.3) -singleChar              :: String -> GenParser Char state Char+singleChar              :: String -> XParser s Char singleChar notAllowed-    = satisfy (\ c -> isXmlChar c && not (c `elem` notAllowed))+    = satisfy (\ c -> isXmlCharCR c && c `notElem` notAllowed)+      <|>+      xmlCRLFChar -singleChars             :: String -> GenParser Char state String+singleChars             :: String -> XParser s String singleChars notAllowed     = many1 (singleChar notAllowed) -entityValue     :: GenParser Char state String+entityValue     :: XParser s String entityValue-    = attrValue+    = ( do+        v <- entityValueDQ+        return ("\"" ++ v ++ "\"")+      )+      <|>+      ( do+        v <- entityValueSQ+        return ("'" ++ v ++ "'")+      )+      <?> "entity value (in quotes)" -attrValueDQ     :: GenParser Char state String-attrValueDQ-    = between dq dq (concRes $ many $ attrChar "<&\"")+entityValueDQ   :: XParser s String+entityValueDQ+    = between dq dq (concRes $ many $ attrChar "&\"") -attrValueSQ     :: GenParser Char state String-attrValueSQ-    = between sq sq (concRes $ many $ attrChar "<&\'")+entityValueSQ   :: XParser s String+entityValueSQ+    = between sq sq (concRes $ many $ attrChar "&\'") -attrValue       :: GenParser Char state String+attrValue       :: XParser s String attrValue     = ( do         v <- attrValueDQ@@ -221,29 +242,36 @@       )       <?> "attribute value (in quotes)" -attrChar        :: String -> GenParser Char state String+attrValueDQ     :: XParser s String+attrValueDQ+    = between dq dq (concRes $ many $ attrChar "<&\"")++attrValueSQ     :: XParser s String+attrValueSQ+    = between sq sq (concRes $ many $ attrChar "<&\'")++attrChar        :: String -> XParser s String attrChar notAllowed     = reference       <|>       mkList (singleChar notAllowed)-      <?> "legal attribute character or reference"-+      <?> ("legal attribute or entity character or reference (not allowed: " ++ show notAllowed ++ " )") -systemLiteral           :: GenParser Char state String+systemLiteral           :: XParser s String systemLiteral     = between dq dq (many $ noneOf "\"")       <|>       between sq sq (many $ noneOf "\'")       <?> "system literal (in quotes)" -pubidLiteral            :: GenParser Char state String+pubidLiteral            :: XParser s String pubidLiteral     = between dq dq (many $ pubidChar "\'")       <|>       between sq sq (many $ pubidChar "")       <?> "pubid literal (in quotes)"       where-      pubidChar         :: String -> GenParser Char state Char+      pubidChar         :: String -> XParser s Char       pubidChar quoteChars           = asciiLetter             <|>@@ -259,7 +287,7 @@ -- -- Character and Entity References (4.1) -reference       :: GenParser Char state String+reference       :: XParser s String reference     = ( do         i <- charRef@@ -271,8 +299,7 @@         return ("&" ++ n ++ ";")       ) --checkCharRef    :: Int -> GenParser Char state Int+checkCharRef    :: Int -> XParser s Int checkCharRef i     = if ( i <= fromEnum (maxBound::Char)            && isXmlChar (toEnum i)@@ -280,37 +307,36 @@         then return i         else unexpected ("illegal value in character reference: " ++ intToCharRef i ++ " , in hex: " ++ intToCharRefHex i) -charRef         :: GenParser Char state Int+charRef         :: XParser s Int charRef     = do-      _ <- try (string "&#x")+      checkString "&#x"       d <- many1 hexDigit-      _ <- semi+      semi       checkCharRef (hexStringToInt d)       <|>       do-      _ <- try (string "&#")+      checkString "&#"       d <- many1 digit-      _ <- semi+      semi       checkCharRef (decimalStringToInt d)       <?> "character reference" --entityRef       :: GenParser Char state String+entityRef       :: XParser s String entityRef     = do-      _ <- char '&'+      amp       n <- name-      _ <- semi+      semi       return n       <?> "entity reference" -peReference     :: GenParser Char state String+peReference     :: XParser s String peReference     = try ( do             _ <- char '%'             n <- name-            _ <- semi+            semi             return n           )       <?> "parameter-entity reference"@@ -319,14 +345,14 @@ -- -- 4.3 -encName         :: GenParser Char state String+encName         :: XParser s String encName     = do       c <- asciiLetter       r <- many (asciiLetter <|> digit <|> oneOf "._-")       return (c:r) -versionNum      :: GenParser Char state String+versionNum      :: XParser s String versionNum     = many1 xmlNameChar @@ -335,7 +361,7 @@ -- -- keywords -keyword         :: String -> GenParser Char state String+keyword         :: String -> XParser s String keyword kw     = try ( do             n <- name@@ -345,7 +371,7 @@           )       <?> kw -keywords        :: [String] -> GenParser Char state String+keywords        :: [String] -> XParser s String keywords     = foldr1 (<|>) . map keyword @@ -353,7 +379,7 @@ -- -- parser for quoted attribute values -quoted          :: GenParser Char state a -> GenParser Char state a+quoted          :: XParser s a -> XParser s a quoted p     = between dq dq p       <|>@@ -363,15 +389,23 @@ -- -- simple char parsers -dq, sq, lt, gt, semi    :: GenParser Char state Char+dq, sq, lt, gt, semi, amp    :: XParser s () -dq      = char '\"'-sq      = char '\''-lt      = char '<'-gt      = char '>'-semi    = char ';'+dq      = char '\"' >> return ()+sq      = char '\'' >> return ()+lt      = char '<'  >> return ()+gt      = char '>'  >> return ()+semi    = char ';'  >> return ()+amp     = char '&'  >> return () -separator       :: Char -> GenParser Char state ()+{-# INLINE  dq #-}+{-# INLINE  sq #-}+{-# INLINE  lt #-}+{-# INLINE  gt #-}+{-# INLINE  semi #-}+{-# INLINE  amp #-}++separator       :: Char -> XParser s () separator c     = do       _ <- try ( do@@ -381,42 +415,45 @@       skipS0       <?> [c] -bar, comma, eq, lpar, rpar      :: GenParser Char state ()+bar, comma, eq, lpar, rpar      :: XParser s ()  bar     = separator '|' comma   = separator ',' eq      = separator '=' -lpar-    = do-      _ <- char '('-      skipS0+{-# INLINE bar #-}+{-# INLINE comma #-}+{-# INLINE eq #-} -rpar-    = do-      skipS0-      _ <- char ')'-      return ()+lpar    = char '(' >> skipS0+{-# INLINE lpar #-} +rpar    = skipS0 >> char ')' >> return ()+{-# INLINE rpar #-} +checkString     :: String -> XParser s ()+checkString s+    = try $ string s >> return ()+{-# INLINE checkString #-}+ -- ------------------------------------------------------------ -- -- all chars but not a special substring -allBut          :: (GenParser Char state Char -> GenParser Char state String) -> String -> GenParser Char state String+allBut          :: (XParser s Char -> XParser s String) -> String -> XParser s String allBut p str     = allBut1 p (const True) str -allBut1         :: (GenParser Char state Char -> GenParser Char state String) -> (Char -> Bool) -> String -> GenParser Char state String+allBut1         :: (XParser s Char -> XParser s String) -> (Char -> Bool) -> String -> XParser s String allBut1 p prd (c:rest)-    = p ( satisfy (\ x -> isXmlChar x && prd x && not (x == c) )+    = p ( satisfy (\ x -> isXmlCharCR x && prd x && not (x == c) )           <|>-          try ( do-                _ <- char c-                notFollowedBy ( do-                                _ <- try (string rest)-                                return c-                              )+          xmlCRLFChar+          <|>+          try ( char c+                >>+                notFollowedBy (try (string rest) >> return c)+                >>                 return c               )         )@@ -428,13 +465,13 @@ -- -- concatenate parse results -concRes         :: GenParser Char state [[a]] -> GenParser Char state [a]+concRes         :: XParser s [[a]] -> XParser s [a] concRes p     = do       sl <- p       return (concat sl) -mkList          :: GenParser Char state a -> GenParser Char state [a]+mkList          :: XParser s a -> XParser s [a] mkList p     = do       r <- p@@ -448,20 +485,20 @@ -- -- Literals (2.3) -nameT           :: GenParser Char state XmlTree+nameT           :: XParser s XmlTree nameT     = do       n <- name-      return (mkDTDElem NAME [(a_name, n)] [])+      return (mkDTDElem' NAME [(a_name, n)] []) -nmtokenT        :: GenParser Char state XmlTree+nmtokenT        :: XParser s XmlTree nmtokenT     = do       n <- nmtoken-      return (mkDTDElem NAME [(a_name, n)] [])+      return (mkDTDElem' NAME [(a_name, n)] [])  -entityValueT    :: GenParser Char state XmlTrees+entityValueT    :: XParser s XmlTrees entityValueT     =  do        sl <- between dq dq (entityTokensT "%&\"")@@ -472,11 +509,11 @@        return sl        <?> "entity value (in quotes)" -entityTokensT   :: String -> GenParser Char state XmlTrees+entityTokensT   :: String -> XParser s XmlTrees entityTokensT notAllowed     = many (entityCharT notAllowed) -entityCharT     :: String -> GenParser Char state XmlTree+entityCharT     :: String -> XParser s XmlTree entityCharT notAllowed     = peReferenceT       <|>@@ -486,60 +523,85 @@       <|>       ( do         cs <- many1 (singleChar notAllowed)-        return (mkText cs)+        return (mkText' cs)       ) -attrValueT      :: GenParser Char state XmlTrees+attrValueT      :: XParser s XmlTrees attrValueT     = between dq dq (attrValueT' "<&\"")       <|>       between sq sq (attrValueT' "<&\'")       <?> "attribute value (in quotes)" -attrValueT'     :: String -> GenParser Char state XmlTrees+attrValueT'     :: String -> XParser s XmlTrees attrValueT' notAllowed-    = many ( referenceT <|> singleCharsT notAllowed)+    = mergeTextNodes <$> many ( referenceT <|> singleCharsT notAllowed) -singleCharsT    :: String -> GenParser Char state XmlTree+singleCharsT    :: String -> XParser s XmlTree singleCharsT notAllowed     = do       cs <- singleChars notAllowed-      return (mkText cs)+      return (mkText' cs)  -- ------------------------------------------------------------ -- -- Character and Entity References (4.1) -referenceT      :: GenParser Char state XmlTree+referenceT      :: XParser s XmlTree referenceT     = charRefT       <|>       entityRefT -charRefT        :: GenParser Char state XmlTree+charRefT        :: XParser s XmlTree charRefT     = do       i <- charRef-      return $! (mkCharRef $! i)+      return (mkCharRef' i) -entityRefT      :: GenParser Char state XmlTree+entityRefT      :: XParser s XmlTree entityRefT     = do       n <- entityRef-      return $! (mkEntityRef $! n)+      return $! (maybe (mkEntityRef' n) mkCharRef' . lookup n $ predefinedXmlEntities) -bypassedEntityRefT      :: GenParser Char state XmlTree+-- optimization: predefined XML entity refs are converted into equivalent char refs+-- so there is no need for an entitiy substitution phase, if there is no DTD+-- Attention: entityRefT must only be called from within XML/HTML content+-- in DTD parsing this optimization is not allowed because of different semantics+-- of charRefs and entityRefs during substitution of entites in ENTITY definitions++predefinedXmlEntities   :: [(String, Int)]+predefinedXmlEntities+    = [ ("lt",   60)+      , ("gt",   62)+      , ("amp",  38)+      , ("apos", 39)+      , ("quot", 34)+      ]++bypassedEntityRefT      :: XParser s XmlTree bypassedEntityRefT     = do       n <- entityRef-      return $! (mkText ("&" ++ n ++ ";"))+      return $! (mkText' ("&" ++ n ++ ";")) -peReferenceT    :: GenParser Char state XmlTree+peReferenceT    :: XParser s XmlTree peReferenceT     = do       r <- peReference-      return $! (mkDTDElem PEREF [(a_peref, r)] [])+      return $! (mkDTDElem' PEREF [(a_peref, r)] [])  -- ------------------------------------------------------------ +mergeTextNodes :: XmlTrees -> XmlTrees+mergeTextNodes+    = foldr addText []+    where+      addText :: XmlTree -> XmlTrees -> XmlTrees+      addText t []+          = [t]+      addText t (t1 : ts)+          = mergeText t t1 ++ ts +-- ------------------------------------------------------------
− src/Text/XML/HXT/RelaxNG.hs 
@@ -1,24 +0,0 @@--- |--- This helper module exports elements from the basic Relax NG libraries:--- Validator, CreatePattern, PatternToString and DataTypes.--- It is the main entry point to the Relax NG schema validator of the Haskell--- XML Toolbox.------ Author : Torben Kuseler------ Version : $Id: RelaxNG.hs,v 1.1 2005/09/02 17:09:39 hxml Exp $--module Text.XML.HXT.RelaxNG-  ( module Text.XML.HXT.RelaxNG.PatternToString-  , module Text.XML.HXT.RelaxNG.Validator-  , module Text.XML.HXT.RelaxNG.DataTypes-  , module Text.XML.HXT.RelaxNG.CreatePattern-  , module Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch-  )-where--import Text.XML.HXT.RelaxNG.PatternToString-import Text.XML.HXT.RelaxNG.Validator-import Text.XML.HXT.RelaxNG.DataTypes-import Text.XML.HXT.RelaxNG.CreatePattern-import Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch
− src/Text/XML/HXT/RelaxNG/BasicArrows.hs 
@@ -1,326 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.RelaxNG.BasicArrows-   Copyright  : Copyright (C) 2005 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : experimental-   Portability: portable-   Version    : $Id$--   Constants and basic arrows for Relax NG---}---- --------------------------------------------------------------module Text.XML.HXT.RelaxNG.BasicArrows-where--import Control.Arrow.ListArrows--import Text.XML.HXT.DOM.Interface-import Text.XML.HXT.Arrow.XmlArrow-    hiding-    ( mkText-    , mkError-    )--hasRngName      :: ArrowXml a => String -> a XmlTree XmlTree-hasRngName s-    = hasName s-      `orElse`-      ( hasLocalPart s >>> hasNamespaceUri relaxNamespace )--checkRngName :: ArrowXml a => [String] -> a XmlTree XmlTree-checkRngName l-    = ( isElem-        >>>-        catA (map hasRngName l)-      )-      `guards` this--noOfChildren    :: ArrowXml a => (Int -> Bool) -> a XmlTree XmlTree-noOfChildren p-    = getChildren-      >>.-      (\ l -> if p (length l) then l else [])---- --------------------------------------------------------------isAttributeRef  :: ArrowXml a => a XmlTree XmlTree-isAttributeRef-    = checkRngName ["attribute", "ref"]--isAttributeRefTextListGroupInterleaveOneOrMoreEmpty     :: ArrowXml a => a XmlTree XmlTree-isAttributeRefTextListGroupInterleaveOneOrMoreEmpty-    = checkRngName ["attribute", "ref", "text", "list", "group", "interleave", "oneOrMore", "empty"]--isAttributeRefTextListInterleave        :: ArrowXml a => a XmlTree XmlTree-isAttributeRefTextListInterleave-    = checkRngName ["attribute", "ref", "text", "list", "interleave"]--isAttributeListGroupInterleaveOneOrMore :: ArrowXml a => a XmlTree XmlTree-isAttributeListGroupInterleaveOneOrMore-    = checkRngName ["attribute", "list", "group", "interleave", "oneOrMore"]--isExternalRefInclude    :: ArrowXml a => a XmlTree XmlTree-isExternalRefInclude-    = checkRngName ["externalRef", "include"]--isNameNsNameValue       :: ArrowXml a => a XmlTree XmlTree-isNameNsNameValue-    = checkRngName ["name", "nsName", "value"]--isNameNsName    :: ArrowXml a => a XmlTree XmlTree-isNameNsName-    = checkRngName ["name", "nsName"]--isNameAnyNameNsName     :: ArrowXml a => a XmlTree XmlTree-isNameAnyNameNsName-    = checkRngName ["name", "anyName", "nsName"]--isDefineOneOrMoreZeroOrMoreOptionalListMixed    :: ArrowXml a => a XmlTree XmlTree-isDefineOneOrMoreZeroOrMoreOptionalListMixed-    = checkRngName ["define", "oneOrMore", "zeroOrMore", "optional", "list", "mixed"]--isChoiceGroupInterleave :: ArrowXml a => a XmlTree XmlTree-isChoiceGroupInterleave-    = checkRngName ["choice", "group", "interleave"]--isChoiceGroupInterleaveOneOrMore        :: ArrowXml a => a XmlTree XmlTree-isChoiceGroupInterleaveOneOrMore-    = checkRngName ["choice", "group", "interleave", "oneOrMore"]--isGroupInterleave       :: ArrowXml a => a XmlTree XmlTree-isGroupInterleave-    = checkRngName ["group", "interleave"]---- --------------------------------------------------------------isRngAnyName            :: ArrowXml a => a XmlTree XmlTree-isRngAnyName            = isElem >>> hasRngName "anyName"--isRngAttribute          :: ArrowXml a => a XmlTree XmlTree-isRngAttribute          = isElem >>> hasRngName "attribute"--isRngChoice             :: ArrowXml a => a XmlTree XmlTree-isRngChoice             = isElem >>> hasRngName "choice"--isRngCombine            :: ArrowXml a => a XmlTree XmlTree-isRngCombine            = isElem >>> hasRngName "combine"--isRngData               :: ArrowXml a => a XmlTree XmlTree-isRngData               = isElem >>> hasRngName "data"--isRngDefine             :: ArrowXml a => a XmlTree XmlTree-isRngDefine             = isElem >>> hasRngName "define"--isRngDiv                :: ArrowXml a => a XmlTree XmlTree-isRngDiv                = isElem >>> hasRngName "div"--isRngElement            :: ArrowXml a => a XmlTree XmlTree-isRngElement            = isElem >>> hasRngName "element"--isRngEmpty              :: ArrowXml a => a XmlTree XmlTree-isRngEmpty              = isElem >>> hasRngName "empty"--isRngExcept             :: ArrowXml a => a XmlTree XmlTree-isRngExcept             = isElem >>> hasRngName "except"--isRngExternalRef        :: ArrowXml a => a XmlTree XmlTree-isRngExternalRef        = isElem >>> hasRngName "externalRef"--isRngGrammar            :: ArrowXml a => a XmlTree XmlTree-isRngGrammar            = isElem >>> hasRngName "grammar"--isRngGroup              :: ArrowXml a => a XmlTree XmlTree-isRngGroup              = isElem >>> hasRngName "group"--isRngInclude            :: ArrowXml a => a XmlTree XmlTree-isRngInclude            = isElem >>> hasRngName "include"--isRngInterleave         :: ArrowXml a => a XmlTree XmlTree-isRngInterleave         = isElem >>> hasRngName "interleave"--isRngList               :: ArrowXml a => a XmlTree XmlTree-isRngList               = isElem >>> hasRngName "list"--isRngMixed              :: ArrowXml a => a XmlTree XmlTree-isRngMixed              = isElem >>> hasRngName "mixed"--isRngName               :: ArrowXml a => a XmlTree XmlTree-isRngName               = isElem >>> hasRngName "name"--isRngNotAllowed         :: ArrowXml a => a XmlTree XmlTree-isRngNotAllowed         = isElem >>> hasRngName "notAllowed"--isRngNsName             :: ArrowXml a => a XmlTree XmlTree-isRngNsName             = isElem >>> hasRngName "nsName"--isRngOneOrMore          :: ArrowXml a => a XmlTree XmlTree-isRngOneOrMore          = isElem >>> hasRngName "oneOrMore"--isRngOptional           :: ArrowXml a => a XmlTree XmlTree-isRngOptional           = isElem >>> hasRngName "optional"--isRngParam              :: ArrowXml a => a XmlTree XmlTree-isRngParam              = isElem >>> hasRngName "param"--isRngParentRef          :: ArrowXml a => a XmlTree XmlTree-isRngParentRef          = isElem >>> hasRngName "parentRef"--isRngRef                :: ArrowXml a => a XmlTree XmlTree-isRngRef                = isElem >>> hasRngName "ref"--isRngRelaxError         :: ArrowXml a => a XmlTree XmlTree-isRngRelaxError         = isElem >>> hasRngName "relaxError"--isRngStart              :: ArrowXml a => a XmlTree XmlTree-isRngStart              = isElem >>> hasRngName "start"--isRngText               :: ArrowXml a => a XmlTree XmlTree-isRngText               = isElem >>> hasRngName "text"--isRngType               :: ArrowXml a => a XmlTree XmlTree-isRngType               = isElem >>> hasRngName "type"--isRngValue              :: ArrowXml a => a XmlTree XmlTree-isRngValue              = isElem >>> hasRngName "value"--isRngZeroOrMore         :: ArrowXml a => a XmlTree XmlTree-isRngZeroOrMore         = isElem >>> hasRngName "zeroOrMore"---- --------------------------------------------------------------mkRngElement            :: ArrowXml a => String -> a n XmlTree -> a n XmlTree -> a n XmlTree-mkRngElement n          = mkElement (mkQName "" n relaxNamespace)--mkRngChoice             :: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree-mkRngChoice             = mkRngElement "choice"--mkRngDefine             :: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree-mkRngDefine             = mkRngElement "define"--mkRngEmpty              :: ArrowXml a => a n XmlTree -> a n XmlTree-mkRngEmpty a            = mkRngElement "empty" a none--mkRngGrammar            :: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree-mkRngGrammar            = mkRngElement "grammar"--mkRngGroup              :: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree-mkRngGroup              = mkRngElement "group"--mkRngInterleave         :: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree-mkRngInterleave         = mkRngElement "interleave"--mkRngName               :: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree-mkRngName               = mkRngElement "name"--mkRngNotAllowed         :: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree-mkRngNotAllowed         = mkRngElement "notAllowed"--mkRngOneOrMore          :: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree-mkRngOneOrMore          = mkRngElement "oneOrMore"--mkRngRef                :: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree-mkRngRef                = mkRngElement "ref"--mkRngRelaxError         :: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree-mkRngRelaxError         = mkRngElement "relaxError"--mkRngStart              :: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree-mkRngStart              = mkRngElement "start"--mkRngText               :: ArrowXml a => a n XmlTree -> a n XmlTree-mkRngText a             = mkRngElement "text" a none---- --------------------------------------------------------------setRngName              :: ArrowXml a => String -> a XmlTree XmlTree-setRngName n            = setElemName (mkQName "" n relaxNamespace)--setRngNameDiv           :: ArrowXml a => a XmlTree XmlTree-setRngNameDiv           = setRngName "div"--setRngNameRef           :: ArrowXml a => a XmlTree XmlTree-setRngNameRef           = setRngName "ref"---- ---------------------------------------------------------------- Attributes--isRngAttrAttribute              :: ArrowXml a => a XmlTree XmlTree-isRngAttrAttribute              = isAttr >>> hasRngName "attribute"--isRngAttrCombine                :: ArrowXml a => a XmlTree XmlTree-isRngAttrCombine                = isAttr >>> hasRngName "combine"--isRngAttrDatatypeLibrary        :: ArrowXml a => a XmlTree XmlTree-isRngAttrDatatypeLibrary        = isAttr >>> hasRngName "datatypeLibrary"--isRngAttrHref                   :: ArrowXml a => a XmlTree XmlTree-isRngAttrHref                   = isAttr >>> hasRngName "href"--isRngAttrName                   :: ArrowXml a => a XmlTree XmlTree-isRngAttrName                   = isAttr >>> hasRngName "name"--isRngAttrNs                     :: ArrowXml a => a XmlTree XmlTree-isRngAttrNs                     = isAttr >>> hasRngName "ns"--isRngAttrType                   :: ArrowXml a => a XmlTree XmlTree-isRngAttrType                   = isAttr >>> hasRngName "type"---- --------------------------------------------------------------hasRngAttrAttribute             :: ArrowXml a => a XmlTree XmlTree-hasRngAttrAttribute             = hasAttr "attribute"--hasRngAttrCombine               :: ArrowXml a => a XmlTree XmlTree-hasRngAttrCombine               = hasAttr "combine"--hasRngAttrDatatypeLibrary       :: ArrowXml a => a XmlTree XmlTree-hasRngAttrDatatypeLibrary       = hasAttr "datatypeLibrary"--hasRngAttrHref                  :: ArrowXml a => a XmlTree XmlTree-hasRngAttrHref                  = hasAttr "href"--hasRngAttrName                  :: ArrowXml a => a XmlTree XmlTree-hasRngAttrName                  = hasAttr "name"--hasRngAttrNs                    :: ArrowXml a => a XmlTree XmlTree-hasRngAttrNs                    = hasAttr "ns"--hasRngAttrType                  :: ArrowXml a => a XmlTree XmlTree-hasRngAttrType                  = hasAttr "type"---- --------------------------------------------------------------getRngAttrAttribute             :: ArrowXml a => a XmlTree String-getRngAttrAttribute             = getAttrValue "attribute"--getRngAttrCombine               :: ArrowXml a => a XmlTree String-getRngAttrCombine               = getAttrValue "combine"--getRngAttrDatatypeLibrary       :: ArrowXml a => a XmlTree String-getRngAttrDatatypeLibrary       = getAttrValue "datatypeLibrary"--getRngAttrDescr                 :: ArrowXml a => a XmlTree String-getRngAttrDescr                 = getAttrValue "descr"--getRngAttrHref                  :: ArrowXml a => a XmlTree String-getRngAttrHref                  = getAttrValue "href"--getRngAttrName                  :: ArrowXml a => a XmlTree String-getRngAttrName                  = getAttrValue "name"--getRngAttrNs                    :: ArrowXml a => a XmlTree String-getRngAttrNs                    = getAttrValue "ns"--getRngAttrType                  :: ArrowXml a => a XmlTree String-getRngAttrType                  = getAttrValue "type"---- -------------------------------------------------------------
− src/Text/XML/HXT/RelaxNG/CreatePattern.hs 
@@ -1,349 +0,0 @@--- |------ Creates the 'Pattern' datastructure from a simplified Relax NG schema.--- The created datastructure is used in the validation algorithm--- (see also: "Text.XML.HXT.RelaxNG.Validation")--module Text.XML.HXT.RelaxNG.CreatePattern-  ( createPatternFromXmlTree-  , createNameClass-  , firstChild-  , lastChild-  , module Text.XML.HXT.RelaxNG.PatternFunctions-  )-where--import Control.Arrow.ListArrows--import Text.XML.HXT.DOM.Interface--import Text.XML.HXT.Arrow.XmlArrow--import Text.XML.HXT.RelaxNG.DataTypes-import Text.XML.HXT.RelaxNG.BasicArrows-import Text.XML.HXT.RelaxNG.PatternFunctions--import Data.Maybe-    ( fromMaybe )--import Data.List-    ( isPrefixOf )---- ---------------------------------------------------------------- | Creates the 'Pattern' datastructure from a simplified Relax NG schema.--createPatternFromXmlTree :: LA XmlTree Pattern-createPatternFromXmlTree = createPatternFromXml $< createEnv- where- -- | Selects all define-pattern and creates an environment list.- -- Each list entry maps the define name to the children of the define-pattern.- -- The map is used to replace a ref-pattern with the referenced define-pattern.- createEnv :: LA XmlTree Env- createEnv = listA $ deep isRngDefine-                     >>>-                     (getRngAttrName &&& getChildren)----- | Transforms each XML-element to the corresponding pattern--createPatternFromXml :: Env -> LA XmlTree Pattern-createPatternFromXml env- = choiceA [-     isRoot                            :-> processRoot env,-     isRngEmpty      :-> constA Empty,-     isRngNotAllowed :-> mkNotAllowed,-     isRngText       :-> constA Text,-     isRngChoice     :-> mkRelaxChoice env,-     isRngInterleave :-> mkRelaxInterleave env,-     isRngGroup      :-> mkRelaxGroup env,-     isRngOneOrMore  :-> mkRelaxOneOrMore env,-     isRngList       :-> mkRelaxList env,-     isRngData       :-> mkRelaxData env,-     isRngValue      :-> mkRelaxValue,-     isRngAttribute  :-> mkRelaxAttribute env,-     isRngElement    :-> mkRelaxElement env,-     isRngRef        :-> mkRelaxRef env,-     this                              :-> mkRelaxError ""-   ]---processRoot :: Env -> LA XmlTree Pattern-processRoot env-  = getChildren-    >>>-    choiceA [-      isRngRelaxError :-> (mkRelaxError $< getRngAttrDescr),-      isRngGrammar    :-> (processGrammar env),-      this                              :-> (mkRelaxError "no grammar-pattern in schema")-    ]---processGrammar :: Env -> LA XmlTree Pattern-processGrammar env-  = getChildren-    >>>-    choiceA [-      isRngDefine     :-> none,-      isRngRelaxError :-> (mkRelaxError $< getAttrValue "desc"),-      isRngStart      :-> (getChildren >>> createPatternFromXml env),-      this            :-> (mkRelaxError "no start-pattern in schema")-    ]---{- |-  Transforms a ref-element.-  The value of the name-attribute is looked up in the environment list-  to find the corresponding define-pattern.-  Haskells lazy-evaluation is used to transform circular structures.--}-mkRelaxRef :: Env -> LA XmlTree Pattern-mkRelaxRef e- = getRngAttrName-   >>>-   arr (\n -> fromMaybe (notAllowed $ "define-pattern with name " ++ n ++ " not found")-              . lookup n $ transformEnv e-       )- where- transformEnv :: [(String, XmlTree)] -> [(String, Pattern)]- transformEnv env = [ (treeName, (transformEnvElem tree env)) | (treeName, tree) <- env]- transformEnvElem :: XmlTree -> [(String, XmlTree)] -> Pattern- transformEnvElem tree env = head $ runLA (createPatternFromXml env) tree----- | Transforms a notAllowed-element.-mkNotAllowed :: LA XmlTree Pattern-mkNotAllowed = constA $ notAllowed "notAllowed-pattern in Relax NG schema definition"----- | Creates an error message.-mkRelaxError :: String -> LA XmlTree Pattern-mkRelaxError errStr- = choiceA [-     isRngRelaxError :-> (getRngAttrDescr >>> arr notAllowed),-     isElem  :-> ( getName-                   >>>-                   arr (\n -> notAllowed $ "Pattern " ++ n ++-                                           " is not allowed in Relax NG schema"-                       )-                 ),-     isAttr  :-> ( getName-                   >>>-                   arr (\n -> notAllowed $ "Attribute " ++ n ++-                                           " is not allowed in Relax NG schema"-                       )-                 ),-     isError :-> (getErrorMsg >>> arr notAllowed),-     this    :-> (arr (\e -> notAllowed $ if errStr /= ""-                                          then errStr-                                          else "Can't create pattern from " ++ show e)-                 )-   ]----- | Transforms a choice-element.-mkRelaxChoice :: Env -> LA XmlTree Pattern-mkRelaxChoice env-    = ifA ( getChildren >>.-            ( \ l -> if length l == 1 then l else [] )-          )-      ( createPatternFromXml env )-      ( getTwoChildrenPattern env >>> arr2 Choice )---- | Transforms a interleave-element.-mkRelaxInterleave :: Env -> LA XmlTree Pattern-mkRelaxInterleave env-    = getTwoChildrenPattern env-      >>>-      arr2 Interleave----- | Transforms a group-element.-mkRelaxGroup :: Env -> LA XmlTree Pattern-mkRelaxGroup env-    = getTwoChildrenPattern env-      >>>-      arr2 Group----- | Transforms a oneOrMore-element.-mkRelaxOneOrMore :: Env -> LA XmlTree Pattern-mkRelaxOneOrMore env-    = getOneChildPattern env-      >>>-      arr OneOrMore----- | Transforms a list-element.-mkRelaxList :: Env -> LA XmlTree Pattern-mkRelaxList env-    = getOneChildPattern env-      >>>-      arr List----- | Transforms a data- or dataExcept-element.-mkRelaxData :: Env -> LA XmlTree Pattern-mkRelaxData env-  = ifA (getChildren >>> isRngExcept)-     (processDataExcept >>> arr3 DataExcept)-     (processData >>> arr2 Data)-  where-  processDataExcept :: LA XmlTree (Datatype, (ParamList, Pattern))-  processDataExcept = getDatatype &&& getParamList &&&-                      ( getChildren-                        >>>-                        isRngExcept-                        >>>-                        getChildren-                        >>>-                        createPatternFromXml env-                      )-  processData :: LA XmlTree (Datatype, ParamList)-  processData = getDatatype &&& getParamList-  getParamList :: LA XmlTree ParamList-  getParamList = listA $ getChildren-                         >>>-                         isRngParam-                         >>>-                         (getRngAttrName &&& (getChildren >>> getText))----- | Transforms a value-element.-mkRelaxValue :: LA XmlTree Pattern-mkRelaxValue = getDatatype &&& getValue &&& getContext-               >>>-               arr3 Value-  where-  getContext :: LA XmlTree Context-  getContext = getAttrValue contextBaseAttr &&& getMapping-  getMapping :: LA XmlTree [(Prefix, Uri)]-  getMapping = listA $ getAttrl >>>-                       ( (getName >>> isA (contextAttributes `isPrefixOf`))-                         `guards`-                         ( (getName >>> arr (drop $ length contextAttributes))-                           &&&-                           (getChildren >>> getText)-                         )-                       )-  getValue :: LA XmlTree String-  getValue = (getChildren >>> getText) `orElse` (constA "")---getDatatype :: LA XmlTree Datatype-getDatatype = getRngAttrDatatypeLibrary-              &&&-              getRngAttrType----- | Transforms a attribute-element.--- The first child is a 'NameClass', the second (the last) one a pattern.--mkRelaxAttribute :: Env -> LA XmlTree Pattern-mkRelaxAttribute env-    = ( ( firstChild >>> createNameClass )-        &&&-        ( lastChild >>> createPatternFromXml env )-      )-      >>>-      arr2 Attribute---- | Transforms a element-element.--- The first child is a 'NameClass', the second (the last) one a pattern.-mkRelaxElement :: Env -> LA XmlTree Pattern-mkRelaxElement env-    = ( ( firstChild >>> createNameClass )-        &&&-        ( lastChild >>> createPatternFromXml env )-      )-      >>>-      arr2 Element----- | Creates a 'NameClass' from an \"anyName\"-, \"nsName\"- or  \"name\"-Pattern,-createNameClass :: LA XmlTree NameClass-createNameClass-    = choiceA-      [ isRngAnyName :-> processAnyName-      , isRngNsName  :-> processNsName-      , isRngName    :-> processName-      , isRngChoice  :-> processChoice-      , this         :-> mkNameClassError-      ]-    where-    processAnyName :: LA XmlTree NameClass-    processAnyName-        = ifA (getChildren >>> isRngExcept)-          ( getChildren-            >>> getChildren-            >>> createNameClass-            >>> arr AnyNameExcept-          )-         ( constA AnyName )--    processNsName :: LA XmlTree NameClass-    processNsName-        = ifA (getChildren >>> isRngExcept)-          ( ( getRngAttrNs-              &&&-              ( getChildren >>> getChildren >>> createNameClass )-            )-            >>>-            arr2 NsNameExcept-          )-          ( getRngAttrNs >>> arr NsName )--    processName :: LA XmlTree NameClass-    processName-        = (getRngAttrNs &&& (getChildren >>> getText)) >>> arr2 Name--    processChoice :: LA XmlTree NameClass-    processChoice-        = ( ( firstChild >>> createNameClass )-            &&&-            ( lastChild  >>> createNameClass )-          )-          >>>-          arr2 NameClassChoice--mkNameClassError :: LA XmlTree NameClass-mkNameClassError-    = choiceA [ isRngRelaxError-                        :-> ( getRngAttrDescr-                              >>>-                              arr NCError-                         )-              , isElem  :-> ( getName-                              >>>-                              arr (\n -> NCError ("Can't create name class from element " ++ n))-                            )-              , isAttr  :-> ( getName-                              >>>-                              arr (\n -> NCError ("Can't create name class from attribute: " ++ n))-                            )-              , isError :-> ( getErrorMsg-                              >>>-                              arr NCError-                            )-              , this    :-> ( arr (\e ->  NCError $ "Can't create name class from " ++ show e) )-              ]---getOneChildPattern :: Env -> LA XmlTree Pattern-getOneChildPattern env-    = firstChild >>> createPatternFromXml env---getTwoChildrenPattern :: Env -> LA XmlTree (Pattern, Pattern)-getTwoChildrenPattern env-    = ( getOneChildPattern env )-        &&&-        ( lastChild  >>> createPatternFromXml env )---- | Simple access arrows--firstChild      :: (ArrowTree a, Tree t) => a (t b) (t b)-firstChild      = single getChildren--lastChild       :: (ArrowTree a, Tree t) => a (t b) (t b)-lastChild       = getChildren >>. (take 1 . reverse)
− src/Text/XML/HXT/RelaxNG/DataTypeLibMysql.hs 
@@ -1,169 +0,0 @@--- |--- Datatype library for the MySQL datatypes------ $Id: DataTypeLibMysql.hs,v 1.1 2005/09/02 17:09:39 hxml Exp $--module Text.XML.HXT.RelaxNG.DataTypeLibMysql-  ( mysqlNS-  , mysqlDatatypeLib-  )-where--import Text.XML.HXT.RelaxNG.DataTypeLibUtils--import Data.Maybe---- ---------------------------------------------------------------- | Namespace of the MySQL datatype library--mysqlNS :: String-mysqlNS = "http://www.mysql.com"----- | The main entry point to the MySQL datatype library.------ The 'DTC' constructor exports the list of supported datatypes and params.--- It also exports the specialized functions to validate a XML instance value with--- respect to a datatype.--mysqlDatatypeLib :: DatatypeLibrary-mysqlDatatypeLib = (mysqlNS, DTC datatypeAllowsMysql datatypeEqualMysql mysqlDatatypes)----- | All supported datatypes of the library-mysqlDatatypes :: AllowedDatatypes-mysqlDatatypes = [ -- numeric types-                   ("SIGNED-TINYINT", numericParams)-                 , ("UNSIGNED-TINYINT", numericParams)-                 , ("SIGNED-SMALLINT", numericParams)-                 , ("UNSIGNED-SMALLINT", numericParams)-                 , ("SIGNED-MEDIUMINT", numericParams)-                 , ("UNSIGNED-MEDIUMINT", numericParams)-                 , ("SIGNED-INT", numericParams)-                 , ("UNSIGNED-INT", numericParams)-                 , ("SIGNED-BIGINT", numericParams)-                 , ("UNSIGNED-BIGINT", numericParams)--                 -- string types-                 , ("CHAR", stringParams)-                 , ("VARCHAR", stringParams)-                 , ("BINARY", stringParams)-                 , ("VARBINARY", stringParams)-                 , ("TINYTEXT", stringParams)-                 , ("TINYBLOB", stringParams)-                 , ("TEXT", stringParams)-                 , ("BLOB", stringParams)-                 , ("MEDIUMTEXT", stringParams)-                 , ("MEDIUMBLOB", stringParams)-                 , ("LONGTEXT", stringParams)-                 , ("LONGBLOB", stringParams)-                 ]----- | List of supported string datatypes-stringTypes :: [String]-stringTypes = [ "CHAR"-              , "VARCHAR"-              , "BINARY"-              , "VARBINARY"-              , "TINYTEXT"-              , "TINYBLOB"-              , "TEXT"-              , "BLOB"-              , "MEDIUMTEXT"-              , "MEDIUMBLOB"-              , "LONGTEXT"-              , "LONGBLOB"-              ]----- | List of supported numeric datatypes-numericTypes :: [String]-numericTypes = [ "SIGNED-TINYINT"-               , "UNSIGNED-TINYINT"-               , "SIGNED-SMALLINT"-               , "UNSIGNED-SMALLINT"-               , "SIGNED-MEDIUMINT"-               , "UNSIGNED-MEDIUMINT"-               , "SIGNED-INT"-               , "UNSIGNED-INT"-               , "SIGNED-BIGINT"-               , "UNSIGNED-BIGINT"-               ]----- | List of allowed params for the numeric datatypes-numericParams :: AllowedParams-numericParams = [ rng_maxExclusive-                , rng_minExclusive-                , rng_maxInclusive-                , rng_minInclusive-                ]----- | List of allowed params for the string datatypes-stringParams :: AllowedParams-stringParams = [ rng_length-               , rng_maxLength-               , rng_minLength-               ]---- ------------------------------------------------------------------ | Tests whether a XML instance value matches a data-pattern.--datatypeAllowsMysql :: DatatypeAllows-datatypeAllowsMysql d params value _-    = performCheck check value-    where-    check-        | isJust ndt    = checkNum (fromJust ndt)-        | isJust sdt    = checkStr (fromJust sdt)-        | otherwise     = failure $ errorMsgDataTypeNotAllowed mysqlNS d params-    checkNum r  = uncurry (numberValid d) r params-    checkStr r  = uncurry (stringValid d) r params-    ndt = lookup d $-          [ ("SIGNED-TINYINT", ((-128), 127))-          , ("UNSIGNED-TINYINT", (0, 255))-          , ("SIGNED-SMALLINT", ((-32768), 32767))-          , ("UNSIGNED-SMALLINT", (0, 65535))-          , ("SIGNED-MEDIUMINT", ((-8388608), 8388607))-          , ("UNSIGNED-MEDIUMINT", (0, 16777215))-          , ("SIGNED-INT", ((-2147483648), 2147483647))-          , ("UNSIGNED-INT", (0, 4294967295))-          , ("SIGNED-BIGINT", ((-9223372036854775808), 9223372036854775807))-          , ("UNSIGNED-BIGINT", (0, 18446744073709551615))-          ]-    sdt = lookup d $-          [ ("CHAR", (0, 255))-          , ("VARCHAR", (0, 65535))-          , ("BINARY", (0, 255))-          , ("VARBINARY", (0, 65535))-          , ("TINYTEXT", (0, 256))-          , ("TINYBLOB", (0, 256))-          , ("TEXT", (0, 65536))-          , ("BLOB", (0, 65536))-          , ("MEDIUMTEXT", (0, 16777216))-          , ("MEDIUMBLOB", (0, 16777216))-          , ("LONGTEXT", (0, 4294967296))-          , ("LONGBLOB", (0, 4294967296))-          ]---- ---------------------------------------------------------------- | Tests whether a XML instance value matches a value-pattern.--datatypeEqualMysql :: DatatypeEqual-datatypeEqualMysql d s1 _ s2 _-    = performCheck check (s1, s2)-      where-      cmp nf    = arr (\ (x1, x2) -> (nf x1, nf x2))-                  >>>-                  assert (uncurry (==)) (uncurry $ errorMsgEqual d)-      check-          | d `elem` stringTypes        = cmp id-          | d `elem` numericTypes       = cmp normalizeNumber-          | otherwise                   = failure $ const (errorMsgDataTypeNotAllowed0 mysqlNS d)---- ------------------------------------------------------------
− src/Text/XML/HXT/RelaxNG/DataTypeLibUtils.hs 
@@ -1,407 +0,0 @@--- |--- exports helper functions for the integration of new datatype-libraries--module Text.XML.HXT.RelaxNG.DataTypeLibUtils-  ( errorMsgEqual-  , errorMsgDataTypeNotAllowed-  , errorMsgDataTypeNotAllowed0-  , errorMsgDataTypeNotAllowed2-  , errorMsgDataLibQName-  , errorMsgParam--  , rng_length-  , rng_maxLength-  , rng_minLength-   ,rng_maxExclusive-  , rng_minExclusive-  , rng_maxInclusive-  , rng_minInclusive--  , module Control.Arrow-  , module Text.XML.HXT.DOM.Util-  , module Text.XML.HXT.RelaxNG.Utils-  , module Text.XML.HXT.RelaxNG.DataTypes--  , FunctionTable--  , stringValidFT       -- generalized checkString-  , fctTableString      -- minLength, maxLenght, length-  , fctTableList        -- minLength, maxLenght, length--  , stringValid         -- checkString-  , numberValid         -- checkNumeric--  , numParamValid--  , CheckA              -- Check datatype-  , CheckString         -- CheckA String String-  , CheckInteger        -- CheckA Integer Integer--  , performCheck        -- run a CheckA-  , ok                  -- always true-  , failure             -- create an error meesage-  , assert              -- create a primitive check from a predicate-  , assertMaybe         -- create a primitive check from a maybe-  , checkWith           -- convert value before checking-  )--where-import Prelude hiding (id, (.))--import Control.Category-import Control.Arrow--import Data.Maybe--import Text.XML.HXT.DOM.Util--import Text.XML.HXT.RelaxNG.DataTypes-import Text.XML.HXT.RelaxNG.Utils---- --------------------------------------------------------------newtype CheckA a b      = C { runCheck :: a -> Either String b }--instance Category CheckA where-    id          = C $ Right--    f2 . f1     = C $                           -- logical and: f1 and f2 must hold-                  \ x -> case runCheck f1 x of-                         Right y        -> runCheck f2 y-                         Left  e        -> Left e--instance Arrow CheckA where-    arr f       = C ( Right . f )               -- unit: no check, always o.k., just a conversion--    first f1    = C $                           -- check 1. component of a pair-                  \ ~(x1, x2) -> case runCheck f1 x1 of-                                 Right y1       -> Right (y1, x2)-                                 Left  e        -> Left  e--    second f2   = C $                           -- check 2. component of a pair-                  \ ~(x1, x2) -> case runCheck f2 x2 of-                                 Right y2       -> Right (x1, y2)-                                 Left  e        -> Left  e----instance ArrowZero CheckA where-    zeroArrow   = C $ const (Left "")           -- always false: zero--instance ArrowPlus CheckA where-    f1 <+> f2   = C $                           -- logical or-                  \ x -> case runCheck f1 x of-                         Right y1       -> Right y1-                         Left  e1       -> case runCheck f2 x of-                                           Right y2     -> Right y2-                                           Left  e2     -> Left ( if null e1-                                                                  then e2-                                                                  else-                                                                  if null e2-                                                                  then e1-                                                                  else e1 ++ " or " ++ e2-                                                                )--type CheckString        = CheckA String String-type CheckInteger       = CheckA Integer Integer---- | run a check and deliver Just an error message or Nothing--performCheck    :: CheckA a b -> a -> Maybe String-performCheck c  = either Just (const Nothing) . runCheck c---- | always failure--failure         :: (a -> String) -> CheckA a b-failure msg     = C (Left . msg)---- | every thing is fine--ok              :: CheckA a a-ok              = arr id---- | perform a simple check with a predicate p,---   when the predicate holds, assert acts as identity,---   else an error message is generated--assert  :: (a -> Bool) -> (a -> String) -> CheckA a a-assert p msg    = C $ \ x -> if p x then Right x else Left (msg x)---- | perform a simple check with a Maybe function, Nothing indicates error--assertMaybe     :: (a -> Maybe b) -> (a -> String) -> CheckA a b-assertMaybe f msg-    = C $ \ x -> case f x of-                 Nothing        -> Left (msg x)-                 Just y         -> Right y---- | perform a check, but convert the value before checking--checkWith       :: (a -> b) -> CheckA b c -> CheckA a a-checkWith f c   = C $-                  \ x -> case runCheck c (f x) of-                         Right _        -> Right x-                         Left  e        -> Left  e---- ---------------------------------------------------------------- RelaxNG attribute names--rng_length, rng_maxLength, rng_minLength- ,rng_maxExclusive, rng_minExclusive, rng_maxInclusive, rng_minInclusive :: String--rng_length              = "length"-rng_maxLength           = "maxLength"-rng_minLength           = "minLength"--rng_maxExclusive        = "maxExclusive"-rng_minExclusive        = "minExclusive"-rng_maxInclusive        = "maxInclusive"-rng_minInclusive        = "minInclusive"---- ---------------------------------------------------------------- | Function table type--type FunctionTable      = [(String, String -> String -> Bool)]---- | Function table for numeric tests,--- XML document value is first operand, schema value second--fctTableNum :: (Ord a, Num a) => [(String, a -> a -> Bool)]-fctTableNum-    = [ (rng_maxExclusive, (<))-      , (rng_minExclusive, (>))-      , (rng_maxInclusive, (<=))-      , (rng_minInclusive, (>=))-      ]---- | Function table for string tests,--- XML document value is first operand, schema value second-fctTableString :: FunctionTable-fctTableString-    = [ (rng_length,    (numParamValid (==)))-      , (rng_maxLength, (numParamValid (<=)))-      , (rng_minLength, (numParamValid (>=)))-      ]---- | Function table for list tests,--- XML document value is first operand, schema value second--fctTableList :: FunctionTable-fctTableList-    = [ (rng_length,    (listParamValid (==)))-      , (rng_maxLength, (listParamValid (<=)))-      , (rng_minLength, (listParamValid (>=)))-      ]--{- |-tests whether a string value matches a numeric param--valid example:--> <data type="CHAR"> <param name="maxLength">5</param> </data>--invalid example:--> <data type="CHAR"> <param name="minLength">foo</param> </data>---}--numParamValid :: (Integer -> Integer -> Bool) -> String -> String -> Bool-numParamValid fct a b-  = isNumber b-    &&-    ( toInteger (length a) `fct` (read b) )--{- |-tests whether a list value matches a length constraint--valid example:--> <data type="IDREFS"> <param name="maxLength">5</param> </data>--invalid example:--> <data type="IDREFS"> <param name="minLength">foo</param> </data>---}--listParamValid :: (Integer -> Integer -> Bool) -> String -> String -> Bool-listParamValid fct a b-  = isNumber b-    &&-    ( toInteger (length . words $ a) `fct` (read b) )---- --------------------------------------------------------------- new check functions--{- |-Tests whether a \"string\" datatype value is between the lower and-upper bound of the datatype and matches all parameters.--All tests are performed on the string value.--   * 1.parameter  :  datatype--   - 2.parameter  :  lower bound of the datatype range--   - 3.parameter  :  upper bound of the datatype range (-1 = no upper bound)--   - 4.parameter  :  list of parameters--   - 5.parameter  :  datatype value to be checked--   - return : Just \"Errormessage\" in case of an error, else Nothing---}--stringValid     :: DatatypeName -> Integer -> Integer -> ParamList -> CheckString-stringValid     = stringValidFT fctTableString--stringValidFT :: FunctionTable -> DatatypeName -> Integer -> Integer -> ParamList -> CheckString-stringValidFT ft datatype lowerBound upperBound params-    = assert boundsOK boundsErr-      >>>-      paramsStringValid params-    where-    boundsOK v-        = ( (lowerBound == 0)-            ||-            (toInteger (length v) >= lowerBound)-          )-          &&-          ( (upperBound == (-1))-            ||-            (toInteger (length v) <= upperBound)-          )--    boundsErr v-        = "Length of " ++ v-          ++ " (" ++ (show $ length v) ++ " chars) out of range: "-          ++ show lowerBound ++ " .. " ++ show upperBound-          ++ " for datatype " ++ datatype--    paramStringValid :: (LocalName, String) -> CheckString-    paramStringValid (pn, pv)-        = assert paramOK (errorMsgParam pn pv)-          where-          paramOK v  = paramFct pn v pv-          paramFct n = fromMaybe (const . const $ True) $ lookup n ft--    paramsStringValid :: ParamList -> CheckString-    paramsStringValid-        = foldr (>>>) ok . map paramStringValid---- --------------------------------------------------------------{- |-Tests whether a \"numeric\" datatype value is between the lower and upper-bound of the datatype and matches all parameters.--First, the string value is parsed into a numeric representation.-If no error occur, all following tests are performed on the numeric value.--   * 1.parameter  :  datatype--   - 2.parameter  :  lower bound of the datatype range--   - 3.parameter  :  upper bound of the datatype range (-1 = no upper bound)--   - 4.parameter  :  list of parameters--   - 5.parameter  :  datatype value to be checked--   - return : Just \"Errormessage\" in case of an error, else Nothing---}--numberValid :: DatatypeName -> Integer -> Integer -> ParamList -> CheckString-numberValid datatype lowerBound upperBound params-    = assert isNumber numErr-      >>>-      checkWith read ( assert inRange rangeErr-                       >>>-                       paramsNumValid params-                     )-    where-    inRange     :: Integer -> Bool-    inRange x   = x >= lowerBound-                  &&-                  x <= upperBound--    rangeErr v  = ( "Value = " ++ show v ++ " out of range: "-                    ++ show lowerBound ++ " .. " ++ show upperBound-                    ++ " for datatype " ++ datatype-                  )-    numErr v-        = "Value = " ++ v ++ " is not a number"--paramsNumValid  :: ParamList -> CheckInteger-paramsNumValid-    = foldr (>>>) ok . map paramNumValid--paramNumValid   :: (LocalName, String) -> CheckInteger-paramNumValid (pn, pv)-    = assert paramOK (errorMsgParam pn pv . show)-    where-    paramOK  v = isNumber pv-                 &&-                 paramFct pn v (read pv)-    paramFct n = fromJust $ lookup n fctTableNum---- --------------------------------------------------------------{- |-Error Message for the equality test of two datatype values--   * 1.parameter  :  datatype--   - 2.parameter  :  datatype value--   - 3.parameter  :  datatype value--example:--> errorMsgEqual "Int" "21" "42" -> "Datatype Int with value = 21 expected, but value = 42 found"---}--errorMsgParam   :: LocalName -> String -> String -> String-errorMsgParam pn pv v-    = ( "Parameter restriction: \""-        ++ pn ++ " = " ++ pv-        ++ "\" does not hold for value = \"" ++ v ++ "\""-      )--errorMsgEqual :: DatatypeName -> String -> String -> String-errorMsgEqual d s1 s2-    = ( "Datatype" ++ show d ++-        " with value = " ++ show s1 ++-        " expected, but value = " ++ show s2 ++ " found"-      )-errorMsgDataTypeNotAllowed :: String -> String -> [(String, String)] -> String -> String-errorMsgDataTypeNotAllowed l t p v-    = ( "Datatype " ++ show t ++ " with parameter(s) " ++-        formatStringListPairs p ++ " and value = " ++ show v ++-        " not allowed for DatatypeLibrary " ++ show l-      )--errorMsgDataTypeNotAllowed0 :: String -> String -> String-errorMsgDataTypeNotAllowed0 l t-    = ( "Datatype " ++ show t ++-        " not allowed for DatatypeLibrary " ++ show l-      )-errorMsgDataTypeNotAllowed2 :: String -> String -> String -> String -> String-errorMsgDataTypeNotAllowed2 l t v1 v2-    = ( "Datatype " ++ show t ++-        " with values = " ++ show v1 ++-        " and " ++ show v2 ++-        " not allowed for DatatypeLibrary " ++ show l-      )--errorMsgDataLibQName :: String -> String -> String -> String-errorMsgDataLibQName l n v-    = show v ++ " is not a valid " ++ n ++ " for DatatypeLibrary " ++ l---- ------------------------------------------------------------
− src/Text/XML/HXT/RelaxNG/DataTypeLibraries.hs 
@@ -1,140 +0,0 @@--- | This modul exports the list of supported datatype libraries.--- It also exports the main functions to validate an XML instance value--- with respect to a datatype.--module Text.XML.HXT.RelaxNG.DataTypeLibraries-  ( datatypeLibraries-  , datatypeEqual-  , datatypeAllows-  )-where--import Text.XML.HXT.DOM.Interface-    ( relaxNamespace-    )--import Text.XML.HXT.RelaxNG.DataTypeLibUtils--import Text.XML.HXT.RelaxNG.DataTypeLibMysql-    ( mysqlDatatypeLib )--import Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C-    ( w3cDatatypeLib )--import Data.Maybe-    ( fromJust )---- ----------------------------------------------------------------- | List of all supported datatype libraries which can be--- used within the Relax NG validator modul.--datatypeLibraries :: DatatypeLibraries-datatypeLibraries-    = [ relaxDatatypeLib-      , relaxDatatypeLib'-      , mysqlDatatypeLib-      , w3cDatatypeLib-      ]---{- |-Tests whether a XML instance value matches a value-pattern.--The following tests are performed:--   * 1. :  does the uri exist in the list of supported datatype libraries--   - 2. :  does the library support the datatype--   - 3. :  does the XML instance value match the value-pattern--The hard work is done by the specialized 'DatatypeEqual' function-(see also: 'DatatypeCheck') of the datatype library.--}--datatypeEqual :: Uri -> DatatypeEqual-datatypeEqual uri d s1 c1 s2 c2-    = if elem uri (map fst datatypeLibraries)-      then dtEqFct d s1 c1 s2 c2-      else Just ( "Unknown DatatypeLibrary " ++ show uri )-    where-    DTC _ dtEqFct _ = fromJust $ lookup uri datatypeLibraries--{- |-Tests whether a XML instance value matches a data-pattern.--The following tests are performed:--   * 1. :  does the uri exist in the list of supported datatype libraries--   - 2. :  does the library support the datatype--   - 3. :  does the XML instance value match the data-pattern--   - 4. :  does the XML instance value match all params--The hard work is done by the specialized 'DatatypeAllows' function-(see also: 'DatatypeCheck') of the datatype library.---}--datatypeAllows :: Uri -> DatatypeAllows-datatypeAllows uri d params s1 c1-    = if elem uri (map fst datatypeLibraries)-      then dtAllowFct d params s1 c1-      else Just ( "Unknown DatatypeLibrary " ++ show uri )-    where-    DTC dtAllowFct _ _ = fromJust $ lookup uri datatypeLibraries----- ----------------------------------------------------------------------------------------- Relax NG build in datatype library--relaxDatatypeLib        :: DatatypeLibrary-relaxDatatypeLib        = (relaxNamespace, DTC datatypeAllowsRelax datatypeEqualRelax relaxDatatypes)---- | if there is no datatype uri, the built in datatype library is used-relaxDatatypeLib'       :: DatatypeLibrary-relaxDatatypeLib'       = ("",             DTC datatypeAllowsRelax datatypeEqualRelax relaxDatatypes)---- | The build in Relax NG datatype lib supportes only the token and string datatype,--- without any params.--relaxDatatypes :: AllowedDatatypes-relaxDatatypes-    = map ( (\ x -> (x, [])) . fst ) relaxDatatypeTable--datatypeAllowsRelax :: DatatypeAllows-datatypeAllowsRelax d p v _-    = maybe notAllowed' allowed . lookup d $ relaxDatatypeTable-    where-    notAllowed'-        = Just $ errorMsgDataTypeNotAllowed relaxNamespace d p v-    allowed _-        = Nothing---- | If the token datatype is used, the values have to be normalized--- (trailing and leading whitespaces are removed).--- token does not perform any changes to the values.--datatypeEqualRelax :: DatatypeEqual-datatypeEqualRelax d s1 _ s2 _-    = maybe notAllowed' checkValues . lookup d $ relaxDatatypeTable-      where-      notAllowed'-          = Just $ errorMsgDataTypeNotAllowed2 relaxNamespace d s1 s2-      checkValues predicate-          = if predicate s1 s2-            then Nothing-            else Just $ errorMsgEqual d s1 s2--relaxDatatypeTable :: [(String, String -> String -> Bool)]-relaxDatatypeTable-    = [ ("string", (==))-      , ("token",  \ s1 s2 -> normalizeWhitespace s1 == normalizeWhitespace s2 )-      ]----- --------------------------------------------------------------------------------------
− src/Text/XML/HXT/RelaxNG/DataTypes.hs 
@@ -1,296 +0,0 @@-module Text.XML.HXT.RelaxNG.DataTypes-where--import Text.XML.HXT.DOM.TypeDefs---- --------------------------------------------------------------relaxSchemaFile :: String-relaxSchemaFile = "Text/XML/HXT/RelaxNG/SpecificationSchema.rng"---relaxSchemaGrammarFile :: String-relaxSchemaGrammarFile = "Text/XML/HXT/RelaxNG/SpecificationSchemaGrammar.rng"---- --------------------------------------------------------------- datatypes for the simplification process--a_numberOfErrors,- a_relaxSimplificationChanges,- defineOrigName :: String--a_numberOfErrors             = "numberOfErrors"-a_relaxSimplificationChanges = "relaxSimplificationChanges"-defineOrigName               = "RelaxDefineOriginalName"---type Env = [(String, XmlTree)]---- | Start of a context attribute value--- (see also: 'Text.XML.HXT.RelaxNG.Simplification.simplificationStep1')------ The value is always followed by the original attribute name and value--contextAttributes :: String-contextAttributes = "RelaxContext:"----- | Start of base uri attribute value--- (see also: 'simplificationStep1' in "Text.XML.HXT.RelaxNG.Simplification")--contextBaseAttr :: String-contextBaseAttr = "RelaxContextBaseURI"----- see simplificationStep5 in Text.XML.HXT.RelaxNG.Simplification--type OldName = String-type NewName = String-type NamePair = (OldName, NewName)-type RefList = [NamePair]----- --------------------------------------------------------------- datatype library handling---- | Type of all datatype libraries functions that tests whether--- a XML instance value matches a value-pattern.------ Returns Just \"errorMessage\" in case of an error else Nothing.--type DatatypeEqual  = DatatypeName -> String -> Context -> String -> Context -> Maybe String----- | Type of all datatype libraries functions that tests whether--- a XML instance value matches a data-pattern.------ Returns Just \"errorMessage\" in case of an error else Nothing.--type DatatypeAllows = DatatypeName -> ParamList -> String -> Context -> Maybe String----- | List of all supported datatype libraries--type DatatypeLibraries = [DatatypeLibrary]----- | Each datatype library is identified by a URI.--type DatatypeLibrary   = (Uri, DatatypeCheck)--type DatatypeName      = String--type ParamName         = String----- | List of all supported params for a datatype--type AllowedParams     = [ParamName]----- | List of all supported datatypes and there allowed params--type AllowedDatatypes  = [(DatatypeName, AllowedParams)]----- | The Constructor exports the list of supported datatypes for a library.--- It also exports the specialized datatype library functions to validate--- a XML instance value with respect to a datatype.--data DatatypeCheck-  = DTC { dtAllowsFct    :: DatatypeAllows -- ^ function to test whether a value matches a data-pattern-        , dtEqualFct     :: DatatypeEqual -- ^ function to test whether a value matches a value-pattern-        , dtAllowedTypes :: AllowedDatatypes -- ^ list of all supported params for a datatype-        }---- --------------------------------------------------------------- datatypes for the validation process--type Uri = String--type LocalName = String----- | List of parameters; each parameter is a pair consisting of a local name and a value.--type ParamList = [(LocalName, String)]--type Prefix = String----- | A Context represents the context of an XML element.--- It consists of a base URI and a mapping from prefixes to namespace URIs.--type Context = (Uri, [(Prefix, Uri)])---- | A Datatype identifies a datatype by a datatype library name and a local name.--type Datatype = (Uri, LocalName)--showDatatype    :: Datatype -> String-showDatatype (u, ln)-         | null u       = ln-         | otherwise    = "{" ++ u ++ "}" ++ ln---- | Represents a name class--data NameClass = AnyName-               | AnyNameExcept NameClass-               | Name Uri LocalName-               | NsName Uri-               | NsNameExcept Uri NameClass-               | NameClassChoice NameClass NameClass-               | NCError String-               deriving Eq--instance Show NameClass-    where-    show AnyName        = "AnyName"-    show (AnyNameExcept nameClass)-                        = "AnyNameExcept: " ++ show nameClass-    show (Name uri localName)-        | null uri      = localName-        | otherwise     = "{" ++ uri ++ "}" ++ localName-    show (NsName uri)   = "{" ++ uri ++ "}AnyName"-    show (NsNameExcept uri nameClass)-                        = "NsNameExcept: {" ++ uri ++ "}" ++ show nameClass-    show (NameClassChoice nameClass1 nameClass2)-                        = "NameClassChoice: " ++ show nameClass1 ++ "|" ++ show nameClass2-    show (NCError string)-                         = "NCError: " ++ string----- | Represents a pattern after simplification--data Pattern = Empty-             | NotAllowed ErrMessage-             | Text-             | Choice Pattern Pattern-             | Interleave Pattern Pattern-             | Group Pattern Pattern-             | OneOrMore Pattern-             | List Pattern-             | Data Datatype ParamList-             | DataExcept Datatype ParamList Pattern-             | Value Datatype String Context-             | Attribute NameClass Pattern-             | Element NameClass Pattern-             | After Pattern Pattern--instance Show Pattern where-    show Empty                  = "empty"-    show (NotAllowed e)         = show e-    show Text                   = "text"-    show (Choice p1 p2)         = "( " ++ show p1 ++ " | " ++ show p2 ++ " )"-    show (Interleave p1 p2)     = "( " ++ show p1 ++ " & " ++ show p2 ++ " )"-    show (Group p1 p2)          = "( " ++ show p1 ++ " , " ++ show p2 ++ " )"-    show (OneOrMore p)          = show p ++ "+"-    show (List p)               = "list { " ++ show p ++ " }"-    show (Data dt pl)           = showDatatype dt ++ showPL pl-                                  where-                                  showPL []     = ""-                                  showPL l      = " {" ++ concatMap showP l ++ " }"-                                  showP (ln, v) = " " ++ ln ++ " = " ++ show v-    show (DataExcept dt pl p)   = show (Data dt pl) ++ " - (" ++ show p ++ " )"-    show (Value dt v _cx)       = showDatatype dt ++ " " ++ show v-    show (Attribute nc p)       = "attribute " ++ show nc ++ " { " ++ show p ++ " }"-    show (Element nc p)         = "element "   ++ show nc ++ " { " ++ show p ++ " }"-    show (After p1 p2)          =  "( " ++ show p1 ++ " ; " ++ show p2 ++ " )"--data ErrMessage = ErrMsg ErrLevel [String]-                  -- deriving Show--instance Show ErrMessage where-    show (ErrMsg _lev es) = foldr1 (\ x y -> x ++ "\n" ++ y) es--type ErrLevel   = Int---- ---------------------------------------------------------------- smart constructor funtions for Pattern---- | smart constructor for NotAllowed--notAllowed      :: String -> Pattern-notAllowed      = notAllowedN 0--notAllowed1     :: String -> Pattern-notAllowed1     = notAllowedN 1--notAllowed2     :: String -> Pattern-notAllowed2     = notAllowedN 2--notAllowedN     :: ErrLevel -> String -> Pattern-notAllowedN l s = NotAllowed (ErrMsg l [s])---- | merge error messages------ If error levels are different, the more important is taken,--- if level is 2 (max level) both error messages are taken--- else the 1. error mesage is taken--mergeNotAllowed :: Pattern -> Pattern -> Pattern-mergeNotAllowed p1@(NotAllowed (ErrMsg l1 s1)) p2@(NotAllowed (ErrMsg l2 s2))-    | l1 < l2   = p2-    | l1 > l2   = p1-    | l1 == 2   = NotAllowed $ ErrMsg 2 (s1 ++ s2)-    | otherwise = p1---- TODO : weird error when collecting error messages errors are duplicated--mergeNotAllowed _p1 _p2-    = notAllowed2 "mergeNotAllowed with wrong patterns"---- | smart constructor for Choice--choice :: Pattern -> Pattern -> Pattern-choice p1@(NotAllowed _) p2@(NotAllowed _)      = mergeNotAllowed p1 p2-choice p1                   (NotAllowed _)      = p1-choice (NotAllowed _)    p2                     = p2-choice p1                p2                     = Choice p1 p2---- | smart constructor for Group--group :: Pattern -> Pattern -> Pattern-group p1@(NotAllowed _)  p2@(NotAllowed _)      = mergeNotAllowed p1 p2-group _                   n@(NotAllowed _)      = n-group   n@(NotAllowed _)  _                     = n-group p                  Empty                  = p-group Empty              p                      = p-group p1                 p2                     = Group p1 p2---- | smart constructor for OneOrMore--oneOrMore :: Pattern -> Pattern-oneOrMore n@(NotAllowed _) = n-oneOrMore p                = OneOrMore p---- | smart constructor for Interleave--interleave :: Pattern -> Pattern -> Pattern-interleave p1@(NotAllowed _) p2@(NotAllowed _)  = mergeNotAllowed p1 p2-interleave _                 p2@(NotAllowed _)  = p2-interleave p1@(NotAllowed _) _                  = p1-interleave p1                Empty              = p1-interleave Empty             p2                 = p2-interleave p1                p2                 = Interleave p1 p2---- | smart constructor for After--after :: Pattern -> Pattern -> Pattern-after p1@(NotAllowed _) p2@(NotAllowed _)       = mergeNotAllowed p1 p2-after _                 p2@(NotAllowed _)       = p2-after p1@(NotAllowed _) _                       = p1-after p1                p2                      = After p1 p2----- | Possible content types of a Relax NG pattern.--- (see also chapter 7.2 in Relax NG specification)--data ContentType = CTEmpty-                 | CTComplex-                 | CTSimple-                 | CTNone-     deriving (Show, Eq, Ord)---- ------------------------------------------------------------
− src/Text/XML/HXT/RelaxNG/PatternFunctions.hs 
@@ -1,108 +0,0 @@--- | basic 'Pattern' functions-----module Text.XML.HXT.RelaxNG.PatternFunctions--where--import Text.XML.HXT.RelaxNG.DataTypes----- --------------------------------------------------------------isRelaxEmpty :: Pattern -> Bool-isRelaxEmpty Empty = True-isRelaxEmpty _     = False--isRelaxNotAllowed :: Pattern -> Bool-isRelaxNotAllowed (NotAllowed _) = True-isRelaxNotAllowed _              = False--isRelaxText :: Pattern -> Bool-isRelaxText Text = True-isRelaxText _    = False--isRelaxChoice :: Pattern -> Bool-isRelaxChoice (Choice _ _) = True-isRelaxChoice _            = False--isRelaxInterleave :: Pattern -> Bool-isRelaxInterleave (Interleave _ _) = True-isRelaxInterleave _                = False--isRelaxGroup :: Pattern -> Bool-isRelaxGroup (Group _ _) = True-isRelaxGroup _           = False--isRelaxOneOrMore :: Pattern -> Bool-isRelaxOneOrMore (OneOrMore _) = True-isRelaxOneOrMore _             = False--isRelaxList :: Pattern -> Bool-isRelaxList (List _) = True-isRelaxList _        = False--isRelaxData :: Pattern -> Bool-isRelaxData (Data _ _) = True-isRelaxData _          = False--isRelaxDataExcept :: Pattern -> Bool-isRelaxDataExcept (DataExcept _ _ _) = True-isRelaxDataExcept _                  = False--isRelaxValue :: Pattern -> Bool-isRelaxValue (Value _ _ _) = True-isRelaxValue _             = False--isRelaxAttribute :: Pattern -> Bool-isRelaxAttribute (Attribute _ _) = True-isRelaxAttribute _               = False--isRelaxElement :: Pattern -> Bool-isRelaxElement (Element _ _) = True-isRelaxElement _             = False--isRelaxAfter :: Pattern -> Bool-isRelaxAfter (After _ _) = True-isRelaxAfter _           = False----- | Returns a list of children pattern for each pattern,--- e.g. (Choice p1 p2) = [p1, p2]-getChildrenPattern :: Pattern -> [Pattern]-getChildrenPattern (Choice p1 p2) = [p1, p2]-getChildrenPattern (Interleave p1 p2) = [p1, p2]-getChildrenPattern (Group p1 p2) = [p1, p2]-getChildrenPattern (OneOrMore p) = [p]-getChildrenPattern (List p) = [p]-getChildrenPattern (Element _ p) = [p]-getChildrenPattern (DataExcept _ _ p) = [p]-getChildrenPattern (Attribute _ p) = [p]-getChildrenPattern (After p1 p2) = [p1, p2]-getChildrenPattern _ = []----- | Returns the nameclass of a element- or attribute pattern.--- Otherwise 'NCError' is returned.-getNameClassFromPattern :: Pattern -> NameClass-getNameClassFromPattern (Element nc _) = nc-getNameClassFromPattern (Attribute nc _) = nc-getNameClassFromPattern _ = NCError "Pattern without a NameClass"----- | Returns a string representation of the pattern name-getPatternName :: Pattern -> String-getPatternName (Empty) = "Empty"-getPatternName (NotAllowed _) = "NotAllowed"-getPatternName (Text) = "Text"-getPatternName (Choice _ _) = "Choice"-getPatternName (Interleave _ _) = "Interleave"-getPatternName (Group _ _) = "Group"-getPatternName (OneOrMore _) = "OneOrMore"-getPatternName (List _) = "List"-getPatternName (Data _ _ ) = "Data"-getPatternName (DataExcept _ _ _) = "DataExcept"-getPatternName (Value _ _ _) = "Value"-getPatternName (Attribute _ _) = "Attribute"-getPatternName (Element _ _) = "Element"-getPatternName (After _ _) = "After"
− src/Text/XML/HXT/RelaxNG/PatternToString.hs 
@@ -1,360 +0,0 @@-module Text.XML.HXT.RelaxNG.PatternToString-  ( patternToStringTree-  , patternToFormatedString-  , xmlTreeToPatternStringTree-  , xmlTreeToPatternFormatedString-  , xmlTreeToPatternString-  , nameClassToString-  )-where--import Control.Arrow.ListArrows--import Data.Tree.NTree.TypeDefs--import Text.XML.HXT.DOM.Interface--import Text.XML.HXT.RelaxNG.DataTypes-import Text.XML.HXT.RelaxNG.CreatePattern-import Text.XML.HXT.RelaxNG.Utils---- --------------------------------------------------------------type PatternTree = NTree String---{- |-Returns a string representation of the pattern structure.-(see also: 'createPatternFromXmlTree')--Example:--> Element {}foo (Choice (Choice (Value ("","token") "abc"-> ("foo","www.bar.baz")]))(Data ("http://www.mysql.com","VARCHAR")-> [("length","2"),("maxLength","5")])) (Element {}bar (Group (Element {}baz--The function can @not@ be used to display circular ref-pattern structures.--}--xmlTreeToPatternString :: LA XmlTree String-xmlTreeToPatternString-    = createPatternFromXmlTree-      >>^-      show----- | Returns a string representation of a nameclass.--nameClassToString :: NameClass -> String-nameClassToString AnyName-    = "AnyName"--nameClassToString (AnyNameExcept nc)-    = "AnyNameExcept " ++ nameClassToString nc--nameClassToString (Name uri local)-    = "{" ++ uri ++ "}" ++ local--nameClassToString (NsName uri)-    = "{" ++ uri ++ "}"--nameClassToString (NsNameExcept uri nc)-    = uri ++ "except (NsName) " ++ nameClassToString nc--nameClassToString (NameClassChoice nc1 nc2)-    = nameClassToString nc1 ++ " " ++ nameClassToString nc2--nameClassToString (NCError e)-    = "NameClass Error: " ++ e----- --------------------------------------------------------------{- |-Returns a tree representation of the pattern structure.-The hard work is done by 'formatTree'.--Example:--> +---element {}bar->     |->     +---group->         |->         +---oneOrMore->         |   |->         |   +---attribute AnyName->         |       |->         |       +---text->         |->         +---text--The function can be used to display circular ref-pattern structures.--Example:--> <define name="baz">->   <element name="baz">->     ... <ref name="baz"/> ...->   </element>-> </define>---}--patternToStringTree :: LA Pattern String-patternToStringTree-    = fromSLA [] pattern2PatternTree-      >>^-      (\p -> formatTree id p ++ "\n")----- | Returns a tree representation of the pattern structure.--- (see also: 'createPatternFromXmlTree' and 'patternToStringTree')--xmlTreeToPatternStringTree :: LA XmlTree String-xmlTreeToPatternStringTree-    = createPatternFromXmlTree-      >>>-      patternToStringTree---pattern2PatternTree :: SLA [NameClass] Pattern PatternTree-pattern2PatternTree-    = choiceA-      [ isA isRelaxEmpty      :-> (constA $ NTree "empty" [])-      , isA isRelaxNotAllowed :-> notAllowed2PatternTree-      , isA isRelaxText       :-> (constA $ NTree "text" [])-      , isA isRelaxChoice     :-> choice2PatternTree-      , isA isRelaxInterleave :-> children2PatternTree "interleave"-      , isA isRelaxGroup      :-> children2PatternTree "group"-      , isA isRelaxOneOrMore  :-> children2PatternTree "oneOrMore"-      , isA isRelaxList       :-> children2PatternTree "list"-      , isA isRelaxData       :-> data2PatternTree-      , isA isRelaxDataExcept :-> dataExcept2PatternTree-      , isA isRelaxValue      :-> value2PatternTree-      , isA isRelaxAttribute  :-> createPatternTreeFromElement "attribute"-      , isA isRelaxElement    :-> element2PatternTree-      , isA isRelaxAfter      :-> children2PatternTree "after"-      ]--notAllowed2PatternTree :: SLA [NameClass] Pattern PatternTree-notAllowed2PatternTree-    = arr $ \(NotAllowed (ErrMsg _l sl)) -> NTree "notAllowed" $ map (\ s -> NTree s []) sl---data2PatternTree :: SLA [NameClass] Pattern PatternTree-data2PatternTree-    = arr $ \ (Data d p) -> NTree "data" [ datatype2PatternTree d-                                         , mapping2PatternTree "parameter" p-                                         ]--dataExcept2PatternTree :: SLA [NameClass] Pattern PatternTree-dataExcept2PatternTree-    = this &&& (listA $ arrL getChildrenPattern >>> pattern2PatternTree)-      >>>-      arr2 ( \ (DataExcept d param _) pattern ->-             NTree "dataExcept" ([ datatype2PatternTree d-                                 , mapping2PatternTree "parameter" param-                                 ] ++ pattern)-           )--value2PatternTree :: SLA [NameClass] Pattern PatternTree-value2PatternTree-    = arr $ \ (Value d v c) -> NTree ("value = " ++ v) [ datatype2PatternTree d-                                                       , context2PatternTree c-                                                       ]---createPatternTreeFromElement :: String -> SLA [NameClass] Pattern PatternTree-createPatternTreeFromElement name-    = ( arr getNameClassFromPattern-        &&&-        listA (arrL getChildrenPattern >>> pattern2PatternTree)-      )-      >>>-      arr2 (\nc rl -> NTree (name ++ " " ++ show nc) rl)--children2PatternTree :: String -> SLA [NameClass] Pattern PatternTree-children2PatternTree name-    = listA (arrL getChildrenPattern >>> pattern2PatternTree)-      >>^-      (NTree name)--choice2PatternTree :: SLA [NameClass] Pattern PatternTree-choice2PatternTree-    = ifA ( -- wenn das zweite kind ein noch nicht ausgegebenes element ist,-            -- muss dieses anders behandelt werden-            -- nur fuer bessere formatierung des outputs-            arr (last . getChildrenPattern) >>> isA (isRelaxElement) >>>-            (arr getNameClassFromPattern &&& getState) >>>-            isA(\ (nc, liste) -> not $ elem nc liste)-          )-      ( -- element in status aufnehmen, wird dann nicht mehr vom erste kind ausgegeben-        arr getChildrenPattern-        >>>-        changeState (\s p -> (getNameClassFromPattern (last p)) : s)-        >>>-        ( ( head ^>> pattern2PatternTree )              -- erstes kind normal verarbeiten-          &&&                                           -- zweites kind, das element, verarbeiten-          ( last ^>> createPatternTreeFromElement "element" )-        )-        >>>-        arr2 ( \ l1 l2 -> NTree "choice" [l1, l2] )-      )-      ( children2PatternTree "choice" )---element2PatternTree :: SLA [NameClass] Pattern PatternTree-element2PatternTree-    = ifA ( (arr getNameClassFromPattern &&& getState)-            >>>-            isA (\ (nc, liste) -> elem nc liste)-          )-      ( arr getNameClassFromPattern-        >>>-        arr (\nc -> NTree ("reference to element " ++ show nc) [])-      )-      ( changeState (\ s p -> (getNameClassFromPattern p) : s)-        >>>-        createPatternTreeFromElement "element"-      )---mapping2PatternTree :: String -> [(Prefix, Uri)] -> PatternTree-mapping2PatternTree name mapping-    = NTree name (map (\(a, b) -> NTree (a ++ " = " ++ b) []) mapping)---datatype2PatternTree :: Datatype -> PatternTree-datatype2PatternTree dt-    = NTree (datatype2String dt) []---context2PatternTree :: Context -> PatternTree-context2PatternTree (base, mapping)-    = NTree "context" [ NTree ("base-uri = " ++ base) []-                      , mapping2PatternTree "namespace environment" mapping-                      ]---- ---------------------------------------------------------------- | Returns a formated string representation of the pattern structure.--- (see also: 'createPatternFromXmlTree' and 'patternToFormatedString')-xmlTreeToPatternFormatedString :: LA XmlTree String-xmlTreeToPatternFormatedString-    = createPatternFromXmlTree-      >>>-      fromSLA [] patternToFormatedString---{- |-Returns a formated string representation of the pattern structure.--Example:--> Element {}foo (Choice (Choice ( Value = abc,-> datatypelibrary = http://relaxng.org/ns/structure/1.0, type = token,-> context (base-uri =file://test.rng,-> parameter: xml = http://www.w3.org/XML/1998/namespaces, foo = www.bar.baz),--The function can be used to display circular ref-pattern structures.--}--patternToFormatedString :: SLA [NameClass] Pattern String-patternToFormatedString-    = choiceA-      [ isA isRelaxEmpty      :-> (constA " empty ")-      , isA isRelaxNotAllowed :-> (arr $ \ (NotAllowed errorEnv) -> show errorEnv)-      , isA isRelaxText       :-> (constA " text ")-      , isA isRelaxChoice     :-> children2FormatedString "choice"-      , isA isRelaxInterleave :-> children2FormatedString "interleave"-      , isA isRelaxGroup      :-> children2FormatedString "group"-      , isA isRelaxOneOrMore  :-> children2FormatedString "oneOrMore"-      , isA isRelaxList       :-> children2FormatedString "list"-      , isA isRelaxData       :-> data2FormatedString-      , isA isRelaxDataExcept :-> dataExcept2FormatedString-      , isA isRelaxValue      :-> value2FormatedString-      , isA isRelaxAttribute  :-> createFormatedStringFromElement "attribute"-      , isA isRelaxElement    :-> element2FormatedString-      , isA isRelaxAfter      :-> children2FormatedString "after"-      ]--children2FormatedString :: String -> SLA [NameClass] Pattern String-children2FormatedString name-    = listA (arrL getChildrenPattern >>> patternToFormatedString)-      >>^-      (\ l -> name ++ " (" ++ formatStringListPatt l ++ ") " )--data2FormatedString :: SLA [NameClass] Pattern String-data2FormatedString-    = arr ( \ (Data datatype paramList) ->-            "Data " ++ datatype2String datatype ++ "\n " ++-            mapping2String "parameter" paramList ++ "\n"-          )--dataExcept2FormatedString :: SLA [NameClass] Pattern String-dataExcept2FormatedString- = arr ( \ (DataExcept datatype paramList _) ->-         "DataExcept " ++ show datatype ++ "\n " ++-         mapping2String "parameter" paramList ++ "\n "-       )-   &&&-   ( arr (\ (DataExcept _ _ p) -> p) >>> patternToFormatedString )-   >>>-   arr2 (++)---value2FormatedString :: SLA [NameClass] Pattern String-value2FormatedString- = arr $ \(Value datatype val context) ->-           "Value = " ++ val ++ ", " ++ datatype2String datatype ++-           "\n " ++ context2String context ++ "\n"---element2FormatedString :: SLA [NameClass] Pattern String-element2FormatedString-    = ifA ( (arr getNameClassFromPattern &&& getState)-            >>>-            isA (\ (nc, liste) -> elem nc liste)-          )-      ( arr getNameClassFromPattern-        >>^-        ( \nc -> "reference to element " ++ nameClassToString nc ++ " " )-      )-      ( changeState (\ s p -> (getNameClassFromPattern p) : s)-        >>>-        createFormatedStringFromElement "element"-      )---createFormatedStringFromElement :: String -> SLA [NameClass] Pattern String-createFormatedStringFromElement name-    = ( arr getNameClassFromPattern-        &&&-        ( listA (arrL getChildrenPattern >>> patternToFormatedString)-          >>^-          formatStringListId-        )-      )-      >>>-      arr2 (\ nc rl -> name ++ " " ++ nameClassToString nc ++ " (" ++ rl ++ ")")----- --------------------------------------------------------------mapping2String :: String -> [(Prefix, Uri)] -> String-mapping2String name mapping-    = name ++ ": " ++-      formatStringList id ", " (map (\(a, b) -> a ++ " = " ++ b) mapping)--datatype2String :: Datatype -> String-datatype2String (lib, localName)-    = "datatypelibrary = " ++ getLib ++ ", type = " ++ localName-    where-    getLib = if lib == "" then relaxNamespace else lib--context2String :: Context -> String-context2String (base, mapping)-    = "context (base-uri = " ++ base ++ ", " ++-      mapping2String "namespace environment" mapping ++ ")"---- ------------------------------------------------------------
− src/Text/XML/HXT/RelaxNG/Schema.hs 
@@ -1,3921 +0,0 @@-{- |-   Module     : Text.HXT.RelaxNG.Schema--   Don't edit this module, it's generated by RelaxSchemaToXmlTree---}--module Text.XML.HXT.RelaxNG.Schema-    ( relaxSchemaTree, relaxSchemaArrow )-where--import Text.XML.HXT.DOM.TypeDefs-import Text.XML.HXT.DOM.XmlNode (mkRoot, mkElement, mkAttr, mkText)--import Control.Arrow.ListArrows--relaxSchemaArrow :: ArrowList a => a b XmlTree-relaxSchemaArrow = constA relaxSchemaTree--relaxSchemaTree :: XmlTree-relaxSchemaTree =-  let-  ns1   = "http://relaxng.org/ns/structure/1.0"-  qn1   = mkSNsName "RelaxContext:xml"-  qn2   = mkSNsName "RelaxContextBaseURI"-  qn3   = mkSNsName "RelaxContextDefault"-  qn4   = mkNsName "anyName" ns1-  qn5   = mkNsName "attribute" ns1-  qn6   = mkNsName "choice" ns1-  qn7   = mkNsName "data" ns1-  qn8   = mkSNsName "datatypeLibrary"-  qn9   = mkNsName "define" ns1-  qn10  = mkNsName "element" ns1-  qn11  = mkNsName "empty" ns1-  qn12  = mkNsName "except" ns1-  qn13  = mkNsName "grammar" ns1-  qn14  = mkNsName "group" ns1-  qn15  = mkNsName "interleave" ns1-  qn16  = mkSNsName "name"-  qn17  = mkNsName "name" ns1-  qn18  = mkSNsName "ns"-  qn19  = mkNsName "nsName" ns1-  qn20  = mkNsName "oneOrMore" ns1-  qn21  = mkNsName "ref" ns1-  qn22  = mkNsName "start" ns1-  qn23  = mkNsName "text" ns1-  qn24  = mkSNsName "type"-  qn25  = mkNsName "value" ns1-  in-  mkRoot []-    [ mkElement qn13 []-      [ mkElement qn22 []-        [ mkElement qn6 []-          [ mkElement qn6 []-            [ mkElement qn6 []-              [ mkElement qn6 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn21-                                              [ mkAttr qn16 [ mkText "24" ]-                                              ] []-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "25" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "26" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "27" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "28" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "29" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "30" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "31" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "32" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "33" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "34" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "35" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "36" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "37" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "38" ]-                    ] []-                  ]-                , mkElement qn21-                  [ mkAttr qn16 [ mkText "39" ]-                  ] []-                ]-              , mkElement qn21-                [ mkAttr qn16 [ mkText "42" ]-                ] []-              ]-            , mkElement qn21-              [ mkAttr qn16 [ mkText "43" ]-              ] []-            ]-          , mkElement qn21-            [ mkAttr qn16 [ mkText "44" ]-            ] []-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "44" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "grammar"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn21-                          [ mkAttr qn16 [ mkText "11" ]-                          ] []-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "10" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "22" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "23" ]-                      ] []-                    ]-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "43" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "externalRef"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn5 []-                [ mkElement qn17-                  [ mkAttr qn18 [ mkText "" ]-                  ]-                  [ mkText "href"-                  ]-                , mkElement qn7-                  [ mkAttr qn24 [ mkText "anyURI" ]-                  , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                  ] []-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn6 []-              [ mkElement qn11 [] []-              , mkElement qn20 []-                [ mkElement qn21-                  [ mkAttr qn16 [ mkText "15" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "42" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "notAllowed"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn6 []-              [ mkElement qn11 [] []-              , mkElement qn20 []-                [ mkElement qn21-                  [ mkAttr qn16 [ mkText "15" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "39" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "data"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn5 []-                [ mkElement qn17-                  [ mkAttr qn18 [ mkText "" ]-                  ]-                  [ mkText "type"-                  ]-                , mkElement qn7-                  [ mkAttr qn24 [ mkText "NCName" ]-                  , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                  ] []-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn21-                      [ mkAttr qn16 [ mkText "40" ]-                      ] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "41" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "41" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "except"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "24" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "26" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "27" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "28" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "29" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "30" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "31" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "32" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "33" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "34" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "35" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "36" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "37" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "38" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "39" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "42" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "43" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "44" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "40" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "param"-            ]-          , mkElement qn14 []-            [ mkElement qn5 []-              [ mkElement qn17-                [ mkAttr qn18 [ mkText "" ]-                ]-                [ mkText "name"-                ]-              , mkElement qn7-                [ mkAttr qn24 [ mkText "NCName" ]-                , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                ] []-              ]-            , mkElement qn23 [] []-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "38" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "value"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn5 []-                  [ mkElement qn17-                    [ mkAttr qn18 [ mkText "" ]-                    ]-                    [ mkText "type"-                    ]-                  , mkElement qn7-                    [ mkAttr qn24 [ mkText "NCName" ]-                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                    ] []-                  ]-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn23 [] []-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "37" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "text"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn6 []-              [ mkElement qn11 [] []-              , mkElement qn20 []-                [ mkElement qn21-                  [ mkAttr qn16 [ mkText "15" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "36" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "empty"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn6 []-              [ mkElement qn11 [] []-              , mkElement qn20 []-                [ mkElement qn21-                  [ mkAttr qn16 [ mkText "15" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "35" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "parentRef"-            ]-          , mkElement qn14 []-            [ mkElement qn5 []-              [ mkElement qn17-                [ mkAttr qn18 [ mkText "" ]-                ]-                [ mkText "name"-                ]-              , mkElement qn7-                [ mkAttr qn24 [ mkText "NCName" ]-                , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                ] []-              ]-            , mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "34" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "ref"-            ]-          , mkElement qn14 []-            [ mkElement qn5 []-              [ mkElement qn17-                [ mkAttr qn18 [ mkText "" ]-                ]-                [ mkText "name"-                ]-              , mkElement qn7-                [ mkAttr qn24 [ mkText "NCName" ]-                , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                ] []-              ]-            , mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "33" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "mixed"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "24" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "26" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "27" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "28" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "29" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "30" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "31" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "32" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "33" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "34" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "35" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "36" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "37" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "38" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "39" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "42" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "43" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "44" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "32" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "list"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "24" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "26" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "27" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "28" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "29" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "30" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "31" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "32" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "33" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "34" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "35" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "36" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "37" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "38" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "39" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "42" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "43" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "44" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "31" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "oneOrMore"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "24" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "26" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "27" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "28" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "29" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "30" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "31" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "32" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "33" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "34" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "35" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "36" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "37" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "38" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "39" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "42" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "43" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "44" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "30" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "zeroOrMore"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "24" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "26" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "27" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "28" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "29" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "30" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "31" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "32" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "33" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "34" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "35" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "36" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "37" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "38" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "39" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "42" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "43" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "44" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "29" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "optional"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "24" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "26" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "27" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "28" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "29" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "30" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "31" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "32" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "33" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "34" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "35" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "36" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "37" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "38" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "39" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "42" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "43" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "44" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "28" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "choice"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "24" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "26" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "27" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "28" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "29" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "30" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "31" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "32" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "33" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "34" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "35" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "36" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "37" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "38" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "39" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "42" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "43" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "44" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "27" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "interleave"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "24" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "26" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "27" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "28" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "29" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "30" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "31" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "32" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "33" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "34" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "35" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "36" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "37" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "38" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "39" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "42" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "43" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "44" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "26" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "group"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "24" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "26" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "27" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "28" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "29" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "30" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "31" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "32" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "33" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "34" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "35" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "36" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "37" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "38" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "39" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "42" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "43" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "44" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "25" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "attribute"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn5 []-                  [ mkElement qn17-                    [ mkAttr qn18 [ mkText "" ]-                    ]-                    [ mkText "name"-                    ]-                  , mkElement qn7-                    [ mkAttr qn24 [ mkText "QName" ]-                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                    ] []-                  ]-                , mkElement qn15 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn20 []-                      [ mkElement qn21-                        [ mkAttr qn16 [ mkText "15" ]-                        ] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn21-                          [ mkAttr qn16 [ mkText "17" ]-                          ] []-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "18" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "19" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "20" ]-                      ] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "24" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "26" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "27" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "28" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "29" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "30" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "31" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "32" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "33" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "34" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "35" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "36" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "37" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "38" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "39" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "42" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "43" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "44" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "24" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "element"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn6 []-                [ mkElement qn5 []-                  [ mkElement qn17-                    [ mkAttr qn18 [ mkText "" ]-                    ]-                    [ mkText "name"-                    ]-                  , mkElement qn7-                    [ mkAttr qn24 [ mkText "QName" ]-                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                    ] []-                  ]-                , mkElement qn15 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn20 []-                      [ mkElement qn21-                        [ mkAttr qn16 [ mkText "15" ]-                        ] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn21-                          [ mkAttr qn16 [ mkText "17" ]-                          ] []-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "18" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "19" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "20" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "24" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "26" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "27" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "28" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "29" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "30" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "31" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "32" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "33" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "34" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "35" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "36" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "37" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "38" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "39" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "42" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "43" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "44" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "23" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "include"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn5 []-                [ mkElement qn17-                  [ mkAttr qn18 [ mkText "" ]-                  ]-                  [ mkText "href"-                  ]-                , mkElement qn7-                  [ mkAttr qn24 [ mkText "anyURI" ]-                  , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                  ] []-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn21-                        [ mkAttr qn16 [ mkText "11" ]-                        ] []-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "10" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "21" ]-                      ] []-                    ]-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "22" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "div"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn21-                          [ mkAttr qn16 [ mkText "11" ]-                          ] []-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "10" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "22" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "23" ]-                      ] []-                    ]-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "21" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "div"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn21-                        [ mkAttr qn16 [ mkText "11" ]-                        ] []-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "10" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "21" ]-                      ] []-                    ]-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "20" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "choice"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn21-                        [ mkAttr qn16 [ mkText "17" ]-                        ] []-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "18" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "19" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "20" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "19" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "nsName"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn21-                  [ mkAttr qn16 [ mkText "16" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "18" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "anyName"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn21-                  [ mkAttr qn16 [ mkText "16" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "17" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "name"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn7-              [ mkAttr qn24 [ mkText "QName" ]-              , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-              ] []-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "16" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "except"-            ]-          , mkElement qn15 []-            [ mkElement qn6 []-              [ mkElement qn11 [] []-              , mkElement qn20 []-                [ mkElement qn21-                  [ mkAttr qn16 [ mkText "15" ]-                  ] []-                ]-              ]-            , mkElement qn20 []-              [ mkElement qn6 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn21-                      [ mkAttr qn16 [ mkText "17" ]-                      ] []-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "18" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "19" ]-                    ] []-                  ]-                , mkElement qn21-                  [ mkAttr qn16 [ mkText "20" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "15" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn4 []-            [ mkElement qn12 []-              [ mkElement qn19-                [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                ] []-              ]-            ]-          , mkElement qn6 []-            [ mkElement qn11 [] []-            , mkElement qn20 []-              [ mkElement qn6 []-                [ mkElement qn6 []-                  [ mkElement qn5 []-                    [ mkElement qn4 [] []-                    , mkElement qn23 [] []-                    ]-                  , mkElement qn23 [] []-                  ]-                , mkElement qn21-                  [ mkAttr qn16 [ mkText "0" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "0" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn4 [] []-          , mkElement qn6 []-            [ mkElement qn11 [] []-            , mkElement qn20 []-              [ mkElement qn6 []-                [ mkElement qn6 []-                  [ mkElement qn5 []-                    [ mkElement qn4 [] []-                    , mkElement qn23 [] []-                    ]-                  , mkElement qn23 [] []-                  ]-                , mkElement qn21-                  [ mkAttr qn16 [ mkText "0" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "10" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "define"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn5 []-                  [ mkElement qn17-                    [ mkAttr qn18 [ mkText "" ]-                    ]-                    [ mkText "name"-                    ]-                  , mkElement qn7-                    [ mkAttr qn24 [ mkText "NCName" ]-                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                    ] []-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "combine"-                      ]-                    , mkElement qn6 []-                      [ mkElement qn25-                        [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]-                        , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                        , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/Schema.rng" ]-                        , mkAttr qn8 [ mkText "" ]-                        , mkAttr qn24 [ mkText "token" ]-                        , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                        ]-                        [ mkText "choice"-                        ]-                      , mkElement qn25-                        [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]-                        , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                        , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/Schema.rng" ]-                        , mkAttr qn8 [ mkText "" ]-                        , mkAttr qn24 [ mkText "token" ]-                        , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                        ]-                        [ mkText "interleave"-                        ]-                      ]-                    ]-                  ]-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "24" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "26" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "27" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "28" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "29" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "30" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "31" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "32" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "33" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "34" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "35" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "36" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "37" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "38" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "39" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "42" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "43" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "44" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "11" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "start"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn5 []-                  [ mkElement qn17-                    [ mkAttr qn18 [ mkText "" ]-                    ]-                    [ mkText "combine"-                    ]-                  , mkElement qn6 []-                    [ mkElement qn25-                      [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]-                      , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                      , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/Schema.rng" ]-                      , mkAttr qn8 [ mkText "" ]-                      , mkAttr qn24 [ mkText "token" ]-                      , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                      ]-                      [ mkText "choice"-                      ]-                    , mkElement qn25-                      [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]-                      , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                      , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/Schema.rng" ]-                      , mkAttr qn8 [ mkText "" ]-                      , mkAttr qn24 [ mkText "token" ]-                      , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                      ]-                      [ mkText "interleave"-                      ]-                    ]-                  ]-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "15" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn21-                                                    [ mkAttr qn16 [ mkText "24" ]-                                                    ] []-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "25" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "26" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "27" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "28" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "29" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "30" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "31" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "32" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "33" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "34" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "35" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "36" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "37" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "38" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "39" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "42" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "43" ]-                    ] []-                  ]-                , mkElement qn21-                  [ mkAttr qn16 [ mkText "44" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      ]-    ]
− src/Text/XML/HXT/RelaxNG/SchemaGrammar.hs 
@@ -1,3831 +0,0 @@-{- |-   Module     : Text.HXT.RelaxNG.SchemaGrammar--   Don't edit this module, it's generated by RelaxSchemaToXmlTree---}--module Text.XML.HXT.RelaxNG.SchemaGrammar-    ( relaxSchemaTree, relaxSchemaArrow )-where--import Text.XML.HXT.DOM.TypeDefs-import Text.XML.HXT.DOM.XmlNode (mkRoot, mkElement, mkAttr, mkText)--import Control.Arrow.ListArrows--relaxSchemaArrow :: ArrowList a => a b XmlTree-relaxSchemaArrow = constA relaxSchemaTree--relaxSchemaTree :: XmlTree-relaxSchemaTree =-  let-  ns1   = "http://relaxng.org/ns/structure/1.0"-  qn1   = mkSNsName "RelaxContext:xml"-  qn2   = mkSNsName "RelaxContextBaseURI"-  qn3   = mkSNsName "RelaxContextDefault"-  qn4   = mkNsName "anyName" ns1-  qn5   = mkNsName "attribute" ns1-  qn6   = mkNsName "choice" ns1-  qn7   = mkNsName "data" ns1-  qn8   = mkSNsName "datatypeLibrary"-  qn9   = mkNsName "define" ns1-  qn10  = mkNsName "element" ns1-  qn11  = mkNsName "empty" ns1-  qn12  = mkNsName "except" ns1-  qn13  = mkNsName "grammar" ns1-  qn14  = mkNsName "group" ns1-  qn15  = mkNsName "interleave" ns1-  qn16  = mkSNsName "name"-  qn17  = mkNsName "name" ns1-  qn18  = mkSNsName "ns"-  qn19  = mkNsName "nsName" ns1-  qn20  = mkNsName "oneOrMore" ns1-  qn21  = mkNsName "ref" ns1-  qn22  = mkNsName "start" ns1-  qn23  = mkNsName "text" ns1-  qn24  = mkSNsName "type"-  qn25  = mkNsName "value" ns1-  in-  mkRoot []-    [ mkElement qn13 []-      [ mkElement qn22 []-        [ mkElement qn21-          [ mkAttr qn16 [ mkText "14" ]-          ] []-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "44" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "externalRef"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn5 []-                [ mkElement qn17-                  [ mkAttr qn18 [ mkText "" ]-                  ]-                  [ mkText "href"-                  ]-                , mkElement qn7-                  [ mkAttr qn24 [ mkText "anyURI" ]-                  , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                  ] []-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn6 []-              [ mkElement qn11 [] []-              , mkElement qn20 []-                [ mkElement qn21-                  [ mkAttr qn16 [ mkText "16" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "43" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "notAllowed"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn6 []-              [ mkElement qn11 [] []-              , mkElement qn20 []-                [ mkElement qn21-                  [ mkAttr qn16 [ mkText "16" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "40" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "data"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn5 []-                [ mkElement qn17-                  [ mkAttr qn18 [ mkText "" ]-                  ]-                  [ mkText "type"-                  ]-                , mkElement qn7-                  [ mkAttr qn24 [ mkText "NCName" ]-                  , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                  ] []-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn21-                      [ mkAttr qn16 [ mkText "41" ]-                      ] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "42" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "42" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "except"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "26" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "27" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "28" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "29" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "30" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "31" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "32" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "33" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "34" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "35" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "36" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "37" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "38" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "39" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "40" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "43" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "44" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "14" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "41" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "param"-            ]-          , mkElement qn14 []-            [ mkElement qn5 []-              [ mkElement qn17-                [ mkAttr qn18 [ mkText "" ]-                ]-                [ mkText "name"-                ]-              , mkElement qn7-                [ mkAttr qn24 [ mkText "NCName" ]-                , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                ] []-              ]-            , mkElement qn23 [] []-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "39" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "value"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn5 []-                  [ mkElement qn17-                    [ mkAttr qn18 [ mkText "" ]-                    ]-                    [ mkText "type"-                    ]-                  , mkElement qn7-                    [ mkAttr qn24 [ mkText "NCName" ]-                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                    ] []-                  ]-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn23 [] []-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "38" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "text"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn6 []-              [ mkElement qn11 [] []-              , mkElement qn20 []-                [ mkElement qn21-                  [ mkAttr qn16 [ mkText "16" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "37" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "empty"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn6 []-              [ mkElement qn11 [] []-              , mkElement qn20 []-                [ mkElement qn21-                  [ mkAttr qn16 [ mkText "16" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "36" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "parentRef"-            ]-          , mkElement qn14 []-            [ mkElement qn5 []-              [ mkElement qn17-                [ mkAttr qn18 [ mkText "" ]-                ]-                [ mkText "name"-                ]-              , mkElement qn7-                [ mkAttr qn24 [ mkText "NCName" ]-                , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                ] []-              ]-            , mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "35" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "ref"-            ]-          , mkElement qn14 []-            [ mkElement qn5 []-              [ mkElement qn17-                [ mkAttr qn18 [ mkText "" ]-                ]-                [ mkText "name"-                ]-              , mkElement qn7-                [ mkAttr qn24 [ mkText "NCName" ]-                , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                ] []-              ]-            , mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "34" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "mixed"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "26" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "27" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "28" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "29" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "30" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "31" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "32" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "33" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "34" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "35" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "36" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "37" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "38" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "39" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "40" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "43" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "44" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "14" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "33" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "list"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "26" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "27" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "28" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "29" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "30" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "31" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "32" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "33" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "34" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "35" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "36" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "37" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "38" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "39" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "40" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "43" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "44" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "14" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "32" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "oneOrMore"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "26" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "27" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "28" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "29" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "30" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "31" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "32" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "33" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "34" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "35" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "36" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "37" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "38" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "39" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "40" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "43" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "44" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "14" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "31" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "zeroOrMore"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "26" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "27" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "28" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "29" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "30" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "31" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "32" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "33" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "34" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "35" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "36" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "37" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "38" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "39" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "40" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "43" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "44" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "14" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "30" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "optional"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "26" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "27" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "28" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "29" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "30" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "31" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "32" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "33" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "34" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "35" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "36" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "37" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "38" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "39" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "40" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "43" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "44" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "14" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "29" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "choice"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "26" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "27" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "28" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "29" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "30" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "31" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "32" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "33" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "34" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "35" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "36" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "37" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "38" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "39" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "40" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "43" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "44" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "14" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "28" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "interleave"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "26" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "27" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "28" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "29" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "30" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "31" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "32" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "33" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "34" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "35" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "36" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "37" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "38" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "39" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "40" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "43" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "44" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "14" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "27" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "group"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "26" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "27" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "28" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "29" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "30" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "31" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "32" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "33" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "34" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "35" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "36" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "37" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "38" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "39" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "40" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "43" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "44" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "14" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "26" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "attribute"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn5 []-                  [ mkElement qn17-                    [ mkAttr qn18 [ mkText "" ]-                    ]-                    [ mkText "name"-                    ]-                  , mkElement qn7-                    [ mkAttr qn24 [ mkText "QName" ]-                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                    ] []-                  ]-                , mkElement qn15 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn20 []-                      [ mkElement qn21-                        [ mkAttr qn16 [ mkText "16" ]-                        ] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn21-                          [ mkAttr qn16 [ mkText "18" ]-                          ] []-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "19" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "20" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "21" ]-                      ] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "26" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "27" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "28" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "29" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "30" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "31" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "32" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "33" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "34" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "35" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "36" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "37" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "38" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "39" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "40" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "43" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "44" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "14" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "25" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "element"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn6 []-                [ mkElement qn5 []-                  [ mkElement qn17-                    [ mkAttr qn18 [ mkText "" ]-                    ]-                    [ mkText "name"-                    ]-                  , mkElement qn7-                    [ mkAttr qn24 [ mkText "QName" ]-                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                    ] []-                  ]-                , mkElement qn15 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn20 []-                      [ mkElement qn21-                        [ mkAttr qn16 [ mkText "16" ]-                        ] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn21-                          [ mkAttr qn16 [ mkText "18" ]-                          ] []-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "19" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "20" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "21" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "26" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "27" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "28" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "29" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "30" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "31" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "32" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "33" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "34" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "35" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "36" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "37" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "38" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "39" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "40" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "43" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "44" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "14" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "24" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "include"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn5 []-                [ mkElement qn17-                  [ mkAttr qn18 [ mkText "" ]-                  ]-                  [ mkText "href"-                  ]-                , mkElement qn7-                  [ mkAttr qn24 [ mkText "anyURI" ]-                  , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                  ] []-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn21-                        [ mkAttr qn16 [ mkText "11" ]-                        ] []-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "10" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "22" ]-                      ] []-                    ]-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "23" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "div"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn21-                          [ mkAttr qn16 [ mkText "11" ]-                          ] []-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "10" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "23" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "24" ]-                      ] []-                    ]-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "22" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "div"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn21-                        [ mkAttr qn16 [ mkText "11" ]-                        ] []-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "10" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "22" ]-                      ] []-                    ]-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "21" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "choice"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn21-                        [ mkAttr qn16 [ mkText "18" ]-                        ] []-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "19" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "20" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "21" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "20" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "nsName"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn21-                  [ mkAttr qn16 [ mkText "17" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "19" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "anyName"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn21-                  [ mkAttr qn16 [ mkText "17" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "18" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "name"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn7-              [ mkAttr qn24 [ mkText "QName" ]-              , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-              ] []-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "17" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "except"-            ]-          , mkElement qn15 []-            [ mkElement qn6 []-              [ mkElement qn11 [] []-              , mkElement qn20 []-                [ mkElement qn21-                  [ mkAttr qn16 [ mkText "16" ]-                  ] []-                ]-              ]-            , mkElement qn20 []-              [ mkElement qn6 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn21-                      [ mkAttr qn16 [ mkText "18" ]-                      ] []-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "19" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "20" ]-                    ] []-                  ]-                , mkElement qn21-                  [ mkAttr qn16 [ mkText "21" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "16" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn4 []-            [ mkElement qn12 []-              [ mkElement qn19-                [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                ] []-              ]-            ]-          , mkElement qn6 []-            [ mkElement qn11 [] []-            , mkElement qn20 []-              [ mkElement qn6 []-                [ mkElement qn6 []-                  [ mkElement qn5 []-                    [ mkElement qn4 [] []-                    , mkElement qn23 [] []-                    ]-                  , mkElement qn23 [] []-                  ]-                , mkElement qn21-                  [ mkAttr qn16 [ mkText "0" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "0" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn4 [] []-          , mkElement qn6 []-            [ mkElement qn11 [] []-            , mkElement qn20 []-              [ mkElement qn6 []-                [ mkElement qn6 []-                  [ mkElement qn5 []-                    [ mkElement qn4 [] []-                    , mkElement qn23 [] []-                    ]-                  , mkElement qn23 [] []-                  ]-                , mkElement qn21-                  [ mkAttr qn16 [ mkText "0" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "10" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "define"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn5 []-                  [ mkElement qn17-                    [ mkAttr qn18 [ mkText "" ]-                    ]-                    [ mkText "name"-                    ]-                  , mkElement qn7-                    [ mkAttr qn24 [ mkText "NCName" ]-                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                    ] []-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "combine"-                      ]-                    , mkElement qn6 []-                      [ mkElement qn25-                        [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]-                        , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                        , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/SchemaGrammar.rng" ]-                        , mkAttr qn8 [ mkText "" ]-                        , mkAttr qn24 [ mkText "token" ]-                        , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                        ]-                        [ mkText "choice"-                        ]-                      , mkElement qn25-                        [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]-                        , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                        , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/SchemaGrammar.rng" ]-                        , mkAttr qn8 [ mkText "" ]-                        , mkAttr qn24 [ mkText "token" ]-                        , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                        ]-                        [ mkText "interleave"-                        ]-                      ]-                    ]-                  ]-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn20 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn6 []-                                                    [ mkElement qn21-                                                      [ mkAttr qn16 [ mkText "25" ]-                                                      ] []-                                                    , mkElement qn21-                                                      [ mkAttr qn16 [ mkText "26" ]-                                                      ] []-                                                    ]-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "27" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "28" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "29" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "30" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "31" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "32" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "33" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "34" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "35" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "36" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "37" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "38" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "39" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "40" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "43" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "44" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "14" ]-                    ] []-                  ]-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "11" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "start"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn5 []-                  [ mkElement qn17-                    [ mkAttr qn18 [ mkText "" ]-                    ]-                    [ mkText "combine"-                    ]-                  , mkElement qn6 []-                    [ mkElement qn25-                      [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]-                      , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                      , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/SchemaGrammar.rng" ]-                      , mkAttr qn8 [ mkText "" ]-                      , mkAttr qn24 [ mkText "token" ]-                      , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                      ]-                      [ mkText "choice"-                      ]-                    , mkElement qn25-                      [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]-                      , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                      , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/SchemaGrammar.rng" ]-                      , mkAttr qn8 [ mkText "" ]-                      , mkAttr qn24 [ mkText "token" ]-                      , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                      ]-                      [ mkText "interleave"-                      ]-                    ]-                  ]-                ]-              , mkElement qn14 []-                [ mkElement qn14 []-                  [ mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "ns"-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  , mkElement qn6 []-                    [ mkElement qn11 [] []-                    , mkElement qn5 []-                      [ mkElement qn17-                        [ mkAttr qn18 [ mkText "" ]-                        ]-                        [ mkText "datatypeLibrary"-                        ]-                      , mkElement qn7-                        [ mkAttr qn24 [ mkText "anyURI" ]-                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                        ] []-                      ]-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn20 []-                    [ mkElement qn5 []-                      [ mkElement qn4 []-                        [ mkElement qn12 []-                          [ mkElement qn6 []-                            [ mkElement qn19-                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                              ] []-                            , mkElement qn19-                              [ mkAttr qn18 [ mkText "" ]-                              ] []-                            ]-                          ]-                        ]-                      , mkElement qn23 [] []-                      ]-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn6 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn6 []-                          [ mkElement qn6 []-                            [ mkElement qn6 []-                              [ mkElement qn6 []-                                [ mkElement qn6 []-                                  [ mkElement qn6 []-                                    [ mkElement qn6 []-                                      [ mkElement qn6 []-                                        [ mkElement qn6 []-                                          [ mkElement qn6 []-                                            [ mkElement qn6 []-                                              [ mkElement qn6 []-                                                [ mkElement qn6 []-                                                  [ mkElement qn21-                                                    [ mkAttr qn16 [ mkText "25" ]-                                                    ] []-                                                  , mkElement qn21-                                                    [ mkAttr qn16 [ mkText "26" ]-                                                    ] []-                                                  ]-                                                , mkElement qn21-                                                  [ mkAttr qn16 [ mkText "27" ]-                                                  ] []-                                                ]-                                              , mkElement qn21-                                                [ mkAttr qn16 [ mkText "28" ]-                                                ] []-                                              ]-                                            , mkElement qn21-                                              [ mkAttr qn16 [ mkText "29" ]-                                              ] []-                                            ]-                                          , mkElement qn21-                                            [ mkAttr qn16 [ mkText "30" ]-                                            ] []-                                          ]-                                        , mkElement qn21-                                          [ mkAttr qn16 [ mkText "31" ]-                                          ] []-                                        ]-                                      , mkElement qn21-                                        [ mkAttr qn16 [ mkText "32" ]-                                        ] []-                                      ]-                                    , mkElement qn21-                                      [ mkAttr qn16 [ mkText "33" ]-                                      ] []-                                    ]-                                  , mkElement qn21-                                    [ mkAttr qn16 [ mkText "34" ]-                                    ] []-                                  ]-                                , mkElement qn21-                                  [ mkAttr qn16 [ mkText "35" ]-                                  ] []-                                ]-                              , mkElement qn21-                                [ mkAttr qn16 [ mkText "36" ]-                                ] []-                              ]-                            , mkElement qn21-                              [ mkAttr qn16 [ mkText "37" ]-                              ] []-                            ]-                          , mkElement qn21-                            [ mkAttr qn16 [ mkText "38" ]-                            ] []-                          ]-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "39" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "40" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "43" ]-                      ] []-                    ]-                  , mkElement qn21-                    [ mkAttr qn16 [ mkText "44" ]-                    ] []-                  ]-                , mkElement qn21-                  [ mkAttr qn16 [ mkText "14" ]-                  ] []-                ]-              ]-            ]-          ]-        ]-      , mkElement qn9-        [ mkAttr qn16 [ mkText "14" ]-        ]-        [ mkElement qn10 []-          [ mkElement qn17-            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-            ]-            [ mkText "grammar"-            ]-          , mkElement qn14 []-            [ mkElement qn14 []-              [ mkElement qn14 []-                [ mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "ns"-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                , mkElement qn6 []-                  [ mkElement qn11 [] []-                  , mkElement qn5 []-                    [ mkElement qn17-                      [ mkAttr qn18 [ mkText "" ]-                      ]-                      [ mkText "datatypeLibrary"-                      ]-                    , mkElement qn7-                      [ mkAttr qn24 [ mkText "anyURI" ]-                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]-                      ] []-                    ]-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn5 []-                    [ mkElement qn4 []-                      [ mkElement qn12 []-                        [ mkElement qn6 []-                          [ mkElement qn19-                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]-                            ] []-                          , mkElement qn19-                            [ mkAttr qn18 [ mkText "" ]-                            ] []-                          ]-                        ]-                      ]-                    , mkElement qn23 [] []-                    ]-                  ]-                ]-              ]-            , mkElement qn15 []-              [ mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn21-                    [ mkAttr qn16 [ mkText "16" ]-                    ] []-                  ]-                ]-              , mkElement qn6 []-                [ mkElement qn11 [] []-                , mkElement qn20 []-                  [ mkElement qn6 []-                    [ mkElement qn6 []-                      [ mkElement qn6 []-                        [ mkElement qn21-                          [ mkAttr qn16 [ mkText "11" ]-                          ] []-                        , mkElement qn21-                          [ mkAttr qn16 [ mkText "10" ]-                          ] []-                        ]-                      , mkElement qn21-                        [ mkAttr qn16 [ mkText "23" ]-                        ] []-                      ]-                    , mkElement qn21-                      [ mkAttr qn16 [ mkText "24" ]-                      ] []-                    ]-                  ]-                ]-              ]-            ]-          ]-        ]-      ]-    ]
− src/Text/XML/HXT/RelaxNG/Simplification.hs 
@@ -1,2321 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.RelaxNG.Simplification-   Copyright  : Copyright (C) 2008 Torben Kuseler, Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : stable-   Portability: portable--   The modul creates the simplified form of a Relax NG schema.-   See also chapter 4 of the Relax NG specification.---}---- --------------------------------------------------------------module Text.XML.HXT.RelaxNG.Simplification-  ( createSimpleForm-  , getErrors-  )--where---import Control.Arrow.ListArrows--import           Text.XML.HXT.DOM.Interface-import qualified Text.XML.HXT.DOM.XmlNode as XN-    ( mkAttr-    , mkText-    )--import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlIOStateArrow--import Text.XML.HXT.Arrow.Namespace-    ( processWithNsEnv-    , propagateNamespaces-    )--import Text.XML.HXT.Arrow.Edit-    ( removeWhiteSpace-    )--import Text.XML.HXT.RelaxNG.DataTypes-import Text.XML.HXT.RelaxNG.BasicArrows-import Text.XML.HXT.RelaxNG.CreatePattern-import Text.XML.HXT.RelaxNG.DataTypeLibraries-import Text.XML.HXT.RelaxNG.Utils-import Text.XML.HXT.RelaxNG.Validation-import Text.XML.HXT.RelaxNG.Schema        as S-import Text.XML.HXT.RelaxNG.SchemaGrammar as SG--import Data.Maybe-    ( fromJust-    , fromMaybe-    , isNothing-    )-import Data.List-    ( elemIndices-    , isPrefixOf-    , nub-    , deleteBy-    , find-    , (\\)-    )--import System.Directory-  ( doesFileExist )----- --------------------------------------------------------------{--- 4.1. Annotations: Foreign attributes and elements are removed.-- 4.2. Whitespace:-    - For each element other than value and param, each child that is a string-      containing only whitespace characters is removed. -> fertig-    - Leading and trailing whitespace characters are removed from the value of each name,-      type and combine attribute and from the content of each name element. -> fertig-- 4.3. datatypeLibrary attribute:-    - The value of each datatypeLibary attribute is transformed by escaping disallowed characters-    - For any data or value element that does not have a datatypeLibrary attribute,-      a datatypeLibrary attribute is added.-    - Any datatypeLibrary attribute that is on an element other than data or value is removed.-- 4.4. type attribute of value element--}-simplificationStep1 :: IOSArrow XmlTree XmlTree-simplificationStep1-    = ( {--        - 4.5. href attribute-        - The value of the href attribute on an externalRef or include element is first-        - transformed by escaping disallowed characters-        - The URI reference is then resolved into an absolute form-        - The value of the href attribute will be used to construct an element.-        -}-        ( processHref $< getBaseURI )-        >>>-        -- 4.10 QNames-        processWithNsEnv processEnvNames (toNsEnv [("xml",xmlNamespace)])-        >>>-        -- 4.4 For any data or value element that does not have a datatypeLibrary attribute,-        -- a datatypeLibrary attribute is added.-        -- Wird vorgezogen, da danach der Rest in einem Baumdurchlauf erledigt werden kann-        processdatatypeLib ""-        >>>-        processTopDownWithAttrl-        (-         ( -- 4.1 Foreign attributes and elements are removed-           none-           `when`-           ( ( isElem >>> neg isRoot-               >>>-               getNamespaceUri-               >>>-               isA (\ uri -> (not $ compareURI uri relaxNamespace))-             )-             `orElse`-             ( isAttr-               >>>-               getNamespaceUri-               >>>-               isA (\ uri -> (uri /= "" && (not $ compareURI uri relaxNamespace)))-             )-           )-         )-         >>>-         ( -- 4.2 For each element other than value and param, each child that-           -- is a string containing only whitespace characters is removed.-           ( processChildren removeWhiteSpace-             `whenNot`-             (isRngParam `orElse` isRngValue)-           )-           `when` isElem-         )-         >>>-         ( -- 4.2 Leading and trailing whitespace characters are removed from the value-           -- of each name, type and combine attribute ...-           changeAttrValue normalizeWhitespace-           `when`-           ( isRngAttrName `orElse` isRngAttrType `orElse` isRngAttrCombine)-         )-         >>>-         ( -- 4.2 ... and from the content of each name element.-           processChildren (changeText normalizeWhitespace)-           `when`-           isRngName-         )-         >>>-         ( -- 4.3 The value of each datatypeLibary attribute is transformed-           -- by escaping disallowed characters-           changeAttrValue escapeURI-           `when`-           isRngAttrDatatypeLibrary-         )-         >>>-         ( -- The value of the datatypeLibary attribute has to be a valid URI-           ( mkRelaxError "" $< ( getRngAttrDatatypeLibrary-                                  >>>-                                  arr (\ a -> ( "datatypeLibrary attribute: " ++-                                                a ++ " is not a valid URI"-                                              )-                                      )-                                )-           )-           `when`-           ( isElem-             >>>-             hasRngAttrDatatypeLibrary-             >>>-             getRngAttrDatatypeLibrary >>> isA (not . isRelaxAnyURI)-           )-         )-         >>>-         ( -- 4.3 Any datatypeLibrary attribute that is on an element-           -- other than data or value is removed.-           removeAttr "datatypeLibrary"-           `when`-           ( isElem-             >>>-             neg (isRngData `orElse` isRngValue)-             >>>-             hasRngAttrDatatypeLibrary-           )-         )-         >>>-         ( -- 4.4 For any value element that does not have a type attribute,-           -- a type attribute is added with value token and the value of-           -- the datatypeLibrary attribute is changed to the empty string.-           ( addAttr "type" "token"-             >>>-             addAttr "datatypeLibrary" ""-           )-           `when`-           ( isRngValue >>> neg hasRngAttrType )-         )-        )-      ) `when` collectErrors-    where-    processHref :: String -> IOSArrow XmlTree XmlTree-    processHref uri-        = processChildren-          ( choiceA-            [ ( isElem >>> hasAttr "xml:base" )-              :-> ( ifA ( isExternalRefInclude >>> hasRngAttrHref )-                    ( -- The value of the href attribute is transformed by-                      -- escaping disallowed characters-                      (processAttrl (changeAttrValue escapeURI `when` isRngAttrHref))-                      >>> -- compute the new base uri from the old uri and the href attribute-                      (addAttr "href" $< (absURI "href" $< (absURI "xml:base" uri)))-                      >>>-                      (processHref $< absURI "xml:base" uri)-                    ) -- element without a href attribute, just compute the new base uri-                    (processHref $< absURI "xml:base" uri)-                  )-            , ( isExternalRefInclude >>> hasRngAttrHref )-              :-> ( -- The value of the href attribute is transformed by-                    -- escaping disallowed characters-                    (processAttrl (changeAttrValue escapeURI `when` isRngAttrHref))-                    >>>-                    (addAttr "href" $< absURI "href" uri)-                  )-            , this-              :-> processHref uri-            ]-          )-        where-        absURI :: String -> String -> IOSArrow XmlTree String-        absURI attrName u-            = ( getAttrValue attrName-                >>>-                arr (\ a -> fromMaybe "" (expandURIString a u))-                >>> -- the uri should not have a fragment-identifier (4.5)-                ( arr ("illegal URI, fragment identifier not allowed: " ++)-                  `whenNot`-                  (getFragmentFromURI >>> isA null)-                )-              )--    processEnvNames :: NsEnv -> IOSArrow XmlTree XmlTree-    processEnvNames env-        = ( ( (replaceQNames env $< getAttrValue "name")-              `when`-              ( (isRngElement `orElse` isRngAttribute)-                >>>-                getRngAttrName-                >>>-                isA (elem ':')-              )-            )-            >>>-            ( (addAttrl (getBaseURI >>> createAttrL))-              `when`-              isRngValue-            )-          )-        where-        createAttrL :: IOSArrow String XmlTree-        createAttrL-            = setBaseUri &&& constA (map createAttr env) >>> arr2L (:)-            where--            createAttr :: (XName, XName) -> XmlTree-            createAttr (pre, uri)-                = XN.mkAttr (mkName nm) [XN.mkText (show uri)]-                where-                nm  | isNullXName pre   = "RelaxContextDefault"-                    | otherwise         = contextAttributes ++ show pre--            setBaseUri :: IOSArrow String XmlTree-            setBaseUri = mkAttr (mkName contextBaseAttr) (txt $< this)--        replaceQNames :: NsEnv -> String -> IOSArrow XmlTree XmlTree-        replaceQNames e name-            | isNothing uri-                = mkRelaxError "" ( "No Namespace-Mapping for the prefix " ++ show pre ++-                                    " in the Context of Element: " ++ show name-                                  )-            | otherwise-                = addAttr "name" ( "{" ++ (show . fromJust $ uri) ++ "}" ++ local )-            where-            (pre, local') = span (/= ':') name-            local         = tail local'-            uri         :: Maybe XName-            uri           = lookup (newXName pre) e--    -- The value of the added datatypeLibrary attribute is the value of the-    -- datatypeLibrary attribute of the nearest ancestor element that-    -- has a datatypeLibrary attribute, or the empty string-    -- if there is no such ancestor.-    processdatatypeLib :: (ArrowXml a) => String -> a XmlTree XmlTree-    processdatatypeLib lib-        = processChildren $-          choiceA-          [ ( isElem >>> hasRngAttrDatatypeLibrary-            -- set the new datatypeLibrary value-            )-            :->-            ( processdatatypeLib $< getRngAttrDatatypeLibrary )-          , ( (isRngData `orElse` isRngValue)-              >>>-              neg hasRngAttrDatatypeLibrary-              -- add a datatypeLibrary attribute-            )-            :->-            ( addAttr "datatypeLibrary" lib >>> processdatatypeLib lib )-          , this-            :->-            processdatatypeLib lib-          ]---- ---------------------------------------------------------------{--- 4.5. href attribute-    - see simplificationStep1-- 4.6. externalRef element-    - An element is constructed using the URI reference-      that is the value of href attribute-    - This element must match the syntax for pattern.-    - The element is transformed by recursively applying the rules from-      this subsection and from previous subsections of this section.-    - This must not result in a loop.-    - Any ns attribute on the externalRef element is transferred-      to the referenced element if the referenced element does-      not already have an ns attribute.-    - The externalRef element is then replaced by the referenced element.-- 4.7. include element-    - An element is constructed using the URI reference that is the-      value of href attribute-    - This element must be a grammar element, matching the syntax for grammar.-    - This grammar element is transformed by recursively applying the rules-      from this subsection and from previous subsections of this section.-    - This must not result in a loop.--    - If the include element has a start component, then the grammar element-      must have a start component.-    - If the include element has a start component, then all start components-      are removed from the grammar element.-    - If the include element has a define component, then the grammar element-      must have a define component with the same name.-    - For every define component of the include element, all define components-      with the same name are removed from the grammar element.--    - The include element is transformed into a div element.-    - The attributes of the div element are the attributes of the-      include element other than the href attribute.-    - The children of the div element are the grammar element-    - The grammar element is then renamed to div.--}--simplificationStep2 :: Attributes -> Bool -> Bool -> [Uri] -> [Uri] -> IOSArrow XmlTree XmlTree-simplificationStep2 readOptions validateExternalRef validateInclude extHRefs includeHRefs =-  ( processTopDown (-      ( (importExternalRef $<< (getRngAttrNs &&& getRngAttrHref))-        `when`-        isRngExternalRef-      )-      >>>-      ( (importInclude $< getAttrValue "href")-        `when`-        isRngInclude-      )-    )-  ) `when` collectErrors-  where-  importExternalRef :: String -> String -> IOSArrow XmlTree XmlTree-  importExternalRef ns href-    = ifA ( neg $ constA href-                  >>> getPathFromURI-                  >>> ( isA (not . ("illegal URI" `isPrefixOf`))-                        `guards`-                        isIOA doesFileExist-                      )-          )-        ( mkRelaxError ""-          ( show href ++-            ": can't read URI, referenced in externalRef-Pattern"-          )-        )-        ( ifP (const $ elem href extHRefs)-           -- if the referenced name already exists in the list of processed ref attributes-           -- we have found a loop-            ( mkRelaxError ""-              (  "loop in externalRef-Pattern, " ++-                 formatStringListArr (reverse $ href:extHRefs)-              )-            )-            ( ifA ( if validateExternalRef                                      -- if validation parameters are set-                    then validateDocWithRelax S.relaxSchemaArrow [] href        -- the referenced schema is validated with respect to-                    else none                                                   -- the Relax NG specification-                  )-                ( mkRelaxError ""-                  ( "The content of the schema " ++ show href ++-                    ", referenced in externalRef does not " ++-                    "match the syntax for pattern"-                  )-                )-                ( readForRelax readOptions href-                  >>>-                  simplificationStep1                                           -- perform the transformations from previous steps-                  >>>-                  simplificationStep2 readOptions validateExternalRef validateInclude (href:extHRefs) includeHRefs-                  >>>-                  getChildren -- remove the root node-                  >>>-                  ( -- Any ns attribute on the externalRef element-                    -- is transferred to the referenced element-                    addAttr "ns" ns-                    `when`-                    (getRngAttrNs >>> isA (\a -> a == "" && ns /= ""))-                  )-                )-            )-        )--  importInclude :: String -> IOSArrow XmlTree XmlTree-  importInclude href-    = ifA ( -- test whether the referenced schema exists-            neg $ constA href >>> getPathFromURI >>> isIOA doesFileExist-          )-        ( mkRelaxError ""-          ( "Can't read " ++ show href ++-            ", referenced in include-Pattern"-          )-        )-        ( ifP (const $ elem href includeHRefs)-           -- if the referenced name still exists in the list of processed-           -- ref attributes we have found a loop-            ( mkRelaxError ""-              ( "loop in include-Pattern, " ++-                formatStringListArr (reverse $ href:includeHRefs)-              )-            )-            ( ifA ( if validateInclude                                          -- if the parameter is set-                    then validateDocWithRelax SG.relaxSchemaArrow [] href       -- the referenced schema is validated with respect to-                    else none                                                   -- the Relax NG grammar element-                  )-                ( mkRelaxError ""-                  ( "The content of the schema " ++ show href ++-                    ", referenced in include does not match " ++-                    "the syntax for grammar"-                  )-                )-                ( processInclude href $< ( readForRelax readOptions href-                                           >>>-                                           simplificationStep1                          -- perform the transformations from previous steps-                                           >>>-                                           simplificationStep2 readOptions validateExternalRef validateInclude extHRefs (href:includeHRefs)-                                           >>>-                                           getChildren                                  -- remove the root node-                                         )-                )-            )-        )--  processInclude :: String -> XmlTree -> IOSArrow XmlTree XmlTree-  processInclude href newDoc-    = -- The include element is transformed into a div element.-      setRngNameDiv-      >>>-      -- The attributes of the div element are the attributes of-      -- the include element other than the href attribute.-      removeAttr "href"-      >>>-      checkInclude href newDoc---  insertNewDoc :: XmlTree -> Bool -> [String] -> IOSArrow XmlTree XmlTree-  insertNewDoc newDoc hasStart defNames-    = insertChildrenAt 0 $-        constA newDoc-        >>>-        -- If the include element has a start component, then all start components-        -- are removed from the grammar element.-        (removeStartComponent `whenP` (const hasStart))-        >>>-        -- For every define component of the include element, all define components-        -- with the same name are removed from the grammar element.-        ((removeDefineComponent defNames) `whenP` (const $ defNames /= []))-        >>>-        -- The grammar element is then renamed to div.-        setRngNameDiv---  checkInclude :: String -> XmlTree -> IOSArrow XmlTree XmlTree-  checkInclude href newDoc-    = ifA ( -- If the include element has a start component, then the grammar element-            -- must have a start component.-            hasStartComponent &&& (constA newDoc >>> hasStartComponent)-            >>>-            isA (\ (a, b) -> if a then b else True)-          )-        ( ifA ( -- If the include element has a define component, then the grammar element-                -- must have a define component with the same name.-                getDefineComponents &&& (constA newDoc >>> getDefineComponents)-                >>>-                isA (\ (a, b) -> (diff a b) == [])-              )-            (insertNewDoc newDoc $<< hasStartComponent &&& getDefineComponents)-            ( mkRelaxError ""-              ( "Define-pattern missing in schema " ++ show href ++-                ", referenced in include-pattern"-              )-            )-        )-        ( mkRelaxError ""-          ( "Grammar-element without a start-pattern in schema " ++-            show href ++ ", referenced in include-pattern"-          )-        )-    where-    diff a b = (noDoubles a) \\ (noDoubles b)--  removeStartComponent :: IOSArrow XmlTree XmlTree-  removeStartComponent-    = processChildren $-        choiceA [-          isRngStart :-> none,-          isRngDiv   :-> removeStartComponent,-          this       :-> this-        ]--  removeDefineComponent :: [String] -> IOSArrow XmlTree XmlTree-  removeDefineComponent defNames-    = processChildren $-        choiceA [-          ( isRngDefine-            >>>-            getRngAttrName-            >>>-            isA (\n -> elem n defNames))          :-> none,-          (isElem >>> getName >>> isA (== "div")) :-> (removeDefineComponent defNames),-          (constA "foo" >>> isA (== "foo"))       :-> this-        ]--  hasStartComponent :: IOSArrow XmlTree Bool-  hasStartComponent = listA hasStartComponent' >>> arr (any id)-    where-    hasStartComponent' :: IOSArrow XmlTree Bool-    hasStartComponent'-      = getChildren-        >>>-        choiceA [-          isRngStart :-> (constA True),-          isRngDiv   :-> hasStartComponent',-          this       :-> (constA False)-        ]--  getDefineComponents :: IOSArrow XmlTree [String]-  getDefineComponents = listA getDefineComponents'-                        >>>-                        arr (\xs -> [x | x <- xs, x /= ""])-    where-    getDefineComponents' :: IOSArrow XmlTree String-    getDefineComponents'-      = getChildren-        >>>-        choiceA-        [ isRngDefine :-> getRngAttrName-        , isRngDiv    :-> getDefineComponents'-        , this        :-> constA ""-        ]----- ---------------------------------------------------------------{--- 4.8. name attribute of element and attribute elements-    - The name attribute on an element or attribute element-      is transformed into a name child element.-    - If an attribute element has a name attribute but no ns attribute,-      then an ns="" attribute is added to the name child element.-- 4.9. ns attribute-    - For any name, nsName or value element that does not have-      an ns attribute, an ns attribute is added.-    - any ns attribute that is on an element other than name,-      nsName or value is removed.-- 4.10. QNames-    - For any name element containing a prefix, the prefix is removed-      and an ns attribute is added replacing any existing ns attribute.-    - The value of the added ns attribute is the value to which the-      namespace map of the context of the name element maps the prefix.-    - The context must have a mapping for the prefix.--}-simplificationStep3 :: IOSArrow XmlTree XmlTree-simplificationStep3 =-  ( processTopDown (-      ( -- 4.8 The name attribute on an element or attribute-        -- element is transformed into a name child element-        ( insertChildrenAt 0 (mkRngName none (txt $< getRngAttrName))-        )-        >>>-        ( -- 4.8 If an attribute element has a name attribute but no ns attribute,-          --  then an ns="" attribute is added to the name child element-           (processChildren (addAttr "ns" "" `when` isRngName))-           `when`-           (isRngAttribute >>> hasRngAttrName >>> neg hasRngAttrNs)-        )-        >>>-        removeAttr "name"-      )-      `when`-      ( (isRngElement `orElse` isRngAttribute) >>> hasRngAttrName )-    )-    >>>-    -- 4.9 For any name, nsName or value element that does not have-    -- an ns attribute, an ns attribute is added.-    processnsAttribute ""-    >>>-    processTopDown (-      ( -- 4.9 any ns attribute that is on an element other than name,-        -- nsName or value is removed.-        (removeAttr "ns")-        `when`-        (isElem >>> neg (isRngName `orElse` isRngNsName `orElse` isRngValue))-      )-      >>>-      ( -- 4.10 For any name element containing a prefix, the prefix is removed and an ns attribute-        -- is added replacing any existing ns attribute.-        (replaceNameAttr $< (getChildren >>> isText >>> getText))-        `when`-        isRngName-      )-    )-  ) `when` collectErrors-  where-  replaceNameAttr :: (ArrowXml a) => String -> a XmlTree XmlTree-  replaceNameAttr name-    = (addAttr "ns" pre >>> processChildren (changeText $ const local))-      `whenP`-      (const $ elem '}' name)-    where-    (pre', local') = span (/= '}') name-    pre            = tail pre'-    local          = tail local'--  processnsAttribute :: String -> IOSArrow XmlTree XmlTree-  processnsAttribute name-    = processChildren $-        choiceA [-          -- set the new ns attribute value-          (isElem >>> hasRngAttrNs)-               :-> (processnsAttribute $< getRngAttrNs),-          -- For any name, nsName or value element that does not have-          -- an ns attribute, an ns attribute is added.-          ( isNameNsNameValue >>> neg hasRngAttrNs)-               :-> (addAttr "ns" name >>> processnsAttribute name),-          this :-> (processnsAttribute name)-        ]----- ---------------------------------------------------------------{--- 4.11 Each div element is replaced by its children-- 4.12 Number of child elements-    - A define, oneOrMore, zeroOrMore, optional, list or mixed element-      is transformed so that it has exactly one child element-    - An element element is transformed so that it has exactly two child elements-    - A except element is transformed so that it has exactly one child element-    - If an attribute element has only one child element (a name class), then a text element is added.-    - A choice, group or interleave element is transformed so that it has exactly two child elements.-- 4.13 A mixed element is transformed into an interleaving with a text element-- 4.14 An optional element is transformed into a choice with empty-- 4.15 A zeroOrMore element is transformed into a choice between oneOrMore and empty-- 4.16. Constraints: no transformation is performed, but various constraints are checked.-    - An except element that is a child of an anyName element must not have any anyName descendant elements.-    - An except element that is a child of an nsName element must not have any nsName or anyName-      descendant elements.-    - A name element that occurs as the first child of an attribute element or as the descendant of the-      first child of an attribute element and that has an ns attribute with value equal to the empty-      string must not have content equal to xmlns.-    - A name or nsName element that occurs as the first child of an attribute element or as the-      descendant of the first child of an attribute element must not have an ns attribute with-      value http://www.w3.org/2000/xmlns.-    - A data or value element must be correct in its use of datatypes.--}-simplificationStep4 :: IOSArrow XmlTree XmlTree-simplificationStep4 =-  ( processTopDown (-      ( -- Each div element is replaced by its children.-        (getChildren >>> simplificationStep4)-        `when`-        isRngDiv-      )-      >>>-      ( -- A define, oneOrMore, zeroOrMore, optional, list or mixed element-        -- is transformed so that it has exactly one child element-        ( replaceChildren-          ( mkRngGroup-            (setChangesAttr $< (getName >>> arr ("group-Pattern: " ++)))-            getChildren-          )-        )-        `when`-        (  isDefineOneOrMoreZeroOrMoreOptionalListMixed-           >>>-           noOfChildren (> 1)-        )-      )-      >>>-      ( -- An element element is transformed so that it has exactly two child elements-        ( replaceChildren-          ( ( getChildren >>> isNameAnyNameNsName )-            <+>-            ( mkRngGroup none-              ( getChildren-                >>>-                neg isNameAnyNameNsName-              )-            )-          )-        )-        `when`-        ( isRngElement >>> noOfChildren (> 2) )-      )-      >>>-      ( -- A except element is transformed so that it has exactly one child element.-        replaceChildren ( mkRngChoice none getChildren )-        `when`-        ( isRngExcept >>> noOfChildren (> 1) )-      )-      >>>-      ( -- If an attribute element has only one child element-        -- (a name class), then a text element is added.-        insertChildrenAt 1 (mkRngText none)-        `when`-        ( isRngAttribute >>> noOfChildren (== 1) )-      )-      >>>-      ( -- A choice, group or interleave element is transformed so-        -- that it has exactly two child elements.-        ((wrapPattern2Two $< getName) >>> simplificationStep4)-        `when`-        (  isChoiceGroupInterleave-           >>>-           noOfChildren (\ i -> i > 2 || i == 1)-        )-      )-      >>>-      ( -- A mixed element is transformed into an interleaving with a text element-        ( mkRngInterleave-          ( setChangesAttr "mixed is transformed into an interleave" )-          ( getChildren-            <+>-            mkRngText-            ( setChangesAttr ( "new text-Pattern: mixed is transformed into " ++-                                  " an interleave with text"-                             )-            )-          )-        )-        `when`-        isRngMixed-      )-      >>>-      ( -- An optional element is transformed into a choice with empty-        ( mkRngChoice-          ( setChangesAttr "optional is transformed into a choice" )-          ( getChildren-            <+>-            mkRngEmpty-            ( setChangesAttr ( "new empty-Pattern: optional is transformed " ++-                               " into a choice with empty"-                             )-            )-          )-        )-        `when`-        isRngOptional-      )-      >>>-      ( -- A zeroOrMore element is transformed into a choice between oneOrMore and empty-        ( mkRngChoice-          ( setChangesAttr "zeroOrMore is transformed into a choice" )-          ( ( mkRngOneOrMore-              ( setChangesAttr ( "zeroOrMore is transformed into a " ++-                                   "choice between oneOrMore and empty"-                               )-              )-              getChildren-            )-            <+>-            ( mkRngEmpty-              ( setChangesAttr ( "new empty-Pattern: zeroOrMore is transformed " ++-                                   "into a choice between oneOrMore and empty"-                               )-              )-            )-          )-        )-        `when`-        isRngZeroOrMore-      )-    )-  ) `when` collectErrors----- ---------------------------------------------------------------restrictionsStep1 :: IOSArrow XmlTree XmlTree-restrictionsStep1 =-  ( processTopDown (-      ( ( mkRelaxError ""-          ( "An except element that is a child of an anyName " ++-            "element must not have any anyName descendant elements"-          )-        )-        `when`-        ( isRngAnyName-          >>>-          getChildren-          >>>-          isRngExcept-          >>>-          deep isRngAnyName-        )-      )-      >>>-      ( ( mkRelaxError ""-          ( "An except element that is a child of an nsName element " ++-            "must not have any nsName or anyName descendant elements."-          )-        )-        `when`-        ( isRngNsName-          >>>-          getChildren-          >>>-          isRngExcept-          >>>-          deep (isRngAnyName `orElse` isRngNsName)-        )-      )-      >>>-      ( ( mkRelaxError ""-          ( "A name element that occurs as the first child or descendant of " ++-            "an attribute and has an ns attribute with an empty value must " ++-            "not have content equal to \"xmlns\""-          )-        )-        `when`-        ( isRngAttribute-          >>>-          firstChild-          >>>-          ( multi (isRngName >>> hasRngAttrNs) )-          >>>-          ( ( getRngAttrNs >>> isA null)-            `guards`-            (getChildren >>> getText >>> isA (== "xmlns"))-          )-        )-      )-      >>>-      ( ( mkRelaxError ""-          ( "A name or nsName element that occurs as the first child or " ++-            "descendant of an attribute must not have an ns attribute " ++-            "with value http://www.w3.org/2000/xmlns"-          )-        )-        `when`-        ( isRngAttribute-          >>>-          firstChild-          >>>-          ( multi (isNameNsName >>> hasRngAttrNs) )-          >>>-          getRngAttrNs-          >>>-          isA (compareURI xmlnsNamespace)-        )-      )-      >>> -- A data or value element must be correct in its use of datatypes.-      ( ( checkDatatype $<< getRngAttrDatatypeLibrary &&& getRngAttrType )-        `when`-        ( isRngData `orElse` isRngValue )-      )-    )-  ) `when` collectErrors-  where--  -- the datatypeLibrary attribute must identify a valid datatype library--  checkDatatype :: Uri -> DatatypeName -> IOSArrow XmlTree XmlTree-  checkDatatype libName typeName-      = ifP (const $ elem libName $ map fst datatypeLibraries)-        ( checkType libName typeName allowedDataTypes )-        ( mkRelaxError ""-          ( "DatatypeLibrary " ++ show libName ++ " not found" )-        )-    where-    DTC _ _ allowedDataTypes = fromJust $ lookup libName datatypeLibraries--  -- the type attribute must identify a datatype within the datatype library identified-  -- by the value of the datatypeLibrary attribute.--  checkType :: Uri -> DatatypeName -> AllowedDatatypes -> IOSArrow XmlTree XmlTree-  checkType libName typeName allowedTypes-      = ifP (const $ elem typeName $ map fst allowedTypes)-        ( checkParams typeName libName getParams $<-          ( listA (getChildren >>> isRngParam >>> getRngAttrName) )-        )-       ( mkRelaxError ""-         ( "Datatype " ++ show typeName ++-           " not declared for DatatypeLibrary " ++ show libName-         )-       )-    where-    getParams = fromJust $ lookup typeName allowedTypes--  -- For a data element, the parameter list must be one that is allowed by the datatype--  checkParams :: DatatypeName -> Uri -> AllowedParams -> [ParamName] -> IOSArrow XmlTree XmlTree-  checkParams typeName libName allowedParams paramNames-      = ( mkRelaxError ""-          ( "Param(s): " ++ formatStringListQuot diff ++-            " not allowed for Datatype " ++ show typeName ++-            " in Library " ++-            show ( if null libName-                   then relaxNamespace-                   else libName-                 )-          )-        )-        `when`-        ( isRngData >>> isA (const $ diff /= []) )-      where-      diff = filter (\param -> not $ elem param allowedParams) paramNames----- ---------------------------------------------------------------{--- 4.17. combine attribute-    - For each grammar element, all define elements with the same name are combined together.-    - Similarly, for each grammar element all start elements are combined together.-- 4.18. grammar element-    - A grammar must have a start child element.-    - Transform the top-level pattern p into <grammar><start>p</start></grammar>.-    - Rename define elements so that no two define elements anywhere in the schema-      have the same name. To rename a define element, change the value of its name-      attribute and change the value of the name attribute of all ref and parentRef-      elements that refer to that define element.-    - Move all define elements to be children of the top-level grammar element-    - Replace each nested grammar element by the child of its start element-    - Rename each parentRef element to ref.--}-simplificationStep5 :: IOSArrow XmlTree XmlTree-simplificationStep5-    = ( processTopDown-        ( ( ( ( (deep isRngRelaxError)-                <+>-                ( mkRelaxError "" "A grammar must have a start child element" )-              )-              `when`-              (neg (getChildren >>> isRngStart))-            )-            >>>-            -- For each grammar element, all define elements with the same-            -- name are combined together.-            ( combinePatternList "define" $< (getPatternNamesInGrammar "define" >>> arr nub) )-            >>>-            -- Similarly, for each grammar element all start elements-            -- are combined together.-            ( combinePatternList "start" $< (getPatternNamesInGrammar "start" >>> arr nub) )-          )-          `when`-          isRngGrammar-        )-        >>>-        ( -- transform the top-level pattern p into <grammar><start>p</start></grammar>.-          ( replaceChildren-            ( mkRngGrammar none-              ( mkRngStart none getChildren )-            )-          )-          `when`-          neg (getChildren >>> isRngGrammar)-        )-        >>>-        ( renameDefines $<<-          ( getPatternNamesInGrammar "define"-            >>>-            (createUniqueNames $< (getAndSetCounter "define_id" >>> arr read))-            &&&-            constA []-          )-        )-        >>>-        -- Move all define elements to be children of the top-level grammar element-        ( processChildren-          ( -- root node-            processChildren-            ( -- the first grammar pattern remains unchanged-              ( deleteAllDefines-                <+>-                ( getAllDefines >>> processChildren deleteAllDefines )-              )-              >>>-              processTopDown-              ( ( -- Replace each nested grammar element by the child of its start element-                  ( getChildren >>> isRngStart >>> getChildren )-                  `when`-                  isRngGrammar-                )-                >>>-                ( -- Rename each parentRef element to ref.-                  ( setRngNameRef-                    `when`-                    isRngParentRef-                  )-                )-              )-            )-          )-        )-      ) `when` collectErrors-    where-    getPatternNamesInGrammar :: (ArrowXml a) => String -> a XmlTree [String]-    getPatternNamesInGrammar pattern-        = processChildren-          ( processTopDown ( none `when` isRngGrammar ) )-          >>>-          listA ( (multi (isElem >>> hasRngName pattern))-                  >>>-                  getRngAttrName-                )--    createUniqueNames :: Int -> IOSArrow [String] RefList-    createUniqueNames num-        = arr (\ l -> unique l num)-          >>>-          perform (setParamInt "define_id" $< arr (max num . getNextValue))-        where-        unique :: [String] -> Int -> RefList-        unique []     _    = []-        unique (x:xs) num' = (x, (show num')):(unique xs (num'+1))-        getNextValue :: RefList -> Int-        getNextValue [] = 0-        getNextValue rl = maximum (map (read . snd) rl) + 1--    renameDefines :: RefList -> RefList -> IOSArrow XmlTree XmlTree-    renameDefines ref parentRef-        = processChildren-          ( choiceA-            [ isRngDefine-              :-> ( -- the original name is needed for error messages-                    addAttr defineOrigName $< getRngAttrName-                    >>>-                    -- rename the define-pattern-                    -- the new name is looked up in the ref table-                    addAttr "name" $< ( getRngAttrName-                                        >>>-                                        arr (\n -> fromJust $ lookup n ref)-                                      )-                    >>>-                    renameDefines ref parentRef-                  )-            , isRngGrammar-              :-> ( renameDefines $<< ( ( -- compute all define names in the grammar-                                          getPatternNamesInGrammar "define"-                                          >>>-                                          -- create a new (unique) name for all define names-                                          (createUniqueNames $< (getParamInt 0 "define_id"))-                                        )-                                        &&&-                                        -- set the old ref list to be the new parentRef list-                                        constA ref-                                      )-                  )-            , isRngRef-              :-> ( ifA ( getRngAttrName-                          >>>-                          isA (\name -> (elem name (map fst ref)))-                        )-                    ( -- the original name is needed for error messages-                      addAttr defineOrigName $< getRngAttrName-                      >>>-                      -- rename the ref-pattern-                      -- the new name is looked up in the ref table-                      addAttr "name" $< ( getRngAttrName-                                          >>>-                                          arr (\n -> fromJust $ lookup n ref)-                                        )-                    )-                    ( -- the referenced pattern does not exist in the schema-                      mkRelaxError "" $< ( getRngAttrName-                                           >>>-                                           arr (\ n -> ( "Define-Pattern with name " ++ show n ++-                                                         " referenced in ref-Pattern not " ++-                                                         "found in schema"-                                                       )-                                               )-                                         )-                    )-                  )-            , isRngParentRef -- same as ref, but the parentRef list is used-              :-> ( ifA ( getRngAttrName-                          >>>-                          isA (\name -> (elem name (map fst parentRef)))-                        )-                    ( addAttr defineOrigName $< getRngAttrName-                      >>>-                      addAttr "name" $< ( getRngAttrName-                                          >>>-                                          arr (\n -> fromJust $ lookup n parentRef)-                                        )-                    )-                    ( mkRelaxError "" $<-                      ( getRngAttrName-                        >>>-                        arr (\ n -> ( "Define-Pattern with name " ++ show n ++-                                      " referenced in parentRef-Pattern " ++-                                      "not found in schema"-                                    )-                            )-                      )-                    )-                  )-            , this-              :-> renameDefines ref parentRef-            ]-          )---    getAllDefines :: IOSArrow XmlTree XmlTree-    getAllDefines = multi isRngDefine--    deleteAllDefines :: IOSArrow XmlTree XmlTree-    deleteAllDefines = processTopDown $ none `when` isRngDefine--    combinePatternList :: String -> [String] -> IOSArrow XmlTree XmlTree-    combinePatternList _ [] = this-    combinePatternList pattern (x:xs)-        = (replaceChildren $ combinePattern pattern x)-          >>>-          combinePatternList pattern xs--    -- combine a define- or start-pattern (first parameter) with a-    -- specific name (second parameter)-    combinePattern :: String -> String -> IOSArrow XmlTree XmlTree-    combinePattern pattern name-        = createPatternElems pattern name-          <+>-          (getChildren >>> deletePatternElems pattern name)--    createPatternElems :: String -> String -> IOSArrow XmlTree XmlTree-    createPatternElems pattern name-        = ( ( (listA (getElems pattern name >>> getRngAttrCombine))-              >>>-              checkPatternCombine pattern name-            )-            -- After determining this unique value, the combine attributes are removed.-            &&&-            (listA (getElems pattern name >>> removeAttr "combine")))-          >>> -- ((errorCode::Int,errorMessage::String), result::XmlTrees)-          choiceA-          [ isA (\ ((code,_) , _)   -> code == 0)-            :->-            (mkRelaxError "" $< arr (snd . fst))-          , isA (\ ((code,str) , _) -> code == 1 && str == "")-            :->-            arrL snd-          , isA (\ ((code,str) , _) -> code == 1 && str /= "")-            :->-            ( createPatternElem pattern name $<<-              ( arr (snd . fst) &&& (arr snd) )-            )-          , this-            :->-            ( mkRelaxError ""-              ( "Can't create Pattern: " ++ show pattern ++-                " with name " ++ show name ++ " in createPatternElems"-              )-            )-          ]--    createPatternElem :: (ArrowXml a) => String -> String -> String -> XmlTrees -> a n XmlTree-    createPatternElem pattern name combine trees-        = mkRngElement pattern (mkAttr (mkName "name") (txt name))-          ( ( mkRngElement combine none-              (arrL (const trees) >>> getChildren)-            )-            >>>-            wrapPattern2Two combine-          )--    checkPatternCombine :: (ArrowXml a) => String -> String -> a [String] (Int, String)-    checkPatternCombine pattern name-        = choiceA-          [ -- just one pattern with that name -> ok, no combine is needed-            (isA (\ cl -> length cl == 1))-            :->-            constA (1, "")-          , (isA (\ cl -> (length $ elemIndices "" cl) > 1))-            :->-            constA ( 0-                   , "More than one " ++ pattern ++ "-Pattern: " ++ show name ++-                     " without an combine-attribute in the same grammar"-                   )-          , (isA (\ cl -> (length $ nub $ deleteBy (==) "" cl) > 1))-            :->-            arr (\ cl -> ( 0-                         , "Different combine-Attributes: " ++-                           (formatStringListQuot $ noDoubles cl) ++-                           " for the " ++ pattern ++ "-Pattern " ++-                           show name ++ " in the same grammar"-                         )-                )-          , -- ok -> combine value is returned-            this-            :->-            arr (\ cl -> (1, fromJust $ find (/= "") cl))-          ]--    isElemWithNameValue :: (ArrowXml a) => String -> String -> a XmlTree XmlTree-    isElemWithNameValue ename nvalue-        = ( isElem-            >>>-            hasRngName ename-            >>>-            getRngAttrName-            >>>-            isA (== nvalue)-          )-          `guards` this--    getElems :: (ArrowXml a) => String -> String -> a XmlTree XmlTree-    getElems pattern name-        = getChildren-          >>>-          choiceA-          [ isElemWithNameValue pattern name-            :->-            (this <+> getElems pattern name)-          , isRngGrammar-            :-> none-          , this-            :->-            getElems pattern name-          ]--    deletePatternElems :: (ArrowXml a) => String -> String -> a XmlTree XmlTree-    deletePatternElems pattern name-        = choiceA-          [ isElemWithNameValue pattern name-            :->-            none-          , isRngGrammar-            :-> this-          , this-            :->-            processChildren ( deletePatternElems pattern name )-          ]----- ---------------------------------------------------------------{--- 4.19. define and ref elements-    - Remove any define element that is not reachable.-    - Now, for each element element that is not the child of a define element,-      add a define element to the grammar element,-      and replace the element element by a ref element referring-      to the added define element.-    - For each ref element that is expandable and is a descendant-      of a start element or an element element, expand it by replacing-      the ref element by the child of the define element to which it refers-    - This must not result in a loop.-    - Remove any define element whose child is not an element element.--}-simplificationStep6 :: IOSArrow XmlTree XmlTree-simplificationStep6 =-  ( -- Remove any define element that is not reachable.-    (removeUnreachableDefines $<<< getAllDeepDefines-                                   &&&-                                   constA []-                                   &&&-                                   getRefsFromStartPattern-    )-    >>>-    -- for each element element that is not the child of a define element,-    -- add a define element to the grammar element,-    ( processElements False-      >>>-      processChildren (insertChildrenAt 1 (getParam "elementTable"))-    )-    >>>-    -- For each ref element that is expandable...-    -- Remove any define element whose child is not an element element-    (replaceExpandableRefs [] $< getExpandableDefines >>> deleteExpandableDefines)-  ) `when` collectErrors-  where-  replaceExpandableRefs :: RefList -> Env -> IOSArrow XmlTree XmlTree-  replaceExpandableRefs foundNames defTable-    = choiceA [-        isRngRef-             :-> (ifA ( getRngAttrName-                        >>>-                        isA (\name -> elem name (map fst foundNames))-                      )-                    -- we have found a loop if the name is in the list-                    (mkRelaxError "" $< ( getAttrValue defineOrigName-                                          >>>-                                          arr (\ n -> ( "Recursion in ref-Pattern: " ++-                                                        formatStringListArr (reverse $ (n:) $ map snd foundNames)-                                                      )-                                              )-                                        )-                    )-                    (replaceRef $<< getRngAttrName &&& getAttrValue defineOrigName)-                 ),-        this :-> (processChildren $ replaceExpandableRefs foundNames defTable)-      ]-    where-    replaceRef :: NewName -> OldName -> IOSArrow XmlTree XmlTree-    replaceRef name oldname-      = ( constA (fromJust $ lookup name defTable)-          >>>-          getChildren-          >>>-          replaceExpandableRefs ((name,oldname):foundNames) defTable-        )-        `whenP`-        (const $ elem name $ map fst defTable)---  processElements :: Bool -> IOSArrow XmlTree XmlTree-  processElements parentIsDefine-    = processChildren-      ( choiceA-        [ isRngElement-          :-> ( ifP (const parentIsDefine)-                (processElements False)-                ( processElements' $<< ( getAndSetCounter "define_id"-                                         &&&-                                         getDefineName-                                       )-                )-              )-        , isRngDefine-          :-> processElements True-        , this-          :-> processElements False-        ])-    where-    getDefineName :: IOSArrow XmlTree String-    getDefineName-        = firstChild-          >>>-          fromLA createNameClass-          >>>-          arr show--    processElements' :: NewName -> OldName -> IOSArrow XmlTree XmlTree-    processElements' name oldname-      = storeElement name oldname-        >>>-        mkRngRef (createAttr name oldname) none--    storeElement :: NewName -> OldName -> IOSArrow XmlTree XmlTree-    storeElement name oldname-      = perform $-          ( mkRngDefine-             (createAttr name oldname) (processElements False)-          )-          &&&-          (listA $ getParam "elementTable")-          >>>-          arr2 (:)-          >>>-          setParamList "elementTable"--    createAttr :: NewName -> OldName -> IOSArrow XmlTree XmlTree-    createAttr name oldname-      = mkAttr (mkName "name") (txt name)-        <+>-        mkAttr (mkName defineOrigName) (txt $ "created for element " ++ oldname)--  getExpandableDefines :: (ArrowXml a) => a XmlTree Env-  getExpandableDefines-    = listA $ (multi ( ( isRngDefine-                         >>>-                         getChildren-                         >>>-                         neg isRngElement-                       )-                       `guards`-                       this-                     )-              )-              >>>-              (getRngAttrName &&& this)--  deleteExpandableDefines :: (ArrowXml a) => a XmlTree XmlTree-  deleteExpandableDefines-    = processTopDown $ none-                       `when`-                       ( isRngDefine-                         >>>-                         getChildren-                         >>>-                         neg isRngElement-                       )----- ---------------------------------------------------------------{--- 4.20. notAllowed element-    - An attribute, list, group, interleave, or oneOrMore element that has-      a notAllowed child element is transformed into a notAllowed element.-    - A choice element that has two notAllowed child elements-      is transformed into a notAllowed element-    - A choice element that has one notAllowed child element-      is transformed into its other child element.-    - An except element that has a notAllowed child element is removed.-    - The preceding transformations are applied repeatedly-      until none of them is applicable any more.-    - Any define element that is no longer reachable is removed.-- 4.21. empty element-    - A group, interleave or choice element that has two empty child-      elements is transformed into an empty element.-    - A group or interleave element that has one empty child element-      is transformed into its other child element.-    - A choice element whose second child element is an empty element-      is transformed by interchanging its two child elements.-    - A oneOrMore element that has an empty child element-      is transformed into an empty element.-    - The preceding transformations are applied repeatedly-      until none of them is applicable any more.--}--simplificationStep7 :: IOSArrow XmlTree XmlTree-simplificationStep7-    = ( markTreeChanged 0                               -- 0 = no changes, 1 = changes performed-        >>>-        processTopDownWithAttrl-        ( ( -- An attribute, list, group, interleave, or oneOrMore element that has a-            -- notAllowed child element is transformed into a notAllowed element.-            ( ( mkRngNotAllowed none none-                >>>-                markTreeChanged 1-              )-              `whenNot`                                 -- keep all errors-              (deep isRngRelaxError)-            )-            `when`-            ( isAttributeListGroupInterleaveOneOrMore-              >>>-              getChildren-              >>>-              isRngNotAllowed-            )-          )-          >>>-          ( -- A choice element that has two notAllowed child elements is-            -- transformed into a notAllowed element-            ( mkRngNotAllowed none none-              >>>-              markTreeChanged 1-            )-            `when`-            ( isRngChoice-              >>>-              listA (getChildren >>> isRngNotAllowed)-              >>>-              isA (\s -> length s == 2)-            )-          )-          >>>-          ( -- A choice element that has one notAllowed child element is-            -- transformed into its other child element.-            ( getChildren >>> neg isRngNotAllowed-              >>>-              markTreeChanged 1-            )-            `when`-            ( isRngChoice >>> getChildren >>> isRngNotAllowed )-          )-          >>>-          ( -- An except element that has a notAllowed child element is removed.-            ( ( markTreeChanged 1-                >>>-                none-              )-              `whenNot`                  -- keep all errors-              deep isRngRelaxError-            )-            `when`-            ( isRngExcept >>> getChildren >>> isRngNotAllowed )-          )-          >>> -- transforming the empty pattern (4.21)-          ( -- A group, interleave or choice element that has two empty child elements-            -- is transformed into an empty element.-            ( mkRngEmpty none-              >>>-              markTreeChanged 1-            )-            `when`-            ( isChoiceGroupInterleave-              >>>-              listA (getChildren >>> isRngEmpty)-              >>>-              isA (\s -> length s == 2)-            )-          )-          >>>-          ( -- A group or interleave element that has one empty child element-            -- is transformed into its other child element.-            ( getChildren-              >>>-              neg isRngEmpty-              >>>-              markTreeChanged 1-            )-            `when`-            ( isGroupInterleave >>> getChildren >>> isRngEmpty )-          )-          >>>-          ( -- A choice element whose second child element is an empty element is transformed-            -- by interchanging its two child elements.-            changeChoiceChildren-            `when`-            ( isRngChoice >>> getChildren >>> isRngEmpty )-          )-          >>>-          ( -- A oneOrMore element that has an empty child element-            -- is transformed into an empty element.-            ( mkRngEmpty none-              >>>-              markTreeChanged 1-            )-            `when`-            ( isRngOneOrMore >>> getChildren >>> isRngEmpty )-          )-        )-        >>>-        -- The preceding transformations are applied repeatedly-        -- until none of them is applicable any more.-        ( simplificationStep7-          `when`-          hasTreeChanged-        )-      ) `when` collectErrors-    where-    changeChoiceChildren :: IOSArrow XmlTree XmlTree-    changeChoiceChildren-        = ( ( replaceChildren-              ( mkRngEmpty none-                <+>-                (getChildren >>> neg isRngEmpty)-              )-              >>>-              markTreeChanged 1-            )-            `when`-            ( single (getChildren >>> isElem)           -- first child not "empty" elem-              >>>-              neg isRngEmpty-            )-          )--hasTreeChanged  :: IOSArrow b Int-hasTreeChanged-    = getParamInt 0 "rng:changeTree"-      >>>-      isA (== 1)--markTreeChanged :: Int -> IOSArrow b b-markTreeChanged i-    = perform (setParamInt "rng:changeTree" i)---- ---------------------------------------------------------------simplificationStep8 :: IOSArrow XmlTree XmlTree-simplificationStep8                     -- Remove any define element that is not reachable.-    = ( ( removeUnreachableDefines $<<<-          ( getAllDeepDefines-            &&&-            constA []-            &&&-            getRefsFromStartPattern-          )-        )-        `when` collectErrors-      )----- ---------------------------------------------------------------restrictionsStep2 :: IOSArrow XmlTree XmlTree-restrictionsStep2 =-  processTopDown (-    choiceA [--- 7.1.1. attribute pattern, the following paths are prohibited:---        attribute//(ref | attribute)-      isRngAttribute :->-        ( ( deep isRngRelaxError-            <+>-            ( mkRelaxError $<< (getChangesAttr-                                &&&-                                ( listA ( getChildren-                                          >>>-                                          deep isAttributeRef-                                          >>>-                                          (getName &&& getChangesAttr >>> arr2 (++))-                                        )-                                  >>>-                                  arr (\n -> formatStringListPatt n ++-                                             "Pattern not allowed as descendent(s)" ++-                                             " of a attribute-Pattern"-                                      )-                                )-                               )-            )-          )-          `when`-          ( getChildren >>> deep isAttributeRef )-        ),---- 7.1.2. oneOrMore pattern, the following paths are prohibited:---        oneOrMore//(group | interleave)//attribute-      isRngOneOrMore :->-        ( ( deep isRngRelaxError-            <+>-            ( mkRelaxError $<< (getChangesAttr-                                &&&-                                ( listA ( getChildren-                                          >>>-                                          deep isGroupInterleave-                                          >>>-                                          (getName &&& getChangesAttr >>> arr2 (++))-                                        )-                                  &&&-                                  getChangesAttr-                                  >>>-                                  arr2 (\ n c -> ( formatStringListPatt n ++-                                                   "Pattern not allowed as descendent(s) " ++-                                                   "of a oneOrMore-Pattern" ++-                                                   (if null c then "" else " " ++ show c) ++-                                                   " followed by an attribute descendent"-                                                 )-                                       )-                                )-                               )-            )-          )-          `when`-          ( getChildren >>> deep isGroupInterleave-            >>>-            getChildren >>> deep isRngAttribute-          )-        ),---- 7.1.3. list pattern, the following paths are prohibited:---        list//( list | ref | attribute | text | interleave)-      isRngList :->-        ( ( deep isRngRelaxError-            <+>-            ( mkRelaxError $<< (getChangesAttr-                                &&&-                                ( listA ( getChildren-                                          >>>-                                          deep isAttributeRefTextListInterleave-                                          >>>-                                          (getName &&& getChangesAttr >>> arr2 (++))-                                        )-                                  >>>-                                  arr (\n -> formatStringListPatt n ++-                                             "Pattern not allowed as descendent(s) of a list-Pattern")-                                )-                               )-            )-          )-          `when`-          ( getChildren-            >>>-            deep isAttributeRefTextListInterleave-          )-        ),---- 7.1.4. except in data pattern, the following paths are prohibited:---        data/except//(attribute | ref | text | list | group | interleave | oneOrMore | empty)-      isRngData :->-        ( ( deep isRngRelaxError-            <+>-            ( mkRelaxError $<< (getChangesAttr-                                &&&-                                ( listA (getChildren-                                         >>>-                                         deep isAttributeRefTextListGroupInterleaveOneOrMoreEmpty-                                         >>>-                                         (getName &&& getChangesAttr >>> arr2 (++))-                                        )-                                  >>>-                                  arr (\n -> formatStringListPatt n ++-                                             "Pattern not allowed as descendent(s) of a data/except-Pattern")-                                )-                               )-            )-          )-          `when`-          ( getChildren-            >>>-            isRngExcept-            >>>-            deep isAttributeRefTextListGroupInterleaveOneOrMoreEmpty-          )-        ),---- 7.1.5. start element, the following paths are prohibited:---        start//(attribute | data | value | text | list | group | interleave | oneOrMore | empty)-      isRngStart :->-        ( ( deep isRngRelaxError-            <+>-            ( mkRelaxError $<< (getChangesAttr-                                &&&-                                ( listA (getChildren-                                         >>>-                                         deep (checkElemName [ "attribute", "data", "value", "text", "list",-                                                               "group", "interleave", "oneOrMore", "empty"])-                                         >>>-                                         (getName &&& getChangesAttr >>> arr2 (++))-                                        )-                                  >>>-                                  arr (\n -> formatStringListPatt n ++-                                             "Pattern not allowed as descendent(s) of a start-Pattern")-                                )-                               )-            )-          )-          `when`-          ( getChildren-            >>>-            deep (checkElemName [ "attribute", "data", "value", "text", "list",-                                  "group", "interleave", "oneOrMore", "empty"])-          )-        ),--        this :-> this-      ]-  ) `when` collectErrors----- ---------------------------------------------------------------restrictionsStep3 :: IOSArrow XmlTree XmlTree-restrictionsStep3-    = processTopDown-      ( ( deep isRngRelaxError-          <+>-          ( mkRelaxError "" $<-            ( -- getRngAttrName-              ( getChildren >>> isRngName >>> getChildren >>> getText )-              >>>-              arr (\ n -> ( "Content of element " ++ show n ++ " contains a pattern that can match " ++-                            "a child and a pattern that matches a single string"-                          )-                  )-            )-          )-        )-        `when`-        ( isRngElement-          >>>-          ( getChildren >>. (take 1 . reverse) )-          >>>-          getContentType >>> isA (== CTNone)-        )-      ) `when` collectErrors----getContentType :: IOSArrow XmlTree ContentType-getContentType-    = choiceA-      [ isRngValue      :-> (constA CTSimple)-      , isRngData       :-> processData-      , isRngList       :-> (constA CTSimple)-      , isRngText       :-> (constA CTComplex)-      , isRngRef        :-> (constA CTComplex)-      , isRngEmpty      :-> (constA CTEmpty)-      , isRngAttribute  :-> processAttribute-      , isRngGroup      :-> processGroup-      , isRngInterleave :-> processInterleave-      , isRngOneOrMore  :-> processOneOrMore-      , isRngChoice     :-> processChoice-      ]-    where-    processData :: IOSArrow XmlTree ContentType-    processData-        = ifA (neg (getChildren >>> isRngExcept))-          (constA CTSimple)-          ( getChildren-            >>>-            isRngExcept-            >>>-            getChildren-            >>>-            getContentType-            >>>-            ifP (/= CTNone) (constA CTSimple) (constA CTNone)-          )-    processAttribute :: IOSArrow XmlTree ContentType-    processAttribute-        = ifA ( lastChild-                >>>-                getContentType-                >>>-                isA (/= CTNone)-              )-          (constA CTEmpty)-          (constA CTNone)--    processGroup :: IOSArrow XmlTree ContentType-    processGroup-        = get2ContentTypes-          >>>-          arr2 (\a b -> if isGroupable a b then max a b else CTNone)--    processInterleave :: IOSArrow XmlTree ContentType-    processInterleave-        = get2ContentTypes-          >>>-          arr2 (\a b -> if isGroupable a b then max a b else CTNone)--    processOneOrMore :: IOSArrow XmlTree ContentType-    processOneOrMore-        = ifA ( getChildren-                >>>-                getContentType >>> isA (/= CTNone)-                >>>-                isA (\t -> isGroupable t t)-              )-          ( getChildren >>> getContentType )-          ( constA CTNone )--    processChoice :: IOSArrow XmlTree ContentType-    processChoice-        = get2ContentTypes-          >>>-          arr2 max--    isGroupable :: ContentType -> ContentType -> Bool-    isGroupable CTEmpty   _         = True-    isGroupable _         CTEmpty   = True-    isGroupable CTComplex CTComplex = True-    isGroupable _         _         = False---checkPattern :: IOSArrow (XmlTree, ([NameClass], [NameClass])) XmlTree-checkPattern-    = (\ (_, (a, b)) -> isIn a b) `guardsP` (arr fst)-    where-    isIn :: [NameClass] -> [NameClass] -> Bool-    isIn _ []      = False-    isIn [] _      = False-    isIn (x:xs) ys = (any (overlap x) ys) || isIn xs ys---occur :: String -> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree-occur name fct-    = choiceA-      [ ( isElem >>> hasRngName name )-        :->-        fct-      , isChoiceGroupInterleaveOneOrMore-        :->-        (getChildren >>> occur name fct)-      ]--get2ContentTypes :: IOSArrow XmlTree (ContentType, ContentType)-get2ContentTypes-    = ( ( firstChild >>> getContentType )-        &&&-        ( lastChild  >>> getContentType )-      )---- ----------------------------------------------------------------- Duplicate attributes are not allowed. -> fertig--- Attributes using infinite name classes must be repeated; an attribute element that--- has an anyName or nsName descendant element must have a oneOrMore ancestor element. -> fertig---- berechnet alle define-Namen (fuer ref-Pattern) und Nameclasses der element-Pattern--restrictionsStep4 :: IOSArrow XmlTree XmlTree-restrictionsStep4-    = ( restrictionsStep4' $<-        listA ( deep isRngDefine                                -- get all defines-                >>>-                ( getRngAttrName                                -- get define name-                  &&&-                  ( single ( getChildren-                             >>>-                             getChildren-                             >>>-                             fromLA createNameClass             -- compute the name class from 1. grandchild-                           )-                    `orElse`-                    (constA AnyName)-                  )-                )-              )-      ) `when` collectErrors--restrictionsStep4' :: [(String, NameClass)] -> IOSArrow XmlTree XmlTree-restrictionsStep4' nc =-  processTopDown (-    (-      ( deep isRngRelaxError-        <+>-        ( mkRelaxError "" $<-          ( getRngAttrName-            >>>-            arr (\ n -> ( "Both attribute-pattern occuring in an " ++-                          show n ++ " belong to the same name-class"-                        )-                )-          )-        )-      )-      `when`-      ( (isRngGroup `orElse` isRngInterleave)-        >>>-        ( getChildren-          &&&-          ( firstChild-            >>>-            listA ( occur "attribute" (single getChildren)-                    >>>-                    fromLA createNameClass-                  )-          )-          &&&-          ( lastChild-            >>>-            listA ( occur "attribute" (single getChildren)-                    >>>-                    fromLA createNameClass-                  )-          )-        )-        >>> checkPattern-      )-    )-    >>>-    (-      ( deep isRngRelaxError-        <+>-        ( mkRelaxError ""-          ( "An attribute that has an anyName or nsName descendant element " ++-            "must have a oneOrMore ancestor element"-          )-        )-      )-      `when`-      (isRngElement >>> checkInfiniteAttribute)-    )-    >>>-    ( ( deep isRngRelaxError-        <+>-        ( mkRelaxError ""-          ( "Both element-pattern occuring in an interleave " ++-            "belong to the same name-class"-          )-        )-      )-      `when`-      ( isRngInterleave-        >>>-        ( getChildren-          &&&-          (firstChild >>> listA (occur "ref" this >>> getRngAttrName))-          &&&-          (lastChild  >>> listA (occur "ref" this >>> getRngAttrName))-        )-        >>>-        checkNames-      )-    )-    >>>-    ( ( deep isRngRelaxError-        <+>-        ( mkRelaxError "" "A text pattern must not occur in both children of an interleave" )-      )-      `when`-      (isRngInterleave >>> checkText)-    )-  )-  where-  checkInfiniteAttribute :: IOSArrow XmlTree XmlTree-  checkInfiniteAttribute-    = getChildren-      >>>-      choiceA-      [ isRngOneOrMore :-> none-      , ( isRngAttribute-          >>>-          deep (isRngAnyName `orElse` isRngNsName)-        ) :-> this-      , this :-> checkInfiniteAttribute-      ]--  checkNames :: IOSArrow (XmlTree, ([String], [String])) XmlTree-  checkNames = (arr fst)-               &&&-               (arr (\(_, (a, _)) -> getNameClasses nc a))-               &&&-               (arr (\(_, (_, b)) -> getNameClasses nc b))-               >>>-               checkPattern-    where-    getNameClasses :: [(String, NameClass)] -> [String] -> [NameClass]-    getNameClasses nc' l = map (\x -> fromJust $ lookup x nc') l--  checkText :: IOSArrow XmlTree XmlTree-  checkText-      = ( firstChild >>> occur "text" this )-        `guards`-        ( lastChild  >>> occur "text" this )---- ---------------------------------------------------------------overlap         :: NameClass -> NameClass -> Bool-overlap nc1 nc2-    = any (bothContain nc1 nc2) (representatives nc1 ++ representatives nc2)--bothContain     :: NameClass -> NameClass -> QName -> Bool-bothContain nc1 nc2 qn-    = contains nc1 qn && contains nc2 qn--illegalLocalName        :: LocalName-illegalLocalName        = ""--illegalUri              :: Uri-illegalUri              = "\x1"--representatives         :: NameClass -> [QName]-representatives AnyName-    = [mkQName "" illegalLocalName illegalUri]--representatives (AnyNameExcept nc)-    = (mkQName "" illegalLocalName illegalUri) : (representatives nc)--representatives (NsName ns)-    = [mkQName "" illegalLocalName ns]--representatives (NsNameExcept ns nc)-    = (mkQName "" illegalLocalName ns) : (representatives nc)--representatives (Name ns ln)-    = [mkQName "" ln ns]--representatives (NameClassChoice nc1 nc2)-    = (representatives nc1) ++ (representatives nc2)--representatives _-    = []---- --------------------------------------------------------------------------------------------------------resetStates :: IOSArrow XmlTree XmlTree-resetStates-    = ( perform (constA $ setParamInt "define_id" 0)-        >>>-        perform (constA [] >>> setParamList "elementTable" )-        >>>-        perform (constA $ setParamInt a_numberOfErrors 0)-      )---getAllDeepDefines :: IOSArrow XmlTree Env-getAllDeepDefines-    = listA $ deep isRngDefine-      >>>-      ( getRngAttrName &&& this )----- | Return all reachable defines from the start pattern--getRefsFromStartPattern :: IOSArrow XmlTree [String]-getRefsFromStartPattern-  = listA-    ( getChildren-      >>>-      isRngGrammar-      >>>-      getChildren-      >>>-      isRngStart-      >>>-      deep isRngRef-      >>>-      getRngAttrName-    )--removeUnreachableDefines :: Env -> [String] -> [String] -> IOSArrow XmlTree XmlTree-removeUnreachableDefines allDefs processedDefs reachableDefs-    = ifP (const $ unprocessedDefs /= [])-      ( removeUnreachableDefines allDefs (nextTreeName : processedDefs) $< newReachableDefs )-      ( processChildren $ -- root node-        processChildren $ -- first grammar-        ( none-          `when`-          ( isRngDefine-            >>>-            getRngAttrName-            >>>-            isA (\n -> not $ elem n reachableDefs)-          )-        )-      )-    where-    unprocessedDefs :: [String]-    unprocessedDefs-        = reachableDefs \\ processedDefs--    newReachableDefs :: IOSArrow n [String]-    newReachableDefs-        = constA getTree-          >>>-          listA ( deep isRngRef-                  >>>-                  getRngAttrName-                )-          >>>-          arr (noDoubles . (reachableDefs ++))--    getTree :: XmlTree-    getTree-        = fromJust $ lookup nextTreeName allDefs--    nextTreeName :: String-    nextTreeName-        = head unprocessedDefs----- ----------------------------------------------------------------------------------------------------------checkElemName :: [String] -> IOSArrow XmlTree XmlTree-checkElemName l-    = ( isElem >>> getLocalPart >>> isA (\s -> elem s l) )-      `guards`-      this--wrapPattern2Two :: (ArrowXml a) => String -> a XmlTree XmlTree-wrapPattern2Two name-  = choiceA-    [ noOfChildren (> 2)-      :-> ( replaceChildren ( (mkRngElement name none-                               (getChildren >>. take 2)-                              )-                              <+>-                              (getChildren >>. drop 2)-                            )-            >>>-            wrapPattern2Two name-          )-    , noOfChildren (== 1)-      :-> getChildren-    , this-      :-> this-    ]--mkRelaxError :: String -> String -> IOSArrow n XmlTree-mkRelaxError changesStr errStr-  = perform (getAndSetCounter a_numberOfErrors)-    >>>-    mkRngRelaxError none none-    >>>-    addAttr "desc" errStr-    >>>-    ( addAttr "changes" changesStr-      `whenP`-      (const $ changesStr /= "")-    )--collectErrors :: IOSArrow XmlTree XmlTree-collectErrors-  = none-    `when`-    ( stopAfterFirstError-      >>>-      getParamInt 0 a_numberOfErrors >>> isA (>0)-    )-  where-  stopAfterFirstError = getParamString a_do_not_collect_errors-                        >>>-                        isA (== "1")----- | Returns the list of simplification errors or 'none'-getErrors :: IOSArrow XmlTree XmlTree-getErrors = (getParamInt 0 a_numberOfErrors >>> isA (>0))-            `guards`-            (root [] [multi isRngRelaxError])--setChangesAttr :: String -> IOSArrow XmlTree XmlTree-setChangesAttr str-  = ifA (hasAttr a_relaxSimplificationChanges)-      ( processAttrl $-          changeAttrValue (++ (", " ++ str))-          `when`-          (hasRngName a_relaxSimplificationChanges)-      )-      (mkAttr (mkName a_relaxSimplificationChanges) (txt str))---getChangesAttr :: IOSArrow XmlTree String-getChangesAttr-  = getAttrValue a_relaxSimplificationChanges-    &&&-    getParamString a_output_changes-    >>>-    ifP (\(changes, param) -> changes /= "" && param == "1")-      (arr2 $ \l _ -> " (" ++ l ++ ")")-      (constA "")---getAndSetCounter :: String -> IOSArrow b String-getAndSetCounter name-  = genNewId $< getParamInt 0 name-  where-  genNewId :: Int -> IOSArrow b String-  genNewId i = setParamInt name (i+1) >>> constA (show i)----- ----------------------------------------------------------------------------------------------------------- | Creates the simple form of a Relax NG schema--- (see also: 'relaxOptions')--createSimpleForm :: Attributes -> Bool -> Bool -> Bool -> IOSArrow XmlTree XmlTree-createSimpleForm remainingOptions checkRestrictions validateExternalRef validateInclude-    = traceMsg 2 ("createSimpleForm: " ++ show (remainingOptions, checkRestrictions,validateExternalRef, validateInclude))-      >>>-      ( if checkRestrictions-        then createSimpleWithRest-        else createSimpleWithoutRest-      )-    where--    createSimpleWithRest :: IOSArrow XmlTree XmlTree-    createSimpleWithRest-        = seqA $ concat [ simplificationPart1-                        , return $ traceDoc "relax NG: simplificationPart1 done"-                        , restrictionsPart1-                        , return $ traceDoc "relax NG: restrictionsPart1 done"-                        , simplificationPart2-                        , return $ traceDoc "relax NG simplificationPart2 done"-                        , restrictionsPart2-                        , return $ traceDoc "relax NG: restrictionsPart2 done"-                        , finalCleanUp-                        , return $ traceDoc "relax NG: finalCleanUp done"-                        ]--    createSimpleWithoutRest :: IOSArrow XmlTree XmlTree-    createSimpleWithoutRest-        = seqA $ concat [ simplificationPart1-                        , simplificationPart2-                        , finalCleanUp-                        ]-    simplificationPart1 :: [IOSArrow XmlTree XmlTree]-    simplificationPart1-        = [ propagateNamespaces-          , simplificationStep1-          , simplificationStep2 remainingOptions validateExternalRef validateInclude [] []-          , simplificationStep3-          , simplificationStep4-          ]--    simplificationPart2 :: [IOSArrow XmlTree XmlTree]-    simplificationPart2-        = [ simplificationStep5-          , simplificationStep6-          , simplificationStep7-          , simplificationStep8-          ]--    restrictionsPart1 :: [IOSArrow XmlTree XmlTree]-    restrictionsPart1-        = [ restrictionsStep1 ]--    restrictionsPart2 :: [IOSArrow XmlTree XmlTree]-    restrictionsPart2-        = [ restrictionsStep2-          , restrictionsStep3-          , restrictionsStep4-          ]--    finalCleanUp :: [IOSArrow XmlTree XmlTree]-    finalCleanUp-        = [ cleanUp-          , resetStates-          ]--    cleanUp :: IOSArrow XmlTree XmlTree-    cleanUp = processTopDown $-              removeAttr a_relaxSimplificationChanges-              >>>-              removeAttr defineOrigName---- -------------------------------------------------------------------------------------------------------
− src/Text/XML/HXT/RelaxNG/Unicode/Blocks.hs 
@@ -1,229 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.RelaxNG.Unicode.Blocks-   Copyright  : Copyright (C) 2005 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : experimental-   Portability: portable-   Version    : $Id$--   Unicode Code Blocks--   don't edit this module-   it's generated from 'http:\/\/www.unicode.org\/Public\/UNIDATA\/Blocks.txt'--}---- --------------------------------------------------------------module Text.XML.HXT.RelaxNG.Unicode.Blocks-  ( codeBlocks )-where---- --------------------------------------------------------------codeBlocks        :: [(String, (Char, Char))]-codeBlocks =-    [ ( "BasicLatin",   ( '\x0000', '\x007F') )-    , ( "Latin-1Supplement",    ( '\x0080', '\x00FF') )-    , ( "LatinExtended-A",      ( '\x0100', '\x017F') )-    , ( "LatinExtended-B",      ( '\x0180', '\x024F') )-    , ( "IPAExtensions",        ( '\x0250', '\x02AF') )-    , ( "SpacingModifierLetters",       ( '\x02B0', '\x02FF') )-    , ( "CombiningDiacriticalMarks",    ( '\x0300', '\x036F') )-    , ( "GreekandCoptic",       ( '\x0370', '\x03FF') )-    , ( "Cyrillic",     ( '\x0400', '\x04FF') )-    , ( "CyrillicSupplement",   ( '\x0500', '\x052F') )-    , ( "Armenian",     ( '\x0530', '\x058F') )-    , ( "Hebrew",       ( '\x0590', '\x05FF') )-    , ( "Arabic",       ( '\x0600', '\x06FF') )-    , ( "Syriac",       ( '\x0700', '\x074F') )-    , ( "ArabicSupplement",     ( '\x0750', '\x077F') )-    , ( "Thaana",       ( '\x0780', '\x07BF') )-    , ( "NKo",  ( '\x07C0', '\x07FF') )-    , ( "Samaritan",    ( '\x0800', '\x083F') )-    , ( "Devanagari",   ( '\x0900', '\x097F') )-    , ( "Bengali",      ( '\x0980', '\x09FF') )-    , ( "Gurmukhi",     ( '\x0A00', '\x0A7F') )-    , ( "Gujarati",     ( '\x0A80', '\x0AFF') )-    , ( "Oriya",        ( '\x0B00', '\x0B7F') )-    , ( "Tamil",        ( '\x0B80', '\x0BFF') )-    , ( "Telugu",       ( '\x0C00', '\x0C7F') )-    , ( "Kannada",      ( '\x0C80', '\x0CFF') )-    , ( "Malayalam",    ( '\x0D00', '\x0D7F') )-    , ( "Sinhala",      ( '\x0D80', '\x0DFF') )-    , ( "Thai", ( '\x0E00', '\x0E7F') )-    , ( "Lao",  ( '\x0E80', '\x0EFF') )-    , ( "Tibetan",      ( '\x0F00', '\x0FFF') )-    , ( "Myanmar",      ( '\x1000', '\x109F') )-    , ( "Georgian",     ( '\x10A0', '\x10FF') )-    , ( "HangulJamo",   ( '\x1100', '\x11FF') )-    , ( "Ethiopic",     ( '\x1200', '\x137F') )-    , ( "EthiopicSupplement",   ( '\x1380', '\x139F') )-    , ( "Cherokee",     ( '\x13A0', '\x13FF') )-    , ( "UnifiedCanadianAboriginalSyllabics",   ( '\x1400', '\x167F') )-    , ( "Ogham",        ( '\x1680', '\x169F') )-    , ( "Runic",        ( '\x16A0', '\x16FF') )-    , ( "Tagalog",      ( '\x1700', '\x171F') )-    , ( "Hanunoo",      ( '\x1720', '\x173F') )-    , ( "Buhid",        ( '\x1740', '\x175F') )-    , ( "Tagbanwa",     ( '\x1760', '\x177F') )-    , ( "Khmer",        ( '\x1780', '\x17FF') )-    , ( "Mongolian",    ( '\x1800', '\x18AF') )-    , ( "UnifiedCanadianAboriginalSyllabicsExtended",   ( '\x18B0', '\x18FF') )-    , ( "Limbu",        ( '\x1900', '\x194F') )-    , ( "TaiLe",        ( '\x1950', '\x197F') )-    , ( "NewTaiLue",    ( '\x1980', '\x19DF') )-    , ( "KhmerSymbols", ( '\x19E0', '\x19FF') )-    , ( "Buginese",     ( '\x1A00', '\x1A1F') )-    , ( "TaiTham",      ( '\x1A20', '\x1AAF') )-    , ( "Balinese",     ( '\x1B00', '\x1B7F') )-    , ( "Sundanese",    ( '\x1B80', '\x1BBF') )-    , ( "Lepcha",       ( '\x1C00', '\x1C4F') )-    , ( "OlChiki",      ( '\x1C50', '\x1C7F') )-    , ( "VedicExtensions",      ( '\x1CD0', '\x1CFF') )-    , ( "PhoneticExtensions",   ( '\x1D00', '\x1D7F') )-    , ( "PhoneticExtensionsSupplement", ( '\x1D80', '\x1DBF') )-    , ( "CombiningDiacriticalMarksSupplement",  ( '\x1DC0', '\x1DFF') )-    , ( "LatinExtendedAdditional",      ( '\x1E00', '\x1EFF') )-    , ( "GreekExtended",        ( '\x1F00', '\x1FFF') )-    , ( "GeneralPunctuation",   ( '\x2000', '\x206F') )-    , ( "SuperscriptsandSubscripts",    ( '\x2070', '\x209F') )-    , ( "CurrencySymbols",      ( '\x20A0', '\x20CF') )-    , ( "CombiningDiacriticalMarksforSymbols",  ( '\x20D0', '\x20FF') )-    , ( "LetterlikeSymbols",    ( '\x2100', '\x214F') )-    , ( "NumberForms",  ( '\x2150', '\x218F') )-    , ( "Arrows",       ( '\x2190', '\x21FF') )-    , ( "MathematicalOperators",        ( '\x2200', '\x22FF') )-    , ( "MiscellaneousTechnical",       ( '\x2300', '\x23FF') )-    , ( "ControlPictures",      ( '\x2400', '\x243F') )-    , ( "OpticalCharacterRecognition",  ( '\x2440', '\x245F') )-    , ( "EnclosedAlphanumerics",        ( '\x2460', '\x24FF') )-    , ( "BoxDrawing",   ( '\x2500', '\x257F') )-    , ( "BlockElements",        ( '\x2580', '\x259F') )-    , ( "GeometricShapes",      ( '\x25A0', '\x25FF') )-    , ( "MiscellaneousSymbols", ( '\x2600', '\x26FF') )-    , ( "Dingbats",     ( '\x2700', '\x27BF') )-    , ( "MiscellaneousMathematicalSymbols-A",   ( '\x27C0', '\x27EF') )-    , ( "SupplementalArrows-A", ( '\x27F0', '\x27FF') )-    , ( "BraillePatterns",      ( '\x2800', '\x28FF') )-    , ( "SupplementalArrows-B", ( '\x2900', '\x297F') )-    , ( "MiscellaneousMathematicalSymbols-B",   ( '\x2980', '\x29FF') )-    , ( "SupplementalMathematicalOperators",    ( '\x2A00', '\x2AFF') )-    , ( "MiscellaneousSymbolsandArrows",        ( '\x2B00', '\x2BFF') )-    , ( "Glagolitic",   ( '\x2C00', '\x2C5F') )-    , ( "LatinExtended-C",      ( '\x2C60', '\x2C7F') )-    , ( "Coptic",       ( '\x2C80', '\x2CFF') )-    , ( "GeorgianSupplement",   ( '\x2D00', '\x2D2F') )-    , ( "Tifinagh",     ( '\x2D30', '\x2D7F') )-    , ( "EthiopicExtended",     ( '\x2D80', '\x2DDF') )-    , ( "CyrillicExtended-A",   ( '\x2DE0', '\x2DFF') )-    , ( "SupplementalPunctuation",      ( '\x2E00', '\x2E7F') )-    , ( "CJKRadicalsSupplement",        ( '\x2E80', '\x2EFF') )-    , ( "KangxiRadicals",       ( '\x2F00', '\x2FDF') )-    , ( "IdeographicDescriptionCharacters",     ( '\x2FF0', '\x2FFF') )-    , ( "CJKSymbolsandPunctuation",     ( '\x3000', '\x303F') )-    , ( "Hiragana",     ( '\x3040', '\x309F') )-    , ( "Katakana",     ( '\x30A0', '\x30FF') )-    , ( "Bopomofo",     ( '\x3100', '\x312F') )-    , ( "HangulCompatibilityJamo",      ( '\x3130', '\x318F') )-    , ( "Kanbun",       ( '\x3190', '\x319F') )-    , ( "BopomofoExtended",     ( '\x31A0', '\x31BF') )-    , ( "CJKStrokes",   ( '\x31C0', '\x31EF') )-    , ( "KatakanaPhoneticExtensions",   ( '\x31F0', '\x31FF') )-    , ( "EnclosedCJKLettersandMonths",  ( '\x3200', '\x32FF') )-    , ( "CJKCompatibility",     ( '\x3300', '\x33FF') )-    , ( "CJKUnifiedIdeographsExtensionA",       ( '\x3400', '\x4DBF') )-    , ( "YijingHexagramSymbols",        ( '\x4DC0', '\x4DFF') )-    , ( "CJKUnifiedIdeographs", ( '\x4E00', '\x9FFF') )-    , ( "YiSyllables",  ( '\xA000', '\xA48F') )-    , ( "YiRadicals",   ( '\xA490', '\xA4CF') )-    , ( "Lisu", ( '\xA4D0', '\xA4FF') )-    , ( "Vai",  ( '\xA500', '\xA63F') )-    , ( "CyrillicExtended-B",   ( '\xA640', '\xA69F') )-    , ( "Bamum",        ( '\xA6A0', '\xA6FF') )-    , ( "ModifierToneLetters",  ( '\xA700', '\xA71F') )-    , ( "LatinExtended-D",      ( '\xA720', '\xA7FF') )-    , ( "SylotiNagri",  ( '\xA800', '\xA82F') )-    , ( "CommonIndicNumberForms",       ( '\xA830', '\xA83F') )-    , ( "Phags-pa",     ( '\xA840', '\xA87F') )-    , ( "Saurashtra",   ( '\xA880', '\xA8DF') )-    , ( "DevanagariExtended",   ( '\xA8E0', '\xA8FF') )-    , ( "KayahLi",      ( '\xA900', '\xA92F') )-    , ( "Rejang",       ( '\xA930', '\xA95F') )-    , ( "HangulJamoExtended-A", ( '\xA960', '\xA97F') )-    , ( "Javanese",     ( '\xA980', '\xA9DF') )-    , ( "Cham", ( '\xAA00', '\xAA5F') )-    , ( "MyanmarExtended-A",    ( '\xAA60', '\xAA7F') )-    , ( "TaiViet",      ( '\xAA80', '\xAADF') )-    , ( "MeeteiMayek",  ( '\xABC0', '\xABFF') )-    , ( "HangulSyllables",      ( '\xAC00', '\xD7AF') )-    , ( "HangulJamoExtended-B", ( '\xD7B0', '\xD7FF') )-    , ( "HighSurrogates",       ( '\xD800', '\xDB7F') )-    , ( "HighPrivateUseSurrogates",     ( '\xDB80', '\xDBFF') )-    , ( "LowSurrogates",        ( '\xDC00', '\xDFFF') )-    , ( "PrivateUseArea",       ( '\xE000', '\xF8FF') )-    , ( "CJKCompatibilityIdeographs",   ( '\xF900', '\xFAFF') )-    , ( "AlphabeticPresentationForms",  ( '\xFB00', '\xFB4F') )-    , ( "ArabicPresentationForms-A",    ( '\xFB50', '\xFDFF') )-    , ( "VariationSelectors",   ( '\xFE00', '\xFE0F') )-    , ( "VerticalForms",        ( '\xFE10', '\xFE1F') )-    , ( "CombiningHalfMarks",   ( '\xFE20', '\xFE2F') )-    , ( "CJKCompatibilityForms",        ( '\xFE30', '\xFE4F') )-    , ( "SmallFormVariants",    ( '\xFE50', '\xFE6F') )-    , ( "ArabicPresentationForms-B",    ( '\xFE70', '\xFEFF') )-    , ( "HalfwidthandFullwidthForms",   ( '\xFF00', '\xFFEF') )-    , ( "Specials",     ( '\xFFF0', '\xFFFF') )-    , ( "LinearBSyllabary",     ( '\x10000', '\x1007F') )-    , ( "LinearBIdeograms",     ( '\x10080', '\x100FF') )-    , ( "AegeanNumbers",        ( '\x10100', '\x1013F') )-    , ( "AncientGreekNumbers",  ( '\x10140', '\x1018F') )-    , ( "AncientSymbols",       ( '\x10190', '\x101CF') )-    , ( "PhaistosDisc", ( '\x101D0', '\x101FF') )-    , ( "Lycian",       ( '\x10280', '\x1029F') )-    , ( "Carian",       ( '\x102A0', '\x102DF') )-    , ( "OldItalic",    ( '\x10300', '\x1032F') )-    , ( "Gothic",       ( '\x10330', '\x1034F') )-    , ( "Ugaritic",     ( '\x10380', '\x1039F') )-    , ( "OldPersian",   ( '\x103A0', '\x103DF') )-    , ( "Deseret",      ( '\x10400', '\x1044F') )-    , ( "Shavian",      ( '\x10450', '\x1047F') )-    , ( "Osmanya",      ( '\x10480', '\x104AF') )-    , ( "CypriotSyllabary",     ( '\x10800', '\x1083F') )-    , ( "ImperialAramaic",      ( '\x10840', '\x1085F') )-    , ( "Phoenician",   ( '\x10900', '\x1091F') )-    , ( "Lydian",       ( '\x10920', '\x1093F') )-    , ( "Kharoshthi",   ( '\x10A00', '\x10A5F') )-    , ( "OldSouthArabian",      ( '\x10A60', '\x10A7F') )-    , ( "Avestan",      ( '\x10B00', '\x10B3F') )-    , ( "InscriptionalParthian",        ( '\x10B40', '\x10B5F') )-    , ( "InscriptionalPahlavi", ( '\x10B60', '\x10B7F') )-    , ( "OldTurkic",    ( '\x10C00', '\x10C4F') )-    , ( "RumiNumeralSymbols",   ( '\x10E60', '\x10E7F') )-    , ( "Kaithi",       ( '\x11080', '\x110CF') )-    , ( "Cuneiform",    ( '\x12000', '\x123FF') )-    , ( "CuneiformNumbersandPunctuation",       ( '\x12400', '\x1247F') )-    , ( "EgyptianHieroglyphs",  ( '\x13000', '\x1342F') )-    , ( "ByzantineMusicalSymbols",      ( '\x1D000', '\x1D0FF') )-    , ( "MusicalSymbols",       ( '\x1D100', '\x1D1FF') )-    , ( "AncientGreekMusicalNotation",  ( '\x1D200', '\x1D24F') )-    , ( "TaiXuanJingSymbols",   ( '\x1D300', '\x1D35F') )-    , ( "CountingRodNumerals",  ( '\x1D360', '\x1D37F') )-    , ( "MathematicalAlphanumericSymbols",      ( '\x1D400', '\x1D7FF') )-    , ( "MahjongTiles", ( '\x1F000', '\x1F02F') )-    , ( "DominoTiles",  ( '\x1F030', '\x1F09F') )-    , ( "EnclosedAlphanumericSupplement",       ( '\x1F100', '\x1F1FF') )-    , ( "EnclosedIdeographicSupplement",        ( '\x1F200', '\x1F2FF') )-    , ( "CJKUnifiedIdeographsExtensionB",       ( '\x20000', '\x2A6DF') )-    , ( "CJKUnifiedIdeographsExtensionC",       ( '\x2A700', '\x2B73F') )-    , ( "CJKCompatibilityIdeographsSupplement", ( '\x2F800', '\x2FA1F') )-    , ( "Tags", ( '\xE0000', '\xE007F') )-    , ( "VariationSelectorsSupplement", ( '\xE0100', '\xE01EF') )-    , ( "SupplementaryPrivateUseArea-A",        ( '\xF0000', '\xFFFFF') )-    , ( "SupplementaryPrivateUseArea-B",        ( '\x100000', '\x10FFFF') )-    ]---- -------------------------------------------------------------
− src/Text/XML/HXT/RelaxNG/Unicode/CharProps.hs 
@@ -1,3945 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.RelaxNG.Unicode.CharProps-   Copyright  : Copyright (C) 2005 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : experimental-   Portability: portable-   Version    : $Id$--   Unicode character properties--   don't edit this module-   it's generated from 'http:\/\/www.unicode.org\/Public\/UNIDATA\/UnicodeData.txt'---}---- --------------------------------------------------------------module Text.XML.HXT.RelaxNG.Unicode.CharProps-  ( isUnicodeC-  , isUnicodeCc-  , isUnicodeCf-  , isUnicodeCo-  , isUnicodeCs-  , isUnicodeL-  , isUnicodeLl-  , isUnicodeLm-  , isUnicodeLo-  , isUnicodeLt-  , isUnicodeLu-  , isUnicodeM-  , isUnicodeMc-  , isUnicodeMe-  , isUnicodeMn-  , isUnicodeN-  , isUnicodeNd-  , isUnicodeNl-  , isUnicodeNo-  , isUnicodeP-  , isUnicodePc-  , isUnicodePd-  , isUnicodePe-  , isUnicodePf-  , isUnicodePi-  , isUnicodePo-  , isUnicodePs-  , isUnicodeS-  , isUnicodeSc-  , isUnicodeSk-  , isUnicodeSm-  , isUnicodeSo-  , isUnicodeZ-  , isUnicodeZl-  , isUnicodeZp-  , isUnicodeZs-  )-where---- --------------------------------------------------------------isInList        :: Char -> [(Char, Char)] -> Bool-isInList i      =-   foldr (\(lb, ub) b -> i >= lb && (i <= ub || b)) False---- --------------------------------------------------------------isUnicodeC      :: Char -> Bool-isUnicodeC c-  = isInList c-    [ ('\NUL','\US')-    , ('\DEL','\159')-    , ('\173','\173')-    , ('\1536','\1539')-    , ('\1757','\1757')-    , ('\1807','\1807')-    , ('\6068','\6069')-    , ('\8203','\8207')-    , ('\8234','\8238')-    , ('\8288','\8292')-    , ('\8298','\8303')-    , ('\55296','\55296')-    , ('\56191','\56192')-    , ('\56319','\56320')-    , ('\57343','\57344')-    , ('\63743','\63743')-    , ('\65279','\65279')-    , ('\65529','\65531')-    , ('\69821','\69821')-    , ('\119155','\119162')-    , ('\917505','\917505')-    , ('\917536','\917631')-    , ('\983040','\983040')-    , ('\1048573','\1048573')-    , ('\1048576','\1048576')-    , ('\1114109','\1114109')-    ]---- --------------------------------------------------------------isUnicodeCc     :: Char -> Bool-isUnicodeCc c-  = isInList c-    [ ('\NUL','\US')-    , ('\DEL','\159')-    ]---- --------------------------------------------------------------isUnicodeCf     :: Char -> Bool-isUnicodeCf c-  = isInList c-    [ ('\173','\173')-    , ('\1536','\1539')-    , ('\1757','\1757')-    , ('\1807','\1807')-    , ('\6068','\6069')-    , ('\8203','\8207')-    , ('\8234','\8238')-    , ('\8288','\8292')-    , ('\8298','\8303')-    , ('\65279','\65279')-    , ('\65529','\65531')-    , ('\69821','\69821')-    , ('\119155','\119162')-    , ('\917505','\917505')-    , ('\917536','\917631')-    ]---- --------------------------------------------------------------isUnicodeCo     :: Char -> Bool-isUnicodeCo c-  = isInList c-    [ ('\57344','\57344')-    , ('\63743','\63743')-    , ('\983040','\983040')-    , ('\1048573','\1048573')-    , ('\1048576','\1048576')-    , ('\1114109','\1114109')-    ]---- --------------------------------------------------------------isUnicodeCs     :: Char -> Bool-isUnicodeCs c-  = isInList c-    [ ('\55296','\55296')-    , ('\56191','\56192')-    , ('\56319','\56320')-    , ('\57343','\57343')-    ]---- --------------------------------------------------------------isUnicodeL      :: Char -> Bool-isUnicodeL c-  = isInList c-    [ ('A','Z')-    , ('a','z')-    , ('\170','\170')-    , ('\181','\181')-    , ('\186','\186')-    , ('\192','\214')-    , ('\216','\246')-    , ('\248','\705')-    , ('\710','\721')-    , ('\736','\740')-    , ('\748','\748')-    , ('\750','\750')-    , ('\880','\884')-    , ('\886','\887')-    , ('\890','\893')-    , ('\902','\902')-    , ('\904','\906')-    , ('\908','\908')-    , ('\910','\929')-    , ('\931','\1013')-    , ('\1015','\1153')-    , ('\1162','\1317')-    , ('\1329','\1366')-    , ('\1369','\1369')-    , ('\1377','\1415')-    , ('\1488','\1514')-    , ('\1520','\1522')-    , ('\1569','\1610')-    , ('\1646','\1647')-    , ('\1649','\1747')-    , ('\1749','\1749')-    , ('\1765','\1766')-    , ('\1774','\1775')-    , ('\1786','\1788')-    , ('\1791','\1791')-    , ('\1808','\1808')-    , ('\1810','\1839')-    , ('\1869','\1957')-    , ('\1969','\1969')-    , ('\1994','\2026')-    , ('\2036','\2037')-    , ('\2042','\2042')-    , ('\2048','\2069')-    , ('\2074','\2074')-    , ('\2084','\2084')-    , ('\2088','\2088')-    , ('\2308','\2361')-    , ('\2365','\2365')-    , ('\2384','\2384')-    , ('\2392','\2401')-    , ('\2417','\2418')-    , ('\2425','\2431')-    , ('\2437','\2444')-    , ('\2447','\2448')-    , ('\2451','\2472')-    , ('\2474','\2480')-    , ('\2482','\2482')-    , ('\2486','\2489')-    , ('\2493','\2493')-    , ('\2510','\2510')-    , ('\2524','\2525')-    , ('\2527','\2529')-    , ('\2544','\2545')-    , ('\2565','\2570')-    , ('\2575','\2576')-    , ('\2579','\2600')-    , ('\2602','\2608')-    , ('\2610','\2611')-    , ('\2613','\2614')-    , ('\2616','\2617')-    , ('\2649','\2652')-    , ('\2654','\2654')-    , ('\2674','\2676')-    , ('\2693','\2701')-    , ('\2703','\2705')-    , ('\2707','\2728')-    , ('\2730','\2736')-    , ('\2738','\2739')-    , ('\2741','\2745')-    , ('\2749','\2749')-    , ('\2768','\2768')-    , ('\2784','\2785')-    , ('\2821','\2828')-    , ('\2831','\2832')-    , ('\2835','\2856')-    , ('\2858','\2864')-    , ('\2866','\2867')-    , ('\2869','\2873')-    , ('\2877','\2877')-    , ('\2908','\2909')-    , ('\2911','\2913')-    , ('\2929','\2929')-    , ('\2947','\2947')-    , ('\2949','\2954')-    , ('\2958','\2960')-    , ('\2962','\2965')-    , ('\2969','\2970')-    , ('\2972','\2972')-    , ('\2974','\2975')-    , ('\2979','\2980')-    , ('\2984','\2986')-    , ('\2990','\3001')-    , ('\3024','\3024')-    , ('\3077','\3084')-    , ('\3086','\3088')-    , ('\3090','\3112')-    , ('\3114','\3123')-    , ('\3125','\3129')-    , ('\3133','\3133')-    , ('\3160','\3161')-    , ('\3168','\3169')-    , ('\3205','\3212')-    , ('\3214','\3216')-    , ('\3218','\3240')-    , ('\3242','\3251')-    , ('\3253','\3257')-    , ('\3261','\3261')-    , ('\3294','\3294')-    , ('\3296','\3297')-    , ('\3333','\3340')-    , ('\3342','\3344')-    , ('\3346','\3368')-    , ('\3370','\3385')-    , ('\3389','\3389')-    , ('\3424','\3425')-    , ('\3450','\3455')-    , ('\3461','\3478')-    , ('\3482','\3505')-    , ('\3507','\3515')-    , ('\3517','\3517')-    , ('\3520','\3526')-    , ('\3585','\3632')-    , ('\3634','\3635')-    , ('\3648','\3654')-    , ('\3713','\3714')-    , ('\3716','\3716')-    , ('\3719','\3720')-    , ('\3722','\3722')-    , ('\3725','\3725')-    , ('\3732','\3735')-    , ('\3737','\3743')-    , ('\3745','\3747')-    , ('\3749','\3749')-    , ('\3751','\3751')-    , ('\3754','\3755')-    , ('\3757','\3760')-    , ('\3762','\3763')-    , ('\3773','\3773')-    , ('\3776','\3780')-    , ('\3782','\3782')-    , ('\3804','\3805')-    , ('\3840','\3840')-    , ('\3904','\3911')-    , ('\3913','\3948')-    , ('\3976','\3979')-    , ('\4096','\4138')-    , ('\4159','\4159')-    , ('\4176','\4181')-    , ('\4186','\4189')-    , ('\4193','\4193')-    , ('\4197','\4198')-    , ('\4206','\4208')-    , ('\4213','\4225')-    , ('\4238','\4238')-    , ('\4256','\4293')-    , ('\4304','\4346')-    , ('\4348','\4348')-    , ('\4352','\4680')-    , ('\4682','\4685')-    , ('\4688','\4694')-    , ('\4696','\4696')-    , ('\4698','\4701')-    , ('\4704','\4744')-    , ('\4746','\4749')-    , ('\4752','\4784')-    , ('\4786','\4789')-    , ('\4792','\4798')-    , ('\4800','\4800')-    , ('\4802','\4805')-    , ('\4808','\4822')-    , ('\4824','\4880')-    , ('\4882','\4885')-    , ('\4888','\4954')-    , ('\4992','\5007')-    , ('\5024','\5108')-    , ('\5121','\5740')-    , ('\5743','\5759')-    , ('\5761','\5786')-    , ('\5792','\5866')-    , ('\5888','\5900')-    , ('\5902','\5905')-    , ('\5920','\5937')-    , ('\5952','\5969')-    , ('\5984','\5996')-    , ('\5998','\6000')-    , ('\6016','\6067')-    , ('\6103','\6103')-    , ('\6108','\6108')-    , ('\6176','\6263')-    , ('\6272','\6312')-    , ('\6314','\6314')-    , ('\6320','\6389')-    , ('\6400','\6428')-    , ('\6480','\6509')-    , ('\6512','\6516')-    , ('\6528','\6571')-    , ('\6593','\6599')-    , ('\6656','\6678')-    , ('\6688','\6740')-    , ('\6823','\6823')-    , ('\6917','\6963')-    , ('\6981','\6987')-    , ('\7043','\7072')-    , ('\7086','\7087')-    , ('\7168','\7203')-    , ('\7245','\7247')-    , ('\7258','\7293')-    , ('\7401','\7404')-    , ('\7406','\7409')-    , ('\7424','\7615')-    , ('\7680','\7957')-    , ('\7960','\7965')-    , ('\7968','\8005')-    , ('\8008','\8013')-    , ('\8016','\8023')-    , ('\8025','\8025')-    , ('\8027','\8027')-    , ('\8029','\8029')-    , ('\8031','\8061')-    , ('\8064','\8116')-    , ('\8118','\8124')-    , ('\8126','\8126')-    , ('\8130','\8132')-    , ('\8134','\8140')-    , ('\8144','\8147')-    , ('\8150','\8155')-    , ('\8160','\8172')-    , ('\8178','\8180')-    , ('\8182','\8188')-    , ('\8305','\8305')-    , ('\8319','\8319')-    , ('\8336','\8340')-    , ('\8450','\8450')-    , ('\8455','\8455')-    , ('\8458','\8467')-    , ('\8469','\8469')-    , ('\8473','\8477')-    , ('\8484','\8484')-    , ('\8486','\8486')-    , ('\8488','\8488')-    , ('\8490','\8493')-    , ('\8495','\8505')-    , ('\8508','\8511')-    , ('\8517','\8521')-    , ('\8526','\8526')-    , ('\8579','\8580')-    , ('\11264','\11310')-    , ('\11312','\11358')-    , ('\11360','\11492')-    , ('\11499','\11502')-    , ('\11520','\11557')-    , ('\11568','\11621')-    , ('\11631','\11631')-    , ('\11648','\11670')-    , ('\11680','\11686')-    , ('\11688','\11694')-    , ('\11696','\11702')-    , ('\11704','\11710')-    , ('\11712','\11718')-    , ('\11720','\11726')-    , ('\11728','\11734')-    , ('\11736','\11742')-    , ('\11823','\11823')-    , ('\12293','\12294')-    , ('\12337','\12341')-    , ('\12347','\12348')-    , ('\12353','\12438')-    , ('\12445','\12447')-    , ('\12449','\12538')-    , ('\12540','\12543')-    , ('\12549','\12589')-    , ('\12593','\12686')-    , ('\12704','\12727')-    , ('\12784','\12799')-    , ('\13312','\13312')-    , ('\19893','\19893')-    , ('\19968','\19968')-    , ('\40907','\40907')-    , ('\40960','\42124')-    , ('\42192','\42237')-    , ('\42240','\42508')-    , ('\42512','\42527')-    , ('\42538','\42539')-    , ('\42560','\42591')-    , ('\42594','\42606')-    , ('\42623','\42647')-    , ('\42656','\42725')-    , ('\42775','\42783')-    , ('\42786','\42888')-    , ('\42891','\42892')-    , ('\43003','\43009')-    , ('\43011','\43013')-    , ('\43015','\43018')-    , ('\43020','\43042')-    , ('\43072','\43123')-    , ('\43138','\43187')-    , ('\43250','\43255')-    , ('\43259','\43259')-    , ('\43274','\43301')-    , ('\43312','\43334')-    , ('\43360','\43388')-    , ('\43396','\43442')-    , ('\43471','\43471')-    , ('\43520','\43560')-    , ('\43584','\43586')-    , ('\43588','\43595')-    , ('\43616','\43638')-    , ('\43642','\43642')-    , ('\43648','\43695')-    , ('\43697','\43697')-    , ('\43701','\43702')-    , ('\43705','\43709')-    , ('\43712','\43712')-    , ('\43714','\43714')-    , ('\43739','\43741')-    , ('\43968','\44002')-    , ('\44032','\44032')-    , ('\55203','\55203')-    , ('\55216','\55238')-    , ('\55243','\55291')-    , ('\63744','\64045')-    , ('\64048','\64109')-    , ('\64112','\64217')-    , ('\64256','\64262')-    , ('\64275','\64279')-    , ('\64285','\64285')-    , ('\64287','\64296')-    , ('\64298','\64310')-    , ('\64312','\64316')-    , ('\64318','\64318')-    , ('\64320','\64321')-    , ('\64323','\64324')-    , ('\64326','\64433')-    , ('\64467','\64829')-    , ('\64848','\64911')-    , ('\64914','\64967')-    , ('\65008','\65019')-    , ('\65136','\65140')-    , ('\65142','\65276')-    , ('\65313','\65338')-    , ('\65345','\65370')-    , ('\65382','\65470')-    , ('\65474','\65479')-    , ('\65482','\65487')-    , ('\65490','\65495')-    , ('\65498','\65500')-    , ('\65536','\65547')-    , ('\65549','\65574')-    , ('\65576','\65594')-    , ('\65596','\65597')-    , ('\65599','\65613')-    , ('\65616','\65629')-    , ('\65664','\65786')-    , ('\66176','\66204')-    , ('\66208','\66256')-    , ('\66304','\66334')-    , ('\66352','\66368')-    , ('\66370','\66377')-    , ('\66432','\66461')-    , ('\66464','\66499')-    , ('\66504','\66511')-    , ('\66560','\66717')-    , ('\67584','\67589')-    , ('\67592','\67592')-    , ('\67594','\67637')-    , ('\67639','\67640')-    , ('\67644','\67644')-    , ('\67647','\67669')-    , ('\67840','\67861')-    , ('\67872','\67897')-    , ('\68096','\68096')-    , ('\68112','\68115')-    , ('\68117','\68119')-    , ('\68121','\68147')-    , ('\68192','\68220')-    , ('\68352','\68405')-    , ('\68416','\68437')-    , ('\68448','\68466')-    , ('\68608','\68680')-    , ('\69763','\69807')-    , ('\73728','\74606')-    , ('\77824','\78894')-    , ('\119808','\119892')-    , ('\119894','\119964')-    , ('\119966','\119967')-    , ('\119970','\119970')-    , ('\119973','\119974')-    , ('\119977','\119980')-    , ('\119982','\119993')-    , ('\119995','\119995')-    , ('\119997','\120003')-    , ('\120005','\120069')-    , ('\120071','\120074')-    , ('\120077','\120084')-    , ('\120086','\120092')-    , ('\120094','\120121')-    , ('\120123','\120126')-    , ('\120128','\120132')-    , ('\120134','\120134')-    , ('\120138','\120144')-    , ('\120146','\120485')-    , ('\120488','\120512')-    , ('\120514','\120538')-    , ('\120540','\120570')-    , ('\120572','\120596')-    , ('\120598','\120628')-    , ('\120630','\120654')-    , ('\120656','\120686')-    , ('\120688','\120712')-    , ('\120714','\120744')-    , ('\120746','\120770')-    , ('\120772','\120779')-    , ('\131072','\131072')-    , ('\173782','\173782')-    , ('\173824','\173824')-    , ('\177972','\177972')-    , ('\194560','\195101')-    ]---- --------------------------------------------------------------isUnicodeLl     :: Char -> Bool-isUnicodeLl c-  = isInList c-    [ ('a','z')-    , ('\170','\170')-    , ('\181','\181')-    , ('\186','\186')-    , ('\223','\246')-    , ('\248','\255')-    , ('\257','\257')-    , ('\259','\259')-    , ('\261','\261')-    , ('\263','\263')-    , ('\265','\265')-    , ('\267','\267')-    , ('\269','\269')-    , ('\271','\271')-    , ('\273','\273')-    , ('\275','\275')-    , ('\277','\277')-    , ('\279','\279')-    , ('\281','\281')-    , ('\283','\283')-    , ('\285','\285')-    , ('\287','\287')-    , ('\289','\289')-    , ('\291','\291')-    , ('\293','\293')-    , ('\295','\295')-    , ('\297','\297')-    , ('\299','\299')-    , ('\301','\301')-    , ('\303','\303')-    , ('\305','\305')-    , ('\307','\307')-    , ('\309','\309')-    , ('\311','\312')-    , ('\314','\314')-    , ('\316','\316')-    , ('\318','\318')-    , ('\320','\320')-    , ('\322','\322')-    , ('\324','\324')-    , ('\326','\326')-    , ('\328','\329')-    , ('\331','\331')-    , ('\333','\333')-    , ('\335','\335')-    , ('\337','\337')-    , ('\339','\339')-    , ('\341','\341')-    , ('\343','\343')-    , ('\345','\345')-    , ('\347','\347')-    , ('\349','\349')-    , ('\351','\351')-    , ('\353','\353')-    , ('\355','\355')-    , ('\357','\357')-    , ('\359','\359')-    , ('\361','\361')-    , ('\363','\363')-    , ('\365','\365')-    , ('\367','\367')-    , ('\369','\369')-    , ('\371','\371')-    , ('\373','\373')-    , ('\375','\375')-    , ('\378','\378')-    , ('\380','\380')-    , ('\382','\384')-    , ('\387','\387')-    , ('\389','\389')-    , ('\392','\392')-    , ('\396','\397')-    , ('\402','\402')-    , ('\405','\405')-    , ('\409','\411')-    , ('\414','\414')-    , ('\417','\417')-    , ('\419','\419')-    , ('\421','\421')-    , ('\424','\424')-    , ('\426','\427')-    , ('\429','\429')-    , ('\432','\432')-    , ('\436','\436')-    , ('\438','\438')-    , ('\441','\442')-    , ('\445','\447')-    , ('\454','\454')-    , ('\457','\457')-    , ('\460','\460')-    , ('\462','\462')-    , ('\464','\464')-    , ('\466','\466')-    , ('\468','\468')-    , ('\470','\470')-    , ('\472','\472')-    , ('\474','\474')-    , ('\476','\477')-    , ('\479','\479')-    , ('\481','\481')-    , ('\483','\483')-    , ('\485','\485')-    , ('\487','\487')-    , ('\489','\489')-    , ('\491','\491')-    , ('\493','\493')-    , ('\495','\496')-    , ('\499','\499')-    , ('\501','\501')-    , ('\505','\505')-    , ('\507','\507')-    , ('\509','\509')-    , ('\511','\511')-    , ('\513','\513')-    , ('\515','\515')-    , ('\517','\517')-    , ('\519','\519')-    , ('\521','\521')-    , ('\523','\523')-    , ('\525','\525')-    , ('\527','\527')-    , ('\529','\529')-    , ('\531','\531')-    , ('\533','\533')-    , ('\535','\535')-    , ('\537','\537')-    , ('\539','\539')-    , ('\541','\541')-    , ('\543','\543')-    , ('\545','\545')-    , ('\547','\547')-    , ('\549','\549')-    , ('\551','\551')-    , ('\553','\553')-    , ('\555','\555')-    , ('\557','\557')-    , ('\559','\559')-    , ('\561','\561')-    , ('\563','\569')-    , ('\572','\572')-    , ('\575','\576')-    , ('\578','\578')-    , ('\583','\583')-    , ('\585','\585')-    , ('\587','\587')-    , ('\589','\589')-    , ('\591','\659')-    , ('\661','\687')-    , ('\881','\881')-    , ('\883','\883')-    , ('\887','\887')-    , ('\891','\893')-    , ('\912','\912')-    , ('\940','\974')-    , ('\976','\977')-    , ('\981','\983')-    , ('\985','\985')-    , ('\987','\987')-    , ('\989','\989')-    , ('\991','\991')-    , ('\993','\993')-    , ('\995','\995')-    , ('\997','\997')-    , ('\999','\999')-    , ('\1001','\1001')-    , ('\1003','\1003')-    , ('\1005','\1005')-    , ('\1007','\1011')-    , ('\1013','\1013')-    , ('\1016','\1016')-    , ('\1019','\1020')-    , ('\1072','\1119')-    , ('\1121','\1121')-    , ('\1123','\1123')-    , ('\1125','\1125')-    , ('\1127','\1127')-    , ('\1129','\1129')-    , ('\1131','\1131')-    , ('\1133','\1133')-    , ('\1135','\1135')-    , ('\1137','\1137')-    , ('\1139','\1139')-    , ('\1141','\1141')-    , ('\1143','\1143')-    , ('\1145','\1145')-    , ('\1147','\1147')-    , ('\1149','\1149')-    , ('\1151','\1151')-    , ('\1153','\1153')-    , ('\1163','\1163')-    , ('\1165','\1165')-    , ('\1167','\1167')-    , ('\1169','\1169')-    , ('\1171','\1171')-    , ('\1173','\1173')-    , ('\1175','\1175')-    , ('\1177','\1177')-    , ('\1179','\1179')-    , ('\1181','\1181')-    , ('\1183','\1183')-    , ('\1185','\1185')-    , ('\1187','\1187')-    , ('\1189','\1189')-    , ('\1191','\1191')-    , ('\1193','\1193')-    , ('\1195','\1195')-    , ('\1197','\1197')-    , ('\1199','\1199')-    , ('\1201','\1201')-    , ('\1203','\1203')-    , ('\1205','\1205')-    , ('\1207','\1207')-    , ('\1209','\1209')-    , ('\1211','\1211')-    , ('\1213','\1213')-    , ('\1215','\1215')-    , ('\1218','\1218')-    , ('\1220','\1220')-    , ('\1222','\1222')-    , ('\1224','\1224')-    , ('\1226','\1226')-    , ('\1228','\1228')-    , ('\1230','\1231')-    , ('\1233','\1233')-    , ('\1235','\1235')-    , ('\1237','\1237')-    , ('\1239','\1239')-    , ('\1241','\1241')-    , ('\1243','\1243')-    , ('\1245','\1245')-    , ('\1247','\1247')-    , ('\1249','\1249')-    , ('\1251','\1251')-    , ('\1253','\1253')-    , ('\1255','\1255')-    , ('\1257','\1257')-    , ('\1259','\1259')-    , ('\1261','\1261')-    , ('\1263','\1263')-    , ('\1265','\1265')-    , ('\1267','\1267')-    , ('\1269','\1269')-    , ('\1271','\1271')-    , ('\1273','\1273')-    , ('\1275','\1275')-    , ('\1277','\1277')-    , ('\1279','\1279')-    , ('\1281','\1281')-    , ('\1283','\1283')-    , ('\1285','\1285')-    , ('\1287','\1287')-    , ('\1289','\1289')-    , ('\1291','\1291')-    , ('\1293','\1293')-    , ('\1295','\1295')-    , ('\1297','\1297')-    , ('\1299','\1299')-    , ('\1301','\1301')-    , ('\1303','\1303')-    , ('\1305','\1305')-    , ('\1307','\1307')-    , ('\1309','\1309')-    , ('\1311','\1311')-    , ('\1313','\1313')-    , ('\1315','\1315')-    , ('\1317','\1317')-    , ('\1377','\1415')-    , ('\7424','\7467')-    , ('\7522','\7543')-    , ('\7545','\7578')-    , ('\7681','\7681')-    , ('\7683','\7683')-    , ('\7685','\7685')-    , ('\7687','\7687')-    , ('\7689','\7689')-    , ('\7691','\7691')-    , ('\7693','\7693')-    , ('\7695','\7695')-    , ('\7697','\7697')-    , ('\7699','\7699')-    , ('\7701','\7701')-    , ('\7703','\7703')-    , ('\7705','\7705')-    , ('\7707','\7707')-    , ('\7709','\7709')-    , ('\7711','\7711')-    , ('\7713','\7713')-    , ('\7715','\7715')-    , ('\7717','\7717')-    , ('\7719','\7719')-    , ('\7721','\7721')-    , ('\7723','\7723')-    , ('\7725','\7725')-    , ('\7727','\7727')-    , ('\7729','\7729')-    , ('\7731','\7731')-    , ('\7733','\7733')-    , ('\7735','\7735')-    , ('\7737','\7737')-    , ('\7739','\7739')-    , ('\7741','\7741')-    , ('\7743','\7743')-    , ('\7745','\7745')-    , ('\7747','\7747')-    , ('\7749','\7749')-    , ('\7751','\7751')-    , ('\7753','\7753')-    , ('\7755','\7755')-    , ('\7757','\7757')-    , ('\7759','\7759')-    , ('\7761','\7761')-    , ('\7763','\7763')-    , ('\7765','\7765')-    , ('\7767','\7767')-    , ('\7769','\7769')-    , ('\7771','\7771')-    , ('\7773','\7773')-    , ('\7775','\7775')-    , ('\7777','\7777')-    , ('\7779','\7779')-    , ('\7781','\7781')-    , ('\7783','\7783')-    , ('\7785','\7785')-    , ('\7787','\7787')-    , ('\7789','\7789')-    , ('\7791','\7791')-    , ('\7793','\7793')-    , ('\7795','\7795')-    , ('\7797','\7797')-    , ('\7799','\7799')-    , ('\7801','\7801')-    , ('\7803','\7803')-    , ('\7805','\7805')-    , ('\7807','\7807')-    , ('\7809','\7809')-    , ('\7811','\7811')-    , ('\7813','\7813')-    , ('\7815','\7815')-    , ('\7817','\7817')-    , ('\7819','\7819')-    , ('\7821','\7821')-    , ('\7823','\7823')-    , ('\7825','\7825')-    , ('\7827','\7827')-    , ('\7829','\7837')-    , ('\7839','\7839')-    , ('\7841','\7841')-    , ('\7843','\7843')-    , ('\7845','\7845')-    , ('\7847','\7847')-    , ('\7849','\7849')-    , ('\7851','\7851')-    , ('\7853','\7853')-    , ('\7855','\7855')-    , ('\7857','\7857')-    , ('\7859','\7859')-    , ('\7861','\7861')-    , ('\7863','\7863')-    , ('\7865','\7865')-    , ('\7867','\7867')-    , ('\7869','\7869')-    , ('\7871','\7871')-    , ('\7873','\7873')-    , ('\7875','\7875')-    , ('\7877','\7877')-    , ('\7879','\7879')-    , ('\7881','\7881')-    , ('\7883','\7883')-    , ('\7885','\7885')-    , ('\7887','\7887')-    , ('\7889','\7889')-    , ('\7891','\7891')-    , ('\7893','\7893')-    , ('\7895','\7895')-    , ('\7897','\7897')-    , ('\7899','\7899')-    , ('\7901','\7901')-    , ('\7903','\7903')-    , ('\7905','\7905')-    , ('\7907','\7907')-    , ('\7909','\7909')-    , ('\7911','\7911')-    , ('\7913','\7913')-    , ('\7915','\7915')-    , ('\7917','\7917')-    , ('\7919','\7919')-    , ('\7921','\7921')-    , ('\7923','\7923')-    , ('\7925','\7925')-    , ('\7927','\7927')-    , ('\7929','\7929')-    , ('\7931','\7931')-    , ('\7933','\7933')-    , ('\7935','\7943')-    , ('\7952','\7957')-    , ('\7968','\7975')-    , ('\7984','\7991')-    , ('\8000','\8005')-    , ('\8016','\8023')-    , ('\8032','\8039')-    , ('\8048','\8061')-    , ('\8064','\8071')-    , ('\8080','\8087')-    , ('\8096','\8103')-    , ('\8112','\8116')-    , ('\8118','\8119')-    , ('\8126','\8126')-    , ('\8130','\8132')-    , ('\8134','\8135')-    , ('\8144','\8147')-    , ('\8150','\8151')-    , ('\8160','\8167')-    , ('\8178','\8180')-    , ('\8182','\8183')-    , ('\8458','\8458')-    , ('\8462','\8463')-    , ('\8467','\8467')-    , ('\8495','\8495')-    , ('\8500','\8500')-    , ('\8505','\8505')-    , ('\8508','\8509')-    , ('\8518','\8521')-    , ('\8526','\8526')-    , ('\8580','\8580')-    , ('\11312','\11358')-    , ('\11361','\11361')-    , ('\11365','\11366')-    , ('\11368','\11368')-    , ('\11370','\11370')-    , ('\11372','\11372')-    , ('\11377','\11377')-    , ('\11379','\11380')-    , ('\11382','\11388')-    , ('\11393','\11393')-    , ('\11395','\11395')-    , ('\11397','\11397')-    , ('\11399','\11399')-    , ('\11401','\11401')-    , ('\11403','\11403')-    , ('\11405','\11405')-    , ('\11407','\11407')-    , ('\11409','\11409')-    , ('\11411','\11411')-    , ('\11413','\11413')-    , ('\11415','\11415')-    , ('\11417','\11417')-    , ('\11419','\11419')-    , ('\11421','\11421')-    , ('\11423','\11423')-    , ('\11425','\11425')-    , ('\11427','\11427')-    , ('\11429','\11429')-    , ('\11431','\11431')-    , ('\11433','\11433')-    , ('\11435','\11435')-    , ('\11437','\11437')-    , ('\11439','\11439')-    , ('\11441','\11441')-    , ('\11443','\11443')-    , ('\11445','\11445')-    , ('\11447','\11447')-    , ('\11449','\11449')-    , ('\11451','\11451')-    , ('\11453','\11453')-    , ('\11455','\11455')-    , ('\11457','\11457')-    , ('\11459','\11459')-    , ('\11461','\11461')-    , ('\11463','\11463')-    , ('\11465','\11465')-    , ('\11467','\11467')-    , ('\11469','\11469')-    , ('\11471','\11471')-    , ('\11473','\11473')-    , ('\11475','\11475')-    , ('\11477','\11477')-    , ('\11479','\11479')-    , ('\11481','\11481')-    , ('\11483','\11483')-    , ('\11485','\11485')-    , ('\11487','\11487')-    , ('\11489','\11489')-    , ('\11491','\11492')-    , ('\11500','\11500')-    , ('\11502','\11502')-    , ('\11520','\11557')-    , ('\42561','\42561')-    , ('\42563','\42563')-    , ('\42565','\42565')-    , ('\42567','\42567')-    , ('\42569','\42569')-    , ('\42571','\42571')-    , ('\42573','\42573')-    , ('\42575','\42575')-    , ('\42577','\42577')-    , ('\42579','\42579')-    , ('\42581','\42581')-    , ('\42583','\42583')-    , ('\42585','\42585')-    , ('\42587','\42587')-    , ('\42589','\42589')-    , ('\42591','\42591')-    , ('\42595','\42595')-    , ('\42597','\42597')-    , ('\42599','\42599')-    , ('\42601','\42601')-    , ('\42603','\42603')-    , ('\42605','\42605')-    , ('\42625','\42625')-    , ('\42627','\42627')-    , ('\42629','\42629')-    , ('\42631','\42631')-    , ('\42633','\42633')-    , ('\42635','\42635')-    , ('\42637','\42637')-    , ('\42639','\42639')-    , ('\42641','\42641')-    , ('\42643','\42643')-    , ('\42645','\42645')-    , ('\42647','\42647')-    , ('\42787','\42787')-    , ('\42789','\42789')-    , ('\42791','\42791')-    , ('\42793','\42793')-    , ('\42795','\42795')-    , ('\42797','\42797')-    , ('\42799','\42801')-    , ('\42803','\42803')-    , ('\42805','\42805')-    , ('\42807','\42807')-    , ('\42809','\42809')-    , ('\42811','\42811')-    , ('\42813','\42813')-    , ('\42815','\42815')-    , ('\42817','\42817')-    , ('\42819','\42819')-    , ('\42821','\42821')-    , ('\42823','\42823')-    , ('\42825','\42825')-    , ('\42827','\42827')-    , ('\42829','\42829')-    , ('\42831','\42831')-    , ('\42833','\42833')-    , ('\42835','\42835')-    , ('\42837','\42837')-    , ('\42839','\42839')-    , ('\42841','\42841')-    , ('\42843','\42843')-    , ('\42845','\42845')-    , ('\42847','\42847')-    , ('\42849','\42849')-    , ('\42851','\42851')-    , ('\42853','\42853')-    , ('\42855','\42855')-    , ('\42857','\42857')-    , ('\42859','\42859')-    , ('\42861','\42861')-    , ('\42863','\42863')-    , ('\42865','\42872')-    , ('\42874','\42874')-    , ('\42876','\42876')-    , ('\42879','\42879')-    , ('\42881','\42881')-    , ('\42883','\42883')-    , ('\42885','\42885')-    , ('\42887','\42887')-    , ('\42892','\42892')-    , ('\64256','\64262')-    , ('\64275','\64279')-    , ('\65345','\65370')-    , ('\66600','\66639')-    , ('\119834','\119859')-    , ('\119886','\119892')-    , ('\119894','\119911')-    , ('\119938','\119963')-    , ('\119990','\119993')-    , ('\119995','\119995')-    , ('\119997','\120003')-    , ('\120005','\120015')-    , ('\120042','\120067')-    , ('\120094','\120119')-    , ('\120146','\120171')-    , ('\120198','\120223')-    , ('\120250','\120275')-    , ('\120302','\120327')-    , ('\120354','\120379')-    , ('\120406','\120431')-    , ('\120458','\120485')-    , ('\120514','\120538')-    , ('\120540','\120545')-    , ('\120572','\120596')-    , ('\120598','\120603')-    , ('\120630','\120654')-    , ('\120656','\120661')-    , ('\120688','\120712')-    , ('\120714','\120719')-    , ('\120746','\120770')-    , ('\120772','\120777')-    , ('\120779','\120779')-    ]---- --------------------------------------------------------------isUnicodeLm     :: Char -> Bool-isUnicodeLm c-  = isInList c-    [ ('\688','\705')-    , ('\710','\721')-    , ('\736','\740')-    , ('\748','\748')-    , ('\750','\750')-    , ('\884','\884')-    , ('\890','\890')-    , ('\1369','\1369')-    , ('\1600','\1600')-    , ('\1765','\1766')-    , ('\2036','\2037')-    , ('\2042','\2042')-    , ('\2074','\2074')-    , ('\2084','\2084')-    , ('\2088','\2088')-    , ('\2417','\2417')-    , ('\3654','\3654')-    , ('\3782','\3782')-    , ('\4348','\4348')-    , ('\6103','\6103')-    , ('\6211','\6211')-    , ('\6823','\6823')-    , ('\7288','\7293')-    , ('\7468','\7521')-    , ('\7544','\7544')-    , ('\7579','\7615')-    , ('\8305','\8305')-    , ('\8319','\8319')-    , ('\8336','\8340')-    , ('\11389','\11389')-    , ('\11631','\11631')-    , ('\11823','\11823')-    , ('\12293','\12293')-    , ('\12337','\12341')-    , ('\12347','\12347')-    , ('\12445','\12446')-    , ('\12540','\12542')-    , ('\40981','\40981')-    , ('\42232','\42237')-    , ('\42508','\42508')-    , ('\42623','\42623')-    , ('\42775','\42783')-    , ('\42864','\42864')-    , ('\42888','\42888')-    , ('\43471','\43471')-    , ('\43632','\43632')-    , ('\43741','\43741')-    , ('\65392','\65392')-    , ('\65438','\65439')-    ]---- --------------------------------------------------------------isUnicodeLo     :: Char -> Bool-isUnicodeLo c-  = isInList c-    [ ('\443','\443')-    , ('\448','\451')-    , ('\660','\660')-    , ('\1488','\1514')-    , ('\1520','\1522')-    , ('\1569','\1599')-    , ('\1601','\1610')-    , ('\1646','\1647')-    , ('\1649','\1747')-    , ('\1749','\1749')-    , ('\1774','\1775')-    , ('\1786','\1788')-    , ('\1791','\1791')-    , ('\1808','\1808')-    , ('\1810','\1839')-    , ('\1869','\1957')-    , ('\1969','\1969')-    , ('\1994','\2026')-    , ('\2048','\2069')-    , ('\2308','\2361')-    , ('\2365','\2365')-    , ('\2384','\2384')-    , ('\2392','\2401')-    , ('\2418','\2418')-    , ('\2425','\2431')-    , ('\2437','\2444')-    , ('\2447','\2448')-    , ('\2451','\2472')-    , ('\2474','\2480')-    , ('\2482','\2482')-    , ('\2486','\2489')-    , ('\2493','\2493')-    , ('\2510','\2510')-    , ('\2524','\2525')-    , ('\2527','\2529')-    , ('\2544','\2545')-    , ('\2565','\2570')-    , ('\2575','\2576')-    , ('\2579','\2600')-    , ('\2602','\2608')-    , ('\2610','\2611')-    , ('\2613','\2614')-    , ('\2616','\2617')-    , ('\2649','\2652')-    , ('\2654','\2654')-    , ('\2674','\2676')-    , ('\2693','\2701')-    , ('\2703','\2705')-    , ('\2707','\2728')-    , ('\2730','\2736')-    , ('\2738','\2739')-    , ('\2741','\2745')-    , ('\2749','\2749')-    , ('\2768','\2768')-    , ('\2784','\2785')-    , ('\2821','\2828')-    , ('\2831','\2832')-    , ('\2835','\2856')-    , ('\2858','\2864')-    , ('\2866','\2867')-    , ('\2869','\2873')-    , ('\2877','\2877')-    , ('\2908','\2909')-    , ('\2911','\2913')-    , ('\2929','\2929')-    , ('\2947','\2947')-    , ('\2949','\2954')-    , ('\2958','\2960')-    , ('\2962','\2965')-    , ('\2969','\2970')-    , ('\2972','\2972')-    , ('\2974','\2975')-    , ('\2979','\2980')-    , ('\2984','\2986')-    , ('\2990','\3001')-    , ('\3024','\3024')-    , ('\3077','\3084')-    , ('\3086','\3088')-    , ('\3090','\3112')-    , ('\3114','\3123')-    , ('\3125','\3129')-    , ('\3133','\3133')-    , ('\3160','\3161')-    , ('\3168','\3169')-    , ('\3205','\3212')-    , ('\3214','\3216')-    , ('\3218','\3240')-    , ('\3242','\3251')-    , ('\3253','\3257')-    , ('\3261','\3261')-    , ('\3294','\3294')-    , ('\3296','\3297')-    , ('\3333','\3340')-    , ('\3342','\3344')-    , ('\3346','\3368')-    , ('\3370','\3385')-    , ('\3389','\3389')-    , ('\3424','\3425')-    , ('\3450','\3455')-    , ('\3461','\3478')-    , ('\3482','\3505')-    , ('\3507','\3515')-    , ('\3517','\3517')-    , ('\3520','\3526')-    , ('\3585','\3632')-    , ('\3634','\3635')-    , ('\3648','\3653')-    , ('\3713','\3714')-    , ('\3716','\3716')-    , ('\3719','\3720')-    , ('\3722','\3722')-    , ('\3725','\3725')-    , ('\3732','\3735')-    , ('\3737','\3743')-    , ('\3745','\3747')-    , ('\3749','\3749')-    , ('\3751','\3751')-    , ('\3754','\3755')-    , ('\3757','\3760')-    , ('\3762','\3763')-    , ('\3773','\3773')-    , ('\3776','\3780')-    , ('\3804','\3805')-    , ('\3840','\3840')-    , ('\3904','\3911')-    , ('\3913','\3948')-    , ('\3976','\3979')-    , ('\4096','\4138')-    , ('\4159','\4159')-    , ('\4176','\4181')-    , ('\4186','\4189')-    , ('\4193','\4193')-    , ('\4197','\4198')-    , ('\4206','\4208')-    , ('\4213','\4225')-    , ('\4238','\4238')-    , ('\4304','\4346')-    , ('\4352','\4680')-    , ('\4682','\4685')-    , ('\4688','\4694')-    , ('\4696','\4696')-    , ('\4698','\4701')-    , ('\4704','\4744')-    , ('\4746','\4749')-    , ('\4752','\4784')-    , ('\4786','\4789')-    , ('\4792','\4798')-    , ('\4800','\4800')-    , ('\4802','\4805')-    , ('\4808','\4822')-    , ('\4824','\4880')-    , ('\4882','\4885')-    , ('\4888','\4954')-    , ('\4992','\5007')-    , ('\5024','\5108')-    , ('\5121','\5740')-    , ('\5743','\5759')-    , ('\5761','\5786')-    , ('\5792','\5866')-    , ('\5888','\5900')-    , ('\5902','\5905')-    , ('\5920','\5937')-    , ('\5952','\5969')-    , ('\5984','\5996')-    , ('\5998','\6000')-    , ('\6016','\6067')-    , ('\6108','\6108')-    , ('\6176','\6210')-    , ('\6212','\6263')-    , ('\6272','\6312')-    , ('\6314','\6314')-    , ('\6320','\6389')-    , ('\6400','\6428')-    , ('\6480','\6509')-    , ('\6512','\6516')-    , ('\6528','\6571')-    , ('\6593','\6599')-    , ('\6656','\6678')-    , ('\6688','\6740')-    , ('\6917','\6963')-    , ('\6981','\6987')-    , ('\7043','\7072')-    , ('\7086','\7087')-    , ('\7168','\7203')-    , ('\7245','\7247')-    , ('\7258','\7287')-    , ('\7401','\7404')-    , ('\7406','\7409')-    , ('\8501','\8504')-    , ('\11568','\11621')-    , ('\11648','\11670')-    , ('\11680','\11686')-    , ('\11688','\11694')-    , ('\11696','\11702')-    , ('\11704','\11710')-    , ('\11712','\11718')-    , ('\11720','\11726')-    , ('\11728','\11734')-    , ('\11736','\11742')-    , ('\12294','\12294')-    , ('\12348','\12348')-    , ('\12353','\12438')-    , ('\12447','\12447')-    , ('\12449','\12538')-    , ('\12543','\12543')-    , ('\12549','\12589')-    , ('\12593','\12686')-    , ('\12704','\12727')-    , ('\12784','\12799')-    , ('\13312','\13312')-    , ('\19893','\19893')-    , ('\19968','\19968')-    , ('\40907','\40907')-    , ('\40960','\40980')-    , ('\40982','\42124')-    , ('\42192','\42231')-    , ('\42240','\42507')-    , ('\42512','\42527')-    , ('\42538','\42539')-    , ('\42606','\42606')-    , ('\42656','\42725')-    , ('\43003','\43009')-    , ('\43011','\43013')-    , ('\43015','\43018')-    , ('\43020','\43042')-    , ('\43072','\43123')-    , ('\43138','\43187')-    , ('\43250','\43255')-    , ('\43259','\43259')-    , ('\43274','\43301')-    , ('\43312','\43334')-    , ('\43360','\43388')-    , ('\43396','\43442')-    , ('\43520','\43560')-    , ('\43584','\43586')-    , ('\43588','\43595')-    , ('\43616','\43631')-    , ('\43633','\43638')-    , ('\43642','\43642')-    , ('\43648','\43695')-    , ('\43697','\43697')-    , ('\43701','\43702')-    , ('\43705','\43709')-    , ('\43712','\43712')-    , ('\43714','\43714')-    , ('\43739','\43740')-    , ('\43968','\44002')-    , ('\44032','\44032')-    , ('\55203','\55203')-    , ('\55216','\55238')-    , ('\55243','\55291')-    , ('\63744','\64045')-    , ('\64048','\64109')-    , ('\64112','\64217')-    , ('\64285','\64285')-    , ('\64287','\64296')-    , ('\64298','\64310')-    , ('\64312','\64316')-    , ('\64318','\64318')-    , ('\64320','\64321')-    , ('\64323','\64324')-    , ('\64326','\64433')-    , ('\64467','\64829')-    , ('\64848','\64911')-    , ('\64914','\64967')-    , ('\65008','\65019')-    , ('\65136','\65140')-    , ('\65142','\65276')-    , ('\65382','\65391')-    , ('\65393','\65437')-    , ('\65440','\65470')-    , ('\65474','\65479')-    , ('\65482','\65487')-    , ('\65490','\65495')-    , ('\65498','\65500')-    , ('\65536','\65547')-    , ('\65549','\65574')-    , ('\65576','\65594')-    , ('\65596','\65597')-    , ('\65599','\65613')-    , ('\65616','\65629')-    , ('\65664','\65786')-    , ('\66176','\66204')-    , ('\66208','\66256')-    , ('\66304','\66334')-    , ('\66352','\66368')-    , ('\66370','\66377')-    , ('\66432','\66461')-    , ('\66464','\66499')-    , ('\66504','\66511')-    , ('\66640','\66717')-    , ('\67584','\67589')-    , ('\67592','\67592')-    , ('\67594','\67637')-    , ('\67639','\67640')-    , ('\67644','\67644')-    , ('\67647','\67669')-    , ('\67840','\67861')-    , ('\67872','\67897')-    , ('\68096','\68096')-    , ('\68112','\68115')-    , ('\68117','\68119')-    , ('\68121','\68147')-    , ('\68192','\68220')-    , ('\68352','\68405')-    , ('\68416','\68437')-    , ('\68448','\68466')-    , ('\68608','\68680')-    , ('\69763','\69807')-    , ('\73728','\74606')-    , ('\77824','\78894')-    , ('\131072','\131072')-    , ('\173782','\173782')-    , ('\173824','\173824')-    , ('\177972','\177972')-    , ('\194560','\195101')-    ]---- --------------------------------------------------------------isUnicodeLt     :: Char -> Bool-isUnicodeLt c-  = isInList c-    [ ('\453','\453')-    , ('\456','\456')-    , ('\459','\459')-    , ('\498','\498')-    , ('\8072','\8079')-    , ('\8088','\8095')-    , ('\8104','\8111')-    , ('\8124','\8124')-    , ('\8140','\8140')-    , ('\8188','\8188')-    ]---- --------------------------------------------------------------isUnicodeLu     :: Char -> Bool-isUnicodeLu c-  = isInList c-    [ ('A','Z')-    , ('\192','\214')-    , ('\216','\222')-    , ('\256','\256')-    , ('\258','\258')-    , ('\260','\260')-    , ('\262','\262')-    , ('\264','\264')-    , ('\266','\266')-    , ('\268','\268')-    , ('\270','\270')-    , ('\272','\272')-    , ('\274','\274')-    , ('\276','\276')-    , ('\278','\278')-    , ('\280','\280')-    , ('\282','\282')-    , ('\284','\284')-    , ('\286','\286')-    , ('\288','\288')-    , ('\290','\290')-    , ('\292','\292')-    , ('\294','\294')-    , ('\296','\296')-    , ('\298','\298')-    , ('\300','\300')-    , ('\302','\302')-    , ('\304','\304')-    , ('\306','\306')-    , ('\308','\308')-    , ('\310','\310')-    , ('\313','\313')-    , ('\315','\315')-    , ('\317','\317')-    , ('\319','\319')-    , ('\321','\321')-    , ('\323','\323')-    , ('\325','\325')-    , ('\327','\327')-    , ('\330','\330')-    , ('\332','\332')-    , ('\334','\334')-    , ('\336','\336')-    , ('\338','\338')-    , ('\340','\340')-    , ('\342','\342')-    , ('\344','\344')-    , ('\346','\346')-    , ('\348','\348')-    , ('\350','\350')-    , ('\352','\352')-    , ('\354','\354')-    , ('\356','\356')-    , ('\358','\358')-    , ('\360','\360')-    , ('\362','\362')-    , ('\364','\364')-    , ('\366','\366')-    , ('\368','\368')-    , ('\370','\370')-    , ('\372','\372')-    , ('\374','\374')-    , ('\376','\377')-    , ('\379','\379')-    , ('\381','\381')-    , ('\385','\386')-    , ('\388','\388')-    , ('\390','\391')-    , ('\393','\395')-    , ('\398','\401')-    , ('\403','\404')-    , ('\406','\408')-    , ('\412','\413')-    , ('\415','\416')-    , ('\418','\418')-    , ('\420','\420')-    , ('\422','\423')-    , ('\425','\425')-    , ('\428','\428')-    , ('\430','\431')-    , ('\433','\435')-    , ('\437','\437')-    , ('\439','\440')-    , ('\444','\444')-    , ('\452','\452')-    , ('\455','\455')-    , ('\458','\458')-    , ('\461','\461')-    , ('\463','\463')-    , ('\465','\465')-    , ('\467','\467')-    , ('\469','\469')-    , ('\471','\471')-    , ('\473','\473')-    , ('\475','\475')-    , ('\478','\478')-    , ('\480','\480')-    , ('\482','\482')-    , ('\484','\484')-    , ('\486','\486')-    , ('\488','\488')-    , ('\490','\490')-    , ('\492','\492')-    , ('\494','\494')-    , ('\497','\497')-    , ('\500','\500')-    , ('\502','\504')-    , ('\506','\506')-    , ('\508','\508')-    , ('\510','\510')-    , ('\512','\512')-    , ('\514','\514')-    , ('\516','\516')-    , ('\518','\518')-    , ('\520','\520')-    , ('\522','\522')-    , ('\524','\524')-    , ('\526','\526')-    , ('\528','\528')-    , ('\530','\530')-    , ('\532','\532')-    , ('\534','\534')-    , ('\536','\536')-    , ('\538','\538')-    , ('\540','\540')-    , ('\542','\542')-    , ('\544','\544')-    , ('\546','\546')-    , ('\548','\548')-    , ('\550','\550')-    , ('\552','\552')-    , ('\554','\554')-    , ('\556','\556')-    , ('\558','\558')-    , ('\560','\560')-    , ('\562','\562')-    , ('\570','\571')-    , ('\573','\574')-    , ('\577','\577')-    , ('\579','\582')-    , ('\584','\584')-    , ('\586','\586')-    , ('\588','\588')-    , ('\590','\590')-    , ('\880','\880')-    , ('\882','\882')-    , ('\886','\886')-    , ('\902','\902')-    , ('\904','\906')-    , ('\908','\908')-    , ('\910','\911')-    , ('\913','\929')-    , ('\931','\939')-    , ('\975','\975')-    , ('\978','\980')-    , ('\984','\984')-    , ('\986','\986')-    , ('\988','\988')-    , ('\990','\990')-    , ('\992','\992')-    , ('\994','\994')-    , ('\996','\996')-    , ('\998','\998')-    , ('\1000','\1000')-    , ('\1002','\1002')-    , ('\1004','\1004')-    , ('\1006','\1006')-    , ('\1012','\1012')-    , ('\1015','\1015')-    , ('\1017','\1018')-    , ('\1021','\1071')-    , ('\1120','\1120')-    , ('\1122','\1122')-    , ('\1124','\1124')-    , ('\1126','\1126')-    , ('\1128','\1128')-    , ('\1130','\1130')-    , ('\1132','\1132')-    , ('\1134','\1134')-    , ('\1136','\1136')-    , ('\1138','\1138')-    , ('\1140','\1140')-    , ('\1142','\1142')-    , ('\1144','\1144')-    , ('\1146','\1146')-    , ('\1148','\1148')-    , ('\1150','\1150')-    , ('\1152','\1152')-    , ('\1162','\1162')-    , ('\1164','\1164')-    , ('\1166','\1166')-    , ('\1168','\1168')-    , ('\1170','\1170')-    , ('\1172','\1172')-    , ('\1174','\1174')-    , ('\1176','\1176')-    , ('\1178','\1178')-    , ('\1180','\1180')-    , ('\1182','\1182')-    , ('\1184','\1184')-    , ('\1186','\1186')-    , ('\1188','\1188')-    , ('\1190','\1190')-    , ('\1192','\1192')-    , ('\1194','\1194')-    , ('\1196','\1196')-    , ('\1198','\1198')-    , ('\1200','\1200')-    , ('\1202','\1202')-    , ('\1204','\1204')-    , ('\1206','\1206')-    , ('\1208','\1208')-    , ('\1210','\1210')-    , ('\1212','\1212')-    , ('\1214','\1214')-    , ('\1216','\1217')-    , ('\1219','\1219')-    , ('\1221','\1221')-    , ('\1223','\1223')-    , ('\1225','\1225')-    , ('\1227','\1227')-    , ('\1229','\1229')-    , ('\1232','\1232')-    , ('\1234','\1234')-    , ('\1236','\1236')-    , ('\1238','\1238')-    , ('\1240','\1240')-    , ('\1242','\1242')-    , ('\1244','\1244')-    , ('\1246','\1246')-    , ('\1248','\1248')-    , ('\1250','\1250')-    , ('\1252','\1252')-    , ('\1254','\1254')-    , ('\1256','\1256')-    , ('\1258','\1258')-    , ('\1260','\1260')-    , ('\1262','\1262')-    , ('\1264','\1264')-    , ('\1266','\1266')-    , ('\1268','\1268')-    , ('\1270','\1270')-    , ('\1272','\1272')-    , ('\1274','\1274')-    , ('\1276','\1276')-    , ('\1278','\1278')-    , ('\1280','\1280')-    , ('\1282','\1282')-    , ('\1284','\1284')-    , ('\1286','\1286')-    , ('\1288','\1288')-    , ('\1290','\1290')-    , ('\1292','\1292')-    , ('\1294','\1294')-    , ('\1296','\1296')-    , ('\1298','\1298')-    , ('\1300','\1300')-    , ('\1302','\1302')-    , ('\1304','\1304')-    , ('\1306','\1306')-    , ('\1308','\1308')-    , ('\1310','\1310')-    , ('\1312','\1312')-    , ('\1314','\1314')-    , ('\1316','\1316')-    , ('\1329','\1366')-    , ('\4256','\4293')-    , ('\7680','\7680')-    , ('\7682','\7682')-    , ('\7684','\7684')-    , ('\7686','\7686')-    , ('\7688','\7688')-    , ('\7690','\7690')-    , ('\7692','\7692')-    , ('\7694','\7694')-    , ('\7696','\7696')-    , ('\7698','\7698')-    , ('\7700','\7700')-    , ('\7702','\7702')-    , ('\7704','\7704')-    , ('\7706','\7706')-    , ('\7708','\7708')-    , ('\7710','\7710')-    , ('\7712','\7712')-    , ('\7714','\7714')-    , ('\7716','\7716')-    , ('\7718','\7718')-    , ('\7720','\7720')-    , ('\7722','\7722')-    , ('\7724','\7724')-    , ('\7726','\7726')-    , ('\7728','\7728')-    , ('\7730','\7730')-    , ('\7732','\7732')-    , ('\7734','\7734')-    , ('\7736','\7736')-    , ('\7738','\7738')-    , ('\7740','\7740')-    , ('\7742','\7742')-    , ('\7744','\7744')-    , ('\7746','\7746')-    , ('\7748','\7748')-    , ('\7750','\7750')-    , ('\7752','\7752')-    , ('\7754','\7754')-    , ('\7756','\7756')-    , ('\7758','\7758')-    , ('\7760','\7760')-    , ('\7762','\7762')-    , ('\7764','\7764')-    , ('\7766','\7766')-    , ('\7768','\7768')-    , ('\7770','\7770')-    , ('\7772','\7772')-    , ('\7774','\7774')-    , ('\7776','\7776')-    , ('\7778','\7778')-    , ('\7780','\7780')-    , ('\7782','\7782')-    , ('\7784','\7784')-    , ('\7786','\7786')-    , ('\7788','\7788')-    , ('\7790','\7790')-    , ('\7792','\7792')-    , ('\7794','\7794')-    , ('\7796','\7796')-    , ('\7798','\7798')-    , ('\7800','\7800')-    , ('\7802','\7802')-    , ('\7804','\7804')-    , ('\7806','\7806')-    , ('\7808','\7808')-    , ('\7810','\7810')-    , ('\7812','\7812')-    , ('\7814','\7814')-    , ('\7816','\7816')-    , ('\7818','\7818')-    , ('\7820','\7820')-    , ('\7822','\7822')-    , ('\7824','\7824')-    , ('\7826','\7826')-    , ('\7828','\7828')-    , ('\7838','\7838')-    , ('\7840','\7840')-    , ('\7842','\7842')-    , ('\7844','\7844')-    , ('\7846','\7846')-    , ('\7848','\7848')-    , ('\7850','\7850')-    , ('\7852','\7852')-    , ('\7854','\7854')-    , ('\7856','\7856')-    , ('\7858','\7858')-    , ('\7860','\7860')-    , ('\7862','\7862')-    , ('\7864','\7864')-    , ('\7866','\7866')-    , ('\7868','\7868')-    , ('\7870','\7870')-    , ('\7872','\7872')-    , ('\7874','\7874')-    , ('\7876','\7876')-    , ('\7878','\7878')-    , ('\7880','\7880')-    , ('\7882','\7882')-    , ('\7884','\7884')-    , ('\7886','\7886')-    , ('\7888','\7888')-    , ('\7890','\7890')-    , ('\7892','\7892')-    , ('\7894','\7894')-    , ('\7896','\7896')-    , ('\7898','\7898')-    , ('\7900','\7900')-    , ('\7902','\7902')-    , ('\7904','\7904')-    , ('\7906','\7906')-    , ('\7908','\7908')-    , ('\7910','\7910')-    , ('\7912','\7912')-    , ('\7914','\7914')-    , ('\7916','\7916')-    , ('\7918','\7918')-    , ('\7920','\7920')-    , ('\7922','\7922')-    , ('\7924','\7924')-    , ('\7926','\7926')-    , ('\7928','\7928')-    , ('\7930','\7930')-    , ('\7932','\7932')-    , ('\7934','\7934')-    , ('\7944','\7951')-    , ('\7960','\7965')-    , ('\7976','\7983')-    , ('\7992','\7999')-    , ('\8008','\8013')-    , ('\8025','\8025')-    , ('\8027','\8027')-    , ('\8029','\8029')-    , ('\8031','\8031')-    , ('\8040','\8047')-    , ('\8120','\8123')-    , ('\8136','\8139')-    , ('\8152','\8155')-    , ('\8168','\8172')-    , ('\8184','\8187')-    , ('\8450','\8450')-    , ('\8455','\8455')-    , ('\8459','\8461')-    , ('\8464','\8466')-    , ('\8469','\8469')-    , ('\8473','\8477')-    , ('\8484','\8484')-    , ('\8486','\8486')-    , ('\8488','\8488')-    , ('\8490','\8493')-    , ('\8496','\8499')-    , ('\8510','\8511')-    , ('\8517','\8517')-    , ('\8579','\8579')-    , ('\11264','\11310')-    , ('\11360','\11360')-    , ('\11362','\11364')-    , ('\11367','\11367')-    , ('\11369','\11369')-    , ('\11371','\11371')-    , ('\11373','\11376')-    , ('\11378','\11378')-    , ('\11381','\11381')-    , ('\11390','\11392')-    , ('\11394','\11394')-    , ('\11396','\11396')-    , ('\11398','\11398')-    , ('\11400','\11400')-    , ('\11402','\11402')-    , ('\11404','\11404')-    , ('\11406','\11406')-    , ('\11408','\11408')-    , ('\11410','\11410')-    , ('\11412','\11412')-    , ('\11414','\11414')-    , ('\11416','\11416')-    , ('\11418','\11418')-    , ('\11420','\11420')-    , ('\11422','\11422')-    , ('\11424','\11424')-    , ('\11426','\11426')-    , ('\11428','\11428')-    , ('\11430','\11430')-    , ('\11432','\11432')-    , ('\11434','\11434')-    , ('\11436','\11436')-    , ('\11438','\11438')-    , ('\11440','\11440')-    , ('\11442','\11442')-    , ('\11444','\11444')-    , ('\11446','\11446')-    , ('\11448','\11448')-    , ('\11450','\11450')-    , ('\11452','\11452')-    , ('\11454','\11454')-    , ('\11456','\11456')-    , ('\11458','\11458')-    , ('\11460','\11460')-    , ('\11462','\11462')-    , ('\11464','\11464')-    , ('\11466','\11466')-    , ('\11468','\11468')-    , ('\11470','\11470')-    , ('\11472','\11472')-    , ('\11474','\11474')-    , ('\11476','\11476')-    , ('\11478','\11478')-    , ('\11480','\11480')-    , ('\11482','\11482')-    , ('\11484','\11484')-    , ('\11486','\11486')-    , ('\11488','\11488')-    , ('\11490','\11490')-    , ('\11499','\11499')-    , ('\11501','\11501')-    , ('\42560','\42560')-    , ('\42562','\42562')-    , ('\42564','\42564')-    , ('\42566','\42566')-    , ('\42568','\42568')-    , ('\42570','\42570')-    , ('\42572','\42572')-    , ('\42574','\42574')-    , ('\42576','\42576')-    , ('\42578','\42578')-    , ('\42580','\42580')-    , ('\42582','\42582')-    , ('\42584','\42584')-    , ('\42586','\42586')-    , ('\42588','\42588')-    , ('\42590','\42590')-    , ('\42594','\42594')-    , ('\42596','\42596')-    , ('\42598','\42598')-    , ('\42600','\42600')-    , ('\42602','\42602')-    , ('\42604','\42604')-    , ('\42624','\42624')-    , ('\42626','\42626')-    , ('\42628','\42628')-    , ('\42630','\42630')-    , ('\42632','\42632')-    , ('\42634','\42634')-    , ('\42636','\42636')-    , ('\42638','\42638')-    , ('\42640','\42640')-    , ('\42642','\42642')-    , ('\42644','\42644')-    , ('\42646','\42646')-    , ('\42786','\42786')-    , ('\42788','\42788')-    , ('\42790','\42790')-    , ('\42792','\42792')-    , ('\42794','\42794')-    , ('\42796','\42796')-    , ('\42798','\42798')-    , ('\42802','\42802')-    , ('\42804','\42804')-    , ('\42806','\42806')-    , ('\42808','\42808')-    , ('\42810','\42810')-    , ('\42812','\42812')-    , ('\42814','\42814')-    , ('\42816','\42816')-    , ('\42818','\42818')-    , ('\42820','\42820')-    , ('\42822','\42822')-    , ('\42824','\42824')-    , ('\42826','\42826')-    , ('\42828','\42828')-    , ('\42830','\42830')-    , ('\42832','\42832')-    , ('\42834','\42834')-    , ('\42836','\42836')-    , ('\42838','\42838')-    , ('\42840','\42840')-    , ('\42842','\42842')-    , ('\42844','\42844')-    , ('\42846','\42846')-    , ('\42848','\42848')-    , ('\42850','\42850')-    , ('\42852','\42852')-    , ('\42854','\42854')-    , ('\42856','\42856')-    , ('\42858','\42858')-    , ('\42860','\42860')-    , ('\42862','\42862')-    , ('\42873','\42873')-    , ('\42875','\42875')-    , ('\42877','\42878')-    , ('\42880','\42880')-    , ('\42882','\42882')-    , ('\42884','\42884')-    , ('\42886','\42886')-    , ('\42891','\42891')-    , ('\65313','\65338')-    , ('\66560','\66599')-    , ('\119808','\119833')-    , ('\119860','\119885')-    , ('\119912','\119937')-    , ('\119964','\119964')-    , ('\119966','\119967')-    , ('\119970','\119970')-    , ('\119973','\119974')-    , ('\119977','\119980')-    , ('\119982','\119989')-    , ('\120016','\120041')-    , ('\120068','\120069')-    , ('\120071','\120074')-    , ('\120077','\120084')-    , ('\120086','\120092')-    , ('\120120','\120121')-    , ('\120123','\120126')-    , ('\120128','\120132')-    , ('\120134','\120134')-    , ('\120138','\120144')-    , ('\120172','\120197')-    , ('\120224','\120249')-    , ('\120276','\120301')-    , ('\120328','\120353')-    , ('\120380','\120405')-    , ('\120432','\120457')-    , ('\120488','\120512')-    , ('\120546','\120570')-    , ('\120604','\120628')-    , ('\120662','\120686')-    , ('\120720','\120744')-    , ('\120778','\120778')-    ]---- --------------------------------------------------------------isUnicodeM      :: Char -> Bool-isUnicodeM c-  = isInList c-    [ ('\768','\879')-    , ('\1155','\1161')-    , ('\1425','\1469')-    , ('\1471','\1471')-    , ('\1473','\1474')-    , ('\1476','\1477')-    , ('\1479','\1479')-    , ('\1552','\1562')-    , ('\1611','\1630')-    , ('\1648','\1648')-    , ('\1750','\1756')-    , ('\1758','\1764')-    , ('\1767','\1768')-    , ('\1770','\1773')-    , ('\1809','\1809')-    , ('\1840','\1866')-    , ('\1958','\1968')-    , ('\2027','\2035')-    , ('\2070','\2073')-    , ('\2075','\2083')-    , ('\2085','\2087')-    , ('\2089','\2093')-    , ('\2304','\2307')-    , ('\2364','\2364')-    , ('\2366','\2382')-    , ('\2385','\2389')-    , ('\2402','\2403')-    , ('\2433','\2435')-    , ('\2492','\2492')-    , ('\2494','\2500')-    , ('\2503','\2504')-    , ('\2507','\2509')-    , ('\2519','\2519')-    , ('\2530','\2531')-    , ('\2561','\2563')-    , ('\2620','\2620')-    , ('\2622','\2626')-    , ('\2631','\2632')-    , ('\2635','\2637')-    , ('\2641','\2641')-    , ('\2672','\2673')-    , ('\2677','\2677')-    , ('\2689','\2691')-    , ('\2748','\2748')-    , ('\2750','\2757')-    , ('\2759','\2761')-    , ('\2763','\2765')-    , ('\2786','\2787')-    , ('\2817','\2819')-    , ('\2876','\2876')-    , ('\2878','\2884')-    , ('\2887','\2888')-    , ('\2891','\2893')-    , ('\2902','\2903')-    , ('\2914','\2915')-    , ('\2946','\2946')-    , ('\3006','\3010')-    , ('\3014','\3016')-    , ('\3018','\3021')-    , ('\3031','\3031')-    , ('\3073','\3075')-    , ('\3134','\3140')-    , ('\3142','\3144')-    , ('\3146','\3149')-    , ('\3157','\3158')-    , ('\3170','\3171')-    , ('\3202','\3203')-    , ('\3260','\3260')-    , ('\3262','\3268')-    , ('\3270','\3272')-    , ('\3274','\3277')-    , ('\3285','\3286')-    , ('\3298','\3299')-    , ('\3330','\3331')-    , ('\3390','\3396')-    , ('\3398','\3400')-    , ('\3402','\3405')-    , ('\3415','\3415')-    , ('\3426','\3427')-    , ('\3458','\3459')-    , ('\3530','\3530')-    , ('\3535','\3540')-    , ('\3542','\3542')-    , ('\3544','\3551')-    , ('\3570','\3571')-    , ('\3633','\3633')-    , ('\3636','\3642')-    , ('\3655','\3662')-    , ('\3761','\3761')-    , ('\3764','\3769')-    , ('\3771','\3772')-    , ('\3784','\3789')-    , ('\3864','\3865')-    , ('\3893','\3893')-    , ('\3895','\3895')-    , ('\3897','\3897')-    , ('\3902','\3903')-    , ('\3953','\3972')-    , ('\3974','\3975')-    , ('\3984','\3991')-    , ('\3993','\4028')-    , ('\4038','\4038')-    , ('\4139','\4158')-    , ('\4182','\4185')-    , ('\4190','\4192')-    , ('\4194','\4196')-    , ('\4199','\4205')-    , ('\4209','\4212')-    , ('\4226','\4237')-    , ('\4239','\4239')-    , ('\4250','\4253')-    , ('\4959','\4959')-    , ('\5906','\5908')-    , ('\5938','\5940')-    , ('\5970','\5971')-    , ('\6002','\6003')-    , ('\6070','\6099')-    , ('\6109','\6109')-    , ('\6155','\6157')-    , ('\6313','\6313')-    , ('\6432','\6443')-    , ('\6448','\6459')-    , ('\6576','\6592')-    , ('\6600','\6601')-    , ('\6679','\6683')-    , ('\6741','\6750')-    , ('\6752','\6780')-    , ('\6783','\6783')-    , ('\6912','\6916')-    , ('\6964','\6980')-    , ('\7019','\7027')-    , ('\7040','\7042')-    , ('\7073','\7082')-    , ('\7204','\7223')-    , ('\7376','\7378')-    , ('\7380','\7400')-    , ('\7405','\7405')-    , ('\7410','\7410')-    , ('\7616','\7654')-    , ('\7677','\7679')-    , ('\8400','\8432')-    , ('\11503','\11505')-    , ('\11744','\11775')-    , ('\12330','\12335')-    , ('\12441','\12442')-    , ('\42607','\42610')-    , ('\42620','\42621')-    , ('\42736','\42737')-    , ('\43010','\43010')-    , ('\43014','\43014')-    , ('\43019','\43019')-    , ('\43043','\43047')-    , ('\43136','\43137')-    , ('\43188','\43204')-    , ('\43232','\43249')-    , ('\43302','\43309')-    , ('\43335','\43347')-    , ('\43392','\43395')-    , ('\43443','\43456')-    , ('\43561','\43574')-    , ('\43587','\43587')-    , ('\43596','\43597')-    , ('\43643','\43643')-    , ('\43696','\43696')-    , ('\43698','\43700')-    , ('\43703','\43704')-    , ('\43710','\43711')-    , ('\43713','\43713')-    , ('\44003','\44010')-    , ('\44012','\44013')-    , ('\64286','\64286')-    , ('\65024','\65039')-    , ('\65056','\65062')-    , ('\66045','\66045')-    , ('\68097','\68099')-    , ('\68101','\68102')-    , ('\68108','\68111')-    , ('\68152','\68154')-    , ('\68159','\68159')-    , ('\69760','\69762')-    , ('\69808','\69818')-    , ('\119141','\119145')-    , ('\119149','\119154')-    , ('\119163','\119170')-    , ('\119173','\119179')-    , ('\119210','\119213')-    , ('\119362','\119364')-    , ('\917760','\917999')-    ]---- --------------------------------------------------------------isUnicodeMc     :: Char -> Bool-isUnicodeMc c-  = isInList c-    [ ('\2307','\2307')-    , ('\2366','\2368')-    , ('\2377','\2380')-    , ('\2382','\2382')-    , ('\2434','\2435')-    , ('\2494','\2496')-    , ('\2503','\2504')-    , ('\2507','\2508')-    , ('\2519','\2519')-    , ('\2563','\2563')-    , ('\2622','\2624')-    , ('\2691','\2691')-    , ('\2750','\2752')-    , ('\2761','\2761')-    , ('\2763','\2764')-    , ('\2818','\2819')-    , ('\2878','\2878')-    , ('\2880','\2880')-    , ('\2887','\2888')-    , ('\2891','\2892')-    , ('\2903','\2903')-    , ('\3006','\3007')-    , ('\3009','\3010')-    , ('\3014','\3016')-    , ('\3018','\3020')-    , ('\3031','\3031')-    , ('\3073','\3075')-    , ('\3137','\3140')-    , ('\3202','\3203')-    , ('\3262','\3262')-    , ('\3264','\3268')-    , ('\3271','\3272')-    , ('\3274','\3275')-    , ('\3285','\3286')-    , ('\3330','\3331')-    , ('\3390','\3392')-    , ('\3398','\3400')-    , ('\3402','\3404')-    , ('\3415','\3415')-    , ('\3458','\3459')-    , ('\3535','\3537')-    , ('\3544','\3551')-    , ('\3570','\3571')-    , ('\3902','\3903')-    , ('\3967','\3967')-    , ('\4139','\4140')-    , ('\4145','\4145')-    , ('\4152','\4152')-    , ('\4155','\4156')-    , ('\4182','\4183')-    , ('\4194','\4196')-    , ('\4199','\4205')-    , ('\4227','\4228')-    , ('\4231','\4236')-    , ('\4239','\4239')-    , ('\4250','\4252')-    , ('\6070','\6070')-    , ('\6078','\6085')-    , ('\6087','\6088')-    , ('\6435','\6438')-    , ('\6441','\6443')-    , ('\6448','\6449')-    , ('\6451','\6456')-    , ('\6576','\6592')-    , ('\6600','\6601')-    , ('\6681','\6683')-    , ('\6741','\6741')-    , ('\6743','\6743')-    , ('\6753','\6753')-    , ('\6755','\6756')-    , ('\6765','\6770')-    , ('\6916','\6916')-    , ('\6965','\6965')-    , ('\6971','\6971')-    , ('\6973','\6977')-    , ('\6979','\6980')-    , ('\7042','\7042')-    , ('\7073','\7073')-    , ('\7078','\7079')-    , ('\7082','\7082')-    , ('\7204','\7211')-    , ('\7220','\7221')-    , ('\7393','\7393')-    , ('\7410','\7410')-    , ('\43043','\43044')-    , ('\43047','\43047')-    , ('\43136','\43137')-    , ('\43188','\43203')-    , ('\43346','\43347')-    , ('\43395','\43395')-    , ('\43444','\43445')-    , ('\43450','\43451')-    , ('\43453','\43456')-    , ('\43567','\43568')-    , ('\43571','\43572')-    , ('\43597','\43597')-    , ('\43643','\43643')-    , ('\44003','\44004')-    , ('\44006','\44007')-    , ('\44009','\44010')-    , ('\44012','\44012')-    , ('\69762','\69762')-    , ('\69808','\69810')-    , ('\69815','\69816')-    , ('\119141','\119142')-    , ('\119149','\119154')-    ]---- --------------------------------------------------------------isUnicodeMe     :: Char -> Bool-isUnicodeMe c-  = isInList c-    [ ('\1160','\1161')-    , ('\1758','\1758')-    , ('\8413','\8416')-    , ('\8418','\8420')-    , ('\42608','\42610')-    ]---- --------------------------------------------------------------isUnicodeMn     :: Char -> Bool-isUnicodeMn c-  = isInList c-    [ ('\768','\879')-    , ('\1155','\1159')-    , ('\1425','\1469')-    , ('\1471','\1471')-    , ('\1473','\1474')-    , ('\1476','\1477')-    , ('\1479','\1479')-    , ('\1552','\1562')-    , ('\1611','\1630')-    , ('\1648','\1648')-    , ('\1750','\1756')-    , ('\1759','\1764')-    , ('\1767','\1768')-    , ('\1770','\1773')-    , ('\1809','\1809')-    , ('\1840','\1866')-    , ('\1958','\1968')-    , ('\2027','\2035')-    , ('\2070','\2073')-    , ('\2075','\2083')-    , ('\2085','\2087')-    , ('\2089','\2093')-    , ('\2304','\2306')-    , ('\2364','\2364')-    , ('\2369','\2376')-    , ('\2381','\2381')-    , ('\2385','\2389')-    , ('\2402','\2403')-    , ('\2433','\2433')-    , ('\2492','\2492')-    , ('\2497','\2500')-    , ('\2509','\2509')-    , ('\2530','\2531')-    , ('\2561','\2562')-    , ('\2620','\2620')-    , ('\2625','\2626')-    , ('\2631','\2632')-    , ('\2635','\2637')-    , ('\2641','\2641')-    , ('\2672','\2673')-    , ('\2677','\2677')-    , ('\2689','\2690')-    , ('\2748','\2748')-    , ('\2753','\2757')-    , ('\2759','\2760')-    , ('\2765','\2765')-    , ('\2786','\2787')-    , ('\2817','\2817')-    , ('\2876','\2876')-    , ('\2879','\2879')-    , ('\2881','\2884')-    , ('\2893','\2893')-    , ('\2902','\2902')-    , ('\2914','\2915')-    , ('\2946','\2946')-    , ('\3008','\3008')-    , ('\3021','\3021')-    , ('\3134','\3136')-    , ('\3142','\3144')-    , ('\3146','\3149')-    , ('\3157','\3158')-    , ('\3170','\3171')-    , ('\3260','\3260')-    , ('\3263','\3263')-    , ('\3270','\3270')-    , ('\3276','\3277')-    , ('\3298','\3299')-    , ('\3393','\3396')-    , ('\3405','\3405')-    , ('\3426','\3427')-    , ('\3530','\3530')-    , ('\3538','\3540')-    , ('\3542','\3542')-    , ('\3633','\3633')-    , ('\3636','\3642')-    , ('\3655','\3662')-    , ('\3761','\3761')-    , ('\3764','\3769')-    , ('\3771','\3772')-    , ('\3784','\3789')-    , ('\3864','\3865')-    , ('\3893','\3893')-    , ('\3895','\3895')-    , ('\3897','\3897')-    , ('\3953','\3966')-    , ('\3968','\3972')-    , ('\3974','\3975')-    , ('\3984','\3991')-    , ('\3993','\4028')-    , ('\4038','\4038')-    , ('\4141','\4144')-    , ('\4146','\4151')-    , ('\4153','\4154')-    , ('\4157','\4158')-    , ('\4184','\4185')-    , ('\4190','\4192')-    , ('\4209','\4212')-    , ('\4226','\4226')-    , ('\4229','\4230')-    , ('\4237','\4237')-    , ('\4253','\4253')-    , ('\4959','\4959')-    , ('\5906','\5908')-    , ('\5938','\5940')-    , ('\5970','\5971')-    , ('\6002','\6003')-    , ('\6071','\6077')-    , ('\6086','\6086')-    , ('\6089','\6099')-    , ('\6109','\6109')-    , ('\6155','\6157')-    , ('\6313','\6313')-    , ('\6432','\6434')-    , ('\6439','\6440')-    , ('\6450','\6450')-    , ('\6457','\6459')-    , ('\6679','\6680')-    , ('\6742','\6742')-    , ('\6744','\6750')-    , ('\6752','\6752')-    , ('\6754','\6754')-    , ('\6757','\6764')-    , ('\6771','\6780')-    , ('\6783','\6783')-    , ('\6912','\6915')-    , ('\6964','\6964')-    , ('\6966','\6970')-    , ('\6972','\6972')-    , ('\6978','\6978')-    , ('\7019','\7027')-    , ('\7040','\7041')-    , ('\7074','\7077')-    , ('\7080','\7081')-    , ('\7212','\7219')-    , ('\7222','\7223')-    , ('\7376','\7378')-    , ('\7380','\7392')-    , ('\7394','\7400')-    , ('\7405','\7405')-    , ('\7616','\7654')-    , ('\7677','\7679')-    , ('\8400','\8412')-    , ('\8417','\8417')-    , ('\8421','\8432')-    , ('\11503','\11505')-    , ('\11744','\11775')-    , ('\12330','\12335')-    , ('\12441','\12442')-    , ('\42607','\42607')-    , ('\42620','\42621')-    , ('\42736','\42737')-    , ('\43010','\43010')-    , ('\43014','\43014')-    , ('\43019','\43019')-    , ('\43045','\43046')-    , ('\43204','\43204')-    , ('\43232','\43249')-    , ('\43302','\43309')-    , ('\43335','\43345')-    , ('\43392','\43394')-    , ('\43443','\43443')-    , ('\43446','\43449')-    , ('\43452','\43452')-    , ('\43561','\43566')-    , ('\43569','\43570')-    , ('\43573','\43574')-    , ('\43587','\43587')-    , ('\43596','\43596')-    , ('\43696','\43696')-    , ('\43698','\43700')-    , ('\43703','\43704')-    , ('\43710','\43711')-    , ('\43713','\43713')-    , ('\44005','\44005')-    , ('\44008','\44008')-    , ('\44013','\44013')-    , ('\64286','\64286')-    , ('\65024','\65039')-    , ('\65056','\65062')-    , ('\66045','\66045')-    , ('\68097','\68099')-    , ('\68101','\68102')-    , ('\68108','\68111')-    , ('\68152','\68154')-    , ('\68159','\68159')-    , ('\69760','\69761')-    , ('\69811','\69814')-    , ('\69817','\69818')-    , ('\119143','\119145')-    , ('\119163','\119170')-    , ('\119173','\119179')-    , ('\119210','\119213')-    , ('\119362','\119364')-    , ('\917760','\917999')-    ]---- --------------------------------------------------------------isUnicodeN      :: Char -> Bool-isUnicodeN c-  = isInList c-    [ ('0','9')-    , ('\178','\179')-    , ('\185','\185')-    , ('\188','\190')-    , ('\1632','\1641')-    , ('\1776','\1785')-    , ('\1984','\1993')-    , ('\2406','\2415')-    , ('\2534','\2543')-    , ('\2548','\2553')-    , ('\2662','\2671')-    , ('\2790','\2799')-    , ('\2918','\2927')-    , ('\3046','\3058')-    , ('\3174','\3183')-    , ('\3192','\3198')-    , ('\3302','\3311')-    , ('\3430','\3445')-    , ('\3664','\3673')-    , ('\3792','\3801')-    , ('\3872','\3891')-    , ('\4160','\4169')-    , ('\4240','\4249')-    , ('\4969','\4988')-    , ('\5870','\5872')-    , ('\6112','\6121')-    , ('\6128','\6137')-    , ('\6160','\6169')-    , ('\6470','\6479')-    , ('\6608','\6618')-    , ('\6784','\6793')-    , ('\6800','\6809')-    , ('\6992','\7001')-    , ('\7088','\7097')-    , ('\7232','\7241')-    , ('\7248','\7257')-    , ('\8304','\8304')-    , ('\8308','\8313')-    , ('\8320','\8329')-    , ('\8528','\8578')-    , ('\8581','\8585')-    , ('\9312','\9371')-    , ('\9450','\9471')-    , ('\10102','\10131')-    , ('\11517','\11517')-    , ('\12295','\12295')-    , ('\12321','\12329')-    , ('\12344','\12346')-    , ('\12690','\12693')-    , ('\12832','\12841')-    , ('\12881','\12895')-    , ('\12928','\12937')-    , ('\12977','\12991')-    , ('\42528','\42537')-    , ('\42726','\42735')-    , ('\43056','\43061')-    , ('\43216','\43225')-    , ('\43264','\43273')-    , ('\43472','\43481')-    , ('\43600','\43609')-    , ('\44016','\44025')-    , ('\65296','\65305')-    , ('\65799','\65843')-    , ('\65856','\65912')-    , ('\65930','\65930')-    , ('\66336','\66339')-    , ('\66369','\66369')-    , ('\66378','\66378')-    , ('\66513','\66517')-    , ('\66720','\66729')-    , ('\67672','\67679')-    , ('\67862','\67867')-    , ('\68160','\68167')-    , ('\68221','\68222')-    , ('\68440','\68447')-    , ('\68472','\68479')-    , ('\69216','\69246')-    , ('\74752','\74850')-    , ('\119648','\119665')-    , ('\120782','\120831')-    , ('\127232','\127242')-    ]---- --------------------------------------------------------------isUnicodeNd     :: Char -> Bool-isUnicodeNd c-  = isInList c-    [ ('0','9')-    , ('\1632','\1641')-    , ('\1776','\1785')-    , ('\1984','\1993')-    , ('\2406','\2415')-    , ('\2534','\2543')-    , ('\2662','\2671')-    , ('\2790','\2799')-    , ('\2918','\2927')-    , ('\3046','\3055')-    , ('\3174','\3183')-    , ('\3302','\3311')-    , ('\3430','\3439')-    , ('\3664','\3673')-    , ('\3792','\3801')-    , ('\3872','\3881')-    , ('\4160','\4169')-    , ('\4240','\4249')-    , ('\6112','\6121')-    , ('\6160','\6169')-    , ('\6470','\6479')-    , ('\6608','\6618')-    , ('\6784','\6793')-    , ('\6800','\6809')-    , ('\6992','\7001')-    , ('\7088','\7097')-    , ('\7232','\7241')-    , ('\7248','\7257')-    , ('\42528','\42537')-    , ('\43216','\43225')-    , ('\43264','\43273')-    , ('\43472','\43481')-    , ('\43600','\43609')-    , ('\44016','\44025')-    , ('\65296','\65305')-    , ('\66720','\66729')-    , ('\120782','\120831')-    ]---- --------------------------------------------------------------isUnicodeNl     :: Char -> Bool-isUnicodeNl c-  = isInList c-    [ ('\5870','\5872')-    , ('\8544','\8578')-    , ('\8581','\8584')-    , ('\12295','\12295')-    , ('\12321','\12329')-    , ('\12344','\12346')-    , ('\42726','\42735')-    , ('\65856','\65908')-    , ('\66369','\66369')-    , ('\66378','\66378')-    , ('\66513','\66517')-    , ('\74752','\74850')-    ]---- --------------------------------------------------------------isUnicodeNo     :: Char -> Bool-isUnicodeNo c-  = isInList c-    [ ('\178','\179')-    , ('\185','\185')-    , ('\188','\190')-    , ('\2548','\2553')-    , ('\3056','\3058')-    , ('\3192','\3198')-    , ('\3440','\3445')-    , ('\3882','\3891')-    , ('\4969','\4988')-    , ('\6128','\6137')-    , ('\8304','\8304')-    , ('\8308','\8313')-    , ('\8320','\8329')-    , ('\8528','\8543')-    , ('\8585','\8585')-    , ('\9312','\9371')-    , ('\9450','\9471')-    , ('\10102','\10131')-    , ('\11517','\11517')-    , ('\12690','\12693')-    , ('\12832','\12841')-    , ('\12881','\12895')-    , ('\12928','\12937')-    , ('\12977','\12991')-    , ('\43056','\43061')-    , ('\65799','\65843')-    , ('\65909','\65912')-    , ('\65930','\65930')-    , ('\66336','\66339')-    , ('\67672','\67679')-    , ('\67862','\67867')-    , ('\68160','\68167')-    , ('\68221','\68222')-    , ('\68440','\68447')-    , ('\68472','\68479')-    , ('\69216','\69246')-    , ('\119648','\119665')-    , ('\127232','\127242')-    ]---- --------------------------------------------------------------isUnicodeP      :: Char -> Bool-isUnicodeP c-  = isInList c-    [ ('!','#')-    , ('%','*')-    , (',','/')-    , (':',';')-    , ('?','@')-    , ('[',']')-    , ('_','_')-    , ('{','{')-    , ('}','}')-    , ('\161','\161')-    , ('\171','\171')-    , ('\183','\183')-    , ('\187','\187')-    , ('\191','\191')-    , ('\894','\894')-    , ('\903','\903')-    , ('\1370','\1375')-    , ('\1417','\1418')-    , ('\1470','\1470')-    , ('\1472','\1472')-    , ('\1475','\1475')-    , ('\1478','\1478')-    , ('\1523','\1524')-    , ('\1545','\1546')-    , ('\1548','\1549')-    , ('\1563','\1563')-    , ('\1566','\1567')-    , ('\1642','\1645')-    , ('\1748','\1748')-    , ('\1792','\1805')-    , ('\2039','\2041')-    , ('\2096','\2110')-    , ('\2404','\2405')-    , ('\2416','\2416')-    , ('\3572','\3572')-    , ('\3663','\3663')-    , ('\3674','\3675')-    , ('\3844','\3858')-    , ('\3898','\3901')-    , ('\3973','\3973')-    , ('\4048','\4052')-    , ('\4170','\4175')-    , ('\4347','\4347')-    , ('\4961','\4968')-    , ('\5120','\5120')-    , ('\5741','\5742')-    , ('\5787','\5788')-    , ('\5867','\5869')-    , ('\5941','\5942')-    , ('\6100','\6102')-    , ('\6104','\6106')-    , ('\6144','\6154')-    , ('\6468','\6469')-    , ('\6622','\6623')-    , ('\6686','\6687')-    , ('\6816','\6822')-    , ('\6824','\6829')-    , ('\7002','\7008')-    , ('\7227','\7231')-    , ('\7294','\7295')-    , ('\7379','\7379')-    , ('\8208','\8231')-    , ('\8240','\8259')-    , ('\8261','\8273')-    , ('\8275','\8286')-    , ('\8317','\8318')-    , ('\8333','\8334')-    , ('\9001','\9002')-    , ('\10088','\10101')-    , ('\10181','\10182')-    , ('\10214','\10223')-    , ('\10627','\10648')-    , ('\10712','\10715')-    , ('\10748','\10749')-    , ('\11513','\11516')-    , ('\11518','\11519')-    , ('\11776','\11822')-    , ('\11824','\11825')-    , ('\12289','\12291')-    , ('\12296','\12305')-    , ('\12308','\12319')-    , ('\12336','\12336')-    , ('\12349','\12349')-    , ('\12448','\12448')-    , ('\12539','\12539')-    , ('\42238','\42239')-    , ('\42509','\42511')-    , ('\42611','\42611')-    , ('\42622','\42622')-    , ('\42738','\42743')-    , ('\43124','\43127')-    , ('\43214','\43215')-    , ('\43256','\43258')-    , ('\43310','\43311')-    , ('\43359','\43359')-    , ('\43457','\43469')-    , ('\43486','\43487')-    , ('\43612','\43615')-    , ('\43742','\43743')-    , ('\44011','\44011')-    , ('\64830','\64831')-    , ('\65040','\65049')-    , ('\65072','\65106')-    , ('\65108','\65121')-    , ('\65123','\65123')-    , ('\65128','\65128')-    , ('\65130','\65131')-    , ('\65281','\65283')-    , ('\65285','\65290')-    , ('\65292','\65295')-    , ('\65306','\65307')-    , ('\65311','\65312')-    , ('\65339','\65341')-    , ('\65343','\65343')-    , ('\65371','\65371')-    , ('\65373','\65373')-    , ('\65375','\65381')-    , ('\65792','\65793')-    , ('\66463','\66463')-    , ('\66512','\66512')-    , ('\67671','\67671')-    , ('\67871','\67871')-    , ('\67903','\67903')-    , ('\68176','\68184')-    , ('\68223','\68223')-    , ('\68409','\68415')-    , ('\69819','\69820')-    , ('\69822','\69825')-    , ('\74864','\74867')-    ]---- --------------------------------------------------------------isUnicodePc     :: Char -> Bool-isUnicodePc c-  = isInList c-    [ ('_','_')-    , ('\8255','\8256')-    , ('\8276','\8276')-    , ('\65075','\65076')-    , ('\65101','\65103')-    , ('\65343','\65343')-    ]---- --------------------------------------------------------------isUnicodePd     :: Char -> Bool-isUnicodePd c-  = isInList c-    [ ('-','-')-    , ('\1418','\1418')-    , ('\1470','\1470')-    , ('\5120','\5120')-    , ('\6150','\6150')-    , ('\8208','\8213')-    , ('\11799','\11799')-    , ('\11802','\11802')-    , ('\12316','\12316')-    , ('\12336','\12336')-    , ('\12448','\12448')-    , ('\65073','\65074')-    , ('\65112','\65112')-    , ('\65123','\65123')-    , ('\65293','\65293')-    ]---- --------------------------------------------------------------isUnicodePe     :: Char -> Bool-isUnicodePe c-  = isInList c-    [ (')',')')-    , (']',']')-    , ('}','}')-    , ('\3899','\3899')-    , ('\3901','\3901')-    , ('\5788','\5788')-    , ('\8262','\8262')-    , ('\8318','\8318')-    , ('\8334','\8334')-    , ('\9002','\9002')-    , ('\10089','\10089')-    , ('\10091','\10091')-    , ('\10093','\10093')-    , ('\10095','\10095')-    , ('\10097','\10097')-    , ('\10099','\10099')-    , ('\10101','\10101')-    , ('\10182','\10182')-    , ('\10215','\10215')-    , ('\10217','\10217')-    , ('\10219','\10219')-    , ('\10221','\10221')-    , ('\10223','\10223')-    , ('\10628','\10628')-    , ('\10630','\10630')-    , ('\10632','\10632')-    , ('\10634','\10634')-    , ('\10636','\10636')-    , ('\10638','\10638')-    , ('\10640','\10640')-    , ('\10642','\10642')-    , ('\10644','\10644')-    , ('\10646','\10646')-    , ('\10648','\10648')-    , ('\10713','\10713')-    , ('\10715','\10715')-    , ('\10749','\10749')-    , ('\11811','\11811')-    , ('\11813','\11813')-    , ('\11815','\11815')-    , ('\11817','\11817')-    , ('\12297','\12297')-    , ('\12299','\12299')-    , ('\12301','\12301')-    , ('\12303','\12303')-    , ('\12305','\12305')-    , ('\12309','\12309')-    , ('\12311','\12311')-    , ('\12313','\12313')-    , ('\12315','\12315')-    , ('\12318','\12319')-    , ('\64831','\64831')-    , ('\65048','\65048')-    , ('\65078','\65078')-    , ('\65080','\65080')-    , ('\65082','\65082')-    , ('\65084','\65084')-    , ('\65086','\65086')-    , ('\65088','\65088')-    , ('\65090','\65090')-    , ('\65092','\65092')-    , ('\65096','\65096')-    , ('\65114','\65114')-    , ('\65116','\65116')-    , ('\65118','\65118')-    , ('\65289','\65289')-    , ('\65341','\65341')-    , ('\65373','\65373')-    , ('\65376','\65376')-    , ('\65379','\65379')-    ]---- --------------------------------------------------------------isUnicodePf     :: Char -> Bool-isUnicodePf c-  = isInList c-    [ ('\187','\187')-    , ('\8217','\8217')-    , ('\8221','\8221')-    , ('\8250','\8250')-    , ('\11779','\11779')-    , ('\11781','\11781')-    , ('\11786','\11786')-    , ('\11789','\11789')-    , ('\11805','\11805')-    , ('\11809','\11809')-    ]---- --------------------------------------------------------------isUnicodePi     :: Char -> Bool-isUnicodePi c-  = isInList c-    [ ('\171','\171')-    , ('\8216','\8216')-    , ('\8219','\8220')-    , ('\8223','\8223')-    , ('\8249','\8249')-    , ('\11778','\11778')-    , ('\11780','\11780')-    , ('\11785','\11785')-    , ('\11788','\11788')-    , ('\11804','\11804')-    , ('\11808','\11808')-    ]---- --------------------------------------------------------------isUnicodePo     :: Char -> Bool-isUnicodePo c-  = isInList c-    [ ('!','#')-    , ('%','\'')-    , ('*','*')-    , (',',',')-    , ('.','/')-    , (':',';')-    , ('?','@')-    , ('\\','\\')-    , ('\161','\161')-    , ('\183','\183')-    , ('\191','\191')-    , ('\894','\894')-    , ('\903','\903')-    , ('\1370','\1375')-    , ('\1417','\1417')-    , ('\1472','\1472')-    , ('\1475','\1475')-    , ('\1478','\1478')-    , ('\1523','\1524')-    , ('\1545','\1546')-    , ('\1548','\1549')-    , ('\1563','\1563')-    , ('\1566','\1567')-    , ('\1642','\1645')-    , ('\1748','\1748')-    , ('\1792','\1805')-    , ('\2039','\2041')-    , ('\2096','\2110')-    , ('\2404','\2405')-    , ('\2416','\2416')-    , ('\3572','\3572')-    , ('\3663','\3663')-    , ('\3674','\3675')-    , ('\3844','\3858')-    , ('\3973','\3973')-    , ('\4048','\4052')-    , ('\4170','\4175')-    , ('\4347','\4347')-    , ('\4961','\4968')-    , ('\5741','\5742')-    , ('\5867','\5869')-    , ('\5941','\5942')-    , ('\6100','\6102')-    , ('\6104','\6106')-    , ('\6144','\6149')-    , ('\6151','\6154')-    , ('\6468','\6469')-    , ('\6622','\6623')-    , ('\6686','\6687')-    , ('\6816','\6822')-    , ('\6824','\6829')-    , ('\7002','\7008')-    , ('\7227','\7231')-    , ('\7294','\7295')-    , ('\7379','\7379')-    , ('\8214','\8215')-    , ('\8224','\8231')-    , ('\8240','\8248')-    , ('\8251','\8254')-    , ('\8257','\8259')-    , ('\8263','\8273')-    , ('\8275','\8275')-    , ('\8277','\8286')-    , ('\11513','\11516')-    , ('\11518','\11519')-    , ('\11776','\11777')-    , ('\11782','\11784')-    , ('\11787','\11787')-    , ('\11790','\11798')-    , ('\11800','\11801')-    , ('\11803','\11803')-    , ('\11806','\11807')-    , ('\11818','\11822')-    , ('\11824','\11825')-    , ('\12289','\12291')-    , ('\12349','\12349')-    , ('\12539','\12539')-    , ('\42238','\42239')-    , ('\42509','\42511')-    , ('\42611','\42611')-    , ('\42622','\42622')-    , ('\42738','\42743')-    , ('\43124','\43127')-    , ('\43214','\43215')-    , ('\43256','\43258')-    , ('\43310','\43311')-    , ('\43359','\43359')-    , ('\43457','\43469')-    , ('\43486','\43487')-    , ('\43612','\43615')-    , ('\43742','\43743')-    , ('\44011','\44011')-    , ('\65040','\65046')-    , ('\65049','\65049')-    , ('\65072','\65072')-    , ('\65093','\65094')-    , ('\65097','\65100')-    , ('\65104','\65106')-    , ('\65108','\65111')-    , ('\65119','\65121')-    , ('\65128','\65128')-    , ('\65130','\65131')-    , ('\65281','\65283')-    , ('\65285','\65287')-    , ('\65290','\65290')-    , ('\65292','\65292')-    , ('\65294','\65295')-    , ('\65306','\65307')-    , ('\65311','\65312')-    , ('\65340','\65340')-    , ('\65377','\65377')-    , ('\65380','\65381')-    , ('\65792','\65793')-    , ('\66463','\66463')-    , ('\66512','\66512')-    , ('\67671','\67671')-    , ('\67871','\67871')-    , ('\67903','\67903')-    , ('\68176','\68184')-    , ('\68223','\68223')-    , ('\68409','\68415')-    , ('\69819','\69820')-    , ('\69822','\69825')-    , ('\74864','\74867')-    ]---- --------------------------------------------------------------isUnicodePs     :: Char -> Bool-isUnicodePs c-  = isInList c-    [ ('(','(')-    , ('[','[')-    , ('{','{')-    , ('\3898','\3898')-    , ('\3900','\3900')-    , ('\5787','\5787')-    , ('\8218','\8218')-    , ('\8222','\8222')-    , ('\8261','\8261')-    , ('\8317','\8317')-    , ('\8333','\8333')-    , ('\9001','\9001')-    , ('\10088','\10088')-    , ('\10090','\10090')-    , ('\10092','\10092')-    , ('\10094','\10094')-    , ('\10096','\10096')-    , ('\10098','\10098')-    , ('\10100','\10100')-    , ('\10181','\10181')-    , ('\10214','\10214')-    , ('\10216','\10216')-    , ('\10218','\10218')-    , ('\10220','\10220')-    , ('\10222','\10222')-    , ('\10627','\10627')-    , ('\10629','\10629')-    , ('\10631','\10631')-    , ('\10633','\10633')-    , ('\10635','\10635')-    , ('\10637','\10637')-    , ('\10639','\10639')-    , ('\10641','\10641')-    , ('\10643','\10643')-    , ('\10645','\10645')-    , ('\10647','\10647')-    , ('\10712','\10712')-    , ('\10714','\10714')-    , ('\10748','\10748')-    , ('\11810','\11810')-    , ('\11812','\11812')-    , ('\11814','\11814')-    , ('\11816','\11816')-    , ('\12296','\12296')-    , ('\12298','\12298')-    , ('\12300','\12300')-    , ('\12302','\12302')-    , ('\12304','\12304')-    , ('\12308','\12308')-    , ('\12310','\12310')-    , ('\12312','\12312')-    , ('\12314','\12314')-    , ('\12317','\12317')-    , ('\64830','\64830')-    , ('\65047','\65047')-    , ('\65077','\65077')-    , ('\65079','\65079')-    , ('\65081','\65081')-    , ('\65083','\65083')-    , ('\65085','\65085')-    , ('\65087','\65087')-    , ('\65089','\65089')-    , ('\65091','\65091')-    , ('\65095','\65095')-    , ('\65113','\65113')-    , ('\65115','\65115')-    , ('\65117','\65117')-    , ('\65288','\65288')-    , ('\65339','\65339')-    , ('\65371','\65371')-    , ('\65375','\65375')-    , ('\65378','\65378')-    ]---- --------------------------------------------------------------isUnicodeS      :: Char -> Bool-isUnicodeS c-  = isInList c-    [ ('$','$')-    , ('+','+')-    , ('<','>')-    , ('^','^')-    , ('`','`')-    , ('|','|')-    , ('~','~')-    , ('\162','\169')-    , ('\172','\172')-    , ('\174','\177')-    , ('\180','\180')-    , ('\182','\182')-    , ('\184','\184')-    , ('\215','\215')-    , ('\247','\247')-    , ('\706','\709')-    , ('\722','\735')-    , ('\741','\747')-    , ('\749','\749')-    , ('\751','\767')-    , ('\885','\885')-    , ('\900','\901')-    , ('\1014','\1014')-    , ('\1154','\1154')-    , ('\1542','\1544')-    , ('\1547','\1547')-    , ('\1550','\1551')-    , ('\1769','\1769')-    , ('\1789','\1790')-    , ('\2038','\2038')-    , ('\2546','\2547')-    , ('\2554','\2555')-    , ('\2801','\2801')-    , ('\2928','\2928')-    , ('\3059','\3066')-    , ('\3199','\3199')-    , ('\3313','\3314')-    , ('\3449','\3449')-    , ('\3647','\3647')-    , ('\3841','\3843')-    , ('\3859','\3863')-    , ('\3866','\3871')-    , ('\3892','\3892')-    , ('\3894','\3894')-    , ('\3896','\3896')-    , ('\4030','\4037')-    , ('\4039','\4044')-    , ('\4046','\4047')-    , ('\4053','\4056')-    , ('\4254','\4255')-    , ('\4960','\4960')-    , ('\5008','\5017')-    , ('\6107','\6107')-    , ('\6464','\6464')-    , ('\6624','\6655')-    , ('\7009','\7018')-    , ('\7028','\7036')-    , ('\8125','\8125')-    , ('\8127','\8129')-    , ('\8141','\8143')-    , ('\8157','\8159')-    , ('\8173','\8175')-    , ('\8189','\8190')-    , ('\8260','\8260')-    , ('\8274','\8274')-    , ('\8314','\8316')-    , ('\8330','\8332')-    , ('\8352','\8376')-    , ('\8448','\8449')-    , ('\8451','\8454')-    , ('\8456','\8457')-    , ('\8468','\8468')-    , ('\8470','\8472')-    , ('\8478','\8483')-    , ('\8485','\8485')-    , ('\8487','\8487')-    , ('\8489','\8489')-    , ('\8494','\8494')-    , ('\8506','\8507')-    , ('\8512','\8516')-    , ('\8522','\8525')-    , ('\8527','\8527')-    , ('\8592','\9000')-    , ('\9003','\9192')-    , ('\9216','\9254')-    , ('\9280','\9290')-    , ('\9372','\9449')-    , ('\9472','\9933')-    , ('\9935','\9953')-    , ('\9955','\9955')-    , ('\9960','\9983')-    , ('\9985','\9988')-    , ('\9990','\9993')-    , ('\9996','\10023')-    , ('\10025','\10059')-    , ('\10061','\10061')-    , ('\10063','\10066')-    , ('\10070','\10078')-    , ('\10081','\10087')-    , ('\10132','\10132')-    , ('\10136','\10159')-    , ('\10161','\10174')-    , ('\10176','\10180')-    , ('\10183','\10186')-    , ('\10188','\10188')-    , ('\10192','\10213')-    , ('\10224','\10626')-    , ('\10649','\10711')-    , ('\10716','\10747')-    , ('\10750','\11084')-    , ('\11088','\11097')-    , ('\11493','\11498')-    , ('\11904','\11929')-    , ('\11931','\12019')-    , ('\12032','\12245')-    , ('\12272','\12283')-    , ('\12292','\12292')-    , ('\12306','\12307')-    , ('\12320','\12320')-    , ('\12342','\12343')-    , ('\12350','\12351')-    , ('\12443','\12444')-    , ('\12688','\12689')-    , ('\12694','\12703')-    , ('\12736','\12771')-    , ('\12800','\12830')-    , ('\12842','\12880')-    , ('\12896','\12927')-    , ('\12938','\12976')-    , ('\12992','\13054')-    , ('\13056','\13311')-    , ('\19904','\19967')-    , ('\42128','\42182')-    , ('\42752','\42774')-    , ('\42784','\42785')-    , ('\42889','\42890')-    , ('\43048','\43051')-    , ('\43062','\43065')-    , ('\43639','\43641')-    , ('\64297','\64297')-    , ('\65020','\65021')-    , ('\65122','\65122')-    , ('\65124','\65126')-    , ('\65129','\65129')-    , ('\65284','\65284')-    , ('\65291','\65291')-    , ('\65308','\65310')-    , ('\65342','\65342')-    , ('\65344','\65344')-    , ('\65372','\65372')-    , ('\65374','\65374')-    , ('\65504','\65510')-    , ('\65512','\65518')-    , ('\65532','\65533')-    , ('\65794','\65794')-    , ('\65847','\65855')-    , ('\65913','\65929')-    , ('\65936','\65947')-    , ('\66000','\66044')-    , ('\118784','\119029')-    , ('\119040','\119078')-    , ('\119081','\119140')-    , ('\119146','\119148')-    , ('\119171','\119172')-    , ('\119180','\119209')-    , ('\119214','\119261')-    , ('\119296','\119361')-    , ('\119365','\119365')-    , ('\119552','\119638')-    , ('\120513','\120513')-    , ('\120539','\120539')-    , ('\120571','\120571')-    , ('\120597','\120597')-    , ('\120629','\120629')-    , ('\120655','\120655')-    , ('\120687','\120687')-    , ('\120713','\120713')-    , ('\120745','\120745')-    , ('\120771','\120771')-    , ('\126976','\127019')-    , ('\127024','\127123')-    , ('\127248','\127278')-    , ('\127281','\127281')-    , ('\127293','\127293')-    , ('\127295','\127295')-    , ('\127298','\127298')-    , ('\127302','\127302')-    , ('\127306','\127310')-    , ('\127319','\127319')-    , ('\127327','\127327')-    , ('\127353','\127353')-    , ('\127355','\127356')-    , ('\127359','\127359')-    , ('\127370','\127373')-    , ('\127376','\127376')-    , ('\127488','\127488')-    , ('\127504','\127537')-    , ('\127552','\127560')-    ]---- --------------------------------------------------------------isUnicodeSc     :: Char -> Bool-isUnicodeSc c-  = isInList c-    [ ('$','$')-    , ('\162','\165')-    , ('\1547','\1547')-    , ('\2546','\2547')-    , ('\2555','\2555')-    , ('\2801','\2801')-    , ('\3065','\3065')-    , ('\3647','\3647')-    , ('\6107','\6107')-    , ('\8352','\8376')-    , ('\43064','\43064')-    , ('\65020','\65020')-    , ('\65129','\65129')-    , ('\65284','\65284')-    , ('\65504','\65505')-    , ('\65509','\65510')-    ]---- --------------------------------------------------------------isUnicodeSk     :: Char -> Bool-isUnicodeSk c-  = isInList c-    [ ('^','^')-    , ('`','`')-    , ('\168','\168')-    , ('\175','\175')-    , ('\180','\180')-    , ('\184','\184')-    , ('\706','\709')-    , ('\722','\735')-    , ('\741','\747')-    , ('\749','\749')-    , ('\751','\767')-    , ('\885','\885')-    , ('\900','\901')-    , ('\8125','\8125')-    , ('\8127','\8129')-    , ('\8141','\8143')-    , ('\8157','\8159')-    , ('\8173','\8175')-    , ('\8189','\8190')-    , ('\12443','\12444')-    , ('\42752','\42774')-    , ('\42784','\42785')-    , ('\42889','\42890')-    , ('\65342','\65342')-    , ('\65344','\65344')-    , ('\65507','\65507')-    ]---- --------------------------------------------------------------isUnicodeSm     :: Char -> Bool-isUnicodeSm c-  = isInList c-    [ ('+','+')-    , ('<','>')-    , ('|','|')-    , ('~','~')-    , ('\172','\172')-    , ('\177','\177')-    , ('\215','\215')-    , ('\247','\247')-    , ('\1014','\1014')-    , ('\1542','\1544')-    , ('\8260','\8260')-    , ('\8274','\8274')-    , ('\8314','\8316')-    , ('\8330','\8332')-    , ('\8512','\8516')-    , ('\8523','\8523')-    , ('\8592','\8596')-    , ('\8602','\8603')-    , ('\8608','\8608')-    , ('\8611','\8611')-    , ('\8614','\8614')-    , ('\8622','\8622')-    , ('\8654','\8655')-    , ('\8658','\8658')-    , ('\8660','\8660')-    , ('\8692','\8959')-    , ('\8968','\8971')-    , ('\8992','\8993')-    , ('\9084','\9084')-    , ('\9115','\9139')-    , ('\9180','\9185')-    , ('\9655','\9655')-    , ('\9665','\9665')-    , ('\9720','\9727')-    , ('\9839','\9839')-    , ('\10176','\10180')-    , ('\10183','\10186')-    , ('\10188','\10188')-    , ('\10192','\10213')-    , ('\10224','\10239')-    , ('\10496','\10626')-    , ('\10649','\10711')-    , ('\10716','\10747')-    , ('\10750','\11007')-    , ('\11056','\11076')-    , ('\11079','\11084')-    , ('\64297','\64297')-    , ('\65122','\65122')-    , ('\65124','\65126')-    , ('\65291','\65291')-    , ('\65308','\65310')-    , ('\65372','\65372')-    , ('\65374','\65374')-    , ('\65506','\65506')-    , ('\65513','\65516')-    , ('\120513','\120513')-    , ('\120539','\120539')-    , ('\120571','\120571')-    , ('\120597','\120597')-    , ('\120629','\120629')-    , ('\120655','\120655')-    , ('\120687','\120687')-    , ('\120713','\120713')-    , ('\120745','\120745')-    , ('\120771','\120771')-    ]---- --------------------------------------------------------------isUnicodeSo     :: Char -> Bool-isUnicodeSo c-  = isInList c-    [ ('\166','\167')-    , ('\169','\169')-    , ('\174','\174')-    , ('\176','\176')-    , ('\182','\182')-    , ('\1154','\1154')-    , ('\1550','\1551')-    , ('\1769','\1769')-    , ('\1789','\1790')-    , ('\2038','\2038')-    , ('\2554','\2554')-    , ('\2928','\2928')-    , ('\3059','\3064')-    , ('\3066','\3066')-    , ('\3199','\3199')-    , ('\3313','\3314')-    , ('\3449','\3449')-    , ('\3841','\3843')-    , ('\3859','\3863')-    , ('\3866','\3871')-    , ('\3892','\3892')-    , ('\3894','\3894')-    , ('\3896','\3896')-    , ('\4030','\4037')-    , ('\4039','\4044')-    , ('\4046','\4047')-    , ('\4053','\4056')-    , ('\4254','\4255')-    , ('\4960','\4960')-    , ('\5008','\5017')-    , ('\6464','\6464')-    , ('\6624','\6655')-    , ('\7009','\7018')-    , ('\7028','\7036')-    , ('\8448','\8449')-    , ('\8451','\8454')-    , ('\8456','\8457')-    , ('\8468','\8468')-    , ('\8470','\8472')-    , ('\8478','\8483')-    , ('\8485','\8485')-    , ('\8487','\8487')-    , ('\8489','\8489')-    , ('\8494','\8494')-    , ('\8506','\8507')-    , ('\8522','\8522')-    , ('\8524','\8525')-    , ('\8527','\8527')-    , ('\8597','\8601')-    , ('\8604','\8607')-    , ('\8609','\8610')-    , ('\8612','\8613')-    , ('\8615','\8621')-    , ('\8623','\8653')-    , ('\8656','\8657')-    , ('\8659','\8659')-    , ('\8661','\8691')-    , ('\8960','\8967')-    , ('\8972','\8991')-    , ('\8994','\9000')-    , ('\9003','\9083')-    , ('\9085','\9114')-    , ('\9140','\9179')-    , ('\9186','\9192')-    , ('\9216','\9254')-    , ('\9280','\9290')-    , ('\9372','\9449')-    , ('\9472','\9654')-    , ('\9656','\9664')-    , ('\9666','\9719')-    , ('\9728','\9838')-    , ('\9840','\9933')-    , ('\9935','\9953')-    , ('\9955','\9955')-    , ('\9960','\9983')-    , ('\9985','\9988')-    , ('\9990','\9993')-    , ('\9996','\10023')-    , ('\10025','\10059')-    , ('\10061','\10061')-    , ('\10063','\10066')-    , ('\10070','\10078')-    , ('\10081','\10087')-    , ('\10132','\10132')-    , ('\10136','\10159')-    , ('\10161','\10174')-    , ('\10240','\10495')-    , ('\11008','\11055')-    , ('\11077','\11078')-    , ('\11088','\11097')-    , ('\11493','\11498')-    , ('\11904','\11929')-    , ('\11931','\12019')-    , ('\12032','\12245')-    , ('\12272','\12283')-    , ('\12292','\12292')-    , ('\12306','\12307')-    , ('\12320','\12320')-    , ('\12342','\12343')-    , ('\12350','\12351')-    , ('\12688','\12689')-    , ('\12694','\12703')-    , ('\12736','\12771')-    , ('\12800','\12830')-    , ('\12842','\12880')-    , ('\12896','\12927')-    , ('\12938','\12976')-    , ('\12992','\13054')-    , ('\13056','\13311')-    , ('\19904','\19967')-    , ('\42128','\42182')-    , ('\43048','\43051')-    , ('\43062','\43063')-    , ('\43065','\43065')-    , ('\43639','\43641')-    , ('\65021','\65021')-    , ('\65508','\65508')-    , ('\65512','\65512')-    , ('\65517','\65518')-    , ('\65532','\65533')-    , ('\65794','\65794')-    , ('\65847','\65855')-    , ('\65913','\65929')-    , ('\65936','\65947')-    , ('\66000','\66044')-    , ('\118784','\119029')-    , ('\119040','\119078')-    , ('\119081','\119140')-    , ('\119146','\119148')-    , ('\119171','\119172')-    , ('\119180','\119209')-    , ('\119214','\119261')-    , ('\119296','\119361')-    , ('\119365','\119365')-    , ('\119552','\119638')-    , ('\126976','\127019')-    , ('\127024','\127123')-    , ('\127248','\127278')-    , ('\127281','\127281')-    , ('\127293','\127293')-    , ('\127295','\127295')-    , ('\127298','\127298')-    , ('\127302','\127302')-    , ('\127306','\127310')-    , ('\127319','\127319')-    , ('\127327','\127327')-    , ('\127353','\127353')-    , ('\127355','\127356')-    , ('\127359','\127359')-    , ('\127370','\127373')-    , ('\127376','\127376')-    , ('\127488','\127488')-    , ('\127504','\127537')-    , ('\127552','\127560')-    ]---- --------------------------------------------------------------isUnicodeZ      :: Char -> Bool-isUnicodeZ c-  = isInList c-    [ (' ',' ')-    , ('\160','\160')-    , ('\5760','\5760')-    , ('\6158','\6158')-    , ('\8192','\8202')-    , ('\8232','\8233')-    , ('\8239','\8239')-    , ('\8287','\8287')-    , ('\12288','\12288')-    ]---- --------------------------------------------------------------isUnicodeZl     :: Char -> Bool-isUnicodeZl c-  = isInList c-    [ ('\8232','\8232')-    ]---- --------------------------------------------------------------isUnicodeZp     :: Char -> Bool-isUnicodeZp c-  = isInList c-    [ ('\8233','\8233')-    ]---- --------------------------------------------------------------isUnicodeZs     :: Char -> Bool-isUnicodeZs c-  = isInList c-    [ (' ',' ')-    , ('\160','\160')-    , ('\5760','\5760')-    , ('\6158','\6158')-    , ('\8192','\8202')-    , ('\8239','\8239')-    , ('\8287','\8287')-    , ('\12288','\12288')-    ]---- -------------------------------------------------------------
− src/Text/XML/HXT/RelaxNG/Utils.hs 
@@ -1,161 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.RelaxNG.Utils-   Copyright  : Copyright (C) 2008 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : stable-   Portability: portable--   Helper functions for RelaxNG validation---}---- --------------------------------------------------------------module Text.XML.HXT.RelaxNG.Utils-    ( isRelaxAnyURI-    , compareURI-    , normalizeURI-    , isNumber-    , isNmtoken-    , isName-    , formatStringList-    , formatStringListPatt-    , formatStringListId-    , formatStringListQuot-    , formatStringListPairs-    , formatStringListArr-    )-where--import Text.ParserCombinators.Parsec--import Text.XML.HXT.Parser.XmlTokenParser-    ( skipS0-    , nmtoken-    , name-    )--import Network.URI-    ( isURI-    , isRelativeReference-    , parseURI-    , URI(..)-    )--import Data.Maybe-    ( fromMaybe-    )--import Data.Char-    ( toLower-    )----- ----------------------------------------------------------------- | Tests whether a URI matches the Relax NG anyURI symbol--isRelaxAnyURI :: String -> Bool-isRelaxAnyURI s-    = s == "" ||-      ( isURI s && not (isRelativeReference s) &&-        ( let (URI _ _ path _ frag) = fromMaybe (URI "" Nothing "" "" "") $ parseURI s-          in (frag == "" && path /= "")-        )-      )----- | Tests whether two URIs are equal after 'normalizeURI' is performed--compareURI :: String -> String -> Bool-compareURI uri1 uri2-    = normalizeURI uri1 == normalizeURI uri2----- |  Converts all letters to the corresponding lower-case letter--- and removes a trailing \"\/\"--normalizeURI :: String -> String-normalizeURI ""-    = ""-normalizeURI uri-    = map toLower ( if last uri == '/'-                    then init uri-                    else uri-                  )--checkByParsing  :: Parser String -> String -> Bool-checkByParsing p s-    = either (const False) (const True) (parse p' "" s)-      where-      p' = do-           r <- p-           eof-           return r---- | Tests whether a string matches a number [-](0-9)*-isNumber :: String -> Bool-isNumber-    = checkByParsing parseNumber'-    where-    parseNumber' :: Parser String-    parseNumber'-        = do-          skipS0-          m <- option "" (string "-")-          n <- many1 digit-          skipS0-          return $ m ++ n--isNmtoken       :: String -> Bool-isNmtoken    = checkByParsing nmtoken--isName  :: String -> Bool-isName  = checkByParsing name--{- |--Formats a list of strings into a single string.-The first parameter formats the elements, the 2. is inserted-between two elements.--example:--> formatStringList show ", " ["foo", "bar", "baz"] -> "foo", "bar", "baz"---}--formatStringListPatt :: [String] -> String-formatStringListPatt-    = formatStringList (++ "-") ", "--formatStringListPairs :: [(String,String)] -> String-formatStringListPairs-    = formatStringList id ", "-      . map (\ (a, b) -> a ++ " = " ++ show b)--formatStringListQuot :: [String] -> String-formatStringListQuot-    = formatStringList show ", "--formatStringListId :: [String] -> String-formatStringListId-    = formatStringList id ", "--formatStringListArr :: [String] -> String-formatStringListArr-    = formatStringList show " -> "--formatStringList :: (String -> String) -> String -> [String] -> String-formatStringList _sf _sp []-    = ""-formatStringList sf spacer l-    = reverse $ drop (length spacer) $ reverse $-      foldr (\e -> ((if e /= "" then sf e ++ spacer else "") ++)) "" l---- ----------------------------------------
− src/Text/XML/HXT/RelaxNG/Validation.hs 
@@ -1,617 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.RelaxNG.Validation-   Copyright  : Copyright (C) 2008 Torben Kuseler, Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : stable-   Portability: portable--   Validation of a XML document with respect to a valid Relax NG schema in simple form.-   Copied and modified from \"An algorithm for RELAX NG validation\" by James Clark-   (<http://www.thaiopensource.com/relaxng/derivative.html>).---}---- --------------------------------------------------------------module Text.XML.HXT.RelaxNG.Validation-    ( validateWithRelaxAndHandleErrors-    , validateDocWithRelax-    , validateRelax-    , validateXMLDoc-    , readForRelax-    , normalizeForRelaxValidation-    , contains-    )-where--import Control.Arrow.ListArrows--import           Text.XML.HXT.DOM.Interface-import qualified Text.XML.HXT.DOM.XmlNode as XN-import           Text.XML.HXT.DOM.Unicode-    ( isXmlSpaceChar-    )---import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlIOStateArrow--import Text.XML.HXT.Arrow.Edit-    ( canonicalizeAllNodes-    , collapseAllXText-    )--import Text.XML.HXT.Arrow.ProcessDocument-    ( propagateAndValidateNamespaces-    , getDocumentContents-    , parseXmlDocument-    )--import Text.XML.HXT.RelaxNG.DataTypes-import Text.XML.HXT.RelaxNG.CreatePattern-import Text.XML.HXT.RelaxNG.PatternToString-import Text.XML.HXT.RelaxNG.DataTypeLibraries-import Text.XML.HXT.RelaxNG.Utils-    ( formatStringListQuot-    , compareURI-    )--import Data.Maybe-    ( fromJust-    )--{--import qualified Debug.Trace as T--}---- --------------------------------------------------------------validateWithRelaxAndHandleErrors        :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree-validateWithRelaxAndHandleErrors theSchema-    = validateWithRelax theSchema-      >>>-      handleErrors--validateWithRelax       :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree-validateWithRelax theSchema-    = traceMsg 2 "validate with Relax NG schema"-      >>>-      ( ( normalizeForRelaxValidation           -- prepare the document for validation-          >>>-          getChildren-          >>>-          isElem                                -- and select the root element-        )-        &&&-        theSchema-      )-      >>>-      arr2A validateRelax                       -- compute vaidation errors as a document--handleErrors    :: IOSArrow XmlTree XmlTree-handleErrors-    = traceDoc "error found when validating with Relax NG schema"-      >>>-      ( getChildren                             -- prepare error format-        >>>-        getText-        >>>-        arr ("Relax NG validation: " ++)-        >>>-        mkError c_err-      )-      >>>-      filterErrorMsg                            -- issue errors and set system status---{- |-   normalize a document for validation with Relax NG: remove all namespace declaration attributes,-   remove all processing instructions and merge all sequences of text nodes into a single text node--}--normalizeForRelaxValidation :: ArrowXml a => a XmlTree XmlTree-normalizeForRelaxValidation-  = processTopDownWithAttrl-    (-     ( none `when`                      -- remove all namespace attributes-       ( isAttr-         >>>-         getNamespaceUri-         >>>-         isA (compareURI xmlnsNamespace)-       )-     )-     >>>-     (none `when` isPi)                 -- processing instructions-    )-    >>>-    collapseAllXText                    -- all text node sequences are merged into a single text node---- --------------------------------------------------------------{- | Validates a xml document with respect to a Relax NG schema--   * 1.parameter  :  the arrow for computing the Relax NG schema--   - 2.parameter  :  list of options for reading and validating--   - 3.parameter  :  XML document URI--   - arrow-input  :  ignored--   - arrow-output :  list of errors or 'none'--}--validateDocWithRelax :: IOSArrow XmlTree XmlTree -> Attributes -> String -> IOSArrow XmlTree XmlTree-validateDocWithRelax theSchema al doc-  = ( if null doc-      then root [] []-      else readForRelax al doc-    )-    >>>-    validateWithRelax theSchema-    >>>-    perform handleErrors---{- | Validates a xml document with respect to a Relax NG schema--   * 1.parameter  :  XML document--   - arrow-input  :  Relax NG schema--   - arrow-output :  list of errors or 'none'--}--validateRelax :: XmlTree -> IOSArrow XmlTree XmlTree-validateRelax xmlDoc-  = fromLA-    ( createPatternFromXmlTree-      >>>-      arr (\p -> childDeriv ("",[]) p xmlDoc)-      >>>-      ( (not . nullable)-        `guardsP`-        root [] [ (take 1024 . show) ^>> mkText ]       -- pattern may be recursive, so the string representation-                                                        -- is truncated to 1024 chars to assure termination-      )-    )---- --------------------------------------------------------------readForRelax    :: Attributes -> String -> IOSArrow b XmlTree-readForRelax options schema-    = getDocumentContents options schema-      >>>-      parseXmlDocument False-      >>>-      canonicalizeAllNodes-      >>>-      propagateAndValidateNamespaces---- --------------------------------------------------------------{- old stuff -}--validateXMLDoc :: Attributes -> String -> IOSArrow XmlTree XmlTree-validateXMLDoc al xmlDoc-  = validateRelax-    $<-    ( readForRelax al xmlDoc-      >>>-      normalizeForRelaxValidation-      >>>-      getChildren-    )----- ------------------------------------------------------------------ | tests whether a 'NameClass' contains a particular 'QName'--contains :: NameClass -> QName -> Bool-contains AnyName _                      = True-contains (AnyNameExcept nc)    n        = not (contains nc n)-contains (NsName ns1)          qn       = ns1 == namespaceUri qn-contains (NsNameExcept ns1 nc) qn       = ns1 == namespaceUri qn && not (contains nc qn)-contains (Name ns1 ln1)        qn       = (ns1 == namespaceUri qn) && (ln1 == localPart qn)-contains (NameClassChoice nc1 nc2) n    = (contains nc1 n) || (contains nc2 n)-contains (NCError _) _                  = False----- ------------------------------------------------------------------ | tests whether a pattern matches the empty sequence-nullable:: Pattern -> Bool-nullable (Group p1 p2)          = nullable p1 && nullable p2-nullable (Interleave p1 p2)     = nullable p1 && nullable p2-nullable (Choice p1 p2)         = nullable p1 || nullable p2-nullable (OneOrMore p)          = nullable p-nullable (Element _ _)          = False-nullable (Attribute _ _)        = False-nullable (List _)               = False-nullable (Value _ _ _)          = False-nullable (Data _ _)             = False-nullable (DataExcept _ _ _)     = False-nullable (NotAllowed _)         = False-nullable Empty                  = True-nullable Text                   = True-nullable (After _ _)            = False----- ------------------------------------------------------------------ | computes the derivative of a pattern with respect to a XML-Child and a 'Context'--childDeriv :: Context -> Pattern -> XmlTree -> Pattern--childDeriv cx p t-    | XN.isText t       = textDeriv cx p . fromJust . XN.getText $ t-    | XN.isElem t       = endTagDeriv p4-    | otherwise         = notAllowed "Call to childDeriv with wrong arguments"-    where-    children    =            XN.getChildren $ t-    qn          = fromJust . XN.getElemName $ t-    atts        = fromJust . XN.getAttrl    $ t-    cx1         = ("",[])-    p1          = startTagOpenDeriv p qn-    p2          = attsDeriv cx1 p1 atts-    p3          = startTagCloseDeriv p2-    p4          = childrenDeriv cx1 p3 children---- ------------------------------------------------------------------ | computes the derivative of a pattern with respect to a text node--textDeriv :: Context -> Pattern -> String -> Pattern--textDeriv cx (Choice p1 p2) s-    = choice (textDeriv cx p1 s) (textDeriv cx p2 s)--textDeriv cx (Interleave p1 p2) s-    = choice-      (interleave (textDeriv cx p1 s) p2)-      (interleave p1 (textDeriv cx p2 s))--textDeriv cx (Group p1 p2) s-    = let-      p = group (textDeriv cx p1 s) p2-      in-      if nullable p1-      then choice p (textDeriv cx p2 s)-      else p--textDeriv cx (After p1 p2) s-    = after (textDeriv cx p1 s) p2--textDeriv cx (OneOrMore p) s-    = group (textDeriv cx p s) (choice (OneOrMore p) Empty)--textDeriv _ Text _-    = Text--textDeriv cx1 (Value (uri, s) value cx2) s1-    = case datatypeEqual uri s value cx2 s1 cx1-      of-      Nothing     -> Empty-      Just errStr -> notAllowed errStr--textDeriv cx (Data (uri, s) params) s1-    = case datatypeAllows uri s params s1 cx-      of-      Nothing     -> Empty-      Just errStr -> notAllowed2 errStr--textDeriv cx (DataExcept (uri, s) params p) s1-    = case (datatypeAllows uri s params s1 cx)-      of-      Nothing     -> if not $ nullable $ textDeriv cx p s1-                     then Empty-                     else notAllowed-                              ( "Any value except " ++-                                show (show p) ++-                                " expected, but value " ++-                                show (show s1) ++-                                " found"-                              )-      Just errStr -> notAllowed errStr--textDeriv cx (List p) s-    = if nullable (listDeriv cx p (words s))-      then Empty-      else notAllowed-               ( "List with value(s) " ++-                 show p ++-                 " expected, but value(s) " ++-                 formatStringListQuot (words s) ++-                 " found"-               )--textDeriv _ n@(NotAllowed _) _-    = n--textDeriv _ p s-    = notAllowed-      ( "Pattern " ++ show (getPatternName p) ++-        " expected, but text " ++ show s ++ " found"-      )----- ------------------------------------------------------------------ | To compute the derivative of a pattern with respect to a list of strings,--- simply compute the derivative with respect to each member of the list in turn.--listDeriv :: Context -> Pattern -> [String] -> Pattern--listDeriv _ p []-    = p--listDeriv cx p (x:xs)-    = listDeriv cx (textDeriv cx p x) xs----- ------------------------------------------------------------------ | computes the derivative of a pattern with respect to a start tag open--startTagOpenDeriv :: Pattern -> QName -> Pattern--startTagOpenDeriv (Choice p1 p2) qn-    = choice (startTagOpenDeriv p1 qn) (startTagOpenDeriv p2 qn)--startTagOpenDeriv (Element nc p) qn-    | contains nc qn-        = after p Empty-    | otherwise-        = notAllowed $-          "Element with name " ++ nameClassToString nc ++-            " expected, but " ++ universalName qn ++ " found"--startTagOpenDeriv (Interleave p1 p2) qn-    = choice-      (applyAfter (flip interleave p2) (startTagOpenDeriv p1 qn))-      (applyAfter (interleave p1) (startTagOpenDeriv p2 qn))--startTagOpenDeriv (OneOrMore p) qn-    = applyAfter-      (flip group (choice (OneOrMore p) Empty))-      (startTagOpenDeriv p qn)--startTagOpenDeriv (Group p1 p2) qn-    = let-      x = applyAfter (flip group p2) (startTagOpenDeriv p1 qn)-      in-      if nullable p1-      then choice x (startTagOpenDeriv p2 qn)-      else x--startTagOpenDeriv (After p1 p2) qn-    = applyAfter (flip after p2) (startTagOpenDeriv p1 qn)--startTagOpenDeriv n@(NotAllowed _) _-    = n--startTagOpenDeriv p qn-    = notAllowed ( show p ++ " expected, but Element " ++ universalName qn ++ " found" )---- ---------------------------------------------------------------- auxiliary functions for tracing-{--attsDeriv' cx p ts-    = T.trace ("attsDeriv: p=" ++ (take 1000 . show) p ++ ", t=" ++ showXts ts) $-      T.trace ("res= " ++ (take 1000 . show) res) res-    where-    res = attsDeriv cx p ts--attDeriv' cx p t-    = T.trace ("attDeriv: p=" ++ (take 1000 . show) p ++ ", t=" ++ showXts [t]) $-      T.trace ("res= " ++ (take 1000 . show) res) res-    where-    res = attDeriv cx p t--}---- | To compute the derivative of a pattern with respect to a sequence of attributes,--- simply compute the derivative with respect to each attribute in turn.--attsDeriv :: Context -> Pattern -> XmlTrees -> Pattern--attsDeriv _ p []-    = p-attsDeriv cx p (t : ts)-    | XN.isAttr t-        = attsDeriv cx (attDeriv cx p t) ts-    | otherwise-        = notAllowed "Call to attsDeriv with wrong arguments"--attDeriv :: Context -> Pattern -> XmlTree -> Pattern--attDeriv cx (After p1 p2) att-    = after (attDeriv cx p1 att) p2--attDeriv cx (Choice p1 p2) att-    = choice (attDeriv cx p1 att) (attDeriv cx p2 att)--attDeriv cx (Group p1 p2) att-    = choice-      (group (attDeriv cx p1 att) p2)-      (group p1 (attDeriv cx p2 att))--attDeriv cx (Interleave p1 p2) att-    = choice-      (interleave (attDeriv cx p1 att) p2)-      (interleave p1 (attDeriv cx p2 att))--attDeriv cx (OneOrMore p) att-    = group-      (attDeriv cx p att)-      (choice (OneOrMore p) Empty)--attDeriv cx (Attribute nc p) att-    | isa-      &&-      not (contains nc qn)-        = notAllowed1 $-          "Attribute with name " ++ nameClassToString nc-          ++ " expected, but " ++ universalName qn ++ " found"-    | isa-      &&-      ( ( nullable p-          &&-          whitespace val-        )-        || nullable p'-      )-        = Empty-    | isa-        = err' p'-    where-    isa =            XN.isAttr      $ att-    qn  = fromJust . XN.getAttrName $ att-    av  =            XN.getChildren $ att-    val = showXts av-    p'  = textDeriv cx p val--    err' (NotAllowed (ErrMsg _l es))-        = err'' (": " ++ head es)-    err' _-        = err'' ""-    err'' e-        = notAllowed2 $-          "Attribute value \"" ++ val ++-          "\" does not match datatype spec " ++ show p ++ e--attDeriv _ n@(NotAllowed _) _-    = n--attDeriv _ _p att-    = notAllowed $-      "No matching pattern for attribute '" ++  showXts [att] ++ "' found"---- ------------------------------------------------------------------ | computes the derivative of a pattern with respect to a start tag close--startTagCloseDeriv :: Pattern -> Pattern--startTagCloseDeriv (After p1 p2)-    = after (startTagCloseDeriv p1) p2--startTagCloseDeriv (Choice p1 p2)-    = choice-      (startTagCloseDeriv p1)-      (startTagCloseDeriv p2)--startTagCloseDeriv (Group p1 p2)-    = group-      (startTagCloseDeriv p1)-      (startTagCloseDeriv p2)--startTagCloseDeriv (Interleave p1 p2)-    = interleave-      (startTagCloseDeriv p1)-      (startTagCloseDeriv p2)--startTagCloseDeriv (OneOrMore p)-    = oneOrMore (startTagCloseDeriv p)--startTagCloseDeriv (Attribute nc _)-    = notAllowed1 $-      "Attribut with name, " ++ show nc ++-      " expected, but no more attributes found"--startTagCloseDeriv p-    = p----- ------------------------------------------------------------------ | Computing the derivative of a pattern with respect to a list of children involves--- computing the derivative with respect to each pattern in turn, except--- that whitespace requires special treatment.--childrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern-childrenDeriv _cx p@(NotAllowed _) _-    = p--childrenDeriv cx p []-    = childrenDeriv cx p [XN.mkText ""]--childrenDeriv cx p [tt]-    | ist-      &&-      whitespace s-        = choice p p1-    | ist-        = p1-    where-    ist =            XN.isText    tt-    s   = fromJust . XN.getText $ tt-    p1  = childDeriv cx p tt--childrenDeriv cx p children-    = stripChildrenDeriv cx p children--stripChildrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern-stripChildrenDeriv _ p []-    = p--stripChildrenDeriv cx p (h:t)-    = stripChildrenDeriv cx-      ( if strip h-        then p-        else (childDeriv cx p h)-      ) t----- ------------------------------------------------------------------ | computes the derivative of a pattern with respect to a end tag--endTagDeriv :: Pattern -> Pattern-endTagDeriv (Choice p1 p2)-    = choice (endTagDeriv p1) (endTagDeriv p2)--endTagDeriv (After p1 p2)-    | nullable p1-        = p2-    | otherwise-        = notAllowed $-          show p1 ++ " expected"--endTagDeriv n@(NotAllowed _)-    = n--endTagDeriv _-    = notAllowed "Call to endTagDeriv with wrong arguments"---- ------------------------------------------------------------------ | applies a function (first parameter) to the second part of a after pattern--applyAfter :: (Pattern -> Pattern) -> Pattern -> Pattern--applyAfter f (After p1 p2)      = after p1 (f p2)-applyAfter f (Choice p1 p2)     = choice (applyAfter f p1) (applyAfter f p2)-applyAfter _ n@(NotAllowed _)   = n-applyAfter _ _                  = notAllowed "Call to applyAfter with wrong arguments"---- ------------------------ mothers little helpers--strip           :: XmlTree -> Bool-strip           = maybe False whitespace . XN.getText--whitespace      :: String -> Bool-whitespace      = all isXmlSpaceChar--showXts         :: XmlTrees -> String-showXts         = concat . runLA (xshow $ arrL id)---- ------------------------------------------------------------
− src/Text/XML/HXT/RelaxNG/Validator.hs 
@@ -1,308 +0,0 @@--- |--- This module exports the core functions from the basic validation und simplification libraries.--- It also exports some helper functions for easier access to the validation functionality.--module Text.XML.HXT.RelaxNG.Validator-  ( validateDocumentWithRelaxSchema-  , validateDocumentWithRelax--  , validate-  , validateSchema-  , validateWithSpezification-  , validateSchemaWithSpezification-  , validateWithoutSpezification-  , module Text.XML.HXT.RelaxNG.Validation-  , module Text.XML.HXT.RelaxNG.Simplification-  )-where--import Control.Arrow.ListArrows--import Text.XML.HXT.DOM.Interface-import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlIOStateArrow--import Text.XML.HXT.RelaxNG.Validation-import Text.XML.HXT.RelaxNG.Simplification-import Text.XML.HXT.RelaxNG.Schema        as S---- --------------------------------------------------------------{- |-   validate a document with a Relax NG schema--   * 1.parameter  : the option list for validation--   - 2.parameter  : the URI of the Relax NG Schema--   - arrow-input  : the document to be validated, namespaces must have been processed--   - arrow-output : the input document, or in case of validation errors, an empty document with status information in the root--options evaluated by validateDocumentWithRelaxSchema:--    * 'a_check_restrictions'   : check Relax NG schema restrictions when simplifying the schema (default: on)--    - 'a_validate_externalRef' : validate a Relax NG schema referenced by a externalRef-Pattern (default: on)--    - 'a_validate_include'     : validate a Relax NG schema referenced by a include-Pattern (default: on)--all other options are propagated to the read functions for schema input--example:--> validateDocumentWithRelaxSchema [(a_check_restrictions, "0")] "testSchema.rng"----}--validateDocumentWithRelaxSchema :: Attributes -> String -> IOStateArrow s XmlTree XmlTree-validateDocumentWithRelaxSchema userOptions relaxSchema-    = withOtherUserState ()-      $-      ( ( validate' $< validSchema )    -- try to validate, only possible if schema is o.k.-        `orElse`-        this-      )-      `when`-      documentStatusOk                  -- only do something when document status is ok-    where-    validate' schema-        = setDocumentStatusFromSystemState "read and build Relax NG schema"-          >>>-          validateDocumentWithRelax schema--    validSchema-        = traceMsg 2 ( "read Relax NG schema document: " ++ show relaxSchema )-          >>>-          readForRelax remainingOptions relaxSchema-          >>>-          perform ( let checkSchema = True in           -- test option in al-                    if checkSchema-                    then validateWithRelaxAndHandleErrors S.relaxSchemaArrow-                    else none-                  )-          >>>-          traceMsg 2 "create simplified schema"-          >>>-          createSimpleForm remainingOptions-            ( hasOption a_check_restrictions   )-            ( hasOption a_validate_externalRef )-            ( hasOption a_validate_include     )-          >>>-          traceDoc "simplified schema"-          >>>-          perform ( getErrors-                    >>>-                    handleSimplificationErrors-                  )-    hasOption n-        = optionIsSet n options--    options = addEntries userOptions defaultOptions--    defaultOptions-        = [ ( a_check_restrictions,     v_1 )-          , ( a_validate_externalRef,   v_1 )-          , ( a_validate_include,       v_1 )-          ]--    remainingOptions-         = filter (not . flip hasEntry defaultOptions . fst) options----handleSimplificationErrors      :: IOSArrow XmlTree XmlTree-handleSimplificationErrors-    = traceDoc "simplification errors"-      >>>-      getChildren >>> getAttrValue "desc"-      >>>-      arr ("Relax NG validation: " ++)-      >>>-      mkError c_err-      >>>-      filterErrorMsg---{- | validate an XML document with respect to a Relax NG schema--   * 1.parameter  : the valid and simplified schema as XML tree--   - arrow-input  : the document to be validated--   - arrow-output : the validated and unchanged document or the empty document with status information set in the root node--}--validateDocumentWithRelax       :: XmlTree -> IOSArrow XmlTree XmlTree-validateDocumentWithRelax schema-    = ( traceMsg 1 "validate document with Relax NG schema"-        >>>-        perform ( validateWithRelaxAndHandleErrors (constA schema) )-        >>>-        setDocumentStatusFromSystemState "validate document with Relax NG schema"-      )-      `when` documentStatusOk                           -- only do something when document status is ok---{- |-   normalize a document for Relax NG validation,-   call the 'Text.XML.HXT.RelaxNG.Validation.validateRelax' function for doing the hard work,-   and issue errors--   * 1.parameter  : the arrow for computing the schema--   - arrow-input  : the document to be validated--   - arrow-output : nothing--}---- --------------------------------------------------------------{- | Document validation--Validates a xml document with respect to a Relax NG schema.--First, the schema is validated with respect to the Relax NG Spezification. If no error is found, the xml document is validated with respect to the schema.--   * 1.parameter :  list of options; namespace progagation is always done--   - 2.parameter :  XML document--   - 3.parameter :  Relax NG schema file--available options:--    * 'a_do_not_check_restrictions' : do not check Relax NG schema restrictions (includes do-not-validate-externalRef, do-not-validate-include)--    - 'a_do_not_validate_externalRef' : do not validate a Relax NG schema referenced by a externalRef-Pattern--    - 'a_validate_externalRef' : validate a Relax NG schema referenced by a externalRef-Pattern (default)--    - 'a_do_not_validate_include' : do not validate a Relax NG schema referenced by a include-Pattern--    - 'a_validate_include' : validate a Relax NG schema referenced by a include-Pattern (default)--    - 'a_output_changes' : output Pattern transformations in case of an error--    - 'a_do_not_collect_errors' : stop Relax NG simplification after the first error has occurred--    - all 'Text.XML.HXT.Arrow.ReadDocument.readDocument' options--example:--> validate [(a_do_not_check_restrictions, "1")] "test.xml" "testSchema.rng"---}-validate :: Attributes -> String -> String -> IOSArrow n XmlTree-validate al xmlDocument relaxSchema-  = S.relaxSchemaArrow-    >>>-    validateWithSpezification al xmlDocument relaxSchema-----{- | Relax NG schema validation--Validates a Relax NG schema with respect to the Relax NG Spezification.--   * 1.parameter :  list of available options (see also: 'validate')--   - 2.parameter :  Relax NG schema file---}-validateSchema :: Attributes -> String -> IOSArrow n XmlTree-validateSchema al relaxSchema-  = validate al "" relaxSchema----{- | Document validation--Validates a xml document with respect to a Relax NG schema. Similar to 'validate', but the Relax NG Specification is not created. Can be used, to check a list of documents more efficiently.--   * 1.parameter :  list of available options (see also: 'validate')--   - 2.parameter :  XML document--   - 3.parameter :  Relax NG schema file--   - arrow-input  :  Relax NG Specification in simple form--example:--> Text.XML.HXT.RelaxNG.Schema.relaxSchemaArrow-> >>>-> ( validateWithSpezification [] "foo.xml" "foo.rng"->   &&&->   validateWithSpezification [] "bar.xml" "bar.rng"-> )----}-validateWithSpezification :: Attributes -> String -> String -> IOSArrow XmlTree XmlTree-validateWithSpezification al xmlDocument relaxSchema-  = -- validation of the schema with respect to the specification-    -- returns a list of errors or none if the schema is correct--    ( validateRelax $< ( readForRelax al relaxSchema-                         >>>-                         getChildren-                       )-    )-    `orElse`--    -- validation of the xml document with respect to the schema-    -- returns a list of errors or none if the xml document is correct--    validateWithoutSpezification al xmlDocument relaxSchema--{- | Relax NG schema validation--    see 'validateSchema' and 'validateWithSpezification'--   * 1.parameter :  list of available options (see also: 'validate')--   - 2.parameter :  Relax NG schema file--   - arrow-input  :  Relax NG Specification in simple form--}--validateSchemaWithSpezification :: Attributes -> String -> IOSArrow XmlTree XmlTree-validateSchemaWithSpezification al relaxSchema-  = validateWithSpezification al "" relaxSchema----{- | Document validation--Validates a xml document with respect to a Relax NG schema, but the schema is @not@ validated with respect to a specification first. Should be used only for valid Relax NG schemes.--   * 1.parameter :  list of available options (see also: 'validate')--   - 2.parameter :  XML document--   - 3.parameter :  Relax NG schema file---}---validateWithoutSpezification :: Attributes -> String -> String -> IOSArrow n XmlTree-validateWithoutSpezification al xmlDocument relaxSchema-  = readForRelax al relaxSchema-    >>>-    createSimpleForm al True True True-    >>>-    ( ( getErrors >>> perform handleSimplificationErrors )              -- issue errors in schema simplification-      `orElse`-      ( if null xmlDocument                                             -- no errors: validate document-        then none-        else validateRelax $< ( readForRelax al xmlDocument-                                >>>-                                normalizeForRelaxValidation-                                >>>-                                getChildren-                              )-      )-    )
− src/Text/XML/HXT/RelaxNG/XmlSchema/DataTypeLibW3C.hs 
@@ -1,610 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C-   Copyright  : Copyright (C) 2005 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : experimental-   Portability: portable-   Version    : $Id$--   Datatype library for the W3C XML schema datatypes---}---- --------------------------------------------------------------module Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C-  ( w3cNS-  , w3cDatatypeLib--  , xsd_string                  -- data type names-  , xsd_normalizedString-  , xsd_token-  , xsd_language-  , xsd_NMTOKEN-  , xsd_NMTOKENS-  , xsd_Name-  , xsd_NCName-  , xsd_ID-  , xsd_IDREF-  , xsd_IDREFS-  , xsd_ENTITY-  , xsd_ENTITIES-  , xsd_anyURI-  , xsd_QName-  , xsd_NOTATION-  , xsd_hexBinary-  , xsd_base64Binary-  , xsd_decimal--  , xsd_length                  -- facet names-  , xsd_maxLength-  , xsd_minLength-  , xsd_maxExclusive-  , xsd_minExclusive-  , xsd_maxInclusive-  , xsd_minInclusive-  , xsd_totalDigits-  , xsd_fractionDigits-  , xsd_pattern-  , xsd_enumeration-  )-where--import Data.Maybe-import Data.Ratio--import Network.URI                              ( isURIReference )--import Text.XML.HXT.DOM.QualifiedName           ( isWellformedQualifiedName-                                                , isNCName-                                                )-import Text.XML.HXT.RelaxNG.DataTypeLibUtils-import Text.XML.HXT.RelaxNG.XmlSchema.Regex     ( Regex-                                                , matchWithRE-                                                )-import Text.XML.HXT.RelaxNG.XmlSchema.RegexParser-                                                ( parseRegex-                                                )---- ---------------------------------------------------------------- | Namespace of the W3C XML schema datatype library--w3cNS   :: String-w3cNS   = "http://www.w3.org/2001/XMLSchema-datatypes"---xsd_string- , xsd_normalizedString- , xsd_token- , xsd_language- , xsd_NMTOKEN- , xsd_NMTOKENS- , xsd_Name- , xsd_NCName- , xsd_ID- , xsd_IDREF- , xsd_IDREFS- , xsd_ENTITY- , xsd_ENTITIES- , xsd_anyURI- , xsd_QName- , xsd_NOTATION- , xsd_hexBinary- , xsd_base64Binary- , xsd_decimal- , xsd_integer- , xsd_nonPositiveInteger- , xsd_negativeInteger- , xsd_nonNegativeInteger- , xsd_positiveInteger- , xsd_long- , xsd_int- , xsd_short- , xsd_byte- , xsd_unsignedLong- , xsd_unsignedInt- , xsd_unsignedShort- , xsd_unsignedByte :: String--xsd_string              = "string"-xsd_normalizedString    = "normalizedString"-xsd_token               = "token"-xsd_language            = "language"-xsd_NMTOKEN             = "NMTOKEN"-xsd_NMTOKENS            = "NMTOKENS"-xsd_Name                = "Name"-xsd_NCName              = "NCName"-xsd_ID                  = "ID"-xsd_IDREF               = "IDREF"-xsd_IDREFS              = "IDREFS"-xsd_ENTITY              = "ENTITY"-xsd_ENTITIES            = "ENTITIES"-xsd_anyURI              = "anyURI"-xsd_QName               = "QName"-xsd_NOTATION            = "NOTATION"-xsd_hexBinary           = "hexBinary"-xsd_base64Binary        = "base64Binary"-xsd_decimal             = "decimal"-xsd_integer             = "integer"-xsd_nonPositiveInteger  = "nonPositiveInteger"-xsd_negativeInteger     = "negativeInteger"-xsd_nonNegativeInteger  = "nonNegativeInteger"-xsd_positiveInteger     = "positiveInteger"-xsd_long                = "long"-xsd_int                 = "int"-xsd_short               = "short"-xsd_byte                = "byte"-xsd_unsignedLong        = "unsignedLong"-xsd_unsignedInt         = "unsignedInt"-xsd_unsignedShort       = "unsignedShort"-xsd_unsignedByte        = "unsignedByte"---xsd_length- , xsd_maxLength- , xsd_minLength- , xsd_maxExclusive- , xsd_minExclusive- , xsd_maxInclusive- , xsd_minInclusive- , xsd_totalDigits- , xsd_fractionDigits- , xsd_pattern- , xsd_enumeration :: String--xsd_length              = rng_length-xsd_maxLength           = rng_maxLength-xsd_minLength           = rng_minLength--xsd_maxExclusive        = rng_maxExclusive-xsd_minExclusive        = rng_minExclusive-xsd_maxInclusive        = rng_maxInclusive-xsd_minInclusive        = rng_minInclusive--xsd_totalDigits         = "totalDigits"-xsd_fractionDigits      = "fractionDigits"--xsd_pattern             = "pattern"-xsd_enumeration         = "enumeration"---- -------------------------------------------- | The main entry point to the W3C XML schema datatype library.------ The 'DTC' constructor exports the list of supported datatypes and params.--- It also exports the specialized functions to validate a XML instance value with--- respect to a datatype.-w3cDatatypeLib :: DatatypeLibrary-w3cDatatypeLib = (w3cNS, DTC datatypeAllowsW3C datatypeEqualW3C w3cDatatypes)----- | All supported datatypes of the library-w3cDatatypes :: AllowedDatatypes-w3cDatatypes = [ (xsd_string,                   stringParams)-               , (xsd_normalizedString,         stringParams)-               , (xsd_token,                    stringParams)-               , (xsd_language,                 stringParams)-               , (xsd_NMTOKEN,                  stringParams)-               , (xsd_NMTOKENS,                 listParams  )-               , (xsd_Name,                     stringParams)-               , (xsd_NCName,                   stringParams)-               , (xsd_ID,                       stringParams)-               , (xsd_IDREF,                    stringParams)-               , (xsd_IDREFS,                   listParams  )-               , (xsd_ENTITY,                   stringParams)-               , (xsd_ENTITIES,                 listParams  )-               , (xsd_anyURI,                   stringParams)-               , (xsd_QName,                    stringParams)-               , (xsd_NOTATION,                 stringParams)-               , (xsd_hexBinary,                stringParams)-               , (xsd_base64Binary,             stringParams)-               , (xsd_decimal,                  decimalParams)-               , (xsd_integer,                  integerParams)-               , (xsd_nonPositiveInteger,       integerParams)-               , (xsd_negativeInteger,          integerParams)-               , (xsd_nonNegativeInteger,       integerParams)-               , (xsd_positiveInteger,          integerParams)-               , (xsd_long,                     integerParams)-               , (xsd_int,                      integerParams)-               , (xsd_short,                    integerParams)-               , (xsd_byte,                     integerParams)-               , (xsd_unsignedLong,             integerParams)-               , (xsd_unsignedInt,              integerParams)-               , (xsd_unsignedShort,            integerParams)-               , (xsd_unsignedByte,             integerParams)-               ]---- -------------------------------------------- | List of allowed params for the string datatypes-stringParams    :: AllowedParams-stringParams    = xsd_pattern : map fst fctTableString---- ------------------------------------------patternValid    :: ParamList -> CheckString-patternValid params-    = foldr (>>>) ok . map paramPatternValid $ params-      where-      paramPatternValid (pn, pv)-          | pn == xsd_pattern   = assert (patParamValid pv) (errorMsgParam pn pv)-          | otherwise           = ok--patParamValid :: String -> String -> Bool-patParamValid regex a-    = case parseRegex regex of-      (Left _  )        -> False-      (Right ex)        -> isNothing . matchWithRE ex $ a---- -------------------------------------------- | List of allowed params for the decimal datatypes--decimalParams   :: AllowedParams-decimalParams   = xsd_pattern : map fst fctTableDecimal--fctTableDecimal :: [(String, String -> Rational -> Bool)]-fctTableDecimal-    = [ (xsd_maxExclusive,   cvd (>))-      , (xsd_minExclusive,   cvd (<))-      , (xsd_maxInclusive,   cvd (>=))-      , (xsd_minInclusive,   cvd (<=))-      , (xsd_totalDigits,    cvi (\ l v ->    totalDigits v == l))-      , (xsd_fractionDigits, cvi (\ l v -> fractionDigits v == l))-      ]-    where-    cvd         :: (Rational -> Rational -> Bool) -> (String -> Rational -> Bool)-    cvd op      = \ x y -> isDecimal x && readDecimal x `op` y--    cvi         :: (Int -> Rational -> Bool) -> (String -> Rational -> Bool)-    cvi op      = \ x y -> isNumber x && read x `op` y--decimalValid    :: ParamList -> CheckA Rational Rational-decimalValid params-    = foldr (>>>) ok . map paramDecimalValid $ params-    where-    paramDecimalValid (pn, pv)-        = assert-          ((fromMaybe (const . const $ True) . lookup pn $ fctTableDecimal) pv)-          (errorMsgParam pn pv . showDecimal)---- -------------------------------------------- | List of allowed params for the decimal and integer datatypes--integerParams   :: AllowedParams-integerParams   = xsd_pattern : map fst fctTableInteger--fctTableInteger :: [(String, String -> Integer -> Bool)]-fctTableInteger-    = [ (xsd_maxExclusive,   cvi (>))-      , (xsd_minExclusive,   cvi (<))-      , (xsd_maxInclusive,   cvi (>=))-      , (xsd_minInclusive,   cvi (<=))-      , (xsd_totalDigits,    cvi (\ l v -> totalD v == toInteger l))-      ]-    where-    cvi         :: (Integer -> Integer -> Bool) -> (String -> Integer -> Bool)-    cvi op      = \ x y -> isNumber x && read x `op` y--    totalD i-        | i < 0     = totalD (0-i)-        | otherwise = toInteger . length . show $ i--integerValid    :: DatatypeName -> ParamList -> CheckA Integer Integer-integerValid datatype params-    = assertInRange-      >>>-      (foldr (>>>) ok . map paramIntegerValid $ params)-    where-    assertInRange       :: CheckA Integer Integer-    assertInRange-        = assert-          (fromMaybe (const True) . lookup datatype $ integerRangeTable)-          (\ v -> ( "Datatype " ++ show datatype ++-                    " with value = " ++ show v ++-                    " not in integer value range"-                  )-          )-    paramIntegerValid (pn, pv)-        = assert-          ((fromMaybe (const . const $ True) . lookup pn $ fctTableInteger) pv)-          (errorMsgParam pn pv . show)--integerRangeTable       :: [(String, Integer -> Bool)]-integerRangeTable       = [ (xsd_integer,               const True)-                          , (xsd_nonPositiveInteger,    (<=0)   )-                          , (xsd_negativeInteger,       ( <0)   )-                          , (xsd_nonNegativeInteger,    (>=0)   )-                          , (xsd_positiveInteger,       ( >0)   )-                          , (xsd_long,                  inR 9223372036854775808)-                          , (xsd_int,                   inR 2147483648)-                          , (xsd_short,                 inR 32768)-                          , (xsd_byte,                  inR 128)-                          , (xsd_unsignedLong,          inP 18446744073709551616)-                          , (xsd_unsignedInt,           inP 4294967296)-                          , (xsd_unsignedShort,         inP 65536)-                          , (xsd_unsignedByte,          inP 256)-                          ]-                          where-                          inR b i       = (0 - b) <= i && i < b-                          inP b i       = 0 <= i       && i < b---- -------------------------------------------- | List of allowed params for the list datatypes--listParams      :: AllowedParams-listParams      = xsd_pattern : map fst fctTableList--listValid       :: DatatypeName -> ParamList -> CheckString-listValid d     = stringValidFT fctTableList d 0 (-1)---- ------------------------------------------isNameList      :: (String -> Bool) -> String -> Bool-isNameList p w-    = not (null ts) && all p ts-      where-      ts = words w---- ------------------------------------------rex             :: String -> Regex-rex             = either undefined id . parseRegex--isRex           :: Regex -> String -> Bool-isRex ex        = isNothing . matchWithRE ex---- ------------------------------------------rexLanguage-  , rexHexBinary-  , rexBase64Binary-  , rexDecimal-  , rexInteger  :: Regex--rexLanguage     = rex "[A-Za-z]{1,8}(-[A-Za-z]{1,8})*"-rexHexBinary    = rex "([A-Fa-f0-9]{2})*"-rexBase64Binary = rex $-                  "(" ++ b64 ++ "{4})*((" ++ b64 ++ "{2}==)|(" ++ b64 ++ "{3}=)|)"-                  where-                  b64     = "[A-Za-z0-9+/]"-rexDecimal      = rex "(\\+|-)?(([0-9]+(\\.[0-9]*)?)|(\\.[0-9]+))"-rexInteger      = rex "(\\+|-)?[0-9]+"--isLanguage-  , isHexBinary-  , isBase64Binary-  , isDecimal-  , isInteger   :: String -> Bool--isLanguage      = isRex rexLanguage-isHexBinary     = isRex rexHexBinary-isBase64Binary  = isRex rexBase64Binary-isDecimal       = isRex rexDecimal-isInteger       = isRex rexInteger---- ------------------------------------------normBase64      :: String -> String-normBase64      = filter isB64-                  where-                  isB64 c = ( 'A' <= c && c <= 'Z')-                            ||-                            ( 'a' <= c && c <= 'z')-                            ||-                            ( '0' <= c && c <= '9')-                            ||-                            c == '+'-                            ||-                            c == '/'-                            ||-                            c == '='---- ------------------------------------------readDecimal-  , readDecimal'        :: String -> Rational--readDecimal ('+':s)     = readDecimal' s-readDecimal ('-':s)     = negate (readDecimal' s)-readDecimal      s      = readDecimal' s--readDecimal' s-    | f == 0    = (n % 1)-    | otherwise = (n % 1) + (f % (10 ^ (toInteger (length fs))))-    where-    (ns, fs') = span (/= '.') s-    fs = drop 1 fs'--    f :: Integer-    f | null fs         = 0-      | otherwise       = read fs-    n :: Integer-    n | null ns         = 0-      | otherwise       = read ns--totalDigits-  , totalDigits'-  , fractionDigits      :: Rational -> Int--totalDigits r-    | r == 0                    = 0-    | r < 0                     = totalDigits' . negate  $ r-    | otherwise                 = totalDigits'           $ r--totalDigits' r-    | denominator r == 1        = length . show . numerator  $ r-    | r < (1%1)                 = (\ x -> x-1) . totalDigits' . (+ (1%1))    $ r-    | otherwise                 = totalDigits' . (* (10 % 1)) $ r--fractionDigits r-    | denominator r == 1        = 0-    | otherwise                 = (+1) . fractionDigits . (* (10 % 1)) $ r--showDecimal-  , showDecimal'                :: Rational -> String--showDecimal d-    | d < 0     = ('-':) . showDecimal' . negate    $ d-    | d < 1     = drop 1 . showDecimal' . (+ (1%1)) $ d-    | otherwise =          showDecimal'             $ d--showDecimal' d-    | denominator d == 1        = show . numerator $ d-    | otherwise                 = times10 0        $ d-    where-    times10 i' d'-        | denominator d' == 1   = let-                                  (x, y) = splitAt i' . reverse . show . numerator $ d'-                                  in-                                  reverse y ++ "." ++ reverse x-        | otherwise             = times10 (i' + 1) (d' * (10 % 1))---- -------------------------------------------- | Tests whether a XML instance value matches a data-pattern.--- (see also: 'stringValid')--datatypeAllowsW3C :: DatatypeAllows-datatypeAllowsW3C d params value _-    = performCheck check value-    where-    validString normFct-        = validPattern-          >>>-          arr normFct-          >>>-          validLength--    validNormString-        = validString normalizeWhitespace--    validPattern-        = patternValid params--    validLength-        = stringValid d 0 (-1) params--    validList-        = validPattern-          >>>-          arr normalizeWhitespace-          >>>-          validListLength--    validListLength-        = listValid d params--    validName isN-        = assertW3C isN--    validNCName-        = validNormString >>> validName isNCName--    validQName-        = validNormString >>> validName isWellformedQualifiedName--    validDecimal-        = arr normalizeWhitespace-          >>>-          assertW3C isDecimal-          >>>-          checkWith readDecimal (decimalValid params)--    validInteger inRange-        = validPattern-          >>>-          arr normalizeWhitespace-          >>>-          assertW3C isInteger-          >>>-          checkWith read (integerValid inRange params)--    check       :: CheckString-    check       = fromMaybe notFound . lookup d $ checks--    notFound    = failure $ errorMsgDataTypeNotAllowed w3cNS d params--    checks      :: [(String, CheckA String String)]-    checks      = [ (xsd_string,                validString id)-                  , (xsd_normalizedString,      validString normalizeBlanks)-                  , (xsd_token,                 validNormString)-                  , (xsd_language,              validNormString >>> assertW3C isLanguage)-                  , (xsd_NMTOKEN,               validNormString >>> validName isNmtoken)-                  , (xsd_NMTOKENS,              validList       >>> validName (isNameList isNmtoken))-                  , (xsd_Name,                  validNormString >>> validName isName)-                  , (xsd_NCName,                validNCName)-                  , (xsd_ID,                    validNCName)-                  , (xsd_IDREF,                 validNCName)-                  , (xsd_IDREFS,                validList       >>> validName (isNameList isNCName))-                  , (xsd_ENTITY,                validNCName)-                  , (xsd_ENTITIES,              validList       >>> validName (isNameList isNCName))-                  , (xsd_anyURI,                validName isURIReference >>> validString escapeURI)-                  , (xsd_QName,                 validQName)-                  , (xsd_NOTATION,              validQName)-                  , (xsd_hexBinary,             validString id         >>> assertW3C isHexBinary)-                  , (xsd_base64Binary,          validString normBase64 >>> assertW3C isBase64Binary)-                  , (xsd_decimal,               validPattern >>> validDecimal)-                  , (xsd_integer,               validInteger xsd_integer)-                  , (xsd_nonPositiveInteger,    validInteger xsd_nonPositiveInteger)-                  , (xsd_negativeInteger,       validInteger xsd_negativeInteger)-                  , (xsd_nonNegativeInteger,    validInteger xsd_nonNegativeInteger)-                  , (xsd_positiveInteger,       validInteger xsd_positiveInteger)-                  , (xsd_long,                  validInteger xsd_long)-                  , (xsd_int,                   validInteger xsd_int)-                  , (xsd_short,                 validInteger xsd_short)-                  , (xsd_byte,                  validInteger xsd_byte)-                  , (xsd_unsignedLong,          validInteger xsd_unsignedLong)-                  , (xsd_unsignedInt,           validInteger xsd_unsignedInt)-                  , (xsd_unsignedShort,         validInteger xsd_unsignedShort)-                  , (xsd_unsignedByte,          validInteger xsd_unsignedByte)-                  ]-    assertW3C p = assert p errW3C-    errW3C      = errorMsgDataLibQName w3cNS d---- -------------------------------------------- | Tests whether a XML instance value matches a value-pattern.--datatypeEqualW3C :: DatatypeEqual-datatypeEqualW3C d s1 _ s2 _-    = performCheck check (s1, s2)-    where-    check       :: CheckA (String, String) (String, String)-    check       = maybe notFound found . lookup d $ norm--    notFound    = failure $ const (errorMsgDataTypeNotAllowed0 w3cNS d)--    found nf    = arr (\ (x1, x2) -> (nf x1, nf x2))                    -- normalize both values-                  >>>-                  assert (uncurry (==)) (uncurry $ errorMsgEqual d)     -- and check on (==)--    norm = [ (xsd_string,               id                      )-           , (xsd_normalizedString,     normalizeBlanks         )-           , (xsd_token,                normalizeWhitespace     )-           , (xsd_language,             normalizeWhitespace     )-           , (xsd_NMTOKEN,              normalizeWhitespace     )-           , (xsd_NMTOKENS,             normalizeWhitespace     )-           , (xsd_Name,                 normalizeWhitespace     )-           , (xsd_NCName,               normalizeWhitespace     )-           , (xsd_ID,                   normalizeWhitespace     )-           , (xsd_IDREF,                normalizeWhitespace     )-           , (xsd_IDREFS,               normalizeWhitespace     )-           , (xsd_ENTITY,               normalizeWhitespace     )-           , (xsd_ENTITIES,             normalizeWhitespace     )-           , (xsd_anyURI,               escapeURI . normalizeWhitespace )-           , (xsd_QName,                normalizeWhitespace     )-           , (xsd_NOTATION,             normalizeWhitespace     )-           , (xsd_hexBinary,            id                      )-           , (xsd_base64Binary,         normBase64              )-           , (xsd_decimal,              show . readDecimal . normalizeWhitespace        )-           ]---- ----------------------------------------
− src/Text/XML/HXT/RelaxNG/XmlSchema/Regex.hs 
@@ -1,317 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.RelaxNG.XmlSchema.Regex-   Copyright  : Copyright (C) 2005 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : experimental-   Portability: portable--   W3C XML Schema Regular Expression Matcher--   Grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>---}---- --------------------------------------------------------------module Text.XML.HXT.RelaxNG.XmlSchema.Regex-    ( Regex-    , chars-    , charRngs-    , mkZero-    , mkUnit-    , mkSym-    , mkSym1-    , mkSymRng-    , mkDot-    , mkStar-    , mkAlt-    , mkSeq-    , mkRep-    , mkRng-    , mkOpt-    , mkDif-    , mkCompl-    , isZero-    , nullable-    , delta-    , matchWithRE-    , (<&&>)-    , (<||>)-    )-where--import Data.List        ( foldl' )---- --------------------------------------------------------------data Regex      = Zero String-                | Unit-                | Sym (Char -> Bool)-                | Dot-                | Star Regex-                | Alt Regex Regex-                | Seq Regex Regex-                | Rep Int Regex         -- 1 or more repetitions-                | Rng Int Int Regex     -- n..m repetitions-                | Dif Regex Regex       -- r1 - r2---- --------------------------------------------------------------{- just for documentation--class Inv a where-    inv         :: a -> Bool--instance Inv Regex where-    inv (Zero _)        = True-    inv Unit            = True-    inv (Sym p)         = not . null . chars $ p-    inv Dot             = True-    inv (Star e)        = inv e-    inv (Alt e1 e2)     = inv e1 &&-                          inv e2-    inv (Seq e1 e2)     = inv e1 &&-                          inv e2-    inv (Rep i e)       = i > 0 && inv e-    inv (Rng i j e)     = (i < j || (i == j && i > 1)) &&-                          inv e-    inv (Dif e1 e2)     = inv e1 &&-                          inv e2--}---- --------------------------------------------------------------- | enumerate all chars specified by a predicate------ this function is expensive, it should only be used for testing--chars                           :: (Char -> Bool) -> [Char]-chars p                         = filter p $ [minBound .. maxBound]--charRngs                        :: [Char] -> [(Char, Char)]-charRngs []                     = []-charRngs (x:xs)                 = charRng x xs-                                where-                                charRng y []            = (x,y) : []-                                charRng y xs'@(x1:xs1)-                                    | x1 == succ y      = charRng x1 xs1-                                    | otherwise         = (x,y) : charRngs xs'---- ------------------------------------------------------------------ smart constructors--mkZero                          :: String -> Regex-mkZero                          = Zero-{-# INLINE mkZero #-}--mkUnit                          :: Regex-mkUnit                          = Unit-{-# INLINE mkUnit #-}--mkSym                           :: (Char -> Bool) -> Regex-mkSym                           = Sym-{-# INLINE mkSym #-}--mkSym1                          :: Char -> Regex-mkSym1  c                       = mkSym (==c)--mkSymRng                        :: Char -> Char -> Regex-mkSymRng c1 c2-    | c1 == minBound &&-      c2 == maxBound            = mkDot-    | c1 <= c2                  = mkSym  $ (>= c1) <&&> (<= c2)-    | otherwise                 = mkZero $ "empty char range"--mkDot                           :: Regex-mkDot                           = Dot-{-# INLINE mkDot #-}--mkStar                          :: Regex -> Regex-mkStar (Zero _)                 = mkUnit                -- {}* == ()-mkStar e@Unit                   = e                     -- ()* == ()-mkStar e@(Star _e1)             = e                     -- (r*)* == r*-mkStar (Rep 1 e1)               = mkStar e1             -- (r+)* == r*-mkStar e@(Alt _ _)              = Star (rmStar e)       -- (a*|b)* == (a|b)*-mkStar e                        = Star e--rmStar                          :: Regex -> Regex-rmStar (Alt e1 e2)              = mkAlt (rmStar e1) (rmStar e2)-rmStar (Star e1)                = rmStar e1-rmStar (Rep 1 e1)               = rmStar e1-rmStar e1                       = e1--mkAlt                                   :: Regex -> Regex -> Regex-mkAlt e1            (Zero _)            = e1                            -- e1 u {} = e1-mkAlt (Zero _)      e2                  = e2                            -- {} u e2 = e2-mkAlt e1@(Star Dot) _e2                 = e1                            -- A* u e1 = A*-mkAlt _e1           e2@(Star Dot)       = e2                            -- e1 u A* = A*-mkAlt (Sym p1)      (Sym p2)            = mkSym $ p1 <||> p2            -- melting of predicates-mkAlt e1            e2@(Sym _)          = mkAlt e2 e1                   -- symmetry: predicates always first-mkAlt e1@(Sym _)    (Alt e2@(Sym _) e3) = mkAlt (mkAlt e1 e2) e3        -- prepare melting of predicates-mkAlt (Alt e1 e2)   e3                  = mkAlt e1 (mkAlt e2 e3)        -- associativity-mkAlt e1 e2                             = Alt e1 e2--mkSeq                           :: Regex -> Regex -> Regex-mkSeq e1@(Zero _) _e2           = e1-mkSeq _e1         e2@(Zero _)   = e2-mkSeq Unit        e2            = e2-mkSeq e1          Unit          = e1-mkSeq (Seq e1 e2) e3            = mkSeq e1 (mkSeq e2 e3)-mkSeq e1 e2                     = Seq e1 e2--mkRep           :: Int -> Regex -> Regex-mkRep 0 e                       = mkStar e-mkRep _ e@(Zero _)              = e-mkRep _ e@Unit                  = e-mkRep i e                       = Rep i e--mkRng   :: Int -> Int -> Regex -> Regex-mkRng 0  0  _e                  = mkUnit-mkRng 1  1  e                   = e-mkRng lb ub _e-    | lb > ub                   = Zero $-                                  "illegal range " ++-                                  show lb ++ ".." ++ show ub-mkRng _l _u e@(Zero _)          = e-mkRng _l _u e@Unit              = e-mkRng lb ub e                   = Rng lb ub e--mkOpt                           :: Regex -> Regex-mkOpt                           = mkRng 0 1--mkDif   :: Regex -> Regex -> Regex-mkDif e1@(Zero _) _e2           = e1-mkDif e1          (Zero _)      = e1-mkDif _e1         (Star Dot)    = mkZero "empty set in difference expr"-mkDif Dot         (Sym p)       = mkSym (not . p)-mkDif (Sym _)     Dot           = mkZero "empty set of chars in difference expr"-mkDif (Sym p1)    (Sym p2)-    | null . chars $ (\ x -> p1 x && not (p2 x))-                                = mkZero "empty set of chars in difference expr"-mkDif e1          e2            = Dif e1 e2--mkCompl                         :: Regex -> Regex-mkCompl                         = mkDif mkDot---- --------------------------------------------------------------instance Show Regex where-    show (Zero s)       = "{err:" ++ s ++ "}"-    show Unit           = "()"-    show (Sym p)-        | null (tail cs) &&-          rng1 (head cs)-                        = escRng . head $ cs-        | otherwise     = "[" ++ concat cs' ++ "]"-                          where-                          rng1 (x,y)    = x == y-                          cs            = charRngs . chars $ p-                          cs'           = map escRng cs-                          escRng (x, y)-                              | x == y  = esc x-                              | succ x == y-                                        = esc x        ++ esc y-                              | otherwise-                                        = esc x ++ "-" ++ esc y-                          esc x-                              | x `elem` "\\-[]{}()*+?.^"-                                        = '\\':x:""-                              | x >= ' ' && x <= '~'-                                        = x:""-                              | otherwise-                                        = "&#" ++ show (fromEnum x) ++ ";"-    show Dot            = "."-    show (Star e)       = "(" ++ show e ++ ")*"-    show (Alt e1 e2)    = "(" ++ show e1 ++ "|" ++ show e2 ++ ")"-    show (Seq e1 e2)    = show e1 ++ show e2-    show (Rep 1 e)      = "(" ++ show e ++ ")+"-    show (Rep i e)      = "(" ++ show e ++ "){" ++ show i ++ ",}"-    show (Rng 0 1 e)    = "(" ++ show e ++ ")?"-    show (Rng i j e)    = "(" ++ show e ++ "){" ++ show i ++ "," ++ show j ++ "}"-    show (Dif e1 e2)    = "(" ++ show e1 ++ "-" ++ show e2 ++ ")"---- --------------------------------------------------------------isZero                  :: Regex -> Bool-isZero (Zero _)         = True-isZero _                = False-{-# INLINE isZero #-}--nullable                :: Regex -> Bool-nullable (Zero _)       = False-nullable Unit           = True-nullable (Sym _p)       = False         -- assumption: p holds for at least one char-nullable Dot            = False-nullable (Star _)       = True-nullable (Alt e1 e2)    = nullable e1 ||-                          nullable e2-nullable (Seq e1 e2)    = nullable e1 &&-                          nullable e2-nullable (Rep _i e)     = nullable e-nullable (Rng i _ e)    = i == 0 ||-                          nullable e-nullable (Dif e1 e2)    = nullable e1 &&-                          not (nullable e2)---- --------------------------------------------------------------delta   :: Regex -> Char -> Regex-delta e@(Zero _)  _     = e-delta Unit        c     = mkZero $-                          "unexpected char " ++ show c-delta (Sym p)     c-    | p c               = mkUnit-    | otherwise         = mkZero $-                          "unexpected char " ++ show c ++ ", expected: " ++ oneof ++ chars'-                          where-                          (cs, ds) = splitAt 40 (chars p)-                          oneof-                              | null (tail cs) = ""-                              | otherwise      = "one of "-                          chars'-                              | null (tail cs) = "'" ++ cs ++ "'"-                              | null ds   = "[" ++ cs ++ "]"-                              | otherwise = "[" ++ cs ++ "...]"--delta Dot         _     = mkUnit-delta e@(Star e1) c     = mkSeq (delta e1 c) e-delta (Alt e1 e2) c     = mkAlt (delta e1 c) (delta e2 c)-delta (Seq e1 e2) c-    | nullable e1       = mkAlt (mkSeq (delta e1 c) e2) (delta e2 c)-    | otherwise         = mkSeq (delta e1 c) e2-delta (Rep i e)   c     = mkSeq (delta e c) (mkRep (i-1) e)-delta (Rng i j e) c     = mkSeq (delta e c) (mkRng ((i-1) `max` 0) (j-1) e)-delta (Dif e1 e2) c     = mkDif (delta e1 c) (delta e2 c)---- --------------------------------------------------------------delta'          :: Regex -> String -> Regex-delta'          = foldl' delta--matchWithRE             :: Regex -> String -> Maybe String-matchWithRE e-    = res . delta' e-    where-    res (Zero err)      = Just err-    res re-        | nullable re   = Nothing       -- o.k.-        | otherwise     = Just $ "input does not match " ++ show e---- --------------------------------------------------------------(<&&>)          :: (Char -> Bool) -> (Char -> Bool) -> (Char -> Bool)-f <&&> g        = \ x -> f x && g x             -- liftA2 (&&)--{-# INLINE (<&&>) #-}---(<||>)          :: (Char -> Bool) -> (Char -> Bool) -> (Char -> Bool)-f <||> g        = \ x -> f x || g x             -- liftA2 (||)--{-# INLINE (<||>) #-}---- ------------------------------------------------------------
− src/Text/XML/HXT/RelaxNG/XmlSchema/RegexMatch.hs 
@@ -1,241 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch-   Copyright  : Copyright (C) 2005 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : experimental-   Portability: portable--   Convenient functions for W3C XML Schema Regular Expression Matcher.-   For internals see 'Text.XML.HXT.RelaxNG.XmlSchema.Regex'--   Grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>---}---- --------------------------------------------------------------module Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch-    ( matchRE-    , splitRE-    , sedRE-    , tokenizeRE-    , tokenizeRE'--    , match-    , tokenize-    , tokenize'-    , sed-    , split--    , splitRegex-    )-where--import Data.Maybe--import Text.XML.HXT.RelaxNG.XmlSchema.Regex-import Text.XML.HXT.RelaxNG.XmlSchema.RegexParser--{--import qualified Debug.Trace as T--}---- --------------------------------------------------------------splitRegex              :: Regex -> String -> Maybe (String, String)-splitRegex re ""-    | nullable re       = Just ("", "")-    | otherwise         = Nothing--splitRegex re inp@(c : inp')-    | isZero   re       = Nothing-    | otherwise         = evalRes . splitRegex {- (T.trace (show re') re') -} re' $ inp'-    where-    re' = delta re c-    evalRes Nothing-        | nullable re   = Just ("", inp)-        | otherwise     = Nothing--    evalRes (Just (tok, rest))-                        = Just (c : tok, rest)---- ---------------------------------------------------------------- | split a string by taking the longest prefix matching a regular expression------ @Nothing@ is returned in case of a syntactically wrong regex string--- or in case there is no matching prefix, else the pair of prefix and rest is returned------ examples:------ > splitRE "a*b" "abc" = Just ("ab","c")--- > splitRE "a*"  "bc"  = Just ("", "bc")--- > splitRE "a+"  "bc"  = Nothing--- > splitRE "["   "abc" = Nothing--splitRE :: String -> String -> Maybe (String, String)-splitRE re input-    = either (const Nothing) (flip splitRegex input) . parseRegex $ re---- | convenient function for splitRE------ syntax errors in R.E. are interpreted as no matching prefix found--split           :: String -> String -> (String, String)-split re input-    = fromMaybe ("", input) . splitRE re $ input---- ---------------------------------------------------------------- | split a string into tokens (words) by giving a regular expression--- which all tokens must match------ This can be used for simple tokenizers.--- The words in the result list contain at least one char.--- All none matching chars are discarded. If the given regex contains syntax errors,--- @Nothing@ is returned------ examples:------ > tokenizeRE "a*b" ""         = Just []--- > tokenizeRE "a*b" "abc"      = Just ["ab"]--- > tokenizeRE "a*b" "abaab ab" = Just ["ab","aab","ab"]--- >--- > tokenizeRE "[a-z]{2,}|[0-9]{2,}|[0-9]+[.][0-9]+" "ab123 456.7abc"--- >                                = Just ["ab","123","456.7","abc"]--- >--- > tokenizeRE "[a-z]*|[0-9]{2,}|[0-9]+[.][0-9]+" "cab123 456.7abc"--- >                                = Just ["cab","123","456.7","abc"]--- >--- > tokenizeRE "[^ \t\n\r]*" "abc def\t\n\rxyz"--- >                                = Just ["abc","def","xyz"]--- >--- > tokenizeRE "[^ \t\n\r]*"    = words--tokenizeRE      :: String -> String -> Maybe [String]-tokenizeRE regex input-    = either (const Nothing) (Just . flip token' input) $ parseRegex regex-    where-    token'      :: Regex -> String -> [String]-    token' re inp-        | null inp      = []-        | otherwise     = evalRes . splitRegex re $ inp-        where-        token''         = token' re-        evalRes Nothing = token'' (tail inp)            -- re does not match any prefix-        evalRes (Just (tok, rest))-            | null tok  = token'' (tail rest)           -- re is nullable and only the empty prefix matches-            | otherwise = tok : token'' rest            -- token found, tokenize the rest---- | convenient function for tokenizeRE a string------ syntax errors in R.E. result in an empty list--tokenize        :: String -> String -> [String]-tokenize re-    = fromMaybe [] . tokenizeRE re---- ---------------------------------------------------------------- | split a string into tokens and delimierter by giving a regular expression--- wich all tokens must match------ This is a generalisation of the above 'tokenizeRE' functions.--- The none matching char sequences are marked with @Left@, the matching ones are marked with @Right@------ If the regular expression contains syntax errors @Nothing@ is returned------ The following Law holds:------ > concat . map (either id id) . fromJust . tokenizeRE' re == id--tokenizeRE'     :: String -> String -> Maybe [Either String String]-tokenizeRE' regex input-    = either (const Nothing) (Just . flip token' input) $ parseRegex regex-    where-    token'      :: Regex -> String -> [Either String String]-    token' re-        = tok2 ""-        where-        tok2 :: String -> String -> [Either String String]-        tok2 noMatchPrefix inp-            | null inp  = addNoMatch []-            | otherwise = evalRes . splitRegex re $ inp-            where-            addNoMatch res-                | null noMatchPrefix    = res-                | otherwise             = (Left . reverse $ noMatchPrefix) : res--            evalRes Nothing             = tok2 (head inp : noMatchPrefix) (tail inp)            -- re does not match any prefix-            evalRes (Just (tok, rest))-                | null tok              = tok2 (head rest : noMatchPrefix) (tail rest)          -- re is nullable and only the empty prefix matches-                | otherwise             = addNoMatch . (Right tok :) . tok2 "" $ rest           -- token found, tokenize the rest---- | convenient function for tokenizeRE'------ When the regular expression contains errors @[Left input]@ is returned, that means tokens are found--tokenize'       :: String -> String -> [Either String String]-tokenize' regex input-    = fromMaybe [Left input] . tokenizeRE' regex $ input---- ---------------------------------------------------------------- | sed like editing function------ All matching tokens are edited by the 1. argument, the editing function,--- all other chars remain as they are------ examples:------ > sedRE (const "b") "a" "xaxax"       = Just "xbxbx"--- > sedRE (\ x -> x ++ x) "a" "xax"     = Just "xaax"--- > sedRE undefined       "[" undefined = Nothing--sedRE           :: (String -> String) -> String -> String -> Maybe String-sedRE edit regex input-    = maybe Nothing (Just . concatMap (either id edit)) $ tokenizeRE' regex input---- | convenient function for sedRE------ When the regular expression contains errors, sed is the identity, else--- the funtionality is like 'sedRE'------ > sed undefined "["  == id--sed             :: (String -> String) -> String -> String -> String-sed edit regex input-    = fromMaybe input . sedRE edit regex $ input---- ---------------------------------------------------------------- | match a string with a regular expression------ First argument is the regex, second the input string,--- if the regex is not well formed, @Nothing@ is returned,--- else @Just@ the match result------ Examples:------ > matchRE "x*" "xxx" = Just True--- > matchRE "x" "xxx"  = Just False--- > matchRE "[" "xxx"  = Nothing--matchRE :: String -> String -> Maybe Bool-matchRE regex input-    = either (const Nothing) (Just . isNothing . flip matchWithRE input) $ parseRegex regex----- | convenient function for matchRE------ syntax errors in R.E. are interpreted as no match found--match           :: String -> String -> Bool-match re        = fromMaybe False . matchRE re---- -------------------------------------------------------------
− src/Text/XML/HXT/RelaxNG/XmlSchema/RegexParser.hs 
@@ -1,354 +0,0 @@--- --------------------------------------------------------------{- |-   Module     : Text.XML.HXT.RelaxNG.XmlSchema.RegexParser-   Copyright  : Copyright (C) 2005 Uwe Schmidt-   License    : MIT--   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : experimental-   Portability: portable--   W3C XML Schema Regular Expression Parser--   This parser supports the full W3C standard, the-   complete grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>---}---- --------------------------------------------------------------module Text.XML.HXT.RelaxNG.XmlSchema.RegexParser-    ( parseRegex )-where--import Data.Maybe--import Text.ParserCombinators.Parsec--import Text.XML.HXT.DOM.Unicode--import Text.XML.HXT.RelaxNG.Unicode.Blocks-import Text.XML.HXT.RelaxNG.Unicode.CharProps-import Text.XML.HXT.RelaxNG.XmlSchema.Regex---- --------------------------------------------------------------parseRegex :: String -> Either String Regex-parseRegex-    = either (Left . show) Right-      .-      parse ( do-              r <- regExp-              eof-              return r-            ) ""---- --------------------------------------------------------------regExp  :: Parser Regex-regExp-    = do-      r1 <- branch-      rs <- many branch1-      return (foldr1 mkAlt $ r1:rs)-    where-    branch1-        = do-          _ <- char '|'-          branch--branch  :: Parser Regex-branch-    = do-      rs <- many piece-      return $ foldr mkSeq mkUnit rs--piece   :: Parser Regex-piece-    = do-      r <- atom-      quantifier r--quantifier      :: Regex -> Parser Regex-quantifier r-    = ( do-        _ <- char '?'-        return $ mkOpt r )-      <|>-      ( do-        _ <- char '*'-        return $ mkStar r )-      <|>-      ( do-        _ <- char '+'-        return $ mkRep 1 r )-      <|>-      ( do-        _ <- char '{'-        res <- quantity r-        _ <- char '}'-        return res-      )-      <|>-      ( return r )--quantity        :: Regex -> Parser Regex-quantity r-    = do-      lb <- many1 digit-      quantityRest r (read lb)--quantityRest    :: Regex -> Int -> Parser Regex-quantityRest r lb-    = ( do-        _ <- char ','-        ub <- many digit-        return ( if null ub-                 then mkRep lb r-                 else mkRng lb (read ub) r-               )-      )-      <|>-      ( return $ mkRng lb lb r)--atom    :: Parser Regex-atom-    = char1-      <|>-      charClass-      <|>-      between (char '(') (char ')') regExp--char1   :: Parser Regex-char1-    = do-      c <- satisfy $ (`notElem` ".\\?*+{}()|[]")-      return $ mkSym1 c--charClass       :: Parser Regex-charClass-    = charClassEsc-      <|>-      charClassExpr-      <|>-      wildCardEsc--charClassEsc    :: Parser Regex-charClassEsc-    = do-      _ <- char '\\'-      ( singleCharEsc-        <|>-        multiCharEsc-        <|>-        catEsc-        <|>-        complEsc )--singleCharEsc   :: Parser Regex-singleCharEsc-    = do-      c <- singleCharEsc'-      return $ mkSym1 c--singleCharEsc'  :: Parser Char-singleCharEsc'-    = do-      c <- satisfy (`elem` "nrt\\|.?*+(){}-[]^")-      return $ maybe c id . lookup c . zip "ntr" $ "\n\r\t"--multiCharEsc    :: Parser Regex-multiCharEsc-    = do-      c <- satisfy (`elem` es)-      return $ mkSym . fromJust . lookup c $ pm-    where-    es = map fst pm-    pm = [ ('s',       isXmlSpaceChar           )-         , ('S', not . isXmlSpaceChar           )-         , ('i',       isXmlNameStartChar       )-         , ('I', not . isXmlNameStartChar       )-         , ('c',       isXmlNameChar            )-         , ('C', not . isXmlNameChar            )-         , ('d',       isDigit                  )-         , ('D', not . isDigit                  )-         , ('w', not . isNotWord                )-         , ('W',       isNotWord                )-         ]-    isDigit   = ('0' <=) <&&> (<= '9')-    isNotWord = isUnicodeP <||>-                isUnicodeZ <||>-                isUnicodeC--catEsc  :: Parser Regex-catEsc-    = do-      _ <- char 'p'-      s <- between (char '{') (char '}') charProp-      return $ mkSym s--charProp        :: Parser (Char -> Bool)-charProp-    = isCategory-      <|>-      isBlock--isBlock         :: Parser (Char -> Bool)-isBlock-    = do-      _ <- string "Is"-      name <- many1 (satisfy legalChar)-      let b = lookup name codeBlocks-      if isJust b-         then return $ let-                       (lb, ub) = fromJust b-                       in-                       (lb <=) <&&> (<= ub)-         else fail   $ "unknown Unicode code block " ++ show name-    where-    legalChar c  = 'A' <= c && c <= 'Z' ||-                   'a' <= c && c <= 'z' ||-                   '0' <= c && c <= '9' ||-                   '-' == c--isCategory      :: Parser (Char -> Bool)-isCategory-    = do-      pr <- isCategory'-      return $ fromJust (lookup pr categories)--categories      :: [(String, Char -> Bool)]-categories-    = [ ("C",  isUnicodeC )-      , ("Cc", isUnicodeCc)-      , ("Cf", isUnicodeCf)-      , ("Co", isUnicodeCo)-      , ("Cs", isUnicodeCs)-      , ("L",  isUnicodeL )-      , ("Ll", isUnicodeLl)-      , ("Lm", isUnicodeLm)-      , ("Lo", isUnicodeLo)-      , ("Lt", isUnicodeLt)-      , ("Lu", isUnicodeLu)-      , ("M",  isUnicodeM )-      , ("Mc", isUnicodeMc)-      , ("Me", isUnicodeMe)-      , ("Mn", isUnicodeMn)-      , ("N",  isUnicodeN )-      , ("Nd", isUnicodeNd)-      , ("Nl", isUnicodeNl)-      , ("No", isUnicodeNo)-      , ("P",  isUnicodeP )-      , ("Pc", isUnicodePc)-      , ("Pd", isUnicodePd)-      , ("Pe", isUnicodePe)-      , ("Pf", isUnicodePf)-      , ("Pi", isUnicodePi)-      , ("Po", isUnicodePo)-      , ("Ps", isUnicodePs)-      , ("S",  isUnicodeS )-      , ("Sc", isUnicodeSc)-      , ("Sk", isUnicodeSk)-      , ("Sm", isUnicodeSm)-      , ("So", isUnicodeSo)-      , ("Z",  isUnicodeZ )-      , ("Zl", isUnicodeZl)-      , ("Zp", isUnicodeZp)-      , ("Zs", isUnicodeZs)-      ]--isCategory'     :: Parser String-isCategory'-    = ( foldr1 (<|>) . map (uncurry prop) $-        [ ('L', "ultmo")-        , ('M', "nce")-        , ('N', "dlo")-        , ('P', "cdseifo")-        , ('Z', "slp")-        , ('S', "mcko")-        , ('C', "cfon")-        ]-      ) <?> "illegal Unicode character property"-    where-    prop c1 cs2-        = do-          _ <- char c1-          s2 <- option ""-                ( do-                  c2 <- satisfy (`elem` cs2)-                  return [c2] )-          return $ c1:s2--complEsc        :: Parser Regex-complEsc-    = do-      _ <- char 'P'-      s <- between (char '{') (char '}') charProp-      return $ mkSym (not . s)--charClassExpr   :: Parser Regex-charClassExpr-    = between (char '[') (char ']') charGroup--charGroup       :: Parser Regex-charGroup-    = do-      r <- ( negCharGroup       -- a ^ at beginning denotes negation, not start of posCharGroup-             <|>-             posCharGroup-           )-      s <- option (mkZero "")   -- charClassSub-           ( do-             _ <- char '-'-             charClassExpr-           )-      return $ mkDif r s--posCharGroup    :: Parser Regex-posCharGroup-    = do-      rs <- many1 (charRange <|> charClassEsc)-      return $ foldr1 mkAlt rs--charRange       :: Parser Regex-charRange-    = try seRange-      <|>-      xmlCharIncDash--seRange :: Parser Regex-seRange-    = do-      c1 <- charOrEsc'-      _ <- char '-'-      c2 <- charOrEsc'-      return $ mkSymRng c1 c2--charOrEsc'      :: Parser Char-charOrEsc'-    = satisfy (`notElem` "\\-[]")-      <|>-      singleCharEsc'--xmlCharIncDash  :: Parser Regex-xmlCharIncDash-    = do-      c <- satisfy (`notElem` "\\[]")-      return $ mkSym1 c--negCharGroup    :: Parser Regex-negCharGroup-    = do-      _ <- char '^'-      r <- posCharGroup-      return $ mkCompl r--wildCardEsc     :: Parser Regex-wildCardEsc-    = do-      _ <- char '.'-      return $ mkSym (`notElem` "\n\r")----- ------------------------------------------------------------
src/Text/XML/HXT/Version.hs view
@@ -1,4 +1,4 @@ module Text.XML.HXT.Version where hxt_version :: String-hxt_version = "8.5.1"+hxt_version = "9.3.1.15"
+ src/Text/XML/HXT/XMLSchema/DataTypeLibW3CNames.hs view
@@ -0,0 +1,151 @@+-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.XMLSchema.DataTypeLibW3C+   Copyright  : Copyright (C) 2005-2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id$++   Datatype library for the W3C XML schema datatypes++-}++-- ------------------------------------------------------------++module Text.XML.HXT.XMLSchema.DataTypeLibW3CNames+where++-- ------------------------------------------------------------++-- | Namespace of the W3C XML schema datatype library++w3cNS   :: String+w3cNS   = "http://www.w3.org/2001/XMLSchema-datatypes"++xsd_string+ , xsd_normalizedString+ , xsd_token+ , xsd_language+ , xsd_NMTOKEN+ , xsd_NMTOKENS+ , xsd_Name+ , xsd_NCName+ , xsd_ID+ , xsd_IDREF+ , xsd_IDREFS+ , xsd_ENTITY+ , xsd_ENTITIES+ , xsd_anyURI+ , xsd_QName+ , xsd_NOTATION+ , xsd_hexBinary+ , xsd_base64Binary+ , xsd_decimal+ , xsd_integer+ , xsd_nonPositiveInteger+ , xsd_negativeInteger+ , xsd_nonNegativeInteger+ , xsd_positiveInteger+ , xsd_long+ , xsd_int+ , xsd_short+ , xsd_byte+ , xsd_unsignedLong+ , xsd_unsignedInt+ , xsd_unsignedShort+ , xsd_unsignedByte++ , xsd_boolean+ , xsd_float+ , xsd_double+ , xsd_time+ , xsd_duration+ , xsd_date+ , xsd_dateTime+ , xsd_gDay+ , xsd_gMonth+ , xsd_gMonthDay+ , xsd_gYear+ , xsd_gYearMonth :: String++xsd_string              = "string"+xsd_normalizedString    = "normalizedString"+xsd_token               = "token"+xsd_language            = "language"+xsd_NMTOKEN             = "NMTOKEN"+xsd_NMTOKENS            = "NMTOKENS"+xsd_Name                = "Name"+xsd_NCName              = "NCName"+xsd_ID                  = "ID"+xsd_IDREF               = "IDREF"+xsd_IDREFS              = "IDREFS"+xsd_ENTITY              = "ENTITY"+xsd_ENTITIES            = "ENTITIES"+xsd_anyURI              = "anyURI"+xsd_QName               = "QName"+xsd_NOTATION            = "NOTATION"+xsd_hexBinary           = "hexBinary"+xsd_base64Binary        = "base64Binary"+xsd_decimal             = "decimal"+xsd_integer             = "integer"+xsd_nonPositiveInteger  = "nonPositiveInteger"+xsd_negativeInteger     = "negativeInteger"+xsd_nonNegativeInteger  = "nonNegativeInteger"+xsd_positiveInteger     = "positiveInteger"+xsd_long                = "long"+xsd_int                 = "int"+xsd_short               = "short"+xsd_byte                = "byte"+xsd_unsignedLong        = "unsignedLong"+xsd_unsignedInt         = "unsignedInt"+xsd_unsignedShort       = "unsignedShort"+xsd_unsignedByte        = "unsignedByte"++xsd_boolean             = "boolean"+xsd_float               = "float"+xsd_double              = "double"+xsd_time                = "time"+xsd_duration            = "duration"+xsd_date                = "date"+xsd_dateTime            = "dateTime"+xsd_gDay                = "gDay"+xsd_gMonth              = "gMonth"+xsd_gMonthDay           = "gMonthDay"+xsd_gYear               = "gYear"+xsd_gYearMonth          = "gYearMonth"++xsd_length+ , xsd_maxLength+ , xsd_minLength+ , xsd_maxExclusive+ , xsd_minExclusive+ , xsd_maxInclusive+ , xsd_minInclusive+ , xsd_totalDigits+ , xsd_fractionDigits+ , xsd_pattern+ , xsd_enumeration+ , xsd_whiteSpace :: String++xsd_length              = "length"+xsd_maxLength           = "maxLength"+xsd_minLength           = "minLength"++xsd_maxExclusive        = "maxExclusive"+xsd_minExclusive        = "minExclusive"+xsd_maxInclusive        = "maxInclusive"+xsd_minInclusive        = "minInclusive"++xsd_totalDigits         = "totalDigits"+xsd_fractionDigits      = "fractionDigits"++xsd_pattern             = "pattern"+xsd_enumeration         = "enumeration"++xsd_whiteSpace          = "whiteSpace"++-- ----------------------------------------