hxt 8.5.4 → 9.0.0

raw patch · 104 files changed

+4225/−25187 lines, 104 filesdep +binarydep +hxt-charpropertiesdep +hxt-regex-xmlschemadep −curldep −tagsoupPVP ok

version bump matches the API change (PVP)

Dependencies added: binary, hxt-charproperties, hxt-regex-xmlschema, hxt-unicode

Dependencies removed: curl, tagsoup

API changes (from Hackage documentation)

Files

• examples/arrows/AGentleIntroductionToHXT/PicklerExample/Baseball.hs +6/−6
• examples/arrows/AGentleIntroductionToHXT/SimpleExamples.hs +35/−27
• examples/arrows/HelloWorld/HelloWorld.hs +4/−4
• examples/arrows/HelloWorld/Mini.hs +5/−3
• examples/arrows/RegexXMLSchema/Makefile +0/−128
• examples/arrows/RegexXMLSchema/REtest.hs +0/−170
• examples/arrows/absurls/AbsURIs.hs +44/−39
• examples/arrows/absurls/ProcessDocument.hs +3/−4
• examples/arrows/dtd2hxt/DTDtoHXT.hs +201/−201
• examples/arrows/hparser/HXmlParser.hs +73/−64
• examples/arrows/hparser/Makefile +5/−44
• examples/arrows/hrelaxng/.ghci +0/−3
• examples/arrows/hrelaxng/HRelaxNG.hs +0/−170
• examples/arrows/hrelaxng/Makefile +0/−77
• examples/arrows/hrelaxng/invalid1.xml +0/−1
• examples/arrows/hrelaxng/invalid2.rng +0/−13
• examples/arrows/hrelaxng/invalid3.rng +0/−19
• examples/arrows/hrelaxng/valid1.rng +0/−7
• examples/arrows/hrelaxng/valid1.xml +0/−1
• examples/arrows/hrelaxng/valid2.rng +0/−27
• examples/arrows/hrelaxng/valid2.xml +0/−1
• examples/arrows/performance/GenDoc.hs +10/−9
• examples/arrows/pickle/PickleTest.hs +12/−12
• hxt.cabal +25/−48
• src/Control/Arrow/ArrowExc.hs +38/−0
• src/Control/Arrow/ArrowIO.hs +1/−2
• src/Control/Arrow/ArrowIf.hs +3/−5
• src/Control/Arrow/ArrowList.hs +7/−8
• src/Control/Arrow/ArrowState.hs +1/−1
• src/Control/Arrow/ArrowTree.hs +6/−8
• src/Control/Arrow/IOListArrow.hs +21/−7
• src/Control/Arrow/IOStateListArrow.hs +24/−10
• src/Control/Arrow/ListArrows.hs +4/−2
• src/Data/AssocList.hs +17/−5
• src/Data/Atom.hs +2/−3
• src/Data/Char/UTF8.hs +0/−363
• src/Data/Function/Selector.hs +139/−0
• src/Data/Tree/NTree/TypeDefs.hs +8/−0
• src/Text/XML/HXT/Arrow.hs +0/−64
• src/Text/XML/HXT/Arrow/Binary.hs +69/−0
• src/Text/XML/HXT/Arrow/DTDProcessing.hs +2/−3
• src/Text/XML/HXT/Arrow/DocumentInput.hs +32/−71
• src/Text/XML/HXT/Arrow/DocumentOutput.hs +43/−41
• src/Text/XML/HXT/Arrow/Edit.hs +3/−2
• src/Text/XML/HXT/Arrow/GeneralEntitySubstitution.hs +2/−2
• src/Text/XML/HXT/Arrow/Namespace.hs +21/−9
• src/Text/XML/HXT/Arrow/ParserInterface.hs +15/−25
• src/Text/XML/HXT/Arrow/Pickle.hs +47/−23
• src/Text/XML/HXT/Arrow/Pickle/DTD.hs +1/−1
• src/Text/XML/HXT/Arrow/Pickle/Schema.hs +1/−1
• src/Text/XML/HXT/Arrow/Pickle/Xml.hs +245/−3
• src/Text/XML/HXT/Arrow/ProcessDocument.hs +68/−52
• src/Text/XML/HXT/Arrow/ReadDocument.hs +184/−208
• src/Text/XML/HXT/Arrow/WriteDocument.hs +115/−100
• src/Text/XML/HXT/Arrow/XmlArrow.hs +1/−2
• src/Text/XML/HXT/Arrow/XmlIOStateArrow.hs +0/−989
• src/Text/XML/HXT/Arrow/XmlOptions.hs +242/−0
• src/Text/XML/HXT/Arrow/XmlRegex.hs +11/−3
• src/Text/XML/HXT/Arrow/XmlState.hs +157/−0
• src/Text/XML/HXT/Arrow/XmlState/ErrorHandling.hs +252/−0
• src/Text/XML/HXT/Arrow/XmlState/MimeTypeTable.hs +60/−0
• src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs +218/−0
• src/Text/XML/HXT/Arrow/XmlState/SystemConfig.hs +234/−0
• src/Text/XML/HXT/Arrow/XmlState/TraceHandling.hs +150/−0
• src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs +809/−0
• src/Text/XML/HXT/Arrow/XmlState/URIHandling.hs +239/−0
• src/Text/XML/HXT/Core.hs +69/−0
• src/Text/XML/HXT/DOM/Interface.hs +2/−3
• src/Text/XML/HXT/DOM/IsoLatinTables.hs +0/−719
• src/Text/XML/HXT/DOM/QualifiedName.hs +15/−1
• src/Text/XML/HXT/DOM/TypeDefs.hs +52/−0
• src/Text/XML/HXT/DOM/UTF8Decoding.hs +0/−52
• src/Text/XML/HXT/DOM/Unicode.hs +0/−1105
• src/Text/XML/HXT/DOM/XmlKeywords.hs +1/−158
• src/Text/XML/HXT/DOM/XmlOptions.hs +0/−188
• src/Text/XML/HXT/DTDValidation/DocTransformation.hs +11/−13
• src/Text/XML/HXT/IO/GetHTTPLibCurl.hs +0/−310
• src/Text/XML/HXT/Parser/TagSoup.hs +0/−495
• src/Text/XML/HXT/Parser/XmlCharParser.hs +26/−5
• src/Text/XML/HXT/Parser/XmlDTDTokenParser.hs +0/−1
• src/Text/XML/HXT/Parser/XmlParsec.hs +0/−1
• src/Text/XML/HXT/Parser/XmlTokenParser.hs +10/−11
• src/Text/XML/HXT/RelaxNG.hs +0/−24
• src/Text/XML/HXT/RelaxNG/BasicArrows.hs +0/−326
• src/Text/XML/HXT/RelaxNG/CreatePattern.hs +0/−349
• src/Text/XML/HXT/RelaxNG/DataTypeLibMysql.hs +0/−169
• src/Text/XML/HXT/RelaxNG/DataTypeLibUtils.hs +0/−407
• src/Text/XML/HXT/RelaxNG/DataTypeLibraries.hs +0/−140
• src/Text/XML/HXT/RelaxNG/DataTypes.hs +0/−296
• src/Text/XML/HXT/RelaxNG/PatternFunctions.hs +0/−108
• src/Text/XML/HXT/RelaxNG/PatternToString.hs +0/−360
• src/Text/XML/HXT/RelaxNG/Schema.hs +0/−3921
• src/Text/XML/HXT/RelaxNG/SchemaGrammar.hs +0/−3831
• src/Text/XML/HXT/RelaxNG/Simplification.hs +0/−2321
• src/Text/XML/HXT/RelaxNG/Unicode/Blocks.hs +0/−229
• src/Text/XML/HXT/RelaxNG/Unicode/CharProps.hs +0/−3945
• src/Text/XML/HXT/RelaxNG/Utils.hs +0/−161
• src/Text/XML/HXT/RelaxNG/Validation.hs +0/−617
• src/Text/XML/HXT/RelaxNG/Validator.hs +0/−308
• src/Text/XML/HXT/RelaxNG/XmlSchema/DataTypeLibW3C.hs +0/−610
• src/Text/XML/HXT/RelaxNG/XmlSchema/Regex.hs +0/−317
• src/Text/XML/HXT/RelaxNG/XmlSchema/RegexMatch.hs +0/−241
• src/Text/XML/HXT/RelaxNG/XmlSchema/RegexParser.hs +0/−354
• src/Text/XML/HXT/XMLSchema/DataTypeLibW3CNames.hs +124/−0

@@ -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@@ -115,15 +115,15 @@ 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)+      runX ( xunpickleDocument xpSeason [ withValidate no+					, withTrace 1+					, withRemoveWS yes+					, withPreserveComment no 					] "simple2.xml" 	     >>> 	     processSeason 	     >>>-	     xpickleDocument xpSeason [ (a_indent, v_1)+	     xpickleDocument xpSeason [ withIndent yes 				      ] "new-simple2.xml" 	   )       return ()

@@ -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@@ -35,45 +34,54 @@ 	 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

@@ -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

@@ -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 () 

@@ -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.*-

@@ -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---- ----------------------------------------

@@ -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 ()  -- ------------------------------------------------------------

@@ -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 

@@ -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 ()  -- ------------------------------------------------------------

@@ -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,109 @@ -- 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 "f"      ["output-file"] (ReqArg  (withSysAttr "output-file") "FILE") "output file for resulting document (default: stdout)"+      , 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 ()  -- ------------------------------------------------------------

@@ -29,7 +29,7 @@ 		@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 EXi		= ./invalid.xml@@ -74,7 +74,7 @@ 		$(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  test2		:@@ -84,14 +84,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,51 +107,12 @@ 		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/-		@echo- dist		: 		[ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR) 		cp $(EX) Makefile $(prog).hs $(DIST_DIR)@@ -159,4 +120,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

@@ -1,3 +0,0 @@-:set -i../../../src-:set -Wall -fglasgow-exts-:load HRelaxNG

@@ -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--}

@@ -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 ------------------------------------------------------------

@@ -1,1 +0,0 @@-<bar/>

@@ -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>

@@ -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>

@@ -1,7 +0,0 @@-<grammar xmlns="http://relaxng.org/ns/structure/1.0">-  <start>-    <element name="foo">-      <empty/>-    </element>-  </start>-</grammar>

@@ -1,1 +0,0 @@-<foo/>

@@ -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>

@@ -1,1 +0,0 @@-<foo string2-4="xxx" id="iooo"/>

@@ -5,9 +5,10 @@ module Main where -import Text.XML.HXT.Arrow+import Text.XML.HXT.Core+import Text.XML.HXT.TagSoup -import Text.XML.HXT.DOM.Unicode+import Data.String.Unicode     ( unicodeToXmlEntity     ) @@ -154,13 +155,13 @@  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)+    = readDocument [ withTagSoup+		   , withParseHTML no+		   , withRemoveWS yes+		   , withInputEncoding isoLatin1+		   , withWarnings no+		   , withTrace 1+		   , withStrictInput no 		   ] src       >>>       processChildren (isElem `guards` this)

@@ -5,7 +5,7 @@ import System.Exit import Test.HUnit -import Text.XML.HXT.Arrow+import Text.XML.HXT.Core  -- ------------------------------------------------------------ --@@ -232,7 +232,7 @@ 		 >>> 		 writeDocumentToString []			-- XmlTree => String 		 >>>-		 readFromString [(a_validate, v_0)]		-- String => XmlTree+		 readFromString [ withValidate no ]		-- String => XmlTree 		 >>> 		 arrL (maybeToList . unpickleDoc xpProgram)	-- XmlTree => Program 	       )@@ -245,11 +245,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 +263,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 +279,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" 	       ) 

@@ -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.0.0+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,8 +10,11 @@                 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+                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. License:        OtherLicense License-file:   LICENSE Author:         Uwe Schmidt, Martin Schmidt, Torben Kuseler@@ -56,25 +59,14 @@  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  library  exposed-modules:+  Control.Arrow.ArrowExc,   Control.Arrow.ArrowIO,   Control.Arrow.ArrowIf,   Control.Arrow.ArrowList,@@ -88,10 +80,10 @@   Control.Arrow.StateListArrow,   Data.AssocList,   Data.Atom,-  Data.Char.UTF8,+  Data.Function.Selector,   Data.Tree.Class,   Data.Tree.NTree.TypeDefs,-  Text.XML.HXT.Arrow,+  Text.XML.HXT.Arrow.Binary,   Text.XML.HXT.Arrow.DTDProcessing,   Text.XML.HXT.Arrow.DocumentInput,   Text.XML.HXT.Arrow.DocumentOutput,@@ -107,22 +99,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 +130,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,27 +139,7 @@   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   hs-source-dirs: src@@ -183,5 +158,7 @@                 network    >= 2.1 && < 3,                 deepseq    >= 1.1 && < 2,                 bytestring >= 0.9 && < 1,-                tagsoup    >= 0.10 && < 0.11,-                curl       >= 1.3 && < 2+                binary     >= 0.5 && < 1,+                hxt-charproperties  >= 9 && < 10,+                hxt-unicode         >= 9 && < 10,+                hxt-regex-xmlschema >= 9 && < 10

@@ -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 )+++-- ------------------------------------------------------------

@@ -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  -} 

@@ -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. -}  -- ------------------------------------------------------------

@@ -8,17 +8,16 @@    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 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.  -} 

@@ -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 

@@ -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. -}  -- ------------------------------------------------------------@@ -181,7 +179,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

@@ -23,14 +23,18 @@  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.DeepSeq+import Control.DeepSeq+import Control.Exception      		( SomeException+					, try+					)  -- ------------------------------------------------------------ @@ -116,6 +120,16 @@     arrIO cmd           = IOLA $ \x -> do                                        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

@@ -24,19 +24,23 @@     ) where -import           Prelude hiding (id, (.))+import Prelude hiding (id, (.)) -import           Control.Category+import Control.Category -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.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.ArrowState -import           Control.DeepSeq+import Control.DeepSeq+import Control.Exception                ( SomeException+                                        , try+                                        )  -- ------------------------------------------------------------ @@ -144,6 +148,16 @@     arrIO cmd           = IOSLA $ \ s x -> do                                            res <- cmd x                                            return (s, [res])++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

@@ -17,12 +17,13 @@  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.ArrowNF     , module Control.Arrow.ArrowState     , module Control.Arrow.ArrowTree-    , module Control.Arrow.ArrowIO      , module Control.Arrow.ListArrow            -- arrow types     , module Control.Arrow.StateListArrow@@ -32,6 +33,7 @@ where  import Control.Arrow                            -- arrow classes+import Control.Arrow.ArrowExc import Control.Arrow.ArrowList import Control.Arrow.ArrowIf import Control.Arrow.ArrowNF

@@ -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

@@ -65,12 +65,11 @@ import           Data.ByteString.Internal       ( toForeignPtr, c2w, w2c ) import           Data.ByteString                ( ByteString, pack, unpack ) import qualified Data.Map                       as M+import           Data.String.UTF8Decoding       ( decodeUtf8 )+import           Data.String.Unicode            ( unicodeToUtf8 ) import           Data.Typeable  import           System.IO.Unsafe               ( unsafePerformIO )--import           Text.XML.HXT.DOM.Unicode       ( unicodeToUtf8 )-import           Text.XML.HXT.DOM.UTF8Decoding  ( decodeUtf8 )  -- ------------------------------------------------------------ 

@@ -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

@@ -0,0 +1,139 @@+{-# 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+                                    }++-- ------------------------------------------------------------+-- TODO: delete theses+{-+subS                    :: Selector b c -> Selector a b -> Selector a c+subS = (.)++pairS                   :: Selector s a -> Selector s b -> Selector s (a, b)+pairS = (.&&&.)++chgS                    :: Selector s a -> (a -> a) -> (s -> s)+chgS = update++putS                    :: Selector s a -> a -> (s -> s)+putS = setS++-}+-- ------------------------------------------------------------+{-+type Selector s a       = (s -> a, a -> s -> s)++subS                    :: Selector b c -> Selector a b -> Selector a c+subS (g2, s2) (g1, s1)  = ( g2 . g1+                          , s1s2+                          )+                          where+                          s1s2 x s = s'+                              where+                              x1  = g1 s+                              x1' = s2 x x1+                              s'  = s1 x1' s++pairS                   :: Selector s a -> Selector s b -> Selector s (a, b)+pairS (g1, s1) (g2, s2) = ( g1 &&& g2+                          , \ (x, y) -> s2 y . s1 x+                          )++chgS                    :: Selector s a -> (a -> a) -> (s -> s)+chgS (g, s) f x         = s (f (g x)) x++getS                    :: Selector s a -> s -> a+getS                    = fst                           -- getS (g, _s) x = g x++putS                    :: Selector s a -> a -> (s -> s)+putS s v                = chgS s (const v)++idS                     :: Selector s s+idS                     = (id, const)+-}+-- ------------------------------------------------------------++-- | 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)+						    }++-- ------------------------------------------------------------+

@@ -27,6 +27,7 @@  import Control.DeepSeq +import Data.Binary import Data.Tree.Class import Data.Typeable @@ -50,6 +51,13 @@  instance (NFData a) => NFData (NTree a) where     rnf (NTree n cl)                    = rnf n `seq` rnf cl++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 

@@ -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---- ------------------------------------------------------------

@@ -0,0 +1,69 @@+-- ------------------------------------------------------------++{- |+   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.ArrowList+import           Control.Arrow.ArrowIO++import           Control.DeepSeq++import           Data.Binary+import qualified Data.ByteString.Lazy   as B++import           Text.XML.HXT.Arrow.XmlState.ErrorHandling+import           Text.XML.HXT.Arrow.XmlState.TypeDefs++-- ------------------------------------------------------------++readBinaryValue         :: (NFData a, Binary a) => String -> IOStateArrow s b a+readBinaryValue file    = flip decodeBinaryValue file $< getSysVar 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         :: (NFData a, Binary a) => DeCompressionFct -> String -> IOStateArrow s b a+decodeBinaryValue decompress file+                          = arrIO0 ( do+                                     r <- dec+                                     rnf r `seq` return r+                                   )+                            `catchA`+                            issueExc "readBinaryValue"+    where+    dec                 = B.readFile file >>= return . decode . decompress++-- | 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++-- ------------------------------------------------------------

@@ -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,7 +126,7 @@       processRoot           = ( traceMsg 1 ("processDTD: process parameter entities")               >>>-              setParamString a_standalone ""+              setSysAttrString a_standalone ""               >>>               ( addDocType                 `whenNot`

@@ -8,7 +8,6 @@    Maintainer : Uwe Schmidt (uwe@fh-wedel.de)    Stability  : experimental    Portability: portable-   Version    : $Id$     State arrows for document input -}@@ -22,36 +21,37 @@     , 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 System.FilePath                          ( takeExtension )+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                 ( getDecodingFct+import           Data.List                      ( isPrefixOf )+import           Data.String.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 Text.XML.HXT.DOM.Interface+import           Text.XML.HXT.DOM.Interface -import Text.XML.HXT.Arrow.ParserInterface       ( parseXmlDocEncodingSpec+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.XmlArrow+import           Text.XML.HXT.Arrow.XmlState+import           Text.XML.HXT.Arrow.XmlState.TypeDefs  -- ---------------------------------------------------------- @@ -101,10 +101,7 @@  getFileContents         :: IOStateArrow s XmlTree XmlTree getFileContents-    = applyA ( ( ( getAttrValue  a_strict_input-                   >>>-                   arr isTrueValue-                 )+    = applyA ( ( getSysVar theStrictInput                  &&&                  ( getAttrValue transferURI                    >>>@@ -116,7 +113,7 @@                >>>                arrIO (uncurry FILE.getCont)                >>>-               ( arr (uncurry addError) -- io error occured+               ( arr (uncurry addInputError) -- io error occured                  |||                  arr addTxtContent      -- content read                )@@ -126,20 +123,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                )              ) -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)@@ -150,7 +145,7 @@ addMimeType     = addMime $< ( getAttrValue transferURI                    >>>-                   ( uriToMime $< getSysParam xio_mimeTypes )+                   ( uriToMime $< getMimeTypeTable )                  )     where     addMime mt@@ -168,41 +163,7 @@  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@@ -349,7 +310,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 +319,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@@ -379,7 +340,7 @@         found df             = traceMsg 2 ("decodeDocument: encoding is " ++ show enc)               >>>-              ( decodeText df $< getAttrValue a_ignore_encoding_errors )+              ( decodeText df $< getSysVar theEncodingErrors )               >>>               addAttr transferEncoding enc @@ -388,7 +349,7 @@               >>>               setDocumentStatusFromSystemState "decoding document" -        decodeText df ignoreErrs+        decodeText df withEncErrors             = processChildren               ( getText                                                 -- get the document content                 >>> arr df                                              -- decode the text, result is (string, [errMsg])@@ -396,9 +357,8 @@                         ^>> mkText                       )                       <+>-                      ( 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 +367,7 @@                           >>>                           none                                          -- neccessary for type match with <+>                         )+                        else none                       )                     )               )

@@ -31,12 +31,11 @@ import Control.Arrow.ArrowIO import Control.Arrow.ListArrow -import Text.XML.HXT.DOM.Unicode                 ( getOutputEncodingFct )+import Data.String.Unicode                      ( getOutputEncodingFct )+ import Text.XML.HXT.DOM.Interface  import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlIOStateArrow- import Text.XML.HXT.Arrow.Edit                  ( addHeadlineToXmlDoc                                                 , addXmlPi                                                 , addXmlPiEncoding@@ -44,6 +43,8 @@                                                 , numberLinesInXmlDoc                                                 , treeRepOfXmlDoc                                                 )+import Text.XML.HXT.Arrow.XmlState+import Text.XML.HXT.Arrow.XmlState.TypeDefs  import System.IO                                ( Handle                                                 , IOMode(..)@@ -54,7 +55,6 @@                                                 , hClose                                                 , stdout                                                 )- import System.IO.Error                          ( try )  -- ------------------------------------------------------------@@ -63,45 +63,47 @@  putXmlDocument  :: Bool -> String -> IOStateArrow s XmlTree XmlTree putXmlDocument textMode dst-    = perform ( xshow getChildren+    = perform putDoc+      where+      putDoc+          = xshow getChildren+            >>>+            arrIO (\ s -> try ( hPutDocument (\h -> hPutStrLn h s)))+            >>>+            ( ( 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)+                >>>+                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 +137,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)) 

@@ -66,10 +66,11 @@ import           Control.Arrow.ArrowTree import           Control.Arrow.ListArrow +import           Data.Char.Properties.XMLCharProps      ( isXmlSpaceChar )+ import           Text.XML.HXT.Arrow.XmlArrow 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 )@@ -110,7 +111,7 @@       canonicalize1Node           = (deep isPi `when` isDTD)            -- remove DTD parts, except PIs             >>>-            (none `when` toBeRemoved)           -- remove unintersting nodes+            (none `when` toBeRemoved)           -- remove uninteresting nodes             >>>             ( processAttrl ( processChildren transfCharRef                              >>>

@@ -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,8 +25,9 @@ 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

@@ -109,14 +109,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 +124,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 +160,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

@@ -1,8 +1,19 @@--- |--- 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@@ -19,11 +30,9 @@ 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  -- ------------------------------------------------------------ @@ -68,25 +77,6 @@  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  -- ------------------------------------------------------------ 

@@ -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@@ -50,6 +49,7 @@       -- from Text.XML.HXT.Arrow.Pickle.Xml     , pickleDoc     , unpickleDoc+    , showPickled      , PU(..)     , XmlPickler@@ -57,9 +57,29 @@     , xp4Tuple     , xp5Tuple     , xp6Tuple+    , xp7Tuple+    , xp8Tuple+    , xp9Tuple+    , xp10Tuple+    , xp11Tuple+    , xp12Tuple+    , xp13Tuple+    , xp14Tuple+    , xp15Tuple+    , xp16Tuple+    , xp17Tuple+    , xp18Tuple+    , xp19Tuple+    , xp20Tuple+    , xp21Tuple+    , xp22Tuple+    , xp23Tuple+    , xp24Tuple+     , xpAddFixedAttr     , xpAlt     , xpAttr+    , xpTextAttr     , xpAttrFixed     , xpAttrImplied     , xpChoice@@ -102,10 +122,12 @@ 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 +145,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 +180,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 +192,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,7 +230,7 @@                                   >>>                                   writeDocumentToString []                                   >>>-                                  readFromString [(a_validate, v_1)]+                                  readFromString [withValidate True]                                   >>>                                   ( xunpickleVal xp                                     `orElse`@@ -240,5 +266,3 @@ thePicklerDTD           = dtdDescrToXml . dtdDescr . theSchema  -- --------------------------------------------------------------

@@ -26,7 +26,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  -- ------------------------------------------------------------ 

@@ -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 )

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+ -- ------------------------------------------------------------  {- |@@ -38,6 +40,8 @@ module Text.XML.HXT.Arrow.Pickle.Xml where +import           Control.Arrow.ListArrows+ import           Data.Maybe import           Data.Map (Map) import qualified Data.Map as M@@ -45,11 +49,12 @@ 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.Edit          (xshowEscapeXml) import           Text.XML.HXT.Arrow.Pickle.Schema import           Text.XML.HXT.Arrow.ReadDocument  (xread)-import           Text.XML.HXT.Arrow.Edit          (xshowEscapeXml)+import           Text.XML.HXT.Arrow.WriteDocument (writeDocumentToString)+import           Text.XML.HXT.Arrow.XmlArrow+import           Text.XML.HXT.Arrow.XmlState  -- ------------------------------------------------------------ @@ -119,6 +124,13 @@  -- ------------------------------------------------------------ +-- | 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@@ -220,6 +232,8 @@ 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@@ -268,6 +282,191 @@     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:@@ -623,6 +822,10 @@ xpAttr          :: String -> PU a -> PU a xpAttr          = xpAttrQN . mkName +-- | 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)@@ -692,3 +895,42 @@     xpickle = xpOption xpickle  -- ------------------------------------------------------------++-- ------------------------------------------------------------+{-+-- | Extra library functions for HXT.+module Text.XML.HXT.Extras(+                     showPickled,+                     textAttr,+                     xp7Tuple,+                     xp8Tuple,+                     xp9Tuple,+                     xp10Tuple,+                     xp11Tuple,+                     xp12Tuple,+                     xp13Tuple,+                     xp14Tuple,+                     xp15Tuple,+                     xp16Tuple,+                     xp17Tuple,+                     xp18Tuple,+                     xp19Tuple,+                     xp20Tuple,+                     xp21Tuple,+                     xp22Tuple,+                     xp23Tuple,+                     xp24Tuple+                   ) where++import Text.XML.HXT.Arrow++-- | Pickles a value then writes the document to a string.+showPickled :: (XmlPickler a) => Attributes -> a -> String+showPickled a = concat . (pickleDoc xpickle >>> runLA (writeDocumentToString a))++-- | A text attribute.+textAttr :: String -> PU String+textAttr = flip xpAttr xpText+-}+-- ------------------------------------------------------------+

@@ -8,7 +8,6 @@    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 @@ -22,6 +21,7 @@     , parseHtmlDocument     , validateDocument     , propagateAndValidateNamespaces+    , andValidateNamespaces     , getDocumentContents     ) where@@ -30,40 +30,39 @@ import Control.Arrow.ArrowList import Control.Arrow.ArrowIf import Control.Arrow.ArrowTree+import Control.Arrow.ListArrow                  ( fromLA )  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.XmlState.TypeDefs -import Text.XML.HXT.Arrow.ParserInterface-    ( parseXmlDoc-    , parseHtmlDoc-    , parseHtmlTagSoup-    , substHtmlEntityRefs-    , validateDoc-    , transformDoc-    )+import Text.XML.HXT.Arrow.ParserInterface       ( parseXmlDoc+                                                , parseHtmlDoc+                                                , substHtmlEntityRefs+                                                ) -import Text.XML.HXT.Arrow.Edit-    ( transfAllCharRef-    )+import Text.XML.HXT.Arrow.Edit                  ( transfAllCharRef+                                                )  import Text.XML.HXT.Arrow.GeneralEntitySubstitution-    ( processGeneralEntities-    )+                                               ( processGeneralEntities+                                               ) -import Text.XML.HXT.Arrow.DTDProcessing-    ( processDTD-    )+import Text.XML.HXT.Arrow.DTDProcessing        ( processDTD+                                               ) -import Text.XML.HXT.Arrow.DocumentInput-    ( getXmlContents-    )+import Text.XML.HXT.Arrow.DocumentInput        ( getXmlContents+                                               ) -import Text.XML.HXT.Arrow.Namespace-    ( propagateNamespaces-    , validateNamespaces-    )+import Text.XML.HXT.Arrow.Namespace            ( propagateNamespaces+                                               , validateNamespaces+                                               )+import Text.XML.HXT.DTDValidation.Validation   ( validate+                                               , getDTDSubset+                                               , transform+                                               )  -- ------------------------------------------------------------ @@ -87,7 +86,7 @@ -}  parseXmlDocument        :: Bool -> IOStateArrow s XmlTree XmlTree-parseXmlDocument validate+parseXmlDocument validate'     = ( replaceChildren ( ( getAttrValue a_source                             &&&                             xshow getChildren@@ -106,7 +105,7 @@         >>>         transfAllCharRef         >>>-        ( if validate+        ( if validate'           then validateDocument           else this         )@@ -129,19 +128,14 @@  -} -parseHtmlDocument       :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IOStateArrow s XmlTree XmlTree-parseHtmlDocument withTagSoup withNamespaces warnings preserveCmt removeWhitespace asHtml+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 )         >>>-        removeWarnings+        ( removeWarnings $< getSysVar (theWarnings .&&&. theTagSoup )+        )         >>>         setDocumentStatusFromSystemState "parse HTML document"         >>>@@ -156,20 +150,24 @@       )       `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'+        | withTagSoup'  = withoutUserState $< getSysVar theTagSoupParser -- withoutUserState parseHtmlTagSoup          | otherwise     = traceMsg 1 ("parse document with parsec HTML parser")                           >>>-                          parseHtmlDoc                          -- run parser+                          replaceChildren+                          ( ( getAttrValue a_source             -- get source name+                              &&&+                              xshow getChildren+                            )                                   -- get string to be parsed+                            >>>+                            parseHtmlDoc                        -- run parser+                          )                           >>>                           substHtmlEntityRefs                   -- substitute entity refs-    removeWarnings-        | withTagSoup++    removeWarnings (warnings, withTagSoup')+        | withTagSoup'           &&           not warnings  = this         | otherwise     = processTopDownWithAttrl@@ -209,9 +207,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 +245,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 +276,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  -- ------------------------------------------------------------

@@ -6,11 +6,10 @@    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  -} @@ -28,179 +27,167 @@  import Control.Arrow.ListArrows -import Data.Char                                ( isDigit ) 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 Text.XML.HXT.Arrow.ProcessDocument       ( getDocumentContents                                                 , parseXmlDocument                                                 , 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--- 'a_proxy' : proxy for http access, e.g. www-cache:3128--- 'a_redirect' : automatically follow redirected URIs, default is yes+this filter can be configured by a list of configuration options, a value of type 'Text.XML.HXT.XmlState.TypeDefs.SysConfig' -- 'a_use_curl' : obsolete and ignored, HTTP acccess is always done with curl bindings for libcurl+for all available options see module 'Text.XML.HXT.XmlState.SystemConfig' -- '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.+- @withValidate yes\/no@ :+  switch on\/off DTD validation. Only for XML parsed documents, not for 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+  'Text.XML.HXT.TagSoup' is imported -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+  'Text.XML.HXT.Curl' is imported+                   +- @withHTTP [<http-option>...]@ :+  Use the Haskell HTTP package for HTTP access.+  This is only available when package hxt-http is installed and+  'Text.XML.HXT.HTTP' is imported  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")->              ] "http://localhost/test.php"+> ...+> 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    :: 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+                    )+        )+      )       >>>       traceMsg 1 ("readDocument: " ++ show src ++ " processed")       >>>@@ -208,48 +195,40 @@       >>>       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-     getMimeType         = getAttrValue transferMimeType >>^ stringToLower -    processDoc mimeType+    processDoc mimeType (parseByMimeType, (parseHtml, (acceptedMimeTypes, validateWithRelax)))         = traceMsg 1 (unwords [ "readDocument:", show src                               , "(mime type:", show mimeType, ") will be processed"])           >>>-          ( if isAcceptedMimeType (lookup1 a_accept_mimetypes options) mimeType+          ( if isAcceptedMimeType acceptedMimeTypes mimeType             then ( ifA (fromLA hasEmptyBody)                    ( replaceChildren none )                                     -- empty response, e.g. in if-modified-since request-                   ( parse+                   ( ( parse $< getSysVar (theValidate              .&&&.+                                           theIgnoreNoneXmlContents .&&&.+                                           theTagSoup+                                          )+                     )                      >>>                      ( if isXmlOrHtml-                       then ( checknamespaces+                       then ( ( checknamespaces $< getSysVar (theCheckNamespaces .&&&.+                                                              theTagSoup+                                                             )+                              )                               >>>                               rememberDTDAttrl                               >>>-                              canonicalize+                              ( canonicalize $< getSysVar (thePreserveComment .&&&.+                                                           theCanonicalize    .&&&.+                                                           theTagSoup+                                                          )+                              )                               >>>-                              whitespace+                              ( whitespace $< getSysVar (theRemoveWS .&&&.+                                                         theTagSoup+                                                        )+                              )                               >>>                               relax                             )@@ -272,7 +251,7 @@                                             ( getChildren >>> isWhiteSpace )                                           ) -        isAcceptedMimeType              :: String -> String -> Bool+        isAcceptedMimeType              :: [String] -> String -> Bool         isAcceptedMimeType mts mt             | null mts               ||@@ -280,9 +259,7 @@             | otherwise                 = foldr (matchMt mt') False $ mts'             where             mt'                         = parseMt mt-            mts'                        = words-                                          >>>-                                          map parseMt+            mts'                        = map parseMt                                           $                                           mts             parseMt                     = break (== '/')@@ -293,75 +270,73 @@                                             (mi == mis || mis == "*")                                           )                                           || r-        parse+        parse (validate, (removeNoneXml, withTagSoup'))+	    | 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                     = parseXmlDocument (not validateWithRelax && validate)           -- parse as XML+            | otherwise                 = this                                  -- suppress warning++        checknamespaces (withNamespaces, withTagSoup')+            | withNamespaces+	      &&+	      withTagSoup'		= andValidateNamespaces			-- propagation is done in tagsoup++            | withNamespaces               ||-              validateWithRelax         = propagateAndValidateNamespaces+              validateWithRelax         = propagateAndValidateNamespaces	-- RelaxNG requires correct namespaces+             | otherwise                 = this-        canonicalize-            | withTagSoup               = this                                  -- tagsoup already removes redundant stuff++        canonicalize (preserveCmt, (canonicalize', withTagSoup'))+            | withTagSoup'              = this                                  -- tagsoup already removes redundant stuff             | validateWithRelax         = canonicalizeAllNodes-            | hasOption a_canonicalize+            | canonicalize'               &&               preserveCmt               = canonicalizeForXPath-            | hasOption a_canonicalize  = canonicalizeAllNodes+            | canonicalize'             = canonicalizeAllNodes             | otherwise                 = this+         relax-            | validateWithRelax         = validateDocumentWithRelaxSchema options relaxSchema+            | validateWithRelax         = withoutUserState $< getSysVar theRelaxValidator             | otherwise                 = this-        whitespace++        whitespace (removeWS, withTagSoup')             | removeWS               &&-              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 )  -- ------------------------------------------------------------ @@ -373,18 +348,19 @@ -- -- Default encoding: No encoding is done, the String argument is taken as Unicode string -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 (withInputEncoding unicodeString : 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 )  -- ------------------------------------------------------------ 

@@ -17,6 +17,7 @@  module Text.XML.HXT.Arrow.WriteDocument     ( writeDocument+    , writeDocument'     , writeDocumentToString     , prepareContents     )@@ -28,9 +29,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.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                  ( escapeHtmlDoc                                                 , escapeXmlDoc                                                 , haskellRepOfXmlDoc@@ -40,13 +45,13 @@                                                 , removeDocWhiteSpace                                                 , treeRepOfXmlDoc                                                 )- import Text.XML.HXT.Arrow.DocumentOutput        ( putXmlDocument                                                 , encodeDocument                                                 , encodeDocument'                                                 )  -- ------------------------------------------------------------+--  {- | the main filter for writing documents@@ -57,38 +62,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 +102,7 @@ > module Main > where >-> import Text.XML.HXT.Arrow+> import Text.XML.HXT.Core > > main        :: IO () > main@@ -107,46 +113,66 @@ >            ) >       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 )+        >>>+        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,59 @@ -- | -- indent and format output -prepareContents :: ArrowXml a => Attributes -> (Bool -> String -> a XmlTree XmlTree) -> a XmlTree XmlTree-prepareContents userOptions encodeDoc+prepareContents :: ArrowXml a => XIOSysState -> (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+        | showTree'                     = treeRepOfXmlDoc+        | showHaskell'                  = haskellRepOfXmlDoc+        | outHtml'                      = preventEmptyElements noEEsFor' True                                           >>>                                           escapeHtmlDoc                 -- escape al XML and HTML chars >= 128                                           >>>                                           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)+                                            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-                                            suppressXmlPi ( lookupDef "" a_output_encoding options )+                                            noPi' outEnc'+        | outXml'                       = ( if null noEEsFor'+                                            then this+                                            else preventEmptyElements noEEsFor' False+                                          )+                                          >>>+                                          escapeXmlDoc                  -- escape lt, gt, amp, quot,+                                          >>>+                                          encodeDoc                     -- convert doc into text with respect to output encoding+                                            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 )-              ]  -- ------------------------------------------------------------

@@ -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 

@@ -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)---- ------------------------------------------------------------

@@ -0,0 +1,242 @@+-- ------------------------------------------------------------++{- |+   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_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_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_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_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_text_mode                     = "text-mode"+a_trace                         = "trace"+a_validate                      = "validate"+a_verbose                       = "verbose"++-- ------------------------------------------------------------++-- |+-- select options from a predefined list of option desciptions++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++-- ------------------------------------------------------------